From d869bb5ec819216965e94d0f05be1007fe2584d7 Mon Sep 17 00:00:00 2001 From: Michael McInerney Date: Fri, 3 May 2024 00:54:34 +0930 Subject: [PATCH] spec+proof: use linked lists in the design spec This models the ready queues in the design spec as linked lists via the tcbSchedNext and tcbSchedPrev pointers of a TCB, as in the C. Library functions to update these linked lists are introduced, and used to perform all functions which modify the ready queues. Refinement between the linked lists and the Isabelle lists in the abstract spec is handled via the predicate `heap_ls`. `invs'` has been significantly modified, with the introduction of `valid_sched_pointers` and `sym_heap_sched_pointers`. The various invariants related to the bitmaps have been collected in the invariant `valid_bitmaps`. This includes a major revision to Orphanage, which now uses the tcbQueued field of a TCB to indicate a thread's membership in a ready queue, rather than the previous formulation which used membership in the set of the Isabelle list. Co-authored-by: Rafal Kolanski Co-authored-by: Gerwin Klein Signed-off-by: Michael McInerney --- proof/crefine/AARCH64/ADT_C.thy | 183 +- proof/crefine/AARCH64/ArchMove_C.thy | 9 - proof/crefine/AARCH64/Arch_C.thy | 53 +- proof/crefine/AARCH64/Detype_C.thy | 32 - proof/crefine/AARCH64/Fastpath_C.thy | 74 +- proof/crefine/AARCH64/Fastpath_Equiv.thy | 132 +- proof/crefine/AARCH64/Finalise_C.thy | 273 +- proof/crefine/AARCH64/Interrupt_C.thy | 4 +- proof/crefine/AARCH64/Invoke_C.thy | 48 +- proof/crefine/AARCH64/IpcCancel_C.thy | 2372 +++++------- proof/crefine/AARCH64/Ipc_C.thy | 683 ++-- .../crefine/AARCH64/IsolatedThreadAction.thy | 61 +- proof/crefine/AARCH64/Recycle_C.thy | 56 +- proof/crefine/AARCH64/Refine_C.thy | 100 +- proof/crefine/AARCH64/Retype_C.thy | 71 +- proof/crefine/AARCH64/SR_lemmas_C.thy | 32 +- proof/crefine/AARCH64/Schedule_C.thy | 150 +- proof/crefine/AARCH64/StateRelation_C.thy | 31 +- proof/crefine/AARCH64/SyscallArgs_C.thy | 4 +- proof/crefine/AARCH64/Syscall_C.thy | 60 +- proof/crefine/AARCH64/TcbQueue_C.thy | 73 +- proof/crefine/AARCH64/Tcb_C.thy | 52 +- proof/crefine/AARCH64/Wellformed_C.thy | 3 - proof/crefine/ARM/ADT_C.thy | 174 +- proof/crefine/ARM/ArchMove_C.thy | 7 +- proof/crefine/ARM/Arch_C.thy | 15 +- proof/crefine/ARM/Detype_C.thy | 26 +- proof/crefine/ARM/Fastpath_C.thy | 86 +- proof/crefine/ARM/Fastpath_Equiv.thy | 147 +- proof/crefine/ARM/Finalise_C.thy | 259 +- proof/crefine/ARM/Interrupt_C.thy | 4 +- proof/crefine/ARM/Invoke_C.thy | 49 +- proof/crefine/ARM/IpcCancel_C.thy | 2269 +++++------- proof/crefine/ARM/Ipc_C.thy | 579 ++- proof/crefine/ARM/IsolatedThreadAction.thy | 52 +- proof/crefine/ARM/Recycle_C.thy | 56 +- proof/crefine/ARM/Refine_C.thy | 84 +- proof/crefine/ARM/Retype_C.thy | 58 +- proof/crefine/ARM/SR_lemmas_C.thy | 32 +- proof/crefine/ARM/Schedule_C.thy | 130 +- proof/crefine/ARM/StateRelation_C.thy | 31 +- proof/crefine/ARM/SyscallArgs_C.thy | 4 +- proof/crefine/ARM/Syscall_C.thy | 43 +- proof/crefine/ARM/TcbAcc_C.thy | 21 + proof/crefine/ARM/TcbQueue_C.thy | 101 +- proof/crefine/ARM/Tcb_C.thy | 54 +- proof/crefine/ARM/Wellformed_C.thy | 4 - proof/crefine/ARM_HYP/ADT_C.thy | 173 +- proof/crefine/ARM_HYP/ArchMove_C.thy | 8 - proof/crefine/ARM_HYP/Arch_C.thy | 34 +- proof/crefine/ARM_HYP/Detype_C.thy | 26 +- proof/crefine/ARM_HYP/Fastpath_C.thy | 95 +- proof/crefine/ARM_HYP/Fastpath_Equiv.thy | 145 +- proof/crefine/ARM_HYP/Finalise_C.thy | 281 +- proof/crefine/ARM_HYP/Interrupt_C.thy | 4 +- proof/crefine/ARM_HYP/Invoke_C.thy | 49 +- proof/crefine/ARM_HYP/IpcCancel_C.thy | 2339 +++++------- proof/crefine/ARM_HYP/Ipc_C.thy | 586 ++- .../crefine/ARM_HYP/IsolatedThreadAction.thy | 52 +- proof/crefine/ARM_HYP/Recycle_C.thy | 57 +- proof/crefine/ARM_HYP/Refine_C.thy | 101 +- proof/crefine/ARM_HYP/Retype_C.thy | 36 +- proof/crefine/ARM_HYP/SR_lemmas_C.thy | 32 +- proof/crefine/ARM_HYP/Schedule_C.thy | 143 +- proof/crefine/ARM_HYP/StateRelation_C.thy | 31 +- proof/crefine/ARM_HYP/SyscallArgs_C.thy | 4 +- proof/crefine/ARM_HYP/Syscall_C.thy | 59 +- proof/crefine/ARM_HYP/TcbQueue_C.thy | 101 +- proof/crefine/ARM_HYP/Tcb_C.thy | 54 +- proof/crefine/ARM_HYP/Wellformed_C.thy | 4 - proof/crefine/Move_C.thy | 62 +- proof/crefine/RISCV64/ADT_C.thy | 181 +- proof/crefine/RISCV64/ArchMove_C.thy | 6 - proof/crefine/RISCV64/Arch_C.thy | 11 +- proof/crefine/RISCV64/Detype_C.thy | 26 +- proof/crefine/RISCV64/Finalise_C.thy | 250 +- proof/crefine/RISCV64/Interrupt_C.thy | 4 +- proof/crefine/RISCV64/Invoke_C.thy | 48 +- proof/crefine/RISCV64/IpcCancel_C.thy | 2340 +++++------- proof/crefine/RISCV64/Ipc_C.thy | 682 ++-- .../crefine/RISCV64/IsolatedThreadAction.thy | 59 +- proof/crefine/RISCV64/Recycle_C.thy | 57 +- proof/crefine/RISCV64/Refine_C.thy | 81 +- proof/crefine/RISCV64/Retype_C.thy | 67 +- proof/crefine/RISCV64/SR_lemmas_C.thy | 32 +- proof/crefine/RISCV64/Schedule_C.thy | 147 +- proof/crefine/RISCV64/StateRelation_C.thy | 31 +- proof/crefine/RISCV64/SyscallArgs_C.thy | 4 +- proof/crefine/RISCV64/Syscall_C.thy | 53 +- proof/crefine/RISCV64/TcbQueue_C.thy | 74 +- proof/crefine/RISCV64/Tcb_C.thy | 53 +- proof/crefine/RISCV64/Wellformed_C.thy | 4 - proof/crefine/X64/ADT_C.thy | 181 +- proof/crefine/X64/ArchMove_C.thy | 6 - proof/crefine/X64/Arch_C.thy | 39 +- proof/crefine/X64/Detype_C.thy | 32 +- proof/crefine/X64/Finalise_C.thy | 255 +- proof/crefine/X64/Interrupt_C.thy | 14 +- proof/crefine/X64/Invoke_C.thy | 48 +- proof/crefine/X64/IpcCancel_C.thy | 2358 +++++------- proof/crefine/X64/Ipc_C.thy | 707 ++-- proof/crefine/X64/IsolatedThreadAction.thy | 83 +- proof/crefine/X64/Recycle_C.thy | 57 +- proof/crefine/X64/Refine_C.thy | 83 +- proof/crefine/X64/Retype_C.thy | 81 +- proof/crefine/X64/SR_lemmas_C.thy | 32 +- proof/crefine/X64/Schedule_C.thy | 146 +- proof/crefine/X64/StateRelation_C.thy | 31 +- proof/crefine/X64/SyscallArgs_C.thy | 4 +- proof/crefine/X64/Syscall_C.thy | 53 +- proof/crefine/X64/TcbQueue_C.thy | 64 +- proof/crefine/X64/Tcb_C.thy | 54 +- proof/crefine/X64/Wellformed_C.thy | 4 - proof/infoflow/Scheduler_IF.thy | 4 - proof/infoflow/refine/ADT_IF_Refine.thy | 13 +- proof/infoflow/refine/ADT_IF_Refine_C.thy | 25 +- .../refine/ARM/ArchADT_IF_Refine_C.thy | 18 +- .../refine/ARM/Example_Valid_StateH.thy | 34 +- .../refine/RISCV64/ArchADT_IF_Refine_C.thy | 18 +- .../refine/RISCV64/Example_Valid_StateH.thy | 34 +- proof/invariant-abstract/DetSchedInvs_AI.thy | 13 + .../DetSchedSchedule_AI.thy | 7 + proof/refine/AARCH64/ADT_H.thy | 37 +- proof/refine/AARCH64/ArchAcc_R.thy | 49 +- proof/refine/AARCH64/Arch_R.thy | 8 +- proof/refine/AARCH64/Bits_R.thy | 4 + proof/refine/AARCH64/CNodeInv_R.thy | 32 +- proof/refine/AARCH64/CSpace1_R.thy | 121 +- proof/refine/AARCH64/CSpace_R.thy | 99 +- proof/refine/AARCH64/Detype_R.thy | 273 +- proof/refine/AARCH64/EmptyFail_H.thy | 2 +- proof/refine/AARCH64/Finalise_R.thy | 637 +--- proof/refine/AARCH64/Init_R.thy | 10 +- proof/refine/AARCH64/InterruptAcc_R.thy | 7 +- proof/refine/AARCH64/Interrupt_R.thy | 173 +- proof/refine/AARCH64/InvariantUpdates_H.thy | 100 +- proof/refine/AARCH64/Invariants_H.thy | 276 +- proof/refine/AARCH64/IpcCancel_R.thy | 946 ++--- proof/refine/AARCH64/Ipc_R.thy | 362 +- proof/refine/AARCH64/KHeap_R.thy | 277 +- proof/refine/AARCH64/Refine.thy | 8 +- proof/refine/AARCH64/Retype_R.thy | 501 ++- proof/refine/AARCH64/Schedule_R.thy | 1560 ++++---- proof/refine/AARCH64/StateRelation.thy | 109 +- proof/refine/AARCH64/Syscall_R.thy | 355 +- proof/refine/AARCH64/TcbAcc_R.thy | 3062 +++++++++++----- proof/refine/AARCH64/Tcb_R.thy | 452 +-- proof/refine/AARCH64/Untyped_R.thy | 42 +- proof/refine/AARCH64/VSpace_R.thy | 107 +- proof/refine/AARCH64/orphanage/Orphanage.thy | 1141 +++--- proof/refine/ARM/ADT_H.thy | 37 +- proof/refine/ARM/ArchAcc_R.thy | 187 +- proof/refine/ARM/Arch_R.thy | 13 +- proof/refine/ARM/Bits_R.thy | 4 + proof/refine/ARM/CNodeInv_R.thy | 28 +- proof/refine/ARM/CSpace1_R.thy | 119 +- proof/refine/ARM/CSpace_R.thy | 106 +- proof/refine/ARM/Detype_R.thy | 273 +- proof/refine/ARM/Finalise_R.thy | 587 +-- proof/refine/ARM/Init_R.thy | 10 +- proof/refine/ARM/InterruptAcc_R.thy | 6 +- proof/refine/ARM/Interrupt_R.thy | 163 +- proof/refine/ARM/InvariantUpdates_H.thy | 100 +- proof/refine/ARM/Invariants_H.thy | 234 +- proof/refine/ARM/IpcCancel_R.thy | 986 ++--- proof/refine/ARM/Ipc_R.thy | 463 +-- proof/refine/ARM/KHeap_R.thy | 274 +- proof/refine/ARM/Refine.thy | 12 +- proof/refine/ARM/Retype_R.thy | 432 ++- proof/refine/ARM/Schedule_R.thy | 1631 ++++----- proof/refine/ARM/StateRelation.thy | 116 +- proof/refine/ARM/Syscall_R.thy | 390 +- proof/refine/ARM/TcbAcc_R.thy | 3248 ++++++++++++----- proof/refine/ARM/Tcb_R.thy | 644 ++-- proof/refine/ARM/Untyped_R.thy | 47 +- proof/refine/ARM/VSpace_R.thy | 52 +- proof/refine/ARM/orphanage/Orphanage.thy | 1216 +++--- proof/refine/ARM_HYP/ADT_H.thy | 37 +- proof/refine/ARM_HYP/ArchAcc_R.thy | 178 +- proof/refine/ARM_HYP/Arch_R.thy | 13 +- proof/refine/ARM_HYP/Bits_R.thy | 4 + proof/refine/ARM_HYP/CNodeInv_R.thy | 32 +- proof/refine/ARM_HYP/CSpace1_R.thy | 121 +- proof/refine/ARM_HYP/CSpace_R.thy | 112 +- proof/refine/ARM_HYP/Detype_R.thy | 261 +- proof/refine/ARM_HYP/Finalise_R.thy | 680 +--- proof/refine/ARM_HYP/Init_R.thy | 10 +- proof/refine/ARM_HYP/InterruptAcc_R.thy | 8 +- proof/refine/ARM_HYP/Interrupt_R.thy | 205 +- proof/refine/ARM_HYP/InvariantUpdates_H.thy | 100 +- proof/refine/ARM_HYP/Invariants_H.thy | 273 +- proof/refine/ARM_HYP/IpcCancel_R.thy | 1077 ++---- proof/refine/ARM_HYP/Ipc_R.thy | 493 +-- proof/refine/ARM_HYP/KHeap_R.thy | 295 +- proof/refine/ARM_HYP/PageTableDuplicates.thy | 5 - proof/refine/ARM_HYP/Refine.thy | 13 +- proof/refine/ARM_HYP/Retype_R.thy | 444 ++- proof/refine/ARM_HYP/Schedule_R.thy | 1571 ++++---- proof/refine/ARM_HYP/StateRelation.thy | 119 +- proof/refine/ARM_HYP/Syscall_R.thy | 379 +- proof/refine/ARM_HYP/TcbAcc_R.thy | 3226 +++++++++++----- proof/refine/ARM_HYP/Tcb_R.thy | 638 ++-- proof/refine/ARM_HYP/Untyped_R.thy | 44 +- proof/refine/ARM_HYP/VSpace_R.thy | 146 +- proof/refine/RISCV64/ADT_H.thy | 39 +- proof/refine/RISCV64/ArchAcc_R.thy | 57 +- proof/refine/RISCV64/Arch_R.thy | 15 +- proof/refine/RISCV64/Bits_R.thy | 4 + proof/refine/RISCV64/CNodeInv_R.thy | 32 +- proof/refine/RISCV64/CSpace1_R.thy | 119 +- proof/refine/RISCV64/CSpace_R.thy | 106 +- proof/refine/RISCV64/Detype_R.thy | 211 +- proof/refine/RISCV64/EmptyFail_H.thy | 2 +- proof/refine/RISCV64/Finalise_R.thy | 562 +-- proof/refine/RISCV64/Init_R.thy | 10 +- proof/refine/RISCV64/InterruptAcc_R.thy | 6 +- proof/refine/RISCV64/Interrupt_R.thy | 158 +- proof/refine/RISCV64/InvariantUpdates_H.thy | 100 +- proof/refine/RISCV64/Invariants_H.thy | 262 +- proof/refine/RISCV64/IpcCancel_R.thy | 935 ++--- proof/refine/RISCV64/Ipc_R.thy | 363 +- proof/refine/RISCV64/KHeap_R.thy | 277 +- proof/refine/RISCV64/Refine.thy | 12 +- proof/refine/RISCV64/Retype_R.thy | 433 ++- proof/refine/RISCV64/Schedule_R.thy | 1543 ++++---- proof/refine/RISCV64/StateRelation.thy | 109 +- proof/refine/RISCV64/Syscall_R.thy | 351 +- proof/refine/RISCV64/TcbAcc_R.thy | 3055 +++++++++++----- proof/refine/RISCV64/Tcb_R.thy | 445 +-- proof/refine/RISCV64/Untyped_R.thy | 42 +- proof/refine/RISCV64/VSpace_R.thy | 28 +- proof/refine/RISCV64/orphanage/Orphanage.thy | 1192 +++--- proof/refine/X64/ADT_H.thy | 813 ++--- proof/refine/X64/ArchAcc_R.thy | 74 +- proof/refine/X64/Arch_R.thy | 16 +- proof/refine/X64/Bits_R.thy | 4 + proof/refine/X64/CNodeInv_R.thy | 33 +- proof/refine/X64/CSpace1_R.thy | 122 +- proof/refine/X64/CSpace_R.thy | 106 +- proof/refine/X64/Detype_R.thy | 283 +- proof/refine/X64/EmptyFail_H.thy | 2 +- proof/refine/X64/Finalise_R.thy | 629 +--- proof/refine/X64/Init_R.thy | 10 +- proof/refine/X64/InterruptAcc_R.thy | 6 +- proof/refine/X64/Interrupt_R.thy | 173 +- proof/refine/X64/InvariantUpdates_H.thy | 100 +- proof/refine/X64/Invariants_H.thy | 266 +- proof/refine/X64/IpcCancel_R.thy | 1011 ++--- proof/refine/X64/Ipc_R.thy | 498 +-- proof/refine/X64/KHeap_R.thy | 478 ++- proof/refine/X64/Refine.thy | 14 +- proof/refine/X64/Retype_R.thy | 494 ++- proof/refine/X64/Schedule_R.thy | 1584 ++++---- proof/refine/X64/StateRelation.thy | 139 +- proof/refine/X64/Syscall_R.thy | 394 +- proof/refine/X64/TcbAcc_R.thy | 3218 +++++++++++----- proof/refine/X64/Tcb_R.thy | 628 ++-- proof/refine/X64/Untyped_R.thy | 104 +- proof/refine/X64/VSpace_R.thy | 80 +- spec/design/skel/KernelInit_H.thy | 2 +- spec/design/skel/KernelStateData_H.thy | 8 +- spec/haskell/src/SEL4/Kernel/Thread.lhs | 118 +- spec/haskell/src/SEL4/Model/StateData.lhs | 22 +- spec/haskell/src/SEL4/Object/Endpoint.lhs | 2 + spec/haskell/src/SEL4/Object/Instances.lhs | 2 + spec/haskell/src/SEL4/Object/Notification.lhs | 1 + spec/haskell/src/SEL4/Object/Structures.lhs | 17 +- 267 files changed, 39421 insertions(+), 37135 deletions(-) diff --git a/proof/crefine/AARCH64/ADT_C.thy b/proof/crefine/AARCH64/ADT_C.thy index 10f06c8a7d..c8c1a67caf 100644 --- a/proof/crefine/AARCH64/ADT_C.thy +++ b/proof/crefine/AARCH64/ADT_C.thy @@ -82,8 +82,8 @@ lemma Basic_sem_eq: lemma setTCBContext_C_corres: "\ ccontext_relation tc tc'; t' = tcb_ptr_to_ctcb_ptr t \ \ - corres_underlying rf_sr nf nf' dc (pspace_domain_valid and tcb_at' t) \ - (threadSet (\tcb. tcb \ tcbArch := atcbContextSet tc (tcbArch tcb)\) t) (setTCBContext_C tc' t')" + corres_underlying rf_sr nf nf' dc (pspace_domain_valid and tcb_at' t) \ + (threadSet (\tcb. tcb \ tcbArch := atcbContextSet tc (tcbArch tcb)\) t) (setTCBContext_C tc' t')" apply (simp add: setTCBContext_C_def exec_C_def Basic_sem_eq corres_underlying_def) apply clarsimp apply (simp add: threadSet_def bind_assoc split_def exec_gets) @@ -112,8 +112,6 @@ lemma setTCBContext_C_corres: apply (simp add: map_to_ctes_upd_tcb_no_ctes map_to_tcbs_upd tcb_cte_cases_def cvariable_relation_upd_const ko_at_projectKO_opt cteSizeBits_def) apply (simp add: cep_relations_drop_fun_upd) - apply (apply_conjunct \match conclusion in \cready_queues_relation _ _ _\ \ - \erule cready_queues_relation_not_queue_ptrs; rule ext; simp split: if_split\\) apply (drule ko_at_projectKO_opt) apply (erule (2) cmap_relation_upd_relI) apply (simp add: ctcb_relation_def carch_tcb_relation_def) @@ -648,25 +646,51 @@ lemma tcb_queue_rel'_unique: apply (erule(2) tcb_queue_rel_unique) done -definition - cready_queues_to_H - :: "(tcb_C ptr \ tcb_C) \ (tcb_queue_C[num_tcb_queues]) \ word8 \ word8 \ machine_word list" + +definition tcb_queue_C_to_tcb_queue :: "tcb_queue_C \ tcb_queue" where + "tcb_queue_C_to_tcb_queue q \ + TcbQueue (if head_C q = NULL then None else Some (ctcb_ptr_to_tcb_ptr (head_C q))) + (if end_C q = NULL then None else Some (ctcb_ptr_to_tcb_ptr (end_C q)))" + +definition cready_queues_to_H :: + "tcb_queue_C[num_tcb_queues] \ (domain \ priority \ ready_queue)" where - "cready_queues_to_H h_tcb cs \ \(qdom, prio). if ucast minDom \ qdom \ qdom \ ucast maxDom - \ ucast seL4_MinPrio \ prio \ prio \ ucast seL4_MaxPrio - then THE aq. let cqueue = index cs (cready_queues_index_to_C qdom prio) - in sched_queue_relation' h_tcb aq (head_C cqueue) (StateRelation_C.end_C cqueue) - else []" + "cready_queues_to_H cs \ + \(qdom, prio). + if qdom \ maxDomain \ prio \ maxPriority + then let cqueue = index cs (cready_queues_index_to_C qdom prio) + in tcb_queue_C_to_tcb_queue cqueue + else TcbQueue None None" lemma cready_queues_to_H_correct: - "cready_queues_relation (clift s) cs as \ - cready_queues_to_H (clift s) cs = as" - apply (clarsimp simp: cready_queues_to_H_def cready_queues_relation_def - fun_eq_iff) - apply (rule the_equality) - apply simp - apply (clarsimp simp: Let_def) - apply (rule_tac hp="clift s" in tcb_queue_rel'_unique, simp_all add: lift_t_NULL) + "\cready_queues_relation (ksReadyQueues s) (ksReadyQueues_' ch); + no_0_obj' s; ksReadyQueues_asrt s; pspace_aligned' s; pspace_distinct' s\ + \ cready_queues_to_H (ksReadyQueues_' ch) = ksReadyQueues s" + apply (clarsimp simp: cready_queues_to_H_def cready_queues_relation_def Let_def) + apply (clarsimp simp: fun_eq_iff) + apply (rename_tac d p) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (frule (3) obj_at'_tcbQueueEnd_ksReadyQueues) + apply (frule tcbQueueHead_iff_tcbQueueEnd) + apply (rule conjI) + apply (clarsimp simp: tcb_queue_C_to_tcb_queue_def ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (case_tac "tcbQueueHead (ksReadyQueues s (d, p)) = None") + apply (clarsimp simp: tcb_queue.expand) + apply clarsimp + apply (rename_tac queue_head queue_end) + apply (prop_tac "tcb_at' queue_head s", fastforce simp: tcbQueueEmpty_def obj_at'_def) + apply (prop_tac "tcb_at' queue_end s", fastforce simp: tcbQueueEmpty_def obj_at'_def) + apply (drule tcb_at_not_NULL)+ + apply (fastforce simp: tcb_queue.expand kernel.ctcb_ptr_to_ctcb_ptr) + apply (clarsimp simp: tcbQueueEmpty_def ctcb_queue_relation_def option_to_ctcb_ptr_def + split: option.splits; + metis tcb_queue.exhaust_sel word_not_le) done (* showing that cpspace_relation is actually unique >>>*) @@ -820,17 +844,20 @@ lemma cthread_state_rel_imp_eq: apply (cases y, simp_all add: ThreadState_defs)+ done -lemma ksPSpace_valid_objs_tcbBoundNotification_nonzero: - "\s. ksPSpace s = ah \ no_0_obj' s \ valid_objs' s - \ map_to_tcbs ah p = Some tcb \ tcbBoundNotification tcb \ Some 0" +lemma map_to_tcbs_Some_refs_nonzero: + "\map_to_tcbs (ksPSpace s) p = Some tcb; no_0_obj' s; valid_objs' s\ + \ tcbBoundNotification tcb \ Some 0 + \ tcbSchedPrev tcb \ Some 0 + \ tcbSchedNext tcb \ Some 0" + supply word_neq_0_conv[simp del] apply (clarsimp simp: map_comp_def split: option.splits) - apply (erule(1) valid_objsE') - apply (clarsimp simp: valid_obj'_def valid_tcb'_def) + apply (erule (1) valid_objsE') + apply (fastforce simp: valid_obj'_def valid_tcb'_def) done lemma ksPSpace_valid_objs_atcbVCPUPtr_nonzero: - "\s. ksPSpace s = ah \ no_0_obj' s \ valid_objs' s - \ map_to_tcbs ah p = Some tcb \ atcbVCPUPtr (tcbArch tcb) \ Some 0" + "\ no_0_obj' s; valid_objs' s \ \ + map_to_tcbs (ksPSpace s) p = Some tcb \ atcbVCPUPtr (tcbArch tcb) \ Some 0" apply (clarsimp simp: map_comp_def split: option.splits) apply (erule(1) valid_objsE') apply (clarsimp simp: valid_obj'_def valid_tcb'_def valid_arch_tcb'_def) @@ -855,36 +882,77 @@ lemma carch_tcb_relation_imp_eq: apply (case_tac vcpuptr2 ; simp) done +lemma tcb_ptr_to_ctcb_ptr_inj: + "tcb_ptr_to_ctcb_ptr x = tcb_ptr_to_ctcb_ptr y \ x = y" + by (auto simp: tcb_ptr_to_ctcb_ptr_def ctcb_offset_def) + +lemma + assumes "pspace_aligned' as" "pspace_distinct' as" "valid_tcb' atcb as" + shows tcb_at'_tcbBoundNotification: + "bound (tcbBoundNotification atcb) \ ntfn_at' (the (tcbBoundNotification atcb)) as" + and tcb_at'_tcbSchedPrev: + "tcbSchedPrev atcb \ None \ tcb_at' (the (tcbSchedPrev atcb)) as" + and tcb_at'_tcbSchedNext: + "tcbSchedNext atcb \ None \ tcb_at' (the (tcbSchedNext atcb)) as" + using assms + by (clarsimp simp: valid_tcb'_def obj_at'_def)+ + lemma cpspace_tcb_relation_unique: - assumes tcbs: "cpspace_tcb_relation ah ch" "cpspace_tcb_relation ah' ch" - and vs: "\s. ksPSpace s = ah \ no_0_obj' s \ valid_objs' s" - and vs': "\s. ksPSpace s = ah' \ no_0_obj' s \ valid_objs' s" - assumes ctes: " \tcb tcb'. (\p. map_to_tcbs ah p = Some tcb \ - map_to_tcbs ah' p = Some tcb') \ - (\x\ran tcb_cte_cases. fst x tcb' = fst x tcb)" - shows "map_to_tcbs ah' = map_to_tcbs ah" + assumes tcbs: "cpspace_tcb_relation (ksPSpace as) ch" "cpspace_tcb_relation (ksPSpace as') ch" + assumes vs: "no_0_obj' as" "valid_objs' as" + assumes vs': "no_0_obj' as'" "valid_objs' as'" + assumes ad: "pspace_aligned' as" "pspace_distinct' as" + assumes ad': "pspace_aligned' as'" "pspace_distinct' as'" + assumes ctes: "\tcb tcb'. (\p. map_to_tcbs (ksPSpace as) p = Some tcb \ + map_to_tcbs (ksPSpace as') p = Some tcb') \ + (\x\ran tcb_cte_cases. fst x tcb' = fst x tcb)" + shows "map_to_tcbs (ksPSpace as') = map_to_tcbs (ksPSpace as)" using tcbs(2) tcbs(1) apply (clarsimp simp add: cmap_relation_def) apply (drule inj_image_inv[OF inj_tcb_ptr_to_ctcb_ptr])+ apply (simp add: tcb_ptr_to_ctcb_ptr_def[abs_def] ctcb_offset_def) apply (rule ext) - apply (case_tac "x:dom (map_to_tcbs ah)") + apply (case_tac "x \ dom (map_to_tcbs (ksPSpace as))") apply (drule bspec, assumption)+ apply (simp add: dom_def Collect_eq, drule_tac x=x in spec) apply clarsimp apply (rename_tac p x y) apply (cut_tac ctes) apply (drule_tac x=x in spec, drule_tac x=y in spec, erule impE, fastforce) - apply (frule ksPSpace_valid_objs_tcbBoundNotification_nonzero[OF vs]) - apply (frule ksPSpace_valid_objs_tcbBoundNotification_nonzero[OF vs']) + apply (frule map_to_tcbs_Some_refs_nonzero[OF _ vs]) + apply (frule map_to_tcbs_Some_refs_nonzero[OF _ vs']) apply (frule ksPSpace_valid_objs_atcbVCPUPtr_nonzero[OF vs]) apply (frule ksPSpace_valid_objs_atcbVCPUPtr_nonzero[OF vs']) + apply (rename_tac atcb atcb') + apply (prop_tac "valid_tcb' atcb as") + apply (fastforce intro: vs ad map_to_ko_atI tcb_ko_at_valid_objs_valid_tcb') + apply (prop_tac "valid_tcb' atcb' as'") + apply (fastforce intro: vs' ad' map_to_ko_atI tcb_ko_at_valid_objs_valid_tcb') + apply (frule tcb_at'_tcbSchedPrev[OF ad]) + apply (frule tcb_at'_tcbSchedPrev[OF ad']) + apply (frule tcb_at'_tcbSchedNext[OF ad]) + apply (frule tcb_at'_tcbSchedNext[OF ad']) apply (thin_tac "map_to_tcbs x y = Some z" for x y z)+ - apply (case_tac x, case_tac y, case_tac "the (clift ch (tcb_Ptr (p+0x400)))") + apply (case_tac "the (clift ch (tcb_Ptr (p + 2 ^ ctcb_size_bits)))") apply (clarsimp simp: ctcb_relation_def ran_tcb_cte_cases) - apply (clarsimp simp: option_to_ptr_def option_to_0_def split: option.splits) - apply (auto simp: cfault_rel_imp_eq cthread_state_rel_imp_eq carch_tcb_relation_imp_eq - ccontext_relation_imp_eq up_ucast_inj_eq ctcb_size_bits_def) + apply (clarsimp simp: option_to_ctcb_ptr_def option_to_ptr_def option_to_0_def) + apply (rule tcb.expand) + apply clarsimp + apply (intro conjI) + apply (simp add: cthread_state_rel_imp_eq) + apply (simp add: cfault_rel_imp_eq) + apply (case_tac "tcbBoundNotification atcb'", case_tac "tcbBoundNotification atcb"; clarsimp) + apply (clarsimp split: option.splits) + apply (case_tac "tcbSchedPrev atcb'"; case_tac "tcbSchedPrev atcb"; clarsimp) + apply (force dest!: tcb_at_not_NULL) + apply (force dest!: tcb_at_not_NULL) + apply (force simp: tcb_ptr_to_ctcb_ptr_inj) + apply (case_tac "tcbSchedNext atcb'"; case_tac "tcbSchedNext atcb"; clarsimp) + apply (force dest!: tcb_at_not_NULL) + apply (force dest!: tcb_at_not_NULL) + apply (force simp: tcb_ptr_to_ctcb_ptr_inj) + apply (clarsimp simp: carch_tcb_relation_imp_eq) + apply auto done lemma tcb_queue_rel_clift_unique: @@ -916,10 +984,6 @@ lemma is_aligned_no_overflow_0: abbreviation "is_aligned_opt x n \ case x of None \ True | Some y \ is_aligned y n" -lemma tcb_ptr_to_ctcb_ptr_inj: - "tcb_ptr_to_ctcb_ptr x = tcb_ptr_to_ctcb_ptr y \ x = y" - by (auto simp: tcb_ptr_to_ctcb_ptr_def ctcb_offset_def) - lemma option_to_ctcb_ptr_inj: "\ is_aligned_opt a tcbBlockSizeBits; is_aligned_opt b tcbBlockSizeBits \ \ (option_to_ctcb_ptr a = option_to_ctcb_ptr b) = (a = b)" @@ -1218,8 +1282,8 @@ proof - apply (rule valid_objs'_aligned_vcpuTCB [OF valid_objs]) apply (rule valid_objs'_aligned_vcpuTCB [OF valid_objs']) apply (drule (1) cpspace_tcb_relation_unique) - apply (fastforce intro: no_0_objs no_0_objs' valid_objs valid_objs') - apply (fastforce intro: no_0_objs no_0_objs' valid_objs valid_objs') + apply (fastforce intro: no_0_objs no_0_objs' valid_objs valid_objs')+ + apply (fastforce intro: aligned distinct aligned' distinct')+ apply (intro allI impI,elim exE conjE) apply (rule_tac p=p in map_to_ctes_tcb_ctes, assumption) apply (frule (1) map_to_ko_atI[OF _ aligned distinct]) @@ -1427,7 +1491,7 @@ where ksDomSchedule = cDomSchedule_to_H kernel_all_global_addresses.ksDomSchedule, ksCurDomain = ucast (ksCurDomain_' s), ksDomainTime = ksDomainTime_' s, - ksReadyQueues = cready_queues_to_H (clift (t_hrs_' s)) (ksReadyQueues_' s), + ksReadyQueues = cready_queues_to_H (ksReadyQueues_' s), ksReadyQueuesL1Bitmap = cbitmap_L1_to_H (ksReadyQueuesL1Bitmap_' s), ksReadyQueuesL2Bitmap = cbitmap_L2_to_H (ksReadyQueuesL2Bitmap_' s), ksCurThread = ctcb_ptr_to_tcb_ptr (ksCurThread_' s), @@ -1449,16 +1513,16 @@ lemma trivial_eq_conj: "B = C \ (A \ B) = (A \ C)" lemma cstate_to_H_correct: assumes valid: "valid_state' as" assumes cstate_rel: "cstate_relation as cs" + assumes rdyqs: "ksReadyQueues_asrt as" shows "cstate_to_H cs = as \ksMachineState:= observable_memory (ksMachineState as) (user_mem' as)\" apply (subgoal_tac "cstate_to_machine_H cs = observable_memory (ksMachineState as) (user_mem' as)") apply (rule kernel_state.equality, simp_all add: cstate_to_H_def) - apply (rule cstate_to_pspace_H_correct) + apply (rule cstate_to_pspace_H_correct) using valid apply (simp add: valid_state'_def) using cstate_rel valid apply (clarsimp simp: cstate_relation_def cpspace_relation_def Let_def - observable_memory_def valid_state'_def - valid_pspace'_def) + observable_memory_def valid_state'_def valid_pspace'_def) using cstate_rel apply (clarsimp simp: cstate_relation_def cpspace_relation_def Let_def prod_eq_iff) using cstate_rel @@ -1466,10 +1530,10 @@ lemma cstate_to_H_correct: using valid cstate_rel apply (rule mk_gsUntypedZeroRanges_correct) subgoal - using cstate_rel - by (fastforce simp: cstate_relation_def cpspace_relation_def - Let_def ghost_size_rel_def unat_eq_0 - split: if_split) + using cstate_rel + by (fastforce simp: cstate_relation_def cpspace_relation_def + Let_def ghost_size_rel_def unat_eq_0 + split: if_split) using valid cstate_rel apply (rule cDomScheduleIdx_to_H_correct) using cstate_rel @@ -1483,8 +1547,13 @@ lemma cstate_to_H_correct: using cstate_rel apply (clarsimp simp: cstate_relation_def Let_def) apply (rule cready_queues_to_H_correct) - using cstate_rel - apply (clarsimp simp: cstate_relation_def Let_def) + using cstate_rel rdyqs + apply (fastforce intro!: cready_queues_to_H_correct + simp: cstate_relation_def Let_def) + using valid apply (fastforce simp: valid_state'_def) + using rdyqs apply fastforce + using valid apply (fastforce simp: valid_state'_def) + using valid apply (fastforce simp: valid_state'_def) using cstate_rel apply (clarsimp simp: cstate_relation_def Let_def) using cstate_rel diff --git a/proof/crefine/AARCH64/ArchMove_C.thy b/proof/crefine/AARCH64/ArchMove_C.thy index 805de5eb17..e251a25afc 100644 --- a/proof/crefine/AARCH64/ArchMove_C.thy +++ b/proof/crefine/AARCH64/ArchMove_C.thy @@ -292,9 +292,6 @@ lemma asUser_getRegister_discarded: return_def fail_def stateAssert_def) done -crunches Arch.switchToThread - for valid_queues'[wp]: valid_queues' - (simp: crunch_simps wp: hoare_drop_imps crunch_wps getASID_wp) crunches switchToIdleThread for ksCurDomain[wp]: "\s. P (ksCurDomain s)" @@ -312,10 +309,6 @@ lemma updateASIDPoolEntry_valid_pspace'[wp]: unfolding updateASIDPoolEntry_def valid_pspace'_def getPoolPtr_def by (wpsimp wp: getASID_wp) -crunches switchToIdleThread, switchToThread - for valid_pspace'[wp]: valid_pspace' - (simp: whenE_def crunch_simps wp: crunch_wps hoare_drop_imps) - lemma getMessageInfo_less_4: "\\\ getMessageInfo t \\rv s. msgExtraCaps rv < 4\" including no_pre @@ -454,8 +447,6 @@ lemma ko_at_vcpu_at'D: crunch pred_tcb_at'2[wp]: doMachineOp "\s. P (pred_tcb_at' a b p s)" (simp: crunch_simps) -crunch valid_queues'[wp]: readVCPUReg "\s. valid_queues s" - crunch valid_objs'[wp]: readVCPUReg "\s. valid_objs' s" crunch sch_act_wf'[wp]: readVCPUReg "\s. P (sch_act_wf (ksSchedulerAction s) s)" diff --git a/proof/crefine/AARCH64/Arch_C.thy b/proof/crefine/AARCH64/Arch_C.thy index b18268f950..999ce554fb 100644 --- a/proof/crefine/AARCH64/Arch_C.thy +++ b/proof/crefine/AARCH64/Arch_C.thy @@ -1421,7 +1421,7 @@ lemma performPageGetAddress_ccorres: apply clarsimp apply (rule conseqPre, vcg) apply clarsimp - apply (clarsimp simp: invs_no_0_obj' tcb_at_invs' invs_queues invs_valid_objs' invs_sch_act_wf' + apply (clarsimp simp: invs_no_0_obj' tcb_at_invs' invs_valid_objs' invs_sch_act_wf' rf_sr_ksCurThread msgRegisters_unfold seL4_MessageInfo_lift_def message_info_to_H_def mask_def) apply (cases isCall) @@ -3246,13 +3246,14 @@ lemma decodeARMMMUInvocation_ccorres: apply (rule conjI; clarsimp) apply (frule invs_arch_state') apply (rule conjI, clarsimp simp: valid_arch_state'_def valid_asid_table'_def) - apply (clarsimp simp: neq_Nil_conv excaps_map_def valid_tcb_state'_def invs_queues - invs_sch_act_wf' + apply (clarsimp simp: neq_Nil_conv excaps_map_def valid_tcb_state'_def invs_sch_act_wf' unat_lt2p[where 'a=machine_word_len, folded word_bits_def]) apply (frule interpret_excaps_eq[rule_format, where n=1], simp) apply (rule conjI; clarsimp)+ apply (rule conjI, erule ctes_of_valid', clarsimp) apply (intro conjI) + apply fastforce + apply fastforce apply fastforce apply (fastforce elim!: pred_tcb'_weakenE) apply (clarsimp simp: st_tcb_at'_def obj_at'_def) @@ -3269,15 +3270,17 @@ lemma decodeARMMMUInvocation_ccorres: apply (clarsimp simp: le_mask_asid_bits_helper) apply (simp add: is_aligned_shiftl_self) (* ARMASIDPoolAssign *) - apply (clarsimp simp: isCap_simps valid_tcb_state'_def invs_queues invs_sch_act_wf') + apply (clarsimp simp: isCap_simps valid_tcb_state'_def invs_sch_act_wf') apply (frule invs_arch_state', clarsimp) apply (intro conjI) + apply fastforce apply fastforce - apply (fastforce simp: ct_in_state'_def elim!: pred_tcb'_weakenE) + apply fastforce apply (fastforce simp: ct_in_state'_def elim!: pred_tcb'_weakenE) - apply (cases extraCaps; simp) - apply (clarsimp simp: excaps_in_mem_def slotcap_in_mem_def isPTCap'_def) - apply (simp add: valid_cap'_def) + apply (fastforce simp: ct_in_state'_def elim!: pred_tcb'_weakenE) + apply (cases extraCaps; simp) + apply (clarsimp simp: excaps_in_mem_def slotcap_in_mem_def isPTCap'_def) + apply (simp add: valid_cap'_def) apply (clarsimp simp: null_def neq_Nil_conv mask_def field_simps asid_low_bits_word_bits asidInvalid_def asid_wf_def dest!: filter_eq_ConsD) @@ -3473,7 +3476,10 @@ lemma readVCPUReg_ccorres: apply fastforce done -crunch st_tcb_at'[wp]: readVCPUReg "\s. Q (st_tcb_at' P t s)" +crunches readVCPUReg + for st_tcb_at'[wp]: "\s. Q (st_tcb_at' P t s)" + and pspace_aligned'[wp]: "pspace_aligned'" + and pspace_distinct'[wp]: "pspace_distinct'" (wp: crunch_wps simp: crunch_simps) lemma invokeVCPUReadReg_ccorres: (* styled after invokeTCB_ReadRegisters_ccorres *) @@ -3563,16 +3569,15 @@ lemma invokeVCPUReadReg_ccorres: (* styled after invokeTCB_ReadRegisters_ccorres apply clarsimp apply (rule conseqPre, vcg) apply clarsimp - apply (clarsimp simp: invs_no_0_obj' tcb_at_invs' invs_queues invs_valid_objs' invs_sch_act_wf' + apply (clarsimp simp: invs_no_0_obj' tcb_at_invs' invs_valid_objs' invs_sch_act_wf' rf_sr_ksCurThread msgRegisters_unfold ThreadState_defs seL4_MessageInfo_lift_def message_info_to_H_def mask_def) apply (cases isCall; clarsimp) apply (rule conjI, clarsimp simp: ct_in_state'_def st_tcb_at'_def comp_def) - apply (fastforce simp: obj_at'_def projectKOs) - apply (clarsimp simp: Kernel_C.badgeRegister_def AARCH64.badgeRegister_def - AARCH64_H.badgeRegister_def C_register_defs) + apply (fastforce simp: obj_at'_def) + apply (clarsimp simp: AARCH64.badgeRegister_def AARCH64_H.badgeRegister_def C_register_defs) apply (simp add: rf_sr_def cstate_relation_def Let_def) - apply (rule conjI, clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs ct_in_state'_def) + apply (rule conjI, fastforce simp: pred_tcb_at'_def obj_at'_def ct_in_state'_def) apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def) done @@ -3658,7 +3663,7 @@ lemma decodeVCPUWriteReg_ccorres: apply (vcg exspec=getSyscallArg_modifies) apply (clarsimp simp: word_less_nat_alt word_le_nat_alt conj_commute - invs_no_0_obj' tcb_at_invs' invs_queues invs_valid_objs' invs_sch_act_wf' + invs_no_0_obj' tcb_at_invs' invs_valid_objs' invs_sch_act_wf' rf_sr_ksCurThread msgRegisters_unfold valid_tcb_state'_def ThreadState_defs mask_def) apply (rule conjI; clarsimp) \ \not enough args\ @@ -3913,7 +3918,7 @@ lemma decodeVCPUInjectIRQ_ccorres: apply (vcg exspec=getSyscallArg_modifies) apply (clarsimp simp: word_less_nat_alt word_le_nat_alt conj_commute - invs_no_0_obj' tcb_at_invs' invs_queues invs_valid_objs' invs_sch_act_wf' + invs_no_0_obj' tcb_at_invs' invs_valid_objs' invs_sch_act_wf' rf_sr_ksCurThread msgRegisters_unfold valid_tcb_state'_def ThreadState_defs mask_def) @@ -4015,7 +4020,7 @@ lemma decodeVCPUReadReg_ccorres: apply (vcg exspec=getSyscallArg_modifies) apply (clarsimp simp: word_le_nat_alt conj_commute - invs_no_0_obj' tcb_at_invs' invs_queues invs_valid_objs' invs_sch_act_wf' + invs_no_0_obj' tcb_at_invs' invs_valid_objs' invs_sch_act_wf' rf_sr_ksCurThread msgRegisters_unfold valid_tcb_state'_def ThreadState_defs mask_def) @@ -4119,8 +4124,9 @@ lemma decodeVCPUSetTCB_ccorres: apply vcg apply (clarsimp simp: word_less_nat_alt word_le_nat_alt conj_commute - invs_no_0_obj' tcb_at_invs' invs_queues invs_valid_objs' invs_sch_act_wf' + invs_no_0_obj' tcb_at_invs' invs_valid_objs' invs_sch_act_wf' rf_sr_ksCurThread msgRegisters_unfold + invs_pspace_aligned' invs_pspace_distinct' valid_tcb_state'_def ThreadState_defs mask_def) apply (clarsimp simp: idButNot_def interpret_excaps_test_null excaps_map_def neq_Nil_conv) @@ -4272,18 +4278,15 @@ proof - (* Haskell side *) apply (clarsimp simp: excaps_in_mem_def slotcap_in_mem_def isCap_simps ctes_of_cte_at) apply (clarsimp simp: word_le_nat_alt conj_commute - invs_no_0_obj' tcb_at_invs' invs_queues invs_valid_objs' invs_sch_act_wf' + invs_no_0_obj' tcb_at_invs' invs_valid_objs' invs_sch_act_wf' rf_sr_ksCurThread msgRegisters_unfold - valid_tcb_state'_def mask_def + valid_tcb_state'_def mask_def invs_pspace_aligned' invs_pspace_distinct' valid_cap'_def ct_in_state'_def sysargs_rel_to_n st_tcb_at'_def comp_def runnable'_eq) apply (fastforce elim: obj_at'_weakenE) (* C side *) - apply (clarsimp simp: word_le_nat_alt conj_commute - invs_no_0_obj' tcb_at_invs' invs_queues invs_valid_objs' invs_sch_act_wf' - rf_sr_ksCurThread msgRegisters_unfold - valid_tcb_state'_def ThreadState_defs Kernel_C.maxIRQ_def - and_mask_eq_iff_le_mask capVCPUPtr_eq) + apply (clarsimp simp: word_le_nat_alt rf_sr_ksCurThread msgRegisters_unfold + Kernel_C.maxIRQ_def and_mask_eq_iff_le_mask capVCPUPtr_eq) apply (clarsimp simp: mask_def) done qed diff --git a/proof/crefine/AARCH64/Detype_C.thy b/proof/crefine/AARCH64/Detype_C.thy index d63899c3f7..6e7d6055fb 100644 --- a/proof/crefine/AARCH64/Detype_C.thy +++ b/proof/crefine/AARCH64/Detype_C.thy @@ -1695,38 +1695,6 @@ proof - apply (simp add: cmap_relation_restrict_both_proj) done - moreover - from invs have "valid_queues s" .. - hence "\p. \t \ set (ksReadyQueues s p). tcb_at' t s \ ko_wp_at' live' t s" - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def) - apply (drule spec, drule spec) - apply clarsimp - apply (drule (1) bspec) - apply (rule conjI) - apply (erule obj_at'_weakenE) - apply simp - apply (simp add: obj_at'_real_def) - apply (erule ko_wp_at'_weakenE) - apply (clarsimp simp: inQ_def live'_def) - done - hence tat: "\p. \t \ set (ksReadyQueues s p). tcb_at' t s" - and tlive: "\p. \t \ set (ksReadyQueues s p). ko_wp_at' live' t s" - by auto - from sr have - "cready_queues_relation (clift ?th_s) - (ksReadyQueues_' (globals s')) (ksReadyQueues s)" - unfolding cready_queues_relation_def rf_sr_def cstate_relation_def - cpspace_relation_def - apply (clarsimp simp: Let_def all_conj_distrib) - apply (drule spec, drule spec, drule mp) - apply fastforce - apply ((subst lift_t_typ_region_bytes, rule cm_disj_tcb, assumption+, - simp_all add: objBits_simps pageBits_def)[1])+ - \ \waiting ...\ - apply (simp add: tcb_queue_relation_live_restrict - [OF D.valid_untyped tat tlive rl]) - done - moreover { assume "s' \\<^sub>c armKSGlobalUserVSpace_Ptr " diff --git a/proof/crefine/AARCH64/Fastpath_C.thy b/proof/crefine/AARCH64/Fastpath_C.thy index 132cbee167..c39edefe45 100644 --- a/proof/crefine/AARCH64/Fastpath_C.thy +++ b/proof/crefine/AARCH64/Fastpath_C.thy @@ -39,11 +39,10 @@ lemma getEndpoint_obj_at': lemmas setEndpoint_obj_at_tcb' = setEndpoint_obj_at'_tcb lemma tcbSchedEnqueue_tcbContext[wp]: - "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ - tcbSchedEnqueue t' - \\rv. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" - apply (rule tcbSchedEnqueue_obj_at_unchangedT[OF all_tcbI]) - apply simp + "tcbSchedEnqueue t' \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_when) + apply (wp threadSet_obj_at' hoare_drop_imps threadGet_wp + | simp split: if_split)+ done lemma setCTE_tcbContext: @@ -55,20 +54,16 @@ lemma setCTE_tcbContext: done lemma setThreadState_tcbContext: - "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ - setThreadState a b - \\_. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" - apply (rule setThreadState_obj_at_unchanged) - apply (clarsimp simp: atcbContext_def)+ - done + "setThreadState a b \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + unfolding setThreadState_def rescheduleRequired_def tcbSchedEnqueue_def + tcbQueuePrepend_def rescheduleRequired_def + by (wp threadSet_obj_at' hoare_drop_imps threadGet_wp | wpc + | simp split: if_split)+ lemma setBoundNotification_tcbContext: - "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ - setBoundNotification a b - \\_. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" - apply (rule setBoundNotification_obj_at_unchanged) - apply (clarsimp simp: atcbContext_def)+ - done + "setBoundNotification a b \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + unfolding setBoundNotification_def + by wpsimp declare comp_apply [simp del] crunch tcbContext[wp]: deleteCallerCap "obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t" @@ -756,10 +751,13 @@ lemma switchToThread_fp_ccorres: apply (rule ccorres_assert2) apply csymbr apply (ctac (no_vcg) add: armv_contextSwitch_HWASID_ccorres[where vmid=vmid]) + apply (clarsimp simp: setCurThread_def) + apply (rule ccorres_stateAssert) apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg) apply (clarsimp, rule conseqPre, vcg) apply (clarsimp simp: setCurThread_def simpler_modify_def rf_sr_def cstate_relation_def Let_def carch_state_relation_def cmachine_state_relation_def) + apply (wp hoare_drop_imp) apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift')+ apply (rule conjI) @@ -1209,8 +1207,8 @@ lemma fastpath_dequeue_ccorres: apply (rule conjI) apply (clarsimp simp: cpspace_relation_def update_ep_map_tos update_tcb_map_tos typ_heap_simps') - apply (rule conjI, erule ctcb_relation_null_queue_ptrs) - apply (rule ext, simp add: tcb_null_queue_ptrs_def + apply (rule conjI, erule ctcb_relation_null_ep_ptrs) + apply (rule ext, simp add: tcb_null_ep_ptrs_def split: if_split) apply (rule conjI) apply (rule cpspace_relation_ep_update_ep, assumption+) @@ -1226,8 +1224,6 @@ lemma fastpath_dequeue_ccorres: apply (simp add: carch_state_relation_def typ_heap_simps' cmachine_state_relation_def h_t_valid_clift_Some_iff update_ep_map_tos) - apply (erule cready_queues_relation_null_queue_ptrs) - apply (rule ext, simp add: tcb_null_ep_ptrs_def split: if_split) done lemma st_tcb_at_not_in_ep_queue: @@ -1368,8 +1364,8 @@ lemma fastpath_enqueue_ccorres: apply (rule conjI) apply (clarsimp simp: cpspace_relation_def update_ep_map_tos typ_heap_simps') - apply (rule conjI, erule ctcb_relation_null_queue_ptrs) - apply (rule ext, simp add: tcb_null_queue_ptrs_def + apply (rule conjI, erule ctcb_relation_null_ep_ptrs) + apply (rule ext, simp add: tcb_null_ep_ptrs_def split: if_split) apply (rule conjI) apply (rule_tac S="tcb_ptr_to_ctcb_ptr ` set (ksCurThread \ # list)" @@ -1408,8 +1404,6 @@ lemma fastpath_enqueue_ccorres: auto dest!: map_to_ko_atI)[1] apply (simp add: carch_state_relation_def typ_heap_simps' update_ep_map_tos cmachine_state_relation_def h_t_valid_clift_Some_iff) - apply (erule cready_queues_relation_null_queue_ptrs) - apply (rule ext, simp add: tcb_null_ep_ptrs_def split: if_split) apply (clarsimp simp: typ_heap_simps' EPState_Recv_def mask_def is_aligned_weaken[OF is_aligned_tcb_ptr_to_ctcb_ptr]) apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def) @@ -1418,8 +1412,8 @@ lemma fastpath_enqueue_ccorres: apply (rule conjI) apply (clarsimp simp: cpspace_relation_def update_ep_map_tos typ_heap_simps' ct_in_state'_def) - apply (rule conjI, erule ctcb_relation_null_queue_ptrs) - apply (rule ext, simp add: tcb_null_queue_ptrs_def + apply (rule conjI, erule ctcb_relation_null_ep_ptrs) + apply (rule ext, simp add: tcb_null_ep_ptrs_def split: if_split) apply (rule conjI) apply (rule_tac S="{tcb_ptr_to_ctcb_ptr (ksCurThread \)}" @@ -1439,8 +1433,6 @@ lemma fastpath_enqueue_ccorres: assumption+, auto dest!: map_to_ko_atI)[1] apply (simp add: carch_state_relation_def typ_heap_simps' update_ep_map_tos cmachine_state_relation_def h_t_valid_clift_Some_iff) - apply (erule cready_queues_relation_null_queue_ptrs) - apply (rule ext, simp add: tcb_null_ep_ptrs_def split: if_split) done lemma setCTE_rf_sr: @@ -2255,9 +2247,6 @@ proof - apply (erule cmap_relation_updI, erule ko_at_projectKO_opt) apply (simp add: ctcb_relation_def cthread_state_relation_def) apply simp - apply (rule conjI, erule cready_queues_relation_not_queue_ptrs) - apply (rule ext, simp split: if_split add: typ_heap_simps') - apply (rule ext, simp split: if_split add: typ_heap_simps') apply (simp add: carch_state_relation_def cmachine_state_relation_def typ_heap_simps' map_comp_update projectKO_opt_tcb cvariable_relation_upd_const ko_at_projectKO_opt) @@ -2381,9 +2370,6 @@ proof - apply (erule cmap_relation_updI, erule ko_at_projectKO_opt) apply (simp add: ctcb_relation_def cthread_state_relation_def) apply simp - apply (rule conjI, erule cready_queues_relation_not_queue_ptrs) - apply (rule ext, simp split: if_split) - apply (rule ext, simp split: if_split) apply (simp add: carch_state_relation_def cmachine_state_relation_def typ_heap_simps' map_comp_update projectKO_opt_tcb cvariable_relation_upd_const ko_at_projectKO_opt) @@ -3154,9 +3140,6 @@ proof - ThreadState_defs) apply (clarsimp simp: ccap_relation_ep_helpers) apply simp - apply (rule conjI, erule cready_queues_relation_not_queue_ptrs) - apply (rule ext, simp split: if_split) - apply (rule ext, simp split: if_split) apply (simp add: carch_state_relation_def cmachine_state_relation_def typ_heap_simps' map_comp_update projectKO_opt_tcb cvariable_relation_upd_const ko_at_projectKO_opt) @@ -3236,9 +3219,6 @@ proof - apply (erule cmap_relation_updI, erule ko_at_projectKO_opt) apply (simp add: ctcb_relation_def cthread_state_relation_def) apply simp - apply (rule conjI, erule cready_queues_relation_not_queue_ptrs) - apply (rule ext, simp split: if_split) - apply (rule ext, simp split: if_split) apply (simp add: carch_state_relation_def cmachine_state_relation_def typ_heap_simps' map_comp_update projectKO_opt_tcb cvariable_relation_upd_const ko_at_projectKO_opt) @@ -3382,8 +3362,6 @@ proof - apply (clarsimp simp: invs_ksCurDomain_maxDomain') apply (rename_tac cur_tcb cte) apply (frule invs_valid_objs') - apply (frule invs_queues) - apply (clarsimp simp: valid_queues_def) apply (frule tcbs_of_aligned') apply (simp add: invs_pspace_aligned') apply (frule tcbs_of_cte_wp_at_caller) @@ -3406,14 +3384,19 @@ proof - apply (solves \clarsimp simp: wellformed_mapdata'_def\) apply (frule_tac tcb=tcb in tcbs_of_valid_tcb'[OF invs_valid_objs', rotated], simp) apply (clarsimp simp add: valid_tcb'_def) + apply (frule invs_valid_objs') + apply (frule invs_valid_bitmaps) + apply (frule valid_bitmaps_bitmapQ_no_L1_orphans) + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply clarsimp apply (rule conjI; clarsimp?) (* canonical_address (capEPPtr (cteCap ctea)) *) apply (clarsimp simp: obj_at'_is_canonical dest!: invs_pspace_canonical') apply (clarsimp simp: isCap_simps valid_cap'_def[split_simps capability.split] maskCapRights_def cte_wp_at_ctes_of cte_level_bits_def) apply (frule_tac p=a in ctes_of_valid', clarsimp) - apply (simp add: valid_cap_simps') apply (frule invs_mdb') - apply (rule conjI, solves clarsimp)+ (* a bunch of consequences of invs' *) + apply (simp add: valid_cap_simps') apply (clarsimp simp: cte_wp_at_ctes_of cte_level_bits_def makeObject_cte isValidVTableRoot_def to_bool_def @@ -3426,7 +3409,6 @@ proof - apply (clarsimp simp: asid_has_vmid_def asid_has_entry_def) apply (case_tac asid_entry, fastforce) apply (frule ko_at_valid_ep', fastforce) - apply (frule invs_mdb') apply (safe del: notI disjE)[1] apply (simp add: isSendEP_def valid_ep'_def tcb_at_invs' split: Structures_H.endpoint.split_asm) diff --git a/proof/crefine/AARCH64/Fastpath_Equiv.thy b/proof/crefine/AARCH64/Fastpath_Equiv.thy index 20bbbb6f91..c63144c57e 100644 --- a/proof/crefine/AARCH64/Fastpath_Equiv.thy +++ b/proof/crefine/AARCH64/Fastpath_Equiv.thy @@ -31,13 +31,9 @@ lemma getEndpoint_obj_at': lemmas setEndpoint_obj_at_tcb' = setEndpoint_obj_at'_tcb -lemma tcbSchedEnqueue_tcbContext[wp]: - "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ - tcbSchedEnqueue t' - \\rv. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" - apply (rule tcbSchedEnqueue_obj_at_unchangedT[OF all_tcbI]) - apply simp - done +crunches tcbSchedEnqueue + for tcbContext[wp]: "obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t" + (simp: tcbQueuePrepend_def) lemma setCTE_tcbContext: "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ @@ -50,19 +46,17 @@ lemma setCTE_tcbContext: context begin interpretation Arch . (*FIXME: arch_split*) lemma setThreadState_tcbContext: - "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ - setThreadState a b - \\_. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" - apply (rule setThreadState_obj_at_unchanged) - apply (clarsimp simp: atcbContext_def)+ + "setThreadState st tptr \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + unfolding setThreadState_def rescheduleRequired_def + apply (wpsimp wp: threadSet_wp hoare_drop_imps) + apply (fastforce simp: obj_at'_def objBits_simps projectKOs atcbContext_def ps_clear_upd) done lemma setBoundNotification_tcbContext: - "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ - setBoundNotification a b - \\_. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" - apply (rule setBoundNotification_obj_at_unchanged) - apply (clarsimp simp: atcbContext_def)+ + "setBoundNotification ntfnPtr tptr \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + unfolding setBoundNotification_def + apply (wpsimp wp: threadSet_wp hoare_drop_imps) + apply (fastforce simp: obj_at'_def objBits_simps projectKOs) done declare comp_apply [simp del] @@ -508,6 +502,34 @@ lemma setThreadState_runnable_bitmap_inv: crunches curDomain for (no_fail) no_fail[intro!, wp, simp] +lemma setThreadState_tcbDomain_tcbPriority_obj_at'[wp]: + "setThreadState ts t \obj_at' (\tcb. P (tcbDomain tcb) (tcbPriority tcb)) t'\" + unfolding setThreadState_def rescheduleRequired_def tcbSchedEnqueue_def tcbQueuePrepend_def + apply (wpsimp wp: threadSet_wp hoare_drop_imps threadGet_wp simp: setQueue_def bitmap_fun_defs) + apply (fastforce simp: obj_at'_def st_tcb_at'_def objBits_simps) + done + +lemma setThreadState_tcbQueued_obj_at'[wp]: + "setThreadState ts t \obj_at' (\tcb. P (tcbQueued tcb)) t'\" + unfolding setThreadState_def rescheduleRequired_def tcbSchedEnqueue_def tcbQueuePrepend_def + apply (wpsimp wp: threadSet_wp hoare_drop_imps threadGet_wp simp: setQueue_def bitmap_fun_defs) + apply (fastforce simp: obj_at'_def st_tcb_at'_def objBits_simps) + done + +lemma setThreadState_tcbFault_obj_at'[wp]: + "setThreadState ts t \obj_at' (\tcb. P (tcbFault tcb)) t'\" + unfolding setThreadState_def rescheduleRequired_def tcbSchedEnqueue_def tcbQueuePrepend_def + apply (wpsimp wp: threadSet_wp hoare_drop_imps threadGet_wp simp: setQueue_def bitmap_fun_defs) + apply (fastforce simp: obj_at'_def st_tcb_at'_def objBits_simps) + done + +lemma setThreadState_tcbArch_obj_at'[wp]: + "setThreadState ts t \obj_at' (\tcb. P (tcbArch tcb)) t'\" + unfolding setThreadState_def rescheduleRequired_def tcbSchedEnqueue_def tcbQueuePrepend_def + apply (wpsimp wp: threadSet_wp hoare_drop_imps threadGet_wp simp: setQueue_def bitmap_fun_defs) + apply (fastforce simp: obj_at'_def st_tcb_at'_def objBits_simps) + done + (* FIXME AARCH64 MOVE *) lemma setRegister_simple_modify_registers: "setRegister r v = (\con. ({((), modify_registers (\f. f(r := v)) con)}, False))" @@ -581,7 +603,8 @@ lemma fastpath_callKernel_SysCall_corres: "monadic_rewrite True False (invs' and ct_in_state' ((=) Running) and (\s. ksSchedulerAction s = ResumeCurrentThread) - and (\s. ksDomainTime s \ 0)) + and (\s. ksDomainTime s \ 0) + and ready_qs_runnable) (callKernel (SyscallEvent SysCall)) (fastpaths SysCall)" supply if_cong[cong] option.case_cong[cong] if_split[split del] supply empty_fail_getMRs[wp] (* FIXME *) @@ -763,22 +786,18 @@ lemma fastpath_callKernel_SysCall_corres: apply wp[1] apply (simp cong: if_cong HOL.conj_cong add: if_bool_simps) apply (simp_all only:)[5] - apply ((wp setThreadState_oa_queued[of _ "\a _ _. \ a"] - setThreadState_obj_at_unchanged - asUser_obj_at_unchanged mapM_x_wp' + apply ((wp asUser_obj_at_unchanged mapM_x_wp' sts_st_tcb_at'_cases setThreadState_no_sch_change setEndpoint_obj_at_tcb' fastpathBestSwitchCandidate_lift[where f="setThreadState f t" for f t] - setThreadState_oa_queued fastpathBestSwitchCandidate_lift[where f="asUser t f" for f t] fastpathBestSwitchCandidate_lift[where f="setEndpoint a b" for a b] lookupBitmapPriority_lift setThreadState_runnable_bitmap_inv getEndpoint_obj_at' - | simp add: setMessageInfo_def + | simp add: setMessageInfo_def obj_at'_conj | wp (once) hoare_vcg_disj_lift)+) - apply (simp add: setThreadState_runnable_simp getThreadCallerSlot_def getThreadReplySlot_def locateSlot_conv bind_assoc) @@ -899,8 +918,10 @@ lemma fastpath_callKernel_SysCall_corres: apply (prop_tac "ksCurThread s \ blockedThread") apply normalise_obj_at' apply clarsimp - apply (frule_tac t="blockedThread" in valid_queues_not_runnable_not_queued, assumption) - subgoal by (fastforce simp: st_tcb_at'_def elim: obj_at'_weakenE) + apply (extract_conjunct \match conclusion in "\ tcbQueued _" \ -\) + apply (clarsimp simp: ready_qs_runnable_def) + apply (drule_tac x=blockedThread in spec) + apply (solves \clarsimp simp: obj_at'_def st_tcb_at'_def objBits_simps\) apply (prop_tac "fastpathBestSwitchCandidate blockedThread s") apply (rule_tac ttcb=tcbb and ctcb=tcb in fastpathBestSwitchCandidateI) apply (solves \simp only: disj_ac\) @@ -1064,14 +1085,15 @@ crunch tcbContext[wp]: possibleSwitchTo "obj_at' (\tcb. P ( (atcbContext crunch only_cnode_caps[wp]: doFaultTransfer "\s. P (only_cnode_caps (ctes_of s))" (wp: crunch_wps simp: crunch_simps) +(* FIXME: monadic_rewrite_l does not work with stateAssert here *) lemma tcbSchedDequeue_rewrite_not_queued: "monadic_rewrite True False (tcb_at' t and obj_at' (Not \ tcbQueued) t) (tcbSchedDequeue t) (return ())" - apply (simp add: tcbSchedDequeue_def when_def) - apply (monadic_rewrite_l monadic_rewrite_if_l_False \wp threadGet_const\) - apply (monadic_rewrite_symb_exec_l, rule monadic_rewrite_refl) - apply wp+ - apply (clarsimp simp: o_def obj_at'_def) + apply (simp add: tcbSchedDequeue_def) + apply monadic_rewrite_symb_exec_l + apply (monadic_rewrite_symb_exec_l_known False, simp) + apply (rule monadic_rewrite_refl) + apply (wpsimp wp: threadGet_const)+ done lemma schedule_known_rewrite: @@ -1110,7 +1132,7 @@ lemma schedule_known_rewrite: \wpsimp wp: Arch_switchToThread_obj_at_pre\) (* remove no-ops *) apply simp - apply (repeat 9 \rule monadic_rewrite_symb_exec_l\) (* until switchToThread *) + apply (repeat 13 \rule monadic_rewrite_symb_exec_l\) (* until switchToThread *) apply (rule monadic_rewrite_refl) apply (wpsimp simp: isHighestPrio_def')+ apply (clarsimp simp: ct_in_state'_def not_pred_tcb_at'_strengthen @@ -1372,18 +1394,12 @@ crunches setThreadState, emptySlot, asUser (wp: obj_at_setObject2 crunch_wps simp: crunch_simps updateObject_default_def in_monad) -lemma st_tcb_at_is_Reply_imp_not_tcbQueued: "\s t.\ invs' s; st_tcb_at' isReply t s\ \ obj_at' (\a. \ tcbQueued a) t s" - apply (clarsimp simp: invs'_def valid_state'_def valid_queues_def st_tcb_at'_def valid_queues_no_bitmap_def) - apply (rule all_prio_not_inQ_not_tcbQueued) - apply (clarsimp simp: obj_at'_def) - apply (erule_tac x="d" in allE) - apply (erule_tac x="p" in allE) - apply (erule conjE) - apply (erule_tac x="t" in ballE) - apply (clarsimp simp: obj_at'_def runnable'_def isReply_def) - apply (case_tac "tcbState obj") - apply ((clarsimp simp: inQ_def)+)[8] - apply (clarsimp simp: valid_queues'_def obj_at'_def) +lemma st_tcb_at_is_Reply_imp_not_tcbQueued: + "\s t. \ ready_qs_runnable s; st_tcb_at' isReply t s\ \ obj_at' (\tcb. \ tcbQueued tcb) t s" + apply (clarsimp simp: ready_qs_runnable_def) + apply (drule_tac x=t in spec) + apply (clarsimp simp: st_tcb_at'_def obj_at'_def isReply_def) + apply (case_tac "tcbState obj"; clarsimp) done lemma valid_objs_ntfn_at_tcbBoundNotification: @@ -1439,7 +1455,7 @@ lemma tcbSchedEnqueue_tcbIPCBuffer: "\obj_at' (\tcb. P (tcbIPCBuffer tcb)) t\ tcbSchedEnqueue t' \\_. obj_at' (\tcb. P (tcbIPCBuffer tcb)) t\" - apply (simp add: tcbSchedEnqueue_def unless_when) + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_when) apply (wp threadSet_obj_at' hoare_drop_imps threadGet_wp |simp split: if_split)+ done @@ -1487,11 +1503,21 @@ lemma monadic_rewrite_fail: "monadic_rewrite True E \ fail g" by (simp add: monadic_rewrite_def) +lemma threadSet_tcb_at'[wp]: + "threadSet f t' \\s. P (tcb_at' addr s)\" + apply (wpsimp wp: threadSet_wp) + apply (erule rsubst[where P=P]) + by (clarsimp simp: obj_at'_def ps_clear_upd objBits_simps) + +crunches rescheduleRequired, tcbSchedDequeue, setThreadState, setBoundNotification + for tcb''[wp]: "\s. P (tcb_at' addr s)" + (wp: crunch_wps) + (* FIXME AARCH64 pick up commentary and cleanup from fastpath_callKernel_SysCall_corres *) lemma fastpath_callKernel_SysReplyRecv_corres: "monadic_rewrite True False (invs' and ct_in_state' ((=) Running) and (\s. ksSchedulerAction s = ResumeCurrentThread) - and cnode_caps_gsCNodes') + and cnode_caps_gsCNodes' and ready_qs_runnable) (callKernel (SyscallEvent SysReplyRecv)) (fastpaths SysReplyRecv)" including classic_wp_pre supply if_cong[cong] option.case_cong[cong] @@ -1630,8 +1656,7 @@ lemma fastpath_callKernel_SysReplyRecv_corres: and thread=thread in possibleSwitchTo_rewrite)) | rule cteDeleteOne_replycap_rewrite | rule monadic_rewrite_bind monadic_rewrite_refl - | wp assert_inv mapM_x_wp' - setThreadState_obj_at_unchanged + | wp assert_inv mapM_x_wp' sts_valid_objs' asUser_obj_at_unchanged hoare_strengthen_post[OF _ obj_at_conj'[simplified atomize_conjL], rotated] lookupBitmapPriority_lift @@ -1697,8 +1722,8 @@ lemma fastpath_callKernel_SysReplyRecv_corres: | wps)+)[3] apply (simp cong: rev_conj_cong) apply (wpsimp wp: setThreadState_tcbContext[simplified comp_apply] - setThreadState_oa_queued user_getreg_rv - setThreadState_no_sch_change setThreadState_obj_at_unchanged + user_getreg_rv + setThreadState_no_sch_change sts_valid_objs' sts_st_tcb_at'_cases sts_bound_tcb_at' fastpathBestSwitchCandidate_lift[where f="setThreadState s t" for s t] hoare_weak_lift_imp hoare_vcg_all_lift hoare_vcg_imp_lift @@ -1706,8 +1731,7 @@ lemma fastpath_callKernel_SysReplyRecv_corres: hoare_vcg_ex_lift | wps)+ apply (strengthen imp_consequent[where Q="tcb_at' t s" for t s]) - apply ((wp setThreadState_oa_queued user_getreg_rv setThreadState_no_sch_change - setThreadState_obj_at_unchanged + apply ((wp user_getreg_rv setThreadState_no_sch_change sts_st_tcb_at'_cases sts_bound_tcb_at' emptySlot_obj_at'_not_queued emptySlot_obj_at_ep emptySlot_tcbContext[simplified comp_apply] @@ -1893,7 +1917,9 @@ lemma fastpath_callKernel_SysReplyRecv_corres: apply (clarsimp simp: obj_at_tcbs_of tcbSlots cte_level_bits_def) apply (frule(1) st_tcb_at_is_Reply_imp_not_tcbQueued) - apply (auto simp: obj_at_tcbs_of tcbSlots + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (auto simp: obj_at_tcbs_of tcbSlots projectKOs cte_level_bits_def) done diff --git a/proof/crefine/AARCH64/Finalise_C.thy b/proof/crefine/AARCH64/Finalise_C.thy index cf996daaca..4dcda90638 100644 --- a/proof/crefine/AARCH64/Finalise_C.thy +++ b/proof/crefine/AARCH64/Finalise_C.thy @@ -18,6 +18,108 @@ declare if_split [split del] definition "option_map2 f m = option_map f \ m" +definition ksReadyQueues_head_end_2 :: "(domain \ priority \ ready_queue) \ bool" where + "ksReadyQueues_head_end_2 qs \ + \d p. tcbQueueHead (qs (d, p)) \ None \ tcbQueueEnd (qs (d, p)) \ None" + +abbreviation "ksReadyQueues_head_end s \ ksReadyQueues_head_end_2 (ksReadyQueues s)" + +lemmas ksReadyQueues_head_end_def = ksReadyQueues_head_end_2_def + +lemma ksReadyQueues_asrt_ksReadyQueues_head_end: + "ksReadyQueues_asrt s \ ksReadyQueues_head_end s" + by (fastforce dest: tcbQueueHead_iff_tcbQueueEnd + simp: ready_queue_relation_def ksReadyQueues_asrt_def ksReadyQueues_head_end_def) + +lemma tcbSchedEnqueue_ksReadyQueues_head_end[wp]: + "tcbSchedEnqueue tcbPtr \ksReadyQueues_head_end\" + unfolding tcbSchedEnqueue_def tcbQueuePrepend_def setQueue_def + apply (wpsimp wp: threadSet_wp threadGet_wp simp: bitmap_fun_defs) + apply (clarsimp simp: tcbQueueEmpty_def obj_at'_def ksReadyQueues_head_end_def split: if_splits) + done + +lemma ksReadyQueues_head_end_ksSchedulerAction_update[simp]: + "ksReadyQueues_head_end (s\ksSchedulerAction := ChooseNewThread\) = ksReadyQueues_head_end s" + by (simp add: ksReadyQueues_head_end_def) + +crunches rescheduleRequired + for ksReadyQueues_head_end[wp]: ksReadyQueues_head_end + +lemma setThreadState_ksReadyQueues_head_end[wp]: + "setThreadState ts tcbPtr \ksReadyQueues_head_end\" + unfolding setThreadState_def + by (wpsimp wp: threadSet_wp threadGet_wp simp: bitmap_fun_defs) + +definition ksReadyQueues_head_end_tcb_at'_2 :: + "(domain \ priority \ ready_queue) \ (obj_ref \ tcb) \ bool" where + "ksReadyQueues_head_end_tcb_at'_2 qs tcbs \ + \d p. (\head. tcbQueueHead (qs (d, p)) = Some head \ tcbs head \ None) + \ (\end. tcbQueueEnd (qs (d, p)) = Some end \ tcbs end \ None)" + +abbreviation "ksReadyQueues_head_end_tcb_at' s \ + ksReadyQueues_head_end_tcb_at'_2 (ksReadyQueues s) (tcbs_of' s)" + +lemmas ksReadyQueues_head_end_tcb_at'_def = ksReadyQueues_head_end_tcb_at'_2_def + +lemma ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at': + "\ksReadyQueues_asrt s; pspace_aligned' s; pspace_distinct' s\ + \ ksReadyQueues_head_end_tcb_at' s" + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def + ksReadyQueues_head_end_tcb_at'_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: list_queue_relation_def) + apply (intro conjI impI allI) + apply (case_tac "ts = []", clarsimp) + apply (fastforce dest!: heap_path_head hd_in_set + simp: opt_pred_def tcbQueueEmpty_def split: option.splits) + apply (fastforce simp: queue_end_valid_def opt_pred_def tcbQueueEmpty_def + split: option.splits) + done + +lemma tcbSchedEnqueue_ksReadyQueues_head_end_tcb_at'[wp]: + "tcbSchedEnqueue tcbPtr \ksReadyQueues_head_end_tcb_at'\" + unfolding tcbSchedEnqueue_def tcbQueuePrepend_def setQueue_def + apply (wpsimp wp: threadSet_wp threadGet_wp simp: bitmap_fun_defs) + apply (clarsimp simp: ksReadyQueues_head_end_tcb_at'_def split: if_splits) + done + +lemma ksReadyQueues_head_end_tcb_at'_ksSchedulerAction_update[simp]: + "ksReadyQueues_head_end_tcb_at' (s\ksSchedulerAction := ChooseNewThread\) + = ksReadyQueues_head_end_tcb_at' s" + by (simp add: ksReadyQueues_head_end_tcb_at'_def) + +crunches rescheduleRequired + for ksReadyQueues_head_end_tcb_at'[wp]: ksReadyQueues_head_end_tcb_at' + +lemma setThreadState_ksReadyQueues_head_end_tcb_at'[wp]: + "setThreadState ts tcbPtr \ksReadyQueues_head_end_tcb_at'\" + unfolding setThreadState_def + apply (wpsimp wp: threadSet_wp) + apply (fastforce simp: ksReadyQueues_head_end_tcb_at'_def split: if_splits) + done + +lemma head_end_ksReadyQueues_': + "\ (s, s') \ rf_sr; ksReadyQueues_head_end s; ksReadyQueues_head_end_tcb_at' s; + pspace_aligned' s; pspace_distinct' s; + d \ maxDomain; p \ maxPriority \ + \ head_C (index (ksReadyQueues_' (globals s')) (cready_queues_index_to_C d p)) = NULL + \ end_C (index (ksReadyQueues_' (globals s')) (cready_queues_index_to_C d p)) = NULL" + apply (frule (2) rf_sr_ctcb_queue_relation[where d=d and p=p]) + apply (clarsimp simp: ksReadyQueues_head_end_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: ksReadyQueues_head_end_tcb_at'_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: ctcb_queue_relation_def option_to_ctcb_ptr_def split: option.splits) + apply (rename_tac "end" head end_tcb head_tcb) + apply (prop_tac "tcb_at' head s \ tcb_at' end s") + apply (fastforce intro!: aligned'_distinct'_ko_wp_at'I + simp: obj_at'_real_def opt_map_def split: option.splits) + apply (fastforce dest: tcb_at_not_NULL) + done + lemma tcbSchedEnqueue_cslift_spec: "\s. \\\<^bsub>/UNIV\<^esub> \s. \d v. option_map2 tcbPriority_C (cslift s) \tcb = Some v \ unat v \ numPriorities @@ -29,7 +131,9 @@ lemma tcbSchedEnqueue_cslift_spec: \ None \ option_map2 tcbDomain_C (cslift s) (head_C (index \ksReadyQueues (unat (d*0x100 + v)))) - \ None)\ + \ None) + \ (head_C (index \ksReadyQueues (unat (d * 0x100 + v))) \ NULL + \ end_C (index \ksReadyQueues (unat (d * 0x100 + v))) \ NULL)\ Call tcbSchedEnqueue_'proc {s'. option_map2 tcbEPNext_C (cslift s') = option_map2 tcbEPNext_C (cslift s) \ option_map2 tcbEPPrev_C (cslift s') = option_map2 tcbEPPrev_C (cslift s) @@ -46,8 +150,8 @@ lemma tcbSchedEnqueue_cslift_spec: apply (rule conjI) apply (clarsimp simp: typ_heap_simps cong: if_cong) apply (simp split: if_split) - apply (clarsimp simp: typ_heap_simps if_Some_helper cong: if_cong) - by (simp split: if_split) + by (auto simp: typ_heap_simps' if_Some_helper numPriorities_def + cong: if_cong split: if_splits) lemma setThreadState_cslift_spec: "\s. \\\<^bsub>/UNIV\<^esub> \s. s \\<^sub>c \tptr \ (\x. ksSchedulerAction_' (globals s) = tcb_Ptr x @@ -143,8 +247,9 @@ lemma ctcb_relation_tcbPriority_maxPriority_numPriorities: done lemma tcbSchedEnqueue_cslift_precond_discharge: - "\ (s, s') \ rf_sr; obj_at' (P :: tcb \ bool) x s; - valid_queues s; valid_objs' s \ \ + "\ (s, s') \ rf_sr; obj_at' (P :: tcb \ bool) x s; valid_objs' s ; + ksReadyQueues_head_end s; ksReadyQueues_head_end_tcb_at' s; + pspace_aligned' s; pspace_distinct' s\ \ (\d v. option_map2 tcbPriority_C (cslift s') (tcb_ptr_to_ctcb_ptr x) = Some v \ unat v < numPriorities \ option_map2 tcbDomain_C (cslift s') (tcb_ptr_to_ctcb_ptr x) = Some d @@ -155,31 +260,49 @@ lemma tcbSchedEnqueue_cslift_precond_discharge: \ None \ option_map2 tcbDomain_C (cslift s') (head_C (index (ksReadyQueues_' (globals s')) (unat (d*0x100 + v)))) - \ None))" + \ None) + \ (head_C (index (ksReadyQueues_' (globals s')) (unat (d * 0x100 + v))) \ NULL + \ end_C (index (ksReadyQueues_' (globals s')) (unat (d * 0x100 + v))) \ NULL))" apply (drule(1) obj_at_cslift_tcb) apply (clarsimp simp: typ_heap_simps' option_map2_def) + apply (rename_tac tcb tcb') apply (frule_tac t=x in valid_objs'_maxPriority, fastforce simp: obj_at'_def) apply (frule_tac t=x in valid_objs'_maxDomain, fastforce simp: obj_at'_def) apply (drule_tac P="\tcb. tcbPriority tcb \ maxPriority" in obj_at_ko_at2', simp) apply (drule_tac P="\tcb. tcbDomain tcb \ maxDomain" in obj_at_ko_at2', simp) apply (simp add: ctcb_relation_tcbDomain_maxDomain_numDomains ctcb_relation_tcbPriority_maxPriority_numPriorities) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) + apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" in rf_sr_ctcb_queue_relation) apply (simp add: maxDom_to_H maxPrio_to_H)+ + apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" in head_end_ksReadyQueues_', fastforce+) apply (simp add: cready_queues_index_to_C_def2 numPriorities_def le_maxDomain_eq_less_numDomains) apply (clarsimp simp: ctcb_relation_def) apply (frule arg_cong[where f=unat], subst(asm) unat_ucast_up_simp, simp) - apply (frule tcb_queue'_head_end_NULL) - apply (erule conjunct1[OF valid_queues_valid_q]) - apply (frule(1) tcb_queue_relation_qhead_valid') - apply (simp add: valid_queues_valid_q) - apply (clarsimp simp: h_t_valid_clift_Some_iff) + apply (frule (3) head_end_ksReadyQueues_', fastforce+) + apply (clarsimp simp: ksReadyQueues_head_end_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (prop_tac "\ tcbQueueEmpty ((ksReadyQueues s (tcbDomain tcb, tcbPriority tcb)))") + apply (clarsimp simp: tcbQueueEmpty_def ctcb_queue_relation_def option_to_ctcb_ptr_def + split: option.splits) + apply (clarsimp simp: ksReadyQueues_head_end_tcb_at'_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (clarsimp simp: tcbQueueEmpty_def) + apply (rename_tac head "end" head_tcb end_tcb) + apply (prop_tac "tcb_at' head s") + apply (fastforce intro: aligned'_distinct'_ko_wp_at'I + simp: obj_at'_real_def opt_map_def split: option.splits) + apply (frule_tac thread=head in obj_at_cslift_tcb) + apply fastforce + apply (clarsimp dest: obj_at_cslift_tcb simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) done lemma cancel_all_ccorres_helper: "ccorres dc xfdc - (\s. valid_objs' s \ valid_queues s + (\s. valid_objs' s \ pspace_aligned' s \ pspace_distinct' s + \ ksReadyQueues_head_end s \ ksReadyQueues_head_end_tcb_at' s \ (\t\set ts. tcb_at' t s \ t \ 0) \ sch_act_wf (ksSchedulerAction s) s) {s'. \p. ep_queue_relation (cslift s') ts @@ -234,11 +357,11 @@ next apply (erule cmap_relationE1 [OF cmap_relation_tcb]) apply (erule ko_at_projectKO_opt) apply (fastforce intro: typ_heap_simps) - apply (wp sts_running_valid_queues | simp)+ + apply (wp sts_valid_objs' | simp)+ apply (rule ceqv_refl) apply (rule "Cons.hyps") apply (wp sts_valid_objs' sts_sch_act sch_act_wf_lift hoare_vcg_const_Ball_lift - sts_running_valid_queues sts_st_tcb' setThreadState_oa_queued | simp)+ + sts_st_tcb' | simp)+ apply (vcg exspec=setThreadState_cslift_spec exspec=tcbSchedEnqueue_cslift_spec) apply (clarsimp simp: tcb_at_not_NULL Collect_const_mem valid_tcb_state'_def @@ -252,16 +375,13 @@ next st_tcb_at'_def split: scheduler_action.split_asm) apply (rename_tac word) - apply (frule_tac x=word in tcbSchedEnqueue_cslift_precond_discharge) - apply simp - apply clarsimp - apply clarsimp - apply clarsimp + apply (frule_tac x=word in tcbSchedEnqueue_cslift_precond_discharge; clarsimp?) + apply simp apply clarsimp apply (rule conjI) apply (frule(3) tcbSchedEnqueue_cslift_precond_discharge) apply clarsimp - apply clarsimp + apply clarsimp+ apply (subst ep_queue_relation_shift, fastforce) apply (drule_tac x="tcb_ptr_to_ctcb_ptr thread" in fun_cong)+ @@ -270,11 +390,17 @@ next done qed +crunches setEndpoint, setNotification + for ksReadyQueues_head_end[wp]: ksReadyQueues_head_end + and ksReadyQueues_head_end_tcb_at'[wp]: ksReadyQueues_head_end_tcb_at' + (simp: updateObject_default_def) + lemma cancelAllIPC_ccorres: "ccorres dc xfdc - (invs') (UNIV \ {s. epptr_' s = Ptr epptr}) [] + invs' (UNIV \ {s. epptr_' s = Ptr epptr}) [] (cancelAllIPC epptr) (Call cancelAllIPC_'proc)" apply (cinit lift: epptr_') + apply (rule ccorres_stateAssert) apply (rule ccorres_symb_exec_l [OF _ getEndpoint_inv _ empty_fail_getEndpoint]) apply (rule_tac xf'=ret__unsigned_longlong_' and val="case ep of IdleEP \ scast EPState_Idle @@ -289,7 +415,7 @@ lemma cancelAllIPC_ccorres: apply (simp add: cendpoint_relation_def Let_def split: endpoint.split_asm) apply ceqv - apply (rule_tac A="invs' and ko_at' ep epptr" + apply (rule_tac A="invs' and ksReadyQueues_asrt and ko_at' ep epptr" in ccorres_guard_imp2[where A'=UNIV]) apply wpc apply (rename_tac list) @@ -330,12 +456,11 @@ lemma cancelAllIPC_ccorres: apply ceqv apply (ctac add: rescheduleRequired_ccorres) apply (wp weak_sch_act_wf_lift_linear - cancelAllIPC_mapM_x_valid_queues | simp)+ apply (rule mapM_x_wp', wp)+ apply (wp sts_st_tcb') apply (clarsimp split: if_split) - apply (rule mapM_x_wp', wp)+ + apply (rule mapM_x_wp', wp sts_valid_objs')+ apply (clarsimp simp: valid_tcb_state'_def) apply (simp add: guard_is_UNIV_def) apply (wp set_ep_valid_objs' hoare_vcg_const_Ball_lift @@ -378,18 +503,21 @@ lemma cancelAllIPC_ccorres: apply (rule cancel_all_ccorres_helper) apply ceqv apply (ctac add: rescheduleRequired_ccorres) - apply (wp cancelAllIPC_mapM_x_valid_queues) - apply (wp mapM_x_wp' weak_sch_act_wf_lift_linear + apply (wp mapM_x_wp' weak_sch_act_wf_lift_linear sts_valid_objs' sts_st_tcb' | clarsimp simp: valid_tcb_state'_def split: if_split)+ apply (simp add: guard_is_UNIV_def) apply (wp set_ep_valid_objs' hoare_vcg_const_Ball_lift weak_sch_act_wf_lift_linear) apply vcg - apply (clarsimp simp: valid_ep'_def invs_valid_objs' invs_queues) + apply (clarsimp simp: valid_ep'_def invs_valid_objs') apply (rule cmap_relationE1[OF cmap_relation_ep], assumption) apply (erule ko_at_projectKO_opt) apply (frule obj_at_valid_objs', clarsimp+) apply (clarsimp simp: valid_obj'_def valid_ep'_def) + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (frule ksReadyQueues_asrt_ksReadyQueues_head_end) + apply (frule (2) ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at') subgoal by (auto simp: typ_heap_simps cendpoint_relation_def Let_def tcb_queue_relation'_def invs_valid_objs' valid_objs'_maxDomain valid_objs'_maxPriority @@ -401,9 +529,10 @@ lemma cancelAllIPC_ccorres: lemma cancelAllSignals_ccorres: "ccorres dc xfdc - (invs') (UNIV \ {s. ntfnPtr_' s = Ptr ntfnptr}) [] + invs' (UNIV \ {s. ntfnPtr_' s = Ptr ntfnptr}) [] (cancelAllSignals ntfnptr) (Call cancelAllSignals_'proc)" apply (cinit lift: ntfnPtr_') + apply (rule ccorres_stateAssert) apply (rule ccorres_symb_exec_l [OF _ get_ntfn_inv' _ empty_fail_getNotification]) apply (rule_tac xf'=ret__unsigned_longlong_' and val="case ntfnObj ntfn of IdleNtfn \ scast NtfnState_Idle @@ -418,7 +547,7 @@ lemma cancelAllSignals_ccorres: apply (simp add: cnotification_relation_def Let_def split: ntfn.split_asm) apply ceqv - apply (rule_tac A="invs' and ko_at' ntfn ntfnptr" + apply (rule_tac A="invs' and ksReadyQueues_asrt and ko_at' ntfn ntfnptr" in ccorres_guard_imp2[where A'=UNIV]) apply wpc apply (simp add: notification_state_defs ccorres_cond_iffs) @@ -458,8 +587,7 @@ lemma cancelAllSignals_ccorres: apply (rule cancel_all_ccorres_helper) apply ceqv apply (ctac add: rescheduleRequired_ccorres) - apply (wp cancelAllIPC_mapM_x_valid_queues) - apply (wp mapM_x_wp' weak_sch_act_wf_lift_linear + apply (wp mapM_x_wp' weak_sch_act_wf_lift_linear sts_valid_objs' sts_st_tcb' | clarsimp simp: valid_tcb_state'_def split: if_split)+ apply (simp add: guard_is_UNIV_def) apply (wp set_ntfn_valid_objs' hoare_vcg_const_Ball_lift @@ -470,6 +598,10 @@ lemma cancelAllSignals_ccorres: apply (erule ko_at_projectKO_opt) apply (frule obj_at_valid_objs', clarsimp+) apply (clarsimp simp add: valid_obj'_def valid_ntfn'_def) + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (frule ksReadyQueues_asrt_ksReadyQueues_head_end) + apply (frule (2) ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at') subgoal by (auto simp: typ_heap_simps cnotification_relation_def Let_def tcb_queue_relation'_def invs_valid_objs' valid_objs'_maxDomain valid_objs'_maxPriority @@ -554,16 +686,16 @@ lemma tcb_queue_relation2_cong: context kernel_m begin -lemma setThreadState_ccorres_valid_queues'_simple: - "ccorres dc xfdc (\s. tcb_at' thread s \ valid_queues' s \ \ runnable' st \ sch_act_simple s) +lemma setThreadState_ccorres_simple: + "ccorres dc xfdc (\s. tcb_at' thread s \ \ runnable' st \ sch_act_simple s) ({s'. (\cl fl. cthread_state_relation_lifted st (cl\tsType_CL := ts_' s' && mask 4\, fl))} \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) [] (setThreadState st thread) (Call setThreadState_'proc)" apply (cinit lift: tptr_' cong add: call_ignore_cong) apply (ctac (no_vcg) add: threadSet_tcbState_simple_corres) apply (ctac add: scheduleTCB_ccorres_valid_queues'_simple) - apply (wp threadSet_valid_queues'_and_not_runnable') - apply (clarsimp simp: weak_sch_act_wf_def valid_queues'_def) + apply (wp threadSet_tcbState_st_tcb_at') + apply (fastforce simp: weak_sch_act_wf_def) done lemma updateRestartPC_ccorres: @@ -579,9 +711,7 @@ lemma updateRestartPC_ccorres: done crunches updateRestartPC - for valid_queues'[wp]: valid_queues' - and sch_act_simple[wp]: sch_act_simple - and valid_queues[wp]: Invariants_H.valid_queues + for sch_act_simple[wp]: sch_act_simple and valid_objs'[wp]: valid_objs' and tcb_at'[wp]: "tcb_at' p" @@ -625,21 +755,12 @@ lemma suspend_ccorres: apply (ctac (no_vcg) add: updateRestartPC_ccorres) apply (rule ccorres_return_Skip) apply ceqv - apply (ctac(no_vcg) add: setThreadState_ccorres_valid_queues'_simple) - apply (ctac add: tcbSchedDequeue_ccorres') - apply (rule_tac Q="\_. - (\s. \t' d p. (t' \ set (ksReadyQueues s (d, p)) \ - obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d - \ tcbPriority tcb = p) t' s \ - (t' \ thread \ st_tcb_at' runnable' t' s)) \ - distinct (ksReadyQueues s (d, p))) and valid_queues' and valid_objs' and tcb_at' thread" - in hoare_post_imp) + apply (ctac(no_vcg) add: setThreadState_ccorres_simple) + apply (ctac add: tcbSchedDequeue_ccorres) + apply (rule_tac Q="\_. valid_objs' and tcb_at' thread and pspace_aligned' and pspace_distinct'" + in hoare_post_imp) apply clarsimp - apply (drule_tac x="t" in spec) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp elim!: obj_at'_weakenE simp: inQ_def) - apply (wp sts_valid_queues_partial)[1] + apply (wp sts_valid_objs')[1] apply clarsimp apply (wpsimp simp: valid_tcb_state'_def) apply clarsimp @@ -654,8 +775,7 @@ lemma suspend_ccorres: apply (rule cancelIPC_sch_act_simple) apply (rule cancelIPC_tcb_at'[where t=thread]) apply (rule delete_one_conc_fr.cancelIPC_invs) - apply (fastforce simp: invs_valid_queues' invs_queues invs_valid_objs' - valid_tcb_state'_def) + apply (fastforce simp: invs_valid_objs' valid_tcb_state'_def) apply (auto simp: ThreadState_defs) done @@ -839,7 +959,7 @@ lemma unbindMaybeNotification_ccorres: apply (wp getNotification_wp) apply (clarsimp ) apply (frule (1) ko_at_valid_ntfn'[OF _ invs_valid_objs']) - by (auto simp: valid_ntfn'_def valid_bound_tcb'_def obj_at'_def + by (auto simp: valid_ntfn'_def obj_at'_def objBitsKO_def is_aligned_def option_to_ctcb_ptr_def tcb_at_not_NULL split: ntfn.splits) @@ -978,7 +1098,7 @@ lemma finaliseCap_True_cases_ccorres: apply (rule TrueI conjI impI TrueI)+ apply (frule cap_get_tag_to_H, erule(1) cap_get_tag_isCap [THEN iffD2]) apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def isNotificationCap_def - isEndpointCap_def valid_obj'_def valid_ntfn'_def valid_bound_tcb'_def + isEndpointCap_def valid_obj'_def valid_ntfn'_def dest!: obj_at_valid_objs') apply clarsimp apply (frule cap_get_tag_to_H, erule(1) cap_get_tag_isCap [THEN iffD2]) @@ -1885,20 +2005,6 @@ lemma ep_queue_relation_shift2: apply (clarsimp split: option.split_asm) done -lemma sched_queue_relation_shift: - "(option_map2 tcbSchedNext_C (f (cslift s)) - = option_map2 tcbSchedNext_C (cslift s) - \ option_map2 tcbSchedPrev_C (f (cslift s)) - = option_map2 tcbSchedPrev_C (cslift s)) - \ sched_queue_relation (f (cslift s)) ts qPrev qHead - = sched_queue_relation (cslift s) ts qPrev qHead" - apply (induct ts arbitrary: qPrev qHead; clarsimp) - apply (simp add: option_map2_def fun_eq_iff - map_option_case) - apply (drule_tac x=qHead in spec)+ - apply (clarsimp split: option.split_asm) - done - lemma cendpoint_relation_udpate_arch: "\ cslift x p = Some tcb ; cendpoint_relation (cslift x) v v' \ \ cendpoint_relation ((cslift x)(p \ tcbArch_C_update f tcb)) v v'" @@ -1931,27 +2037,24 @@ lemma archThreadSet_tcbVCPU_Basic_ccorres: apply (rule ccorres_guard_imp2) apply (rule ccorres_pre_getObject_tcb) apply (rule_tac P="tcb_at' tptr and ko_at' tcb tptr" and P'=UNIV in setObject_ccorres_helper) - apply (simp_all add: objBits_simps' archObjSize_def pageBits_def obj_tcb_at') + apply (simp_all add: objBits_simps' obj_tcb_at') apply (rule conseqPre, vcg, clarsimp) apply (rule cmap_relationE1[OF cmap_relation_tcb], assumption, erule ko_at_projectKO_opt) apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def update_tcb_map_tos - typ_heap_simps' cpspace_relation_def update_tcb_map_tos) - apply (safe ; (clarsimp simp: cpspace_relation_def typ_heap_simps - carch_state_relation_def Let_def - update_tcb_map_to_tcb - cmachine_state_relation_def - update_tcb_map_tos)?) + typ_heap_simps' cpspace_relation_def) + apply (safe ; (clarsimp simp: cpspace_relation_def typ_heap_simps + carch_state_relation_def Let_def + update_tcb_map_to_tcb + cmachine_state_relation_def + update_tcb_map_tos)?) apply (subst map_to_ctes_upd_tcb_no_ctes; simp add: tcb_cte_cases_def cteSizeBits_def) apply (erule cmap_relation_updI, erule ko_at_projectKO_opt, simp+) apply (clarsimp simp: ctcb_relation_def carch_tcb_relation_def ccontext_relation_def atcbContextGet_def) apply clarsimp apply (rule cmap_relation_rel_upd[OF _ cendpoint_relation_udpate_arch], simp+) - apply (rule cmap_relation_rel_upd[OF _ cnotification_relation_udpate_arch], simp+) - apply (clarsimp simp add: cready_queues_relation_def Let_def tcb_queue_relation'_def) - apply (subst sched_queue_relation_shift; simp add: fun_eq_iff) - apply (safe ; case_tac "xa = tcb_ptr_to_ctcb_ptr tptr" ; clarsimp simp: option_map2_def map_option_case) - apply (clarsimp simp: cvariable_relation_upd_const) + apply (rule cmap_relation_rel_upd[OF _ cnotification_relation_udpate_arch], simp+) + apply (clarsimp simp: cvariable_relation_upd_const) done lemma setObject_vcpuTCB_updated_Basic_ccorres: @@ -1962,7 +2065,7 @@ lemma setObject_vcpuTCB_updated_Basic_ccorres: (option_to_ctcb_ptr tptr :: tcb_C ptr)))) s)))" apply (rule ccorres_guard_imp2) apply (rule_tac P="ko_at' (vcpuTCBPtr_update t vcpu) vcpuptr" and P'=UNIV in setObject_ccorres_helper) - apply (simp_all add: objBits_simps archObjSize_def pageBits_def obj_tcb_at' vcpuBits_def) + apply (simp_all add: objBits_simps pageBits_def obj_tcb_at' vcpuBits_def) apply (rule conseqPre, vcg, clarsimp) apply (rule cmap_relationE1[OF cmap_relation_vcpu], assumption, erule ko_at_projectKO_opt) apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def typ_heap_simps' diff --git a/proof/crefine/AARCH64/Interrupt_C.thy b/proof/crefine/AARCH64/Interrupt_C.thy index ff57a72814..423709498a 100644 --- a/proof/crefine/AARCH64/Interrupt_C.thy +++ b/proof/crefine/AARCH64/Interrupt_C.thy @@ -259,7 +259,7 @@ supply [[goals_limit=20]] apply (simp add: syscall_error_to_H_cases) apply simp apply (clarsimp simp: Collect_const_mem tcb_at_invs') - apply (clarsimp simp: invs_queues invs_valid_objs' + apply (clarsimp simp: invs_valid_objs' ct_in_state'_def ccap_rights_relation_def mask_def[where n=4] ThreadState_defs) @@ -275,7 +275,7 @@ supply [[goals_limit=20]] excaps_map_def excaps_in_mem_def word_less_nat_alt hd_conv_nth slotcap_in_mem_def valid_tcb_state'_def dest!: interpret_excaps_eq split: bool.splits)+ - apply (auto dest: st_tcb_at_idle_thread' ctes_of_valid')[4] + apply (auto dest: st_tcb_at_idle_thread' ctes_of_valid')[6] apply (drule ctes_of_valid') apply fastforce apply (clarsimp simp add:valid_cap_simps' AARCH64.maxIRQ_def) diff --git a/proof/crefine/AARCH64/Invoke_C.thy b/proof/crefine/AARCH64/Invoke_C.thy index 8433d438b3..f8507f2b61 100644 --- a/proof/crefine/AARCH64/Invoke_C.thy +++ b/proof/crefine/AARCH64/Invoke_C.thy @@ -80,15 +80,14 @@ lemma setDomain_ccorres: and (\s. curThread = ksCurThread s)" in hoare_strengthen_post) apply (wp threadSet_all_invs_but_sch_extra) - apply (clarsimp simp: valid_pspace_valid_objs' st_tcb_at_def[symmetric] - sch_act_simple_def st_tcb_at'_def weak_sch_act_wf_def - split: if_splits) + apply (fastforce simp: valid_pspace_valid_objs' st_tcb_at_def[symmetric] + sch_act_simple_def st_tcb_at'_def weak_sch_act_wf_def + split: if_splits) apply (simp add: guard_is_UNIV_def) - apply (rule_tac Q="\_. invs' and tcb_at' t and sch_act_simple - and (\s. curThread = ksCurThread s \ (\p. t \ set (ksReadyQueues s p)))" + apply (rule_tac Q="\_. invs' and tcb_at' t and sch_act_simple and (\s. curThread = ksCurThread s)" in hoare_strengthen_post) apply (wp weak_sch_act_wf_lift_linear tcbSchedDequeue_not_queued - tcbSchedDequeue_not_in_queue hoare_vcg_imp_lift hoare_vcg_all_lift) + hoare_vcg_imp_lift hoare_vcg_all_lift) apply (clarsimp simp: invs'_def valid_pspace'_def valid_state'_def) apply (fastforce simp: valid_tcb'_def tcb_cte_cases_def invs'_def valid_state'_def valid_pspace'_def) @@ -196,8 +195,8 @@ lemma decodeDomainInvocation_ccorres: apply clarsimp apply (vcg exspec=getSyscallArg_modifies) - apply (clarsimp simp: valid_tcb_state'_def invs_valid_queues' invs_valid_objs' - invs_queues invs_sch_act_wf' ct_in_state'_def pred_tcb_at' + apply (clarsimp simp: valid_tcb_state'_def invs_valid_objs' + invs_sch_act_wf' ct_in_state'_def pred_tcb_at' rf_sr_ksCurThread word_sle_def word_sless_def sysargs_rel_to_n mask_eq_iff_w2p mask_eq_iff_w2p word_size ThreadState_defs) apply (rule conjI) @@ -207,7 +206,7 @@ lemma decodeDomainInvocation_ccorres: apply (drule_tac x="extraCaps ! 0" and P="\v. valid_cap' (fst v) s" in bspec) apply (clarsimp simp: nth_mem interpret_excaps_test_null excaps_map_def) apply (clarsimp simp: valid_cap_simps' pred_tcb'_weakenE active_runnable') - apply (rule conjI) + apply (intro conjI; fastforce?) apply (fastforce simp: tcb_st_refs_of'_def elim:pred_tcb'_weakenE) apply (simp add: word_le_nat_alt unat_ucast unat_numDomains_to_H le_maxDomain_eq_less_numDomains) apply (clarsimp simp: ccap_relation_def cap_to_H_simps cap_thread_cap_lift) @@ -760,15 +759,15 @@ lemma decodeCNodeInvocation_ccorres: apply simp apply (wp injection_wp_E[OF refl]) apply (rule hoare_post_imp_R) - apply (rule_tac Q'="\rv. valid_pspace' and valid_queues + apply (rule_tac Q'="\rv. valid_pspace' and valid_cap' rv and valid_objs' and tcb_at' thread and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_vcg_R_conj) apply (rule deriveCap_Null_helper[OF deriveCap_derived]) apply wp apply (clarsimp simp: cte_wp_at_ctes_of) - apply (simp add: is_derived'_def badge_derived'_def - valid_tcb_state'_def) + apply (fastforce simp: is_derived'_def badge_derived'_def + valid_tcb_state'_def) apply (simp add: Collect_const_mem all_ex_eq_helper) apply (vcg exspec=deriveCap_modifies) apply wp @@ -836,14 +835,14 @@ lemma decodeCNodeInvocation_ccorres: apply (simp add: conj_comms valid_tcb_state'_def) apply (wp injection_wp_E[OF refl]) apply (rule hoare_post_imp_R) - apply (rule_tac Q'="\rv. valid_pspace' and valid_queues + apply (rule_tac Q'="\rv. valid_pspace' and valid_cap' rv and valid_objs' and tcb_at' thread and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_vcg_R_conj) apply (rule deriveCap_Null_helper [OF deriveCap_derived]) apply wp apply (clarsimp simp: cte_wp_at_ctes_of) - apply (simp add: is_derived'_def badge_derived'_def) + apply (fastforce simp: is_derived'_def badge_derived'_def) apply (simp add: Collect_const_mem all_ex_eq_helper) apply (vcg exspec=deriveCap_modifies) apply (simp add: Collect_const_mem) @@ -951,12 +950,14 @@ lemma decodeCNodeInvocation_ccorres: apply (rule_tac Q'="\a b. cte_wp_at' (\x. True) a b \ invs' b \ tcb_at' thread b \ sch_act_wf (ksSchedulerAction b) b \ valid_tcb_state' Restart b \ Q2 b" for Q2 in hoare_post_imp_R) - prefer 2 - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (drule ctes_of_valid') - apply (erule invs_valid_objs') - apply (clarsimp simp:valid_updateCapDataI invs_queues invs_valid_objs' invs_valid_pspace') - apply (assumption) + prefer 2 + apply (clarsimp simp:cte_wp_at_ctes_of) + apply (drule ctes_of_valid') + apply (erule invs_valid_objs') + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (clarsimp simp:valid_updateCapDataI invs_valid_objs' invs_valid_pspace') + apply assumption apply (wp hoare_vcg_all_lift_R injection_wp_E[OF refl] lsfco_cte_at' hoare_vcg_const_imp_lift_R )+ @@ -1351,7 +1352,7 @@ lemma decodeCNodeInvocation_ccorres: apply simp apply (vcg exspec=getSyscallArg_modifies) apply (clarsimp simp: valid_tcb_state'_def invs_valid_objs' invs_valid_pspace' - ct_in_state'_def pred_tcb_at' invs_queues + ct_in_state'_def pred_tcb_at' cur_tcb'_def word_sle_def word_sless_def unat_lt2p[where 'a=machine_word_len, folded word_bits_def]) apply (rule conjI) @@ -1383,9 +1384,6 @@ end context begin interpretation Arch . (*FIXME: arch_split*) -crunch valid_queues[wp]: insertNewCap "valid_queues" - (wp: crunch_wps) - lemmas setCTE_def3 = setCTE_def2[THEN eq_reflection] lemma setCTE_sch_act_wf[wp]: @@ -3311,7 +3309,7 @@ lemma decodeUntypedInvocation_ccorres_helper: and sch_act_simple and ct_active'" in hoare_post_imp_R) prefer 2 apply (clarsimp simp: invs_valid_objs' invs_mdb' - invs_queues ct_in_state'_def pred_tcb_at') + ct_in_state'_def pred_tcb_at') apply (subgoal_tac "ksCurThread s \ ksIdleThread sa") prefer 2 apply clarsimp diff --git a/proof/crefine/AARCH64/IpcCancel_C.thy b/proof/crefine/AARCH64/IpcCancel_C.thy index 540b3b7737..eab695a1e4 100644 --- a/proof/crefine/AARCH64/IpcCancel_C.thy +++ b/proof/crefine/AARCH64/IpcCancel_C.thy @@ -14,12 +14,12 @@ context kernel_m begin lemma cready_queues_index_to_C_in_range': - assumes prems: "qdom \ ucast maxDom" "prio \ ucast maxPrio" + assumes prems: "qdom \ maxDomain" "prio \ maxPriority" shows "cready_queues_index_to_C qdom prio < num_tcb_queues" proof - have P: "unat prio < numPriorities" using prems - by (simp add: numPriorities_def seL4_MaxPrio_def Suc_le_lessD unat_le_helper) + by (simp add: numPriorities_def Suc_le_lessD unat_le_helper maxDomain_def maxPriority_def) have Q: "unat qdom < numDomains" using prems by (simp add: maxDom_to_H le_maxDomain_eq_less_numDomains word_le_nat_alt) @@ -33,36 +33,18 @@ lemmas cready_queues_index_to_C_in_range = lemma cready_queues_index_to_C_inj: "\ cready_queues_index_to_C qdom prio = cready_queues_index_to_C qdom' prio'; - prio \ ucast maxPrio; prio' \ ucast maxPrio \ \ prio = prio' \ qdom = qdom'" + prio \ maxPriority; prio' \ maxPriority \ \ prio = prio' \ qdom = qdom'" apply (rule context_conjI) - apply (auto simp: cready_queues_index_to_C_def numPriorities_def + apply (auto simp: cready_queues_index_to_C_def numPriorities_def maxPriority_def seL4_MaxPrio_def word_le_nat_alt dest: arg_cong[where f="\x. x mod 256"]) done lemma cready_queues_index_to_C_distinct: - "\ qdom = qdom' \ prio \ prio'; prio \ ucast maxPrio; prio' \ ucast maxPrio \ + "\ qdom = qdom' \ prio \ prio'; prio \ maxPriority; prio' \ maxPriority \ \ cready_queues_index_to_C qdom prio \ cready_queues_index_to_C qdom' prio'" apply (auto simp: cready_queues_index_to_C_inj) done -lemma cstate_relation_ksReadyQueues_update: - "\ cstate_relation hs cs; arr = ksReadyQueues_' cs; - sched_queue_relation' (clift (t_hrs_' cs)) v (head_C v') (end_C v'); - qdom \ ucast maxDom; prio \ ucast maxPrio \ - \ cstate_relation (ksReadyQueues_update (\qs. qs ((qdom, prio) := v)) hs) - (ksReadyQueues_'_update (\_. Arrays.update arr - (cready_queues_index_to_C qdom prio) v') cs)" - apply (clarsimp simp: cstate_relation_def Let_def - cmachine_state_relation_def - carch_state_relation_def carch_globals_def - cready_queues_relation_def seL4_MinPrio_def minDom_def) - apply (frule cready_queues_index_to_C_in_range, assumption) - apply clarsimp - apply (frule_tac qdom=qdoma and prio=prioa in cready_queues_index_to_C_in_range, assumption) - apply (frule cready_queues_index_to_C_distinct, assumption+) - apply clarsimp - done - lemma cmap_relation_drop_fun_upd: "\ cm x = Some v; \v''. rel v'' v = rel v'' v' \ \ cmap_relation am (cm (x \ v')) f rel @@ -73,16 +55,6 @@ lemma cmap_relation_drop_fun_upd: apply (auto split: if_split) done -lemma valid_queuesD': - "\ obj_at' (inQ d p) t s; valid_queues' s \ - \ t \ set (ksReadyQueues s (d, p))" - by (simp add: valid_queues'_def) - -lemma invs_valid_queues'[elim!]: - "invs' s \ valid_queues' s" - by (simp add: invs'_def valid_state'_def) - - lemma ntfn_ptr_get_queue_spec: "\s. \ \ {\. s = \ \ \ \\<^sub>c \<^bsup>\\<^esup>ntfnPtr} \ret__struct_tcb_queue_C :== PROC ntfn_ptr_get_queue(\ntfnPtr) \head_C \ret__struct_tcb_queue_C = Ptr (ntfnQueue_head_CL (notification_lift (the (cslift s \<^bsup>s\<^esup>ntfnPtr)))) \ @@ -233,22 +205,19 @@ lemma cancelSignal_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) - apply simp - apply (erule (1) map_to_ko_atI') - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) - apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def) - apply (simp add: carch_state_relation_def carch_globals_def) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) + apply simp + apply (erule (1) map_to_ko_atI') + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) + apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def) + apply (simp add: carch_state_relation_def carch_globals_def) apply (clarsimp simp: carch_state_relation_def carch_globals_def typ_heap_simps' packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) @@ -269,34 +238,31 @@ lemma cancelSignal_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_ntfn_queue) - apply fastforce - apply assumption+ - apply simp - apply (erule (1) map_to_ko_atI') - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) - apply (simp add: cnotification_relation_def Let_def isWaitingNtfn_def - split: ntfn.splits split del: if_split) - apply (erule iffD1 [OF tcb_queue_relation'_cong [OF refl _ _ refl], rotated -1]) - apply (clarsimp simp add: h_t_valid_clift_Some_iff) - apply (subst tcb_queue_relation'_next_canonical; assumption?) - apply fastforce - apply (simp add: notification_lift_def make_canonical_def canonical_bit_def) - apply (clarsimp simp: h_t_valid_clift_Some_iff notification_lift_def) - apply (subst tcb_queue_relation'_prev_canonical; assumption?) - apply fastforce - apply (simp add: make_canonical_def canonical_bit_def) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (rule cendpoint_relation_ntfn_queue) + apply fastforce + apply assumption+ + apply simp + apply (erule (1) map_to_ko_atI') + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) + apply (simp add: cnotification_relation_def Let_def isWaitingNtfn_def + split: ntfn.splits split del: if_split) + apply (erule iffD1 [OF tcb_queue_relation'_cong [OF refl _ _ refl], rotated -1]) + apply (clarsimp simp add: h_t_valid_clift_Some_iff) + apply (subst tcb_queue_relation'_next_canonical; assumption?) + apply fastforce + apply (simp add: notification_lift_def make_canonical_def canonical_bit_def) + apply (clarsimp simp: h_t_valid_clift_Some_iff notification_lift_def) + apply (subst tcb_queue_relation'_prev_canonical; assumption?) + apply fastforce + apply (simp add: make_canonical_def canonical_bit_def) + apply simp subgoal by (clarsimp simp: carch_state_relation_def carch_globals_def) subgoal by (simp add: cmachine_state_relation_def) subgoal by (simp add: h_t_valid_clift_Some_iff) @@ -462,68 +428,6 @@ lemma isRunnable_ccorres [corres]: apply (simp add: ThreadState_defs)+ done - - -lemma tcb_queue_relation_update_head: - fixes getNext_update :: "(tcb_C ptr \ tcb_C ptr) \ tcb_C \ tcb_C" and - getPrev_update :: "(tcb_C ptr \ tcb_C ptr) \ tcb_C \ tcb_C" - assumes qr: "tcb_queue_relation getNext getPrev mp queue NULL qhead" - and qh': "qhead' \ tcb_ptr_to_ctcb_ptr ` set queue" - and cs_tcb: "mp qhead' = Some tcb" - and valid_ep: "\t\set queue. tcb_at' t s" "distinct queue" - and qhN: "qhead' \ NULL" - and fgN: "fg_cons getNext (getNext_update \ (\x _. x))" - and fgP: "fg_cons getPrev (getPrev_update \ (\x _. x))" - and npu: "\f t. getNext (getPrev_update f t) = getNext t" - and pnu: "\f t. getPrev (getNext_update f t) = getPrev t" - shows "tcb_queue_relation getNext getPrev - (upd_unless_null qhead (getPrev_update (\_. qhead') (the (mp qhead))) - (mp(qhead' := Some (getPrev_update (\_. NULL) (getNext_update (\_. qhead) tcb))))) - (ctcb_ptr_to_tcb_ptr qhead' # queue) NULL qhead'" - using qr qh' cs_tcb valid_ep qhN - apply (subgoal_tac "qhead \ qhead'") - apply (clarsimp simp: pnu upd_unless_null_def fg_consD1 [OF fgN] fg_consD1 [OF fgP] npu) - apply (cases queue) - apply simp - apply (frule (2) tcb_queue_relation_next_not_NULL) - apply simp - apply (clarsimp simp: fg_consD1 [OF fgN] fg_consD1 [OF fgP] pnu npu) - apply (subst tcb_queue_relation_cong [OF refl refl refl, where mp' = mp]) - apply (clarsimp simp: inj_eq) - apply (intro impI conjI) - apply (frule_tac x = x in imageI [where f = tcb_ptr_to_ctcb_ptr]) - apply simp - apply simp - apply simp - apply clarsimp - apply (cases queue) - apply simp - apply simp - done - -lemma tcbSchedEnqueue_update: - assumes sr: "sched_queue_relation' mp queue qhead qend" - and qh': "qhead' \ tcb_ptr_to_ctcb_ptr ` set queue" - and cs_tcb: "mp qhead' = Some tcb" - and valid_ep: "\t\set queue. tcb_at' t s" "distinct queue" - and qhN: "qhead' \ NULL" - shows - "sched_queue_relation' - (upd_unless_null qhead (tcbSchedPrev_C_update (\_. qhead') (the (mp qhead))) - (mp(qhead' \ tcb\tcbSchedNext_C := qhead, tcbSchedPrev_C := NULL\))) - (ctcb_ptr_to_tcb_ptr qhead' # queue) qhead' (if qend = NULL then qhead' else qend)" - using sr qh' cs_tcb valid_ep qhN - apply - - apply (erule tcb_queue_relationE') - apply (rule tcb_queue_relationI') - apply (erule (5) tcb_queue_relation_update_head - [where getNext_update = tcbSchedNext_C_update and getPrev_update = tcbSchedPrev_C_update], simp_all)[1] - apply simp - apply (intro impI) - apply (erule (1) tcb_queue_relation_not_NULL') - apply simp - done - lemma tcb_ptr_to_ctcb_ptr_imageD: "x \ tcb_ptr_to_ctcb_ptr ` S \ ctcb_ptr_to_tcb_ptr x \ S" apply (erule imageE) @@ -536,93 +440,6 @@ lemma ctcb_ptr_to_tcb_ptr_imageI: apply simp done -lemma tcb_queue'_head_end_NULL: - assumes qr: "tcb_queue_relation' getNext getPrev mp queue qhead qend" - and tat: "\t\set queue. tcb_at' t s" - shows "(qend = NULL) = (qhead = NULL)" - using qr tat - apply - - apply (erule tcb_queue_relationE') - apply (simp add: tcb_queue_head_empty_iff) - apply (rule impI) - apply (rule tcb_at_not_NULL) - apply (erule bspec) - apply simp - done - -lemma tcb_queue_relation_qhead_mem: - "\ tcb_queue_relation getNext getPrev mp queue NULL qhead; - (\tcb\set queue. tcb_at' tcb t) \ - \ qhead \ NULL \ ctcb_ptr_to_tcb_ptr qhead \ set queue" - by (clarsimp simp: tcb_queue_head_empty_iff tcb_queue_relation_head_hd) - -lemma tcb_queue_relation_qhead_valid: - "\ tcb_queue_relation getNext getPrev (cslift s') queue NULL qhead; - (s, s') \ rf_sr; (\tcb\set queue. tcb_at' tcb s) \ - \ qhead \ NULL \ s' \\<^sub>c qhead" - apply (frule (1) tcb_queue_relation_qhead_mem) - apply clarsimp - apply(drule (3) tcb_queue_memberD) - apply (simp add: h_t_valid_clift_Some_iff) - done - -lemmas tcb_queue_relation_qhead_mem' = tcb_queue_relation_qhead_mem [OF tcb_queue_relation'_queue_rel] -lemmas tcb_queue_relation_qhead_valid' = tcb_queue_relation_qhead_valid [OF tcb_queue_relation'_queue_rel] - - -lemma valid_queues_valid_q: - "valid_queues s \ (\tcb\set (ksReadyQueues s (qdom, prio)). tcb_at' tcb s) \ distinct (ksReadyQueues s (qdom, prio))" - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def) - apply (drule spec [where x = qdom]) - apply (drule spec [where x = prio]) - apply clarsimp - apply (drule (1) bspec, erule obj_at'_weakenE) - apply simp - done - -lemma invs_valid_q: - "invs' s \ (\tcb\set (ksReadyQueues s (qdom, prio)). tcb_at' tcb s) \ distinct (ksReadyQueues s (qdom, prio))" - apply (rule valid_queues_valid_q) - apply (clarsimp simp: invs'_def valid_state'_def) - done - -lemma tcbQueued_not_in_queues: - assumes vq: "valid_queues s" - and objat: "obj_at' (Not \ tcbQueued) thread s" - shows "thread \ set (ksReadyQueues s (d, p))" - using vq objat - apply - - apply clarsimp - apply (drule (1) valid_queues_obj_at'D) - apply (erule obj_atE')+ - apply (clarsimp simp: inQ_def) - done - - -lemma rf_sr_sched_queue_relation: - "\ (s, s') \ rf_sr; d \ ucast maxDom; p \ ucast maxPrio \ - \ sched_queue_relation' (cslift s') (ksReadyQueues s (d, p)) - (head_C (index (ksReadyQueues_' (globals s')) - (cready_queues_index_to_C d p))) - (end_C (index (ksReadyQueues_' (globals s')) - (cready_queues_index_to_C d p)))" - unfolding rf_sr_def cstate_relation_def cready_queues_relation_def - apply (clarsimp simp: Let_def seL4_MinPrio_def minDom_def) - done - -lemma ready_queue_not_in: - assumes vq: "valid_queues s" - and inq: "t \ set (ksReadyQueues s (d, p))" - and neq: "d \ d' \ p \ p'" - shows "t \ set (ksReadyQueues s (d', p'))" -proof - assume "t \ set (ksReadyQueues s (d', p'))" - hence "obj_at' (inQ d' p') t s" using vq by (rule valid_queues_obj_at'D) - moreover have "obj_at' (inQ d p) t s" using inq vq by (rule valid_queues_obj_at'D) - ultimately show False using neq - by (clarsimp elim!: obj_atE' simp: inQ_def) -qed - lemma ctcb_relation_unat_prio_eq: "ctcb_relation tcb tcb' \ unat (tcbPriority tcb) = unat (tcbPriority_C tcb')" apply (clarsimp simp: ctcb_relation_def) @@ -656,137 +473,6 @@ lemma threadSet_queued_ccorres [corres]: apply (clarsimp simp: typ_heap_simps) done -lemma ccorres_pre_getQueue: - assumes cc: "\queue. ccorres r xf (P queue) (P' queue) hs (f queue) c" - shows "ccorres r xf (\s. P (ksReadyQueues s (d, p)) s \ d \ maxDomain \ p \ maxPriority) - {s'. \queue. (let cqueue = index (ksReadyQueues_' (globals s')) - (cready_queues_index_to_C d p) in - sched_queue_relation' (cslift s') queue (head_C cqueue) (end_C cqueue)) \ s' \ P' queue} - hs (getQueue d p >>= (\queue. f queue)) c" - apply (rule ccorres_guard_imp2) - apply (rule ccorres_symb_exec_l2) - defer - defer - apply (rule gq_sp) - defer - apply (rule ccorres_guard_imp) - apply (rule cc) - apply clarsimp - apply assumption - apply assumption - apply (clarsimp simp: getQueue_def gets_exs_valid) - apply clarsimp - apply (drule spec, erule mp) - apply (simp add: Let_def) - apply (erule rf_sr_sched_queue_relation) - apply (simp add: maxDom_to_H maxPrio_to_H)+ - done - -lemma state_relation_queue_update_helper': - "\ (s, s') \ rf_sr; - (\d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct (ksReadyQueues s (d, p))); - globals t = ksReadyQueues_'_update - (\_. Arrays.update (ksReadyQueues_' (globals s')) prio' q') - (t_hrs_'_update f (globals s')); - sched_queue_relation' (cslift t) q (head_C q') (end_C q'); - cslift t |` ( - tcb_ptr_to_ctcb_ptr ` S ) - = cslift s' |` ( - tcb_ptr_to_ctcb_ptr ` S ); - option_map tcb_null_sched_ptrs \ cslift t - = option_map tcb_null_sched_ptrs \ cslift s'; - cslift_all_but_tcb_C t s'; - zero_ranges_are_zero (gsUntypedZeroRanges s) (f (t_hrs_' (globals s'))) - = zero_ranges_are_zero (gsUntypedZeroRanges s) (t_hrs_' (globals s')); - hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s')); - prio' = cready_queues_index_to_C qdom prio; - \x \ S. obj_at' (inQ qdom prio) x s - \ (obj_at' (\tcb. tcbPriority tcb = prio) x s - \ obj_at' (\tcb. tcbDomain tcb = qdom) x s) - \ (tcb_at' x s \ (\d' p'. (d' \ qdom \ p' \ prio) - \ x \ set (ksReadyQueues s (d', p')))); - S \ {}; qdom \ ucast maxDom; prio \ ucast maxPrio \ - \ (s \ksReadyQueues := (ksReadyQueues s)((qdom, prio) := q)\, t) \ rf_sr" - apply (subst(asm) disj_imp_rhs) - apply (subst obj_at'_and[symmetric]) - apply (rule disjI1, erule obj_at'_weakenE, simp add: inQ_def) - apply (subst(asm) disj_imp_rhs) - apply (subst(asm) obj_at'_and[symmetric]) - apply (rule conjI, erule obj_at'_weakenE, simp) - apply (rule allI, rule allI) - apply (drule_tac x=d' in spec) - apply (drule_tac x=p' in spec) - apply clarsimp - apply (drule(1) bspec) - apply (clarsimp simp: inQ_def obj_at'_def) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def) - apply (intro conjI) - \ \cpspace_relation\ - apply (erule nonemptyE, drule(1) bspec) - apply (clarsimp simp: cpspace_relation_def) - apply (drule obj_at_ko_at', clarsimp) - apply (rule cmap_relationE1, assumption, - erule ko_at_projectKO_opt) - apply (frule null_sched_queue) - apply (frule null_sched_epD) - apply (intro conjI) - \ \tcb relation\ - apply (drule ctcb_relation_null_queue_ptrs, - simp_all)[1] - \ \endpoint relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (erule cendpoint_relation_upd_tcb_no_queues, simp+) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (erule cnotification_relation_upd_tcb_no_queues, simp+) - \ \ready queues\ - apply (simp add: cready_queues_relation_def Let_def cready_queues_index_to_C_in_range - seL4_MinPrio_def minDom_def) - apply clarsimp - apply (frule cready_queues_index_to_C_distinct, assumption+) - apply (clarsimp simp: cready_queues_index_to_C_in_range all_conj_distrib) - apply (rule iffD1 [OF tcb_queue_relation'_cong[OF refl], rotated -1], - drule spec, drule spec, erule mp, simp+) - apply clarsimp - apply (drule_tac x="tcb_ptr_to_ctcb_ptr x" in fun_cong)+ - apply (clarsimp simp: restrict_map_def - split: if_split_asm) - by (auto simp: carch_state_relation_def cmachine_state_relation_def) - -lemma state_relation_queue_update_helper: - "\ (s, s') \ rf_sr; valid_queues s; - globals t = ksReadyQueues_'_update - (\_. Arrays.update (ksReadyQueues_' (globals s')) prio' q') - (t_hrs_'_update f (globals s')); - sched_queue_relation' (cslift t) q (head_C q') (end_C q'); - cslift t |` ( - tcb_ptr_to_ctcb_ptr ` S ) - = cslift s' |` ( - tcb_ptr_to_ctcb_ptr ` S ); - option_map tcb_null_sched_ptrs \ cslift t - = option_map tcb_null_sched_ptrs \ cslift s'; - cslift_all_but_tcb_C t s'; - zero_ranges_are_zero (gsUntypedZeroRanges s) (f (t_hrs_' (globals s'))) - = zero_ranges_are_zero (gsUntypedZeroRanges s) (t_hrs_' (globals s')); - hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s')); - prio' = cready_queues_index_to_C qdom prio; - \x \ S. obj_at' (inQ qdom prio) x s - \ (obj_at' (\tcb. tcbPriority tcb = prio) x s - \ obj_at' (\tcb. tcbDomain tcb = qdom) x s) - \ (tcb_at' x s \ (\d' p'. (d' \ qdom \ p' \ prio) - \ x \ set (ksReadyQueues s (d', p')))); - S \ {}; qdom \ ucast maxDom; prio \ ucast maxPrio \ - \ (s \ksReadyQueues := (ksReadyQueues s)((qdom, prio) := q)\, t) \ rf_sr" - apply (subgoal_tac "\d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct(ksReadyQueues s (d, p))") - apply (erule(5) state_relation_queue_update_helper', simp_all) - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE, clarsimp) - done - (* FIXME: move *) lemma cmap_relation_no_upd: "\ cmap_relation a c f rel; a p = Some ko; rel ko v; inj f \ \ cmap_relation a (c(f p \ v)) f rel" @@ -831,8 +517,8 @@ lemma cready_queues_index_to_C_def2: lemma ready_queues_index_spec: "\s. \ \ {s'. s' = s \ (Kernel_Config.numDomains \ 1 \ dom_' s' = 0)} Call ready_queues_index_'proc - \\ret__unsigned_long = (dom_' s) * 0x100 + (prio_' s)\" - by vcg (simp add: numDomains_sge_1_simp) + \\ret__unsigned_long = (dom_' s) * word_of_nat numPriorities + (prio_' s)\" + by vcg (simp add: numDomains_sge_1_simp numPriorities_def) lemma prio_to_l1index_spec: "\s. \ \ {s} Call prio_to_l1index_'proc @@ -927,56 +613,6 @@ lemma cbitmap_L2_relation_bit_set: apply (case_tac "da = d" ; clarsimp simp: num_domains_index_updates) done -lemma carch_state_relation_enqueue_simp: - "carch_state_relation (ksArchState \) - (t_hrs_'_update f - (globals \' \ksReadyQueuesL1Bitmap_' := l1upd, ksReadyQueuesL2Bitmap_' := l2upd \) - \ksReadyQueues_' := rqupd \) = - carch_state_relation (ksArchState \) (t_hrs_'_update f (globals \'))" - unfolding carch_state_relation_def - by clarsimp - -lemma t_hrs_ksReadyQueues_upd_absorb: - "t_hrs_'_update f (g s) \ksReadyQueues_' := rqupd \ = - t_hrs_'_update f (g s \ksReadyQueues_' := rqupd\)" - by simp - -lemma rf_sr_drop_bitmaps_enqueue_helper: - "\ (\,\') \ rf_sr ; - cbitmap_L1_relation ksqL1upd' ksqL1upd ; cbitmap_L2_relation ksqL2upd' ksqL2upd \ - \ - ((\\ksReadyQueues := ksqupd, ksReadyQueuesL1Bitmap := ksqL1upd, ksReadyQueuesL2Bitmap := ksqL2upd\, - \'\idx___unsigned_long_' := i', queue_' := queue_upd', - globals := t_hrs_'_update f - (globals \' - \ksReadyQueuesL1Bitmap_' := ksqL1upd', - ksReadyQueuesL2Bitmap_' := ksqL2upd', - ksReadyQueues_' := ksqupd'\)\) \ rf_sr) = - ((\\ksReadyQueues := ksqupd\, - \'\idx_' := i', queue_' := queue_upd', - globals := t_hrs_'_update f - (globals \' \ksReadyQueues_' := ksqupd'\)\) \ rf_sr)" - unfolding rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def - by (clarsimp simp: rf_sr_cbitmap_L1_relation rf_sr_cbitmap_L2_relation) - -lemma cmachine_state_relation_enqueue_simp: - "cmachine_state_relation (ksMachineState \) - (t_hrs_'_update f - (globals \' \ksReadyQueuesL1Bitmap_' := l1upd, ksReadyQueuesL2Bitmap_' := l2upd \) - \ksReadyQueues_' := rqupd \) = - cmachine_state_relation (ksMachineState \) (t_hrs_'_update f (globals \'))" - unfolding cmachine_state_relation_def - by clarsimp - -lemma tcb_queue_relation'_empty_ksReadyQueues: - "\ sched_queue_relation' (cslift x) (q s) NULL NULL ; \t\ set (q s). tcb_at' t s \ \ q s = []" - apply (clarsimp simp add: tcb_queue_relation'_def) - apply (subst (asm) eq_commute) - apply (cases "q s" rule: rev_cases, simp) - apply (clarsimp simp: tcb_at_not_NULL) - done - lemma invert_prioToL1Index_c_simp: "p \ maxPriority \ @@ -990,13 +626,248 @@ lemma c_invert_assist: "3 - (ucast (p :: priority) >> 6 :: machine_word) < 4" using prio_ucast_shiftr_wordRadix_helper'[simplified wordRadix_def] by - (rule word_less_imp_diff_less, simp_all) +lemma addToBitmap_ccorres: + "ccorres dc xfdc + (K (tdom \ maxDomain \ prio \ maxPriority)) (\\dom = ucast tdom\ \ \\prio = ucast prio\) hs + (addToBitmap tdom prio) (Call addToBitmap_'proc)" + supply prio_and_dom_limit_helpers[simp] invert_prioToL1Index_c_simp[simp] + apply (rule ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (frule maxDomain_le_unat_ucast_explicit) + apply (clarsimp simp: getQueue_def gets_def get_def setQueue_def modify_def + put_def bind_def return_def bitmap_fun_defs) + apply (intro conjI impI allI) + apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def + carch_state_relation_def cmachine_state_relation_def) + apply (rule conjI) + apply (clarsimp intro!: cbitmap_L1_relation_bit_set) + apply (fastforce dest!: cbitmap_L2_relation_bit_set simp: wordRadix_def mask_def) + done + +lemma rf_sr_tcb_update_twice: + "h_t_valid (hrs_htd (hrs2 (globals s') (t_hrs_' (gs2 (globals s'))))) c_guard + (ptr (t_hrs_' (gs2 (globals s'))) (globals s')) + \ ((s, globals_update (\gs. t_hrs_'_update (\ths. + hrs_mem_update (heap_update (ptr ths gs :: tcb_C ptr) (v ths gs)) + (hrs_mem_update (heap_update (ptr ths gs) (v' ths gs)) (hrs2 gs ths))) (gs2 gs)) s') \ rf_sr) + = ((s, globals_update (\gs. t_hrs_'_update (\ths. + hrs_mem_update (heap_update (ptr ths gs) (v ths gs)) (hrs2 gs ths)) (gs2 gs)) s') \ rf_sr)" + by (simp add: rf_sr_def cstate_relation_def Let_def + cpspace_relation_def typ_heap_simps' + carch_state_relation_def cmachine_state_relation_def + packed_heap_update_collapse_hrs) + +lemmas rf_sr_tcb_update_no_queue_gen2 = + rf_sr_obj_update_helper[OF rf_sr_tcb_update_no_queue_gen, simplified] + +lemma tcb_queue_prepend_ccorres: + "ccorres ctcb_queue_relation ret__struct_tcb_queue_C_' + (\s. tcb_at' tcbPtr s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None) + \ (\head. tcbQueueHead queue = Some head \ tcb_at' head s)) + (\ctcb_queue_relation queue \queue\ \ \\tcb = tcb_ptr_to_ctcb_ptr tcbPtr\) hs + (tcbQueuePrepend queue tcbPtr) (Call tcb_queue_prepend_'proc)" + (is "ccorres _ _ ?abs _ _ _ _") + supply if_split[split del] + apply (cinit lift: tcb_') + \ \cinit is not able to lift queue_' because queue_' is later modified in the C program\ + apply (rule_tac xf'=queue_' in ccorres_abstract, ceqv, rename_tac cqueue) + apply (rule_tac P="ctcb_queue_relation queue cqueue" in ccorres_gen_asm2) + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue)" + and R="?abs" + and R'="\\queue = cqueue\" + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + apply ceqv + apply (rule_tac r'=ctcb_queue_relation and xf'=queue_' in ccorres_split_nothrow) + apply (rule_tac Q="?abs" + and Q'="\s'. queue_' s' = cqueue" + in ccorres_cond_both') + apply fastforce + apply clarsimp + apply (rule ccorres_return[where R=\]) + apply (rule conseqPre, vcg) + apply (fastforce simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (rule ccorres_seq_skip'[THEN iffD1]) + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_Guard) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s + \ head_C cqueue = option_to_ctcb_ptr (tcbQueueHead queue)}" + and R="\head_C cqueue = option_to_ctcb_ptr (tcbQueueHead queue)\" + in threadSet_ccorres_lemma4[where P=\ and P'=\]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce intro!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' tcb_cte_cases_def cteSizeBits_def + ctcb_relation_def option_to_ctcb_ptr_def) + apply (clarsimp simp: ctcb_relation_def option_to_ctcb_ptr_def split: if_splits) + apply ceqv + apply simp + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_Guard) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr + \ ko_at' tcb (the (tcbQueueHead queue)) s + \ head_C cqueue = option_to_ctcb_ptr (tcbQueueHead queue)}" + and R="\head_C cqueue = option_to_ctcb_ptr (tcbQueueHead queue)\" + in threadSet_ccorres_lemma4[where P=\ and P'=\]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce intro!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' tcb_cte_cases_def cteSizeBits_def + ctcb_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + apply fastforce + apply ceqv + apply (rule ccorres_return_Skip') + apply wpsimp + apply vcg + apply wpsimp + apply vcg + apply ceqv + apply csymbr + apply (fastforce intro: ccorres_return_C') + apply wpsimp + apply vcg + apply clarsimp + apply (vcg exspec=tcb_queue_empty_modifies) + apply clarsimp + apply (frule (1) tcb_at_h_t_valid) + by (force dest: tcb_at_h_t_valid + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + +lemma tcb_queue_append_ccorres: + "ccorres ctcb_queue_relation ret__struct_tcb_queue_C_' + (\s. tcb_at' tcbPtr s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None) + \ (\head. tcbQueueHead queue = Some head \ tcb_at' head s) + \ (\end. tcbQueueEnd queue = Some end \ tcb_at' end s)) + (\ctcb_queue_relation queue \queue\ \ \\tcb = tcb_ptr_to_ctcb_ptr tcbPtr\) hs + (tcbQueueAppend queue tcbPtr) (Call tcb_queue_append_'proc)" + (is "ccorres _ _ ?abs _ _ _ _") + supply if_split[split del] + apply (cinit lift: tcb_') + \ \cinit is not able to lift queue_' because queue_' is later modified in the C program\ + apply (rule_tac xf'=queue_' in ccorres_abstract, ceqv, rename_tac cqueue) + apply (rule_tac P="ctcb_queue_relation queue cqueue + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None)" + in ccorres_gen_asm2) + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue)" + and R="?abs" + and R'="\\queue = cqueue\" + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + apply ceqv + apply (rule_tac r'=ctcb_queue_relation and xf'=queue_' in ccorres_split_nothrow) + apply (rule_tac Q="?abs" + and Q'="\s'. queue_' s' = cqueue" + in ccorres_cond_both') + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply clarsimp + apply (rule ccorres_return[where R=\]) + apply (rule conseqPre, vcg) + apply (fastforce simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (rule ccorres_seq_skip'[THEN iffD1]) + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_Guard) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s + \ end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd queue)}" + and R="\end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd queue)\" + in threadSet_ccorres_lemma4[where P=\ and P'=\]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce intro!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' tcb_cte_cases_def cteSizeBits_def + ctcb_relation_def option_to_ctcb_ptr_def) + apply (clarsimp simp: ctcb_relation_def option_to_ctcb_ptr_def split: if_splits) + apply ceqv + apply simp + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_Guard) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr + \ ko_at' tcb (the (tcbQueueEnd queue)) s + \ end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd queue)}" + and R="\end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd queue)\" + in threadSet_ccorres_lemma4[where P=\ and P'=\]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce intro!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' tcb_cte_cases_def cteSizeBits_def + ctcb_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + apply fastforce + apply ceqv + apply (rule ccorres_return_Skip') + apply wpsimp + apply vcg + apply wpsimp + apply vcg + apply ceqv + apply csymbr + apply (fastforce intro: ccorres_return_C') + apply wpsimp + apply vcg + apply (vcg exspec=tcb_queue_empty_modifies) + apply clarsimp + apply (frule (1) tcb_at_h_t_valid) + by (force dest: tcb_at_h_t_valid + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + +lemma getQueue_ccorres: + "ccorres ctcb_queue_relation queue_' + (K (tdom \ maxDomain \ prio \ maxPriority)) + \\idx___unsigned_long = word_of_nat (cready_queues_index_to_C tdom prio)\ hs + (getQueue tdom prio) (\queue :== \ksReadyQueues.[unat \idx___unsigned_long])" + apply (rule ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply (clarsimp simp: getQueue_def gets_def get_def bind_def return_def) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def) + apply (frule (1) cready_queues_index_to_C_in_range) + apply (clarsimp simp: unat_of_nat_eq cready_queues_relation_def) + done + +lemma setQueue_ccorres: + "ctcb_queue_relation queue cqueue \ + ccorres dc xfdc + (K (tdom \ maxDomain \ prio \ maxPriority)) + \\idx___unsigned_long = word_of_nat (cready_queues_index_to_C tdom prio)\ hs + (setQueue tdom prio queue) + (Basic (\s. globals_update + (ksReadyQueues_'_update + (\_. Arrays.update (ksReadyQueues_' (globals s)) + (unat (idx___unsigned_long_' s)) cqueue)) s))" + apply (rule ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply (clarsimp simp: setQueue_def get_def modify_def put_def bind_def) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def + carch_state_relation_def cmachine_state_relation_def) + apply (frule (1) cready_queues_index_to_C_in_range) + apply (clarsimp simp: unat_of_nat_eq cready_queues_relation_def) + apply (frule cready_queues_index_to_C_distinct, assumption+) + apply (frule_tac qdom=d and prio=p in cready_queues_index_to_C_in_range) + apply fastforce + apply clarsimp + done + +crunch (empty_fail) empty_fail[wp]: isRunnable + lemma tcbSchedEnqueue_ccorres: "ccorres dc xfdc - (valid_queues and tcb_at' t and valid_objs') - (UNIV \ \\tcb = tcb_ptr_to_ctcb_ptr t\) - hs - (tcbSchedEnqueue t) - (Call tcbSchedEnqueue_'proc)" + (tcb_at' t and valid_objs' and pspace_aligned' and pspace_distinct') + \\tcb = tcb_ptr_to_ctcb_ptr t\ hs + (tcbSchedEnqueue t) (Call tcbSchedEnqueue_'proc)" proof - note prio_and_dom_limit_helpers[simp] word_sle_def[simp] maxDom_to_H[simp] maxPrio_to_H[simp] note invert_prioToL1Index_c_simp[simp] @@ -1007,24 +878,12 @@ proof - show ?thesis apply (cinit lift: tcb_') - apply (rule_tac r'="\rv rv'. rv = to_bool rv'" and xf'="ret__unsigned_longlong_'" - in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (simp add: when_def unless_def del: Collect_const split del: if_split) - apply (rule ccorres_cond[where R=\]) - apply (simp add: to_bool_def) - apply (rule ccorres_rhs_assoc)+ - apply csymbr - apply csymbr - apply csymbr - apply csymbr - apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="dom_'" in ccorres_split_nothrow) + apply (rule ccorres_stateAssert)+ + apply (rule ccorres_symb_exec_l) + apply (rule ccorres_assert) + apply (thin_tac runnable) + apply (rule_tac r'="\rv rv'. rv = to_bool rv'" and xf'="ret__unsigned_longlong_'" + in ccorres_split_nothrow) apply (rule threadGet_vcg_corres) apply (rule allI, rule conseqPre, vcg) apply clarsimp @@ -1032,244 +891,244 @@ proof - apply (drule spec, drule(1) mp, clarsimp) apply (clarsimp simp: typ_heap_simps ctcb_relation_def) apply ceqv - apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="prio_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (rule ccorres_rhs_assoc2)+ - apply (simp only: bind_assoc[symmetric]) - apply (rule ccorres_split_nothrow_novcg_dc) - prefer 2 - apply (rule ccorres_move_c_guard_tcb) - apply simp - apply ctac - prefer 2 - apply (wp, clarsimp, wp+) - apply (rule_tac P="\s. valid_queues s \ (\p. t \ set (ksReadyQueues s p)) - \ (\tcb. ko_at' tcb t s \ tcbDomain tcb =rva - \ tcbPriority tcb = rvb \ valid_tcb' tcb s)" - and P'=UNIV in ccorres_from_vcg) - apply (rule allI, rule conseqPre, vcg) - apply (clarsimp simp: getQueue_def gets_def get_def setQueue_def modify_def - put_def bind_def return_def bitmap_fun_defs null_def) - apply (clarsimp simp: queue_in_range valid_tcb'_def) - apply (rule conjI; clarsimp simp: queue_in_range) - (* queue is empty, set t to be new queue *) - apply (drule (1) obj_at_cslift_tcb) - apply clarsimp - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply (subgoal_tac - "head_C (ksReadyQueues_' (globals x) - .[cready_queues_index_to_C (tcbDomain tcb) (tcbPriority tcb)]) = NULL") - prefer 2 - apply (frule_tac s=\ in tcb_queue'_head_end_NULL; simp add: valid_queues_valid_q) - apply (subgoal_tac - "end_C (ksReadyQueues_' (globals x) - .[cready_queues_index_to_C (tcbDomain tcb) (tcbPriority tcb)]) = NULL") - prefer 2 - apply (frule_tac s=\ in tcb_queue'_head_end_NULL[symmetric]; simp add: valid_queues_valid_q) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (frule maxDomain_le_unat_ucast_explicit) - apply (clarsimp simp: cready_queues_index_to_C_def numPriorities_def) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (simp add: t_hrs_ksReadyQueues_upd_absorb) - - apply (rule conjI) - apply (clarsimp simp: l2BitmapSize_def' wordRadix_def c_invert_assist) - - apply (subst rf_sr_drop_bitmaps_enqueue_helper, assumption) - apply (fastforce intro: cbitmap_L1_relation_bit_set) - apply (fastforce intro: cbitmap_L2_relation_bit_set simp: wordRadix_def mask_def) - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (drule_tac qhead'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedEnqueue_update, - simp_all add: valid_queues_valid_q)[1] - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - apply (erule(1) state_relation_queue_update_helper[where S="{t}"], - (simp | rule globals.equality)+, - simp_all add: cready_queues_index_to_C_def2 numPriorities_def - t_hrs_ksReadyQueues_upd_absorb upd_unless_null_def - typ_heap_simps)[1] - apply (fastforce simp: tcb_null_sched_ptrs_def typ_heap_simps c_guard_clift - elim: obj_at'_weaken)+ - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply clarsimp - apply (rule conjI; clarsimp simp: queue_in_range) - (* invalid, disagreement between C and Haskell on emptiness of queue *) - apply (drule (1) obj_at_cslift_tcb) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (clarsimp simp: cready_queues_index_to_C_def numPriorities_def) - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply clarsimp - apply (drule tcb_queue_relation'_empty_ksReadyQueues; simp add: valid_queues_valid_q) - (* queue was not empty, add t to queue and leave bitmaps alone *) - apply (drule (1) obj_at_cslift_tcb) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (clarsimp simp: cready_queues_index_to_C_def numPriorities_def) - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply clarsimp - apply (frule_tac t=\ in tcb_queue_relation_qhead_mem') - apply (simp add: valid_queues_valid_q) - apply (frule(1) tcb_queue_relation_qhead_valid') - apply (simp add: valid_queues_valid_q) - apply (clarsimp simp: typ_heap_simps h_t_valid_clift_Some_iff numPriorities_def - cready_queues_index_to_C_def2) - apply (drule_tac qhead'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedEnqueue_update, - simp_all add: valid_queues_valid_q)[1] + apply (simp add: when_def unless_def del: Collect_const split del: if_split) + apply (rule ccorres_cond[where R=\]) + apply (simp add: to_bool_def) + apply (rule ccorres_rhs_assoc)+ + apply csymbr + apply csymbr + apply csymbr + apply csymbr + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="dom_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) apply clarsimp - - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - apply (frule(2) obj_at_cslift_tcb[OF valid_queues_obj_at'D]) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (erule_tac S="{t, v}" for v in state_relation_queue_update_helper, - (simp | rule globals.equality)+, - simp_all add: typ_heap_simps if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 upd_unless_null_def - del: fun_upd_restrict_conv - cong: if_cong - split del: if_split)[1] - apply simp - apply (rule conjI) + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="prio_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule ccorres_rhs_assoc2)+ + apply (simp only: bind_assoc[symmetric]) + apply (rule ccorres_split_nothrow_novcg_dc) + prefer 2 + apply (rule ccorres_move_c_guard_tcb) + apply (simp only: dc_def[symmetric]) + apply ctac + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_symb_exec_r) + apply (rule ccorres_Guard_Seq) + apply (simp add: bind_assoc) + apply (ctac add: getQueue_ccorres) + apply (rename_tac queue cqueue) + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue)" + and R="\s. \ tcbQueueEmpty queue \ tcb_at' (the (tcbQueueHead queue)) s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None)" + and R'="{s'. queue_' s' = cqueue}" + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def + tcbQueueEmpty_def) + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_cond[where R=\]) + apply fastforce + apply (ctac add: addToBitmap_ccorres) + apply (rule ccorres_return_Skip) + apply ceqv + apply (ctac add: tcb_queue_prepend_ccorres) + apply (rule ccorres_Guard) + apply (rule setQueue_ccorres) + apply fastforce + apply wpsimp + apply (vcg exspec=tcb_queue_prepend_modifies) + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift') + apply (vcg exspec=addToBitmap_modifies) + apply vcg + apply wpsimp + apply vcg apply clarsimp - apply (drule_tac s="tcb_ptr_to_ctcb_ptr t" in sym, simp) - apply (clarsimp simp add: fun_upd_twist) - prefer 4 - apply (simp add: obj_at'_weakenE[OF _ TrueI]) - apply (rule disjI1, erule (1) valid_queues_obj_at'D) - apply clarsimp - apply (fastforce simp: tcb_null_sched_ptrs_def) - apply (simp add: typ_heap_simps c_guard_clift) - apply (simp add: guard_is_UNIV_def) - apply simp - apply (wp threadGet_wp) - apply vcg - apply simp - apply (wp threadGet_wp) - apply vcg - apply (rule ccorres_return_Skip) - apply simp - apply (wp threadGet_wp) - apply vcg - apply (fastforce simp: valid_objs'_def obj_at'_def ran_def projectKOs typ_at'_def - valid_obj'_def inQ_def - dest!: valid_queues_obj_at'D) - done + apply vcg + apply (rule conseqPre, vcg) + apply clarsimp + apply wpsimp + apply (clarsimp simp: guard_is_UNIV_def) + apply (wpsimp wp: threadGet_wp) + apply vcg + apply clarsimp + apply (wpsimp wp: threadGet_wp) + apply vcg + apply (rule ccorres_return_Skip) + apply (wpsimp wp: threadGet_wp) + apply (vcg expsec=thread_state_get_tcbQueued_modifies) + apply wpsimp + apply (wpsimp wp: isRunnable_wp) + apply wpsimp + apply normalise_obj_at' + apply (rename_tac tcb) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (clarsimp simp: valid_tcb'_def) + apply (frule (1) obj_at_cslift_tcb) + apply (rule conjI) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (force dest!: tcbQueueHead_iff_tcbQueueEnd simp: tcbQueueEmpty_def obj_at'_def) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply (rule conjI) + apply (clarsimp simp: maxDomain_def) + apply (cut_tac qdom="tcbDomain tcb" and prio="tcbPriority tcb" + in cready_queues_index_to_C_in_range) + apply fastforce + apply fastforce + apply (clarsimp simp: word_less_nat_alt cready_queues_index_to_C_def2) + done qed -lemmas tcbSchedDequeue_update - = tcbDequeue_update[where tn=tcbSchedNext_C and tn_update=tcbSchedNext_C_update - and tp'=tcbSchedPrev_C and tp_update=tcbSchedPrev_C_update, - simplified] - -lemma tcb_queue_relation_prev_next: - "\ tcb_queue_relation tn tp' mp queue qprev qhead; - tcbp \ set queue; distinct (ctcb_ptr_to_tcb_ptr qprev # queue); - \t \ set queue. tcb_at' t s; qprev \ tcb_Ptr 0 \ mp qprev \ None; - mp (tcb_ptr_to_ctcb_ptr tcbp) = Some tcb \ - \ (tn tcb \ tcb_Ptr 0 \ tn tcb \ tcb_ptr_to_ctcb_ptr ` set queue - \ mp (tn tcb) \ None \ tn tcb \ tcb_ptr_to_ctcb_ptr tcbp) - \ (tp' tcb \ tcb_Ptr 0 \ (tp' tcb \ tcb_ptr_to_ctcb_ptr ` set queue - \ tp' tcb = qprev) - \ mp (tp' tcb) \ None \ tp' tcb \ tcb_ptr_to_ctcb_ptr tcbp) - \ (tn tcb \ tcb_Ptr 0 \ tn tcb \ tp' tcb)" - apply (induct queue arbitrary: qprev qhead) - apply simp - apply simp - apply (erule disjE) - apply clarsimp - apply (case_tac "queue") - apply clarsimp - apply clarsimp - apply (rule conjI) - apply clarsimp - apply clarsimp - apply (drule_tac f=ctcb_ptr_to_tcb_ptr in arg_cong[where y="tp' tcb"], simp) - apply clarsimp - apply fastforce - done - -lemma tcb_queue_relation_prev_next': - "\ tcb_queue_relation' tn tp' mp queue qhead qend; tcbp \ set queue; distinct queue; - \t \ set queue. tcb_at' t s; mp (tcb_ptr_to_ctcb_ptr tcbp) = Some tcb \ - \ (tn tcb \ tcb_Ptr 0 \ tn tcb \ tcb_ptr_to_ctcb_ptr ` set queue - \ mp (tn tcb) \ None \ tn tcb \ tcb_ptr_to_ctcb_ptr tcbp) - \ (tp' tcb \ tcb_Ptr 0 \ tp' tcb \ tcb_ptr_to_ctcb_ptr ` set queue - \ mp (tp' tcb) \ None \ tp' tcb \ tcb_ptr_to_ctcb_ptr tcbp) - \ (tn tcb \ tcb_Ptr 0 \ tn tcb \ tp' tcb)" - apply (clarsimp simp: tcb_queue_relation'_def split: if_split_asm) - apply (drule(1) tcb_queue_relation_prev_next, simp_all) - apply (fastforce dest: tcb_at_not_NULL) - apply clarsimp - done - -(* L1 bitmap only updated if L2 entry bits end up all zero *) -lemma rf_sr_drop_bitmaps_dequeue_helper_L2: - "\ (\,\') \ rf_sr ; - cbitmap_L2_relation ksqL2upd' ksqL2upd \ - \ -((\\ksReadyQueues := ksqupd, - ksReadyQueuesL2Bitmap := ksqL2upd\, - \'\idx___unsigned_long_' := i', - queue_' := queue_upd', - globals := globals \' - \ksReadyQueuesL2Bitmap_' := ksqL2upd', - ksReadyQueues_' := ksqupd'\\) - \ rf_sr) - = -((\\ksReadyQueues := ksqupd\, - \'\idx___unsigned_long_' := i', - queue_' := queue_upd', - globals := globals \' - \ksReadyQueues_' := ksqupd'\\) \ rf_sr) -" - unfolding rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def - by (clarsimp simp: rf_sr_cbitmap_L1_relation rf_sr_cbitmap_L2_relation) - -lemma rf_sr_drop_bitmaps_dequeue_helper: - "\ (\,\') \ rf_sr ; - cbitmap_L1_relation ksqL1upd' ksqL1upd ; cbitmap_L2_relation ksqL2upd' ksqL2upd \ - \ -((\\ksReadyQueues := ksqupd, - ksReadyQueuesL2Bitmap := ksqL2upd, - ksReadyQueuesL1Bitmap := ksqL1upd\, - \'\idx___unsigned_long_' := i', - queue_' := queue_upd', - globals := globals \' - \ksReadyQueuesL2Bitmap_' := ksqL2upd', - ksReadyQueuesL1Bitmap_' := ksqL1upd', - ksReadyQueues_' := ksqupd'\\) - \ rf_sr) - = -((\\ksReadyQueues := ksqupd\, - \'\idx___unsigned_long_' := i', - queue_' := queue_upd', - globals := globals \' - \ksReadyQueues_' := ksqupd'\\) \ rf_sr) -" - unfolding rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def - by (clarsimp simp: rf_sr_cbitmap_L1_relation rf_sr_cbitmap_L2_relation) +lemma tcbSchedAppend_ccorres: + "ccorres dc xfdc + (tcb_at' t and valid_objs' and pspace_aligned' and pspace_distinct') + \\tcb = tcb_ptr_to_ctcb_ptr t\ hs + (tcbSchedAppend t) (Call tcbSchedAppend_'proc)" +proof - + note prio_and_dom_limit_helpers[simp] word_sle_def[simp] maxDom_to_H[simp] maxPrio_to_H[simp] + note invert_prioToL1Index_c_simp[simp] + (* when numDomains = 1, array bounds checks would become _ = 0 rather than _ < 1, changing the + shape of the proof compared to when numDomains > 1 *) + note word_less_1[simp del] + show ?thesis + apply (cinit lift: tcb_') + apply (rule ccorres_stateAssert)+ + apply (rule ccorres_symb_exec_l) + apply (rule ccorres_assert) + apply (thin_tac "runnable") + apply (rule_tac r'="\rv rv'. rv = to_bool rv'" and xf'="ret__unsigned_longlong_'" + in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (simp add: when_def unless_def del: Collect_const split del: if_split) + apply (rule ccorres_cond[where R=\]) + apply (simp add: to_bool_def) + apply (rule ccorres_rhs_assoc)+ + apply csymbr + apply csymbr + apply csymbr + apply csymbr + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="dom_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="prio_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule ccorres_rhs_assoc2)+ + apply (simp only: bind_assoc[symmetric]) + apply (rule ccorres_split_nothrow_novcg_dc) + prefer 2 + apply (rule ccorres_move_c_guard_tcb) + apply (simp only: dc_def[symmetric]) + apply ctac + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_symb_exec_r) + apply (rule ccorres_Guard_Seq) + apply (simp add: bind_assoc) + apply (ctac add: getQueue_ccorres) + apply (rename_tac queue cqueue) + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue)" + and R="\s. \ tcbQueueEmpty queue \ tcb_at' (the (tcbQueueHead queue)) s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None)" + and R'="{s'. queue_' s' = cqueue}" + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def + tcbQueueEmpty_def) + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_cond[where R=\]) + apply (fastforce dest!: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (ctac add: addToBitmap_ccorres) + apply (rule ccorres_return_Skip) + apply ceqv + apply (ctac add: tcb_queue_append_ccorres) + apply (rule ccorres_Guard) + apply (rule setQueue_ccorres) + apply fastforce + apply wpsimp + apply (vcg exspec=tcb_queue_prepend_modifies) + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift') + apply (vcg exspec=addToBitmap_modifies) + apply vcg + apply wpsimp + apply vcg + apply clarsimp + apply vcg + apply (rule conseqPre, vcg) + apply clarsimp + apply wpsimp + apply (clarsimp simp: guard_is_UNIV_def) + apply (wpsimp wp: threadGet_wp) + apply vcg + apply clarsimp + apply (wpsimp wp: threadGet_wp) + apply clarsimp + apply vcg + apply (rule ccorres_return_Skip) + apply (wpsimp wp: threadGet_wp) + apply (vcg expsec=thread_state_get_tcbQueued_modifies) + apply wpsimp + apply (wpsimp wp: isRunnable_wp) + apply wpsimp + apply normalise_obj_at' + apply (rename_tac tcb) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (clarsimp simp: valid_tcb'_def) + apply (frule (1) obj_at_cslift_tcb) + apply (rule conjI) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (frule (3) obj_at'_tcbQueueEnd_ksReadyQueues) + apply (force dest!: tcbQueueHead_iff_tcbQueueEnd simp: tcbQueueEmpty_def obj_at'_def) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply (rule conjI) + apply (clarsimp simp: maxDomain_def) + apply (cut_tac qdom="tcbDomain tcb" and prio="tcbPriority tcb" + in cready_queues_index_to_C_in_range) + apply fastforce + apply fastforce + apply (clarsimp simp: word_less_nat_alt cready_queues_index_to_C_def2 tcbQueueEmpty_def) + done +qed (* FIXME same proofs as bit_set, maybe can generalise? *) lemma cbitmap_L1_relation_bit_clear: @@ -1286,27 +1145,6 @@ lemma cbitmap_L1_relation_bit_clear: invertL1Index_def l2BitmapSize_def' le_maxDomain_eq_less_numDomains word_le_nat_alt num_domains_index_updates) -lemma cready_queues_relation_empty_queue_helper: - "\ tcbDomain ko \ maxDomain ; tcbPriority ko \ maxPriority ; - cready_queues_relation (cslift \') (ksReadyQueues_' (globals \')) (ksReadyQueues \)\ - \ - cready_queues_relation (cslift \') - (Arrays.update (ksReadyQueues_' (globals \')) (unat (tcbDomain ko) * 256 + unat (tcbPriority ko)) - (tcb_queue_C.end_C_update (\_. NULL) - (head_C_update (\_. NULL) - (ksReadyQueues_' (globals \').[unat (tcbDomain ko) * 256 + unat (tcbPriority ko)])))) - ((ksReadyQueues \)((tcbDomain ko, tcbPriority ko) := []))" - unfolding cready_queues_relation_def Let_def - using maxPrio_to_H[simp] maxDom_to_H[simp] - apply clarsimp - apply (frule (1) cready_queues_index_to_C_in_range[simplified maxDom_to_H maxPrio_to_H]) - apply (fold cready_queues_index_to_C_def[simplified numPriorities_def]) - apply (case_tac "qdom = tcbDomain ko", - simp_all add: prio_and_dom_limit_helpers seL4_MinPrio_def - minDom_def) - apply (fastforce simp: cready_queues_index_to_C_in_range simp: cready_queues_index_to_C_distinct)+ - done - lemma cbitmap_L2_relationD: "\ cbitmap_L2_relation cbitmap2 abitmap2 ; d \ maxDomain ; i < l2BitmapSize \ \ cbitmap2.[unat d].[i] = abitmap2 (d, i)" @@ -1336,61 +1174,301 @@ lemma cbitmap_L2_relation_bit_clear: apply (case_tac "da = d" ; clarsimp simp: num_domains_index_updates) done -lemma tcbSchedDequeue_ccorres': +lemma removeFromBitmap_ccorres: "ccorres dc xfdc - ((\s. \d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct (ksReadyQueues s (d, p))) - and valid_queues' and tcb_at' t and valid_objs') - (UNIV \ \\tcb = tcb_ptr_to_ctcb_ptr t\) - [] - (tcbSchedDequeue t) - (Call tcbSchedDequeue_'proc)" + (K (tdom \ maxDomain \ prio \ maxPriority)) (\\dom = ucast tdom\ \ \\prio = ucast prio\) hs + (removeFromBitmap tdom prio) (Call removeFromBitmap_'proc)" proof - - note prio_and_dom_limit_helpers[simp] word_sle_def[simp] (* when numDomains = 1, array bounds checks would become _ = 0 rather than _ < 1, changing the shape of the proof compared to when numDomains > 1 *) include no_less_1_simps - have ksQ_tcb_at': "\s ko d p. - \d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct (ksReadyQueues s (d, p)) \ - \t\set (ksReadyQueues s (d, p)). tcb_at' t s" - by (fastforce dest: spec elim: obj_at'_weakenE) - - have invert_l1_index_limit: "\p. invertL1Index (prioToL1Index p) < 4" + have invert_l1_index_limit: "\p. invertL1Index (prioToL1Index p) < l2BitmapSize" unfolding invertL1Index_def l2BitmapSize_def' prioToL1Index_def by simp show ?thesis - apply (cinit lift: tcb_') - apply (rule_tac r'="\rv rv'. rv = to_bool rv'" and xf'="ret__unsigned_longlong_'" - in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (simp add: when_def del: Collect_const split del: if_split) - apply (rule ccorres_cond[where R=\]) - apply (simp add: to_bool_def) - apply (rule ccorres_rhs_assoc)+ - apply csymbr - apply csymbr - apply csymbr - apply csymbr - apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="dom_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) + supply if_split[split del] + (* pull out static assms *) + apply simp + apply (rule ccorres_grab_asm[where P=\, simplified]) + apply (cinit lift: dom_' prio_') + apply clarsimp + apply csymbr + apply csymbr + (* we can clear up all C guards now *) + apply (clarsimp simp: maxDomain_le_unat_ucast_explicit word_and_less') + apply (simp add: invert_prioToL1Index_c_simp word_less_nat_alt) + apply (simp add: invert_l1_index_limit[simplified l2BitmapSize_def']) + apply ccorres_rewrite + (* handle L2 update *) + apply (rule_tac ccorres_split_nothrow_novcg_dc) + apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply (clarsimp simp: simpler_gets_def get_def modify_def + put_def bind_def return_def bitmap_fun_defs) + apply (frule rf_sr_cbitmap_L2_relation) + apply (erule cbitmap_L2_relation_update) + apply (erule (1) cbitmap_L2_relation_bit_clear) + (* the check on the C side is identical to checking the L2 entry, rewrite the condition *) + apply (simp add: getReadyQueuesL2Bitmap_def) + apply (rule ccorres_symb_exec_l3, rename_tac l2) + apply (rule_tac C'="{s. l2 = 0}" + and Q="\s. l2 = ksReadyQueuesL2Bitmap s (tdom, invertL1Index (prioToL1Index prio))" + in ccorres_rewrite_cond_sr[where Q'=UNIV]) + apply clarsimp + apply (frule rf_sr_cbitmap_L2_relation) + apply (clarsimp simp: cbitmap_L2_relationD invert_l1_index_limit split: if_split) + (* unset L1 bit when L2 entry is empty *) + apply (rule ccorres_from_vcg[where P=\ and P'=UNIV]) apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="prio_'" in ccorres_split_nothrow) + apply (clarsimp simp: simpler_gets_def get_def modify_def + put_def bind_def return_def bitmap_fun_defs) + apply (frule rf_sr_cbitmap_L1_relation) + apply (erule cbitmap_L1_relation_update) + apply (erule (1) cbitmap_L1_relation_bit_clear) + apply wpsimp+ + apply (fastforce simp: guard_is_UNIV_def) + apply clarsimp + done +qed + +lemma ctcb_ptr_to_tcb_ptr_option_to_ctcb_ptr[simp]: + "ctcb_ptr_to_tcb_ptr (option_to_ctcb_ptr (Some ptr)) = ptr" + by (clarsimp simp: option_to_ctcb_ptr_def) + +lemma tcb_queue_remove_ccorres: + "ccorres ctcb_queue_relation ret__struct_tcb_queue_C_' + (\s. tcb_at' tcbPtr s \ valid_objs' s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None)) + (\ctcb_queue_relation queue \queue\ \ \\tcb = tcb_ptr_to_ctcb_ptr tcbPtr\) hs + (tcbQueueRemove queue tcbPtr) (Call tcb_queue_remove_'proc)" + (is "ccorres _ _ ?abs _ _ _ _") + supply if_split[split del] + apply (cinit' lift: tcb_') + apply (rename_tac tcb') + apply (simp only: tcbQueueRemove_def) + \ \cinit is not able to lift queue_' because queue_' is later modified in the C program\ + apply (rule_tac xf'=queue_' in ccorres_abstract, ceqv, rename_tac cqueue) + apply (rule_tac P="ctcb_queue_relation queue cqueue" in ccorres_gen_asm2) + apply (rule ccorres_pre_getObject_tcb, rename_tac tcb) + apply (rule ccorres_symb_exec_l, rename_tac beforePtrOpt) + apply (rule ccorres_symb_exec_l, rename_tac afterPtrOpt) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac xf'="before___ptr_to_struct_tcb_C_'" + and val="option_to_ctcb_ptr beforePtrOpt" + and R="ko_at' tcb tcbPtr and K (tcbSchedPrev tcb = beforePtrOpt)" + and R'=UNIV + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: obj_at_cslift_tcb simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac xf'="after___ptr_to_struct_tcb_C_'" + and val="option_to_ctcb_ptr afterPtrOpt" + and R="ko_at' tcb tcbPtr and K (tcbSchedNext tcb = afterPtrOpt)" + in ccorres_symb_exec_r_known_rv[where R'=UNIV]) + apply (rule conseqPre, vcg) + apply (fastforce dest: obj_at_cslift_tcb simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule ccorres_cond_seq) + apply (rule ccorres_cond[where R="?abs"]) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (rule ccorres_rhs_assoc)+ + apply csymbr + apply csymbr + apply (fastforce intro: ccorres_return_C') + apply (rule ccorres_cond_seq) + apply (rule_tac Q="?abs" and Q'=\ in ccorres_cond_both') + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def split: if_splits) + apply clarsimp + apply (rule ccorres_assert2) + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb)+ + apply (rule_tac P=\ and P'="tcb_at' tcbPtr" + and Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb (the afterPtrOpt) s}" + in threadSet_ccorres_lemma3) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply fastforce + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb[where thread=tcbPtr]) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule ccorres_symb_exec_r) + apply (fastforce intro: ccorres_return_C') + apply vcg + apply (rule conseqPre, vcg) + apply clarsimp + apply wpsimp + apply vcg + apply wpsimp + apply vcg + apply (rule ccorres_cond_seq) + apply (rule_tac Q="?abs" and Q'=\ in ccorres_cond_both') + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def split: if_splits) + apply clarsimp + apply (rule ccorres_assert2) + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb)+ + apply (rule_tac P=\ and P'="tcb_at' tcbPtr" + and Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb (the beforePtrOpt) s}" + in threadSet_ccorres_lemma3) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply fastforce + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb[where thread=tcbPtr]) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule ccorres_symb_exec_r) + apply (fastforce intro: ccorres_return_C') + apply vcg + apply (rule conseqPre, vcg) + apply clarsimp + apply wpsimp + apply vcg + apply wpsimp + apply vcg + apply clarsimp + apply (rule ccorres_assert2)+ + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb)+ + apply (rule_tac Q="\s tcb'. {s'. (s, s') \ rf_sr \ ko_at' tcb' (the beforePtrOpt) s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb)+ + apply (rule_tac P=\ and P'="tcb_at' tcbPtr" + and Q="\s tcb'. {s'. (s, s') \ rf_sr \ ko_at' tcb' (the afterPtrOpt) s}" + in threadSet_ccorres_lemma3) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb[where thread=tcbPtr]) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb[where thread=tcbPtr]) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply fastforce + apply ceqv + apply (fastforce intro: ccorres_return_C') + apply (wpsimp | vcg)+ + apply (clarsimp split: if_splits) + apply normalise_obj_at' + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + by (intro conjI impI; + clarsimp simp: ctcb_queue_relation_def typ_heap_simps option_to_ctcb_ptr_def + valid_tcb'_def) + +lemma tcbQueueRemove_tcb_at'_head: + "\\s. valid_objs' s \ (\head. tcbQueueHead queue = Some head \ tcb_at' head s)\ + tcbQueueRemove queue t + \\rv s. \ tcbQueueEmpty rv \ tcb_at' (the (tcbQueueHead rv)) s\" + unfolding tcbQueueRemove_def + apply (wpsimp wp: getTCB_wp haskell_assert_wp hoare_vcg_imp_lift') + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (fastforce simp: valid_tcb'_def tcbQueueEmpty_def obj_at'_def) + done + +lemma tcbSchedDequeue_ccorres: + "ccorres dc xfdc + (tcb_at' t and valid_objs' and pspace_aligned' and pspace_distinct') + \\tcb = tcb_ptr_to_ctcb_ptr t\ hs + (tcbSchedDequeue t) (Call tcbSchedDequeue_'proc)" +proof - + note prio_and_dom_limit_helpers[simp] word_sle_def[simp] maxDom_to_H[simp] maxPrio_to_H[simp] + note invert_prioToL1Index_c_simp[simp] + + (* when numDomains = 1, array bounds checks would become _ = 0 rather than _ < 1, changing the + shape of the proof compared to when numDomains > 1 *) + include no_less_1_simps + + show ?thesis + apply (cinit lift: tcb_') + apply (rule ccorres_stateAssert)+ + apply (rule_tac r'="\rv rv'. rv = to_bool rv'" and xf'="ret__unsigned_longlong_'" + in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (simp add: when_def del: Collect_const split del: if_split) + apply (rule ccorres_cond[where R=\]) + apply (simp add: to_bool_def) + apply (rule ccorres_rhs_assoc)+ + apply csymbr + apply csymbr + apply csymbr + apply csymbr + apply csymbr + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="dom_'" in ccorres_split_nothrow) apply (rule threadGet_vcg_corres) apply (rule allI, rule conseqPre, vcg) apply clarsimp @@ -1398,308 +1476,80 @@ proof - apply (drule spec, drule(1) mp, clarsimp) apply (clarsimp simp: typ_heap_simps ctcb_relation_def) apply ceqv - apply (rule ccorres_rhs_assoc2)+ - apply (simp only: bind_assoc[symmetric]) - apply (rule ccorres_split_nothrow_novcg_dc) - prefer 2 - apply (rule ccorres_move_c_guard_tcb) - apply ctac - prefer 2 - apply (wp, clarsimp, wp+) - apply (rule_tac P="(\s. \d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct(ksReadyQueues s (d, p))) - and valid_queues' and obj_at' (inQ rva rvb) t - and (\s. rva \ maxDomain \ rvb \ maxPriority)" - and P'=UNIV in ccorres_from_vcg) - apply (rule allI, rule conseqPre, vcg) - apply (clarsimp simp: getQueue_def gets_def get_def setQueue_def modify_def - put_def bind_def return_def bitmap_fun_defs when_def - null_def) - - apply (rule conjI; clarsimp simp: queue_in_range[simplified maxDom_to_H maxPrio_to_H]) - apply (rule conjI; clarsimp simp: queue_in_range[simplified maxDom_to_H maxPrio_to_H]) - apply (frule(1) valid_queuesD') - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" in rf_sr_sched_queue_relation) - apply (fastforce simp: maxDom_to_H maxPrio_to_H)+ - apply (frule_tac s=\ in tcb_queue_relation_prev_next'; (fastforce simp: ksQ_tcb_at')?) - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (intro conjI; - clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift)+ - apply (drule(2) filter_empty_unfiltered_contr, simp)+ - apply (rule conjI; clarsimp) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (rule conjI; clarsimp) - apply (subst rf_sr_drop_bitmaps_dequeue_helper, assumption) - apply (fastforce intro: cbitmap_L1_relation_bit_clear) - apply (simp add: invert_prioToL1Index_c_simp) - apply (frule rf_sr_cbitmap_L2_relation) - apply (clarsimp simp: cbitmap_L2_relation_def - word_size prioToL1Index_def wordRadix_def mask_def - word_le_nat_alt - numPriorities_def wordBits_def l2BitmapSize_def' - invertL1Index_def numDomains_less_numeric_explicit) - apply (case_tac "d = tcbDomain ko" - ; fastforce simp: le_maxDomain_eq_less_numDomains - numDomains_less_numeric_explicit) - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: maxDom_to_H maxPrio_to_H)+ - - apply (frule_tac s=\ in tcb_queue_relation_prev_next', assumption) - prefer 3 - apply fastforce - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by ((fastforce simp: ksQ_tcb_at')+) - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - (* trivial case, setting queue to empty *) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def carch_state_relation_def - cmachine_state_relation_def) - apply (erule (2) cready_queues_relation_empty_queue_helper) - (* impossible case, C L2 update disagrees with Haskell update *) - apply (simp add: invert_prioToL1Index_c_simp) - apply (subst (asm) num_domains_index_updates) - subgoal by (simp add: le_maxDomain_eq_less_numDomains word_le_nat_alt) - apply (subst (asm) Arrays.index_update) - apply (simp add: invert_l1_index_limit) - - apply (frule rf_sr_cbitmap_L2_relation) - apply (drule_tac i="invertL1Index (prioToL1Index (tcbPriority ko))" - in cbitmap_L2_relationD, assumption) - apply (fastforce simp: l2BitmapSize_def' invert_l1_index_limit) - apply (fastforce simp: prioToL1Index_def invertL1Index_def mask_def wordRadix_def) - (* impossible case *) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (drule(2) filter_empty_unfiltered_contr, fastforce) - - apply (frule (1) valid_queuesD') - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) - apply fold_subgoals[2] - apply (fastforce simp: maxDom_to_H maxPrio_to_H)+ - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (frule_tac s=\ in tcb_queue_relation_prev_next', assumption) - prefer 3 - apply fastforce - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: ksQ_tcb_at')+ - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - apply (clarsimp simp: filter_noteq_op upd_unless_null_def) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI, clarsimp) - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (rule conjI; clarsimp) - apply (simp add: typ_heap_simps) - apply (clarsimp simp: h_t_valid_c_guard [OF h_t_valid_field, OF h_t_valid_clift] - h_t_valid_field[OF h_t_valid_clift] h_t_valid_clift) - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 typ_heap_simps - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - - apply (fastforce simp: tcb_null_sched_ptrs_def typ_heap_simps c_guard_clift - elim: obj_at'_weaken)+ - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split, - simp_all add: typ_heap_simps')[1] - subgoal by (fastforce simp: tcb_null_sched_ptrs_def) - subgoal by fastforce + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="prio_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule ccorres_symb_exec_r) + apply (rule ccorres_Guard_Seq) + apply (simp add: bind_assoc) + apply (ctac add: getQueue_ccorres) + apply (rule_tac r'=ctcb_queue_relation and xf'=new_queue_' in ccorres_split_nothrow) + apply (ctac add: tcb_queue_remove_ccorres) + apply ceqv + apply (rename_tac queue' newqueue) + apply (rule ccorres_Guard_Seq) + apply (ctac add: setQueue_ccorres) + apply (rule ccorres_split_nothrow_novcg_dc) + apply ctac + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue')" + and R="\s. \ tcbQueueEmpty queue' \ tcb_at' (the (tcbQueueHead queue')) s" + in ccorres_symb_exec_r_known_rv[where R'=UNIV]) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def + tcbQueueEmpty_def split: option.splits) + apply ceqv + apply (rule ccorres_cond[where R=\]) + apply fastforce + apply (ctac add: removeFromBitmap_ccorres) + apply (rule ccorres_return_Skip) + apply vcg + apply (wpsimp wp: hoare_vcg_imp_lift') + apply (clarsimp simp: guard_is_UNIV_def) + apply (wpsimp wp: hoare_vcg_imp_lift') + apply vcg + apply ((wpsimp wp: tcbQueueRemove_tcb_at'_head | wp (once) hoare_drop_imps)+)[1] + apply (vcg exspec=tcb_queue_remove_modifies) + apply wpsimp + apply vcg + apply vcg + apply (rule conseqPre, vcg) apply clarsimp - apply (rule conjI; clarsimp) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (rule conjI; clarsimp) - (* invalid, missing bitmap updates on haskell side *) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems - by (fastforce dest!: tcb_queue_relation'_empty_ksReadyQueues - elim: obj_at'_weaken)+ - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - apply (fold_subgoals (prefix))[4] - subgoal premises prems using prems - by - (fastforce simp: typ_heap_simps c_guard_clift tcb_null_sched_ptrs_def - clift_heap_update_same[OF h_t_valid_clift])+ - apply (rule conjI; clarsimp simp: queue_in_range[simplified maxDom_to_H maxPrio_to_H]) - apply (frule (1) valid_queuesD') - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: maxDom_to_H maxPrio_to_H)+ - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (frule_tac s=\ in tcb_queue_relation_prev_next') - apply fastforce - prefer 3 - apply fastforce - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: ksQ_tcb_at')+ - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - apply (clarsimp simp: filter_noteq_op upd_unless_null_def) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI; clarsimp) - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (clarsimp simp: typ_heap_simps) - apply (rule conjI; clarsimp simp: typ_heap_simps) - apply (drule(2) filter_empty_unfiltered_contr[simplified filter_noteq_op], simp) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (rule conjI; clarsimp) - (* impossible case, C L2 update disagrees with Haskell update *) - apply (subst (asm) num_domains_index_updates) - apply (simp add: le_maxDomain_eq_less_numDomains word_le_nat_alt) - apply (subst (asm) Arrays.index_update) - subgoal using invert_l1_index_limit - by (fastforce simp add: invert_prioToL1Index_c_simp intro: nat_Suc_less_le_imp) - apply (frule rf_sr_cbitmap_L2_relation) - apply (simp add: invert_prioToL1Index_c_simp) - apply (drule_tac i="invertL1Index (prioToL1Index (tcbPriority ko))" - in cbitmap_L2_relationD, assumption) - subgoal by (simp add: invert_l1_index_limit l2BitmapSize_def') - apply (fastforce simp: prioToL1Index_def invertL1Index_def mask_def wordRadix_def) - - apply (simp add: invert_prioToL1Index_c_simp) - apply (subst rf_sr_drop_bitmaps_dequeue_helper_L2, assumption) - subgoal by (fastforce dest: rf_sr_cbitmap_L2_relation elim!: cbitmap_L2_relation_bit_clear) - - (* trivial case, setting queue to empty *) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def carch_state_relation_def - cmachine_state_relation_def) - apply (erule (2) cready_queues_relation_empty_queue_helper) - - apply (frule (1) valid_queuesD') - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: maxDom_to_H maxPrio_to_H)+ - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (simp add: invert_prioToL1Index_c_simp) - apply (frule_tac s=\ in tcb_queue_relation_prev_next') - apply (fastforce simp add: ksQ_tcb_at')+ - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - apply (clarsimp simp: filter_noteq_op upd_unless_null_def) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI, clarsimp) - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (clarsimp simp: typ_heap_simps) - apply (rule conjI; clarsimp simp: typ_heap_simps) - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - apply (fastforce simp: tcb_null_sched_ptrs_def) - apply (fastforce simp: typ_heap_simps c_guard_clift) - apply (fastforce simp: typ_heap_simps) - apply (fastforce simp: tcb_null_sched_ptrs_def) - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - apply (fold_subgoals (prefix))[4] - subgoal premises prems using prems - by - (fastforce simp: typ_heap_simps c_guard_clift tcb_null_sched_ptrs_def - clift_heap_update_same[OF h_t_valid_clift])+ - apply (clarsimp) - apply (rule conjI; clarsimp simp: typ_heap_simps) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (rule conjI; clarsimp) - (* invalid, missing bitmap updates on haskell side *) - apply (drule tcb_queue_relation'_empty_ksReadyQueues) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce elim: obj_at'_weaken)+ - (* invalid, missing bitmap updates on haskell side *) - apply (drule tcb_queue_relation'_empty_ksReadyQueues) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce elim: obj_at'_weaken)+ - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 typ_heap_simps - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - apply (fold_subgoals (prefix))[3] - subgoal premises prems using prems - by (fastforce simp: typ_heap_simps c_guard_clift tcb_null_sched_ptrs_def)+ - apply (simp add: guard_is_UNIV_def) - apply simp - apply (wp threadGet_wp) + apply (wpsimp wp: threadGet_wp) + apply vcg + apply clarsimp + apply (wpsimp wp: threadGet_wp) apply vcg - apply simp - apply (wp threadGet_wp) - apply vcg - apply (rule ccorres_return_Skip) - apply simp - apply (wp threadGet_wp) - apply vcg - by (fastforce simp: valid_objs'_def obj_at'_def ran_def projectKOs typ_at'_def - valid_obj'_def valid_tcb'_def inQ_def) + apply (rule ccorres_return_Skip) + apply (wpsimp wp: threadGet_wp) + apply (vcg expsec=thread_state_get_tcbQueued_modifies) + apply normalise_obj_at' + apply (rename_tac tcb) + apply (frule (1) obj_at_cslift_tcb) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (clarsimp simp: valid_tcb'_def) + apply (cut_tac qdom="tcbDomain tcb" and prio="tcbPriority tcb" + in cready_queues_index_to_C_in_range) + apply fastforce + apply fastforce + apply (rule conjI) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (force dest!: tcbQueueHead_iff_tcbQueueEnd simp: tcbQueueEmpty_def obj_at'_def) + by (fastforce simp: word_less_nat_alt + cready_queues_index_to_C_def2 ctcb_relation_def + typ_heap_simps le_maxDomain_eq_less_numDomains(2) unat_trans_ucast_helper) qed -lemma tcbSchedDequeue_ccorres: - "ccorres dc xfdc - (valid_queues and valid_queues' and tcb_at' t and valid_objs') - (UNIV \ \\tcb = tcb_ptr_to_ctcb_ptr t\) - [] - (tcbSchedDequeue t) - (Call tcbSchedDequeue_'proc)" - apply (rule ccorres_guard_imp [OF tcbSchedDequeue_ccorres']) - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE) - apply (clarsimp)+ - done - lemma tcb_queue_relation_append: "\ tcb_queue_relation tn tp' mp queue qprev qhead; queue \ []; qend' \ tcb_ptr_to_ctcb_ptr ` set queue; mp qend' = Some tcb; @@ -1718,211 +1568,6 @@ lemma tcb_queue_relation_append: apply clarsimp done -lemma tcbSchedAppend_update: - assumes sr: "sched_queue_relation' mp queue qhead qend" - and qh': "qend' \ tcb_ptr_to_ctcb_ptr ` set queue" - and cs_tcb: "mp qend' = Some tcb" - and valid_ep: "\t\set queue. tcb_at' t s" "distinct queue" - and qhN: "qend' \ NULL" - shows - "sched_queue_relation' - (upd_unless_null qend (tcbSchedNext_C_update (\_. qend') (the (mp qend))) - (mp(qend' \ tcb\tcbSchedNext_C := NULL, tcbSchedPrev_C := qend\))) - (queue @ [ctcb_ptr_to_tcb_ptr qend']) (if queue = [] then qend' else qhead) qend'" - using sr qh' valid_ep cs_tcb qhN - apply - - apply (rule rev_cases[where xs=queue]) - apply (simp add: tcb_queue_relation'_def upd_unless_null_def) - apply (clarsimp simp: tcb_queue_relation'_def upd_unless_null_def tcb_at_not_NULL) - apply (drule_tac qend'=qend' and tn_update=tcbSchedNext_C_update - and tp_update=tcbSchedPrev_C_update and qend="tcb_ptr_to_ctcb_ptr y" - in tcb_queue_relation_append, simp_all) - apply (fastforce simp add: tcb_at_not_NULL) - apply (simp add: fun_upd_twist) - done - -lemma tcb_queue_relation_qend_mems: - "\ tcb_queue_relation' getNext getPrev mp queue qhead qend; - \x \ set queue. tcb_at' x s \ - \ (qend = NULL \ queue = []) - \ (qend \ NULL \ ctcb_ptr_to_tcb_ptr qend \ set queue)" - apply (clarsimp simp: tcb_queue_relation'_def) - apply (drule bspec, erule last_in_set) - apply (simp add: tcb_at_not_NULL) - done - -lemma tcbSchedAppend_ccorres: - "ccorres dc xfdc - (valid_queues and tcb_at' t and valid_objs') - (UNIV \ \\tcb = tcb_ptr_to_ctcb_ptr t\) - [] - (tcbSchedAppend t) - (Call tcbSchedAppend_'proc)" -proof - - note prio_and_dom_limit_helpers[simp] word_sle_def[simp] maxDom_to_H[simp] maxPrio_to_H[simp] - - (* when numDomains = 1, array bounds checks would become _ = 0 rather than _ < 1, changing the - shape of the proof compared to when numDomains > 1 *) - include no_less_1_simps - - show ?thesis - apply (cinit lift: tcb_') - apply (rule_tac r'="\rv rv'. rv = to_bool rv'" - and xf'="ret__unsigned_longlong_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (simp add: when_def unless_def del: Collect_const split del: if_split) - apply (rule ccorres_cond[where R=\]) - apply (simp add: to_bool_def) - apply (rule ccorres_rhs_assoc)+ - apply csymbr - apply csymbr - apply csymbr - apply csymbr - apply (rule_tac r'="\rv rv'. rv' = ucast rv" - and xf'="dom_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (rule_tac r'="\rv rv'. rv' = ucast rv" - and xf'="prio_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (rule ccorres_rhs_assoc2)+ - apply (simp only: bind_assoc[symmetric]) - apply (rule ccorres_split_nothrow_novcg_dc) - prefer 2 - apply (rule ccorres_move_c_guard_tcb) - apply ctac - prefer 2 - apply (wp, clarsimp, wp+) - apply (rule_tac P="\s. valid_queues s \ (\p. t \ set (ksReadyQueues s p)) - \ (\tcb. ko_at' tcb t s \ tcbDomain tcb =rva - \ tcbPriority tcb = rvb \ valid_tcb' tcb s)" - and P'=UNIV in ccorres_from_vcg) - apply (rule allI, rule conseqPre, vcg) - apply (clarsimp simp: getQueue_def gets_def get_def setQueue_def modify_def - put_def bind_def return_def bitmap_fun_defs null_def) - apply (clarsimp simp: queue_in_range valid_tcb'_def) - apply (rule conjI; clarsimp simp: queue_in_range) - apply (drule (1) obj_at_cslift_tcb) - apply clarsimp - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply (frule_tac s=\ in tcb_queue_relation_qend_mems, simp add: valid_queues_valid_q) - apply (drule_tac qend'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedAppend_update, - simp_all add: valid_queues_valid_q)[1] - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (simp add: invert_prioToL1Index_c_simp) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI; clarsimp) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (simp add: t_hrs_ksReadyQueues_upd_absorb) - apply (subst rf_sr_drop_bitmaps_enqueue_helper, assumption) - apply (fastforce intro: cbitmap_L1_relation_bit_set) - subgoal by (fastforce intro: cbitmap_L2_relation_bit_set simp: wordRadix_def mask_def) - apply (erule(1) state_relation_queue_update_helper[where S="{t}"], - (simp | rule globals.equality)+, - simp_all add: cready_queues_index_to_C_def2 numPriorities_def - t_hrs_ksReadyQueues_upd_absorb upd_unless_null_def - typ_heap_simps)[1] - apply (fastforce simp: tcb_null_sched_ptrs_def elim: obj_at'_weaken) - apply (fastforce simp: typ_heap_simps c_guard_clift) - apply (fastforce simp: tcb_null_sched_ptrs_def elim: obj_at'_weaken) - apply (clarsimp simp: upd_unless_null_def cready_queues_index_to_C_def numPriorities_def) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI; clarsimp simp: queue_in_range) - apply (drule (1) obj_at_cslift_tcb) - apply clarsimp - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply (frule_tac s=\ in tcb_queue_relation_qend_mems, - simp add: valid_queues_valid_q) - apply (drule_tac qend'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedAppend_update, - simp_all add: valid_queues_valid_q)[1] - apply clarsimp - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (clarsimp simp: upd_unless_null_def cready_queues_index_to_C_def numPriorities_def) - apply (drule (1) obj_at_cslift_tcb) - apply clarsimp - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply (frule_tac s=\ in tcb_queue_relation_qend_mems, - simp add: valid_queues_valid_q) - apply (drule_tac qend'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedAppend_update, - simp_all add: valid_queues_valid_q)[1] - apply clarsimp - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - apply (clarsimp simp: cready_queues_index_to_C_def2 numPriorities_def) - apply (frule(2) obj_at_cslift_tcb[OF valid_queues_obj_at'D]) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (erule_tac S="{t, v}" for v in state_relation_queue_update_helper, - (simp | rule globals.equality)+, - simp_all add: typ_heap_simps if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 upd_unless_null_def - cong: if_cong split del: if_split - del: fun_upd_restrict_conv)[1] - apply simp - apply (rule conjI) - apply clarsimp - apply (drule_tac s="tcb_ptr_to_ctcb_ptr t" in sym, simp) - apply (clarsimp simp add: fun_upd_twist) - prefer 4 - apply (simp add: obj_at'_weakenE[OF _ TrueI]) - apply (rule disjI1, erule valid_queues_obj_at'D) - subgoal by simp - subgoal by simp - subgoal by (fastforce simp: tcb_null_sched_ptrs_def) - subgoal by (fastforce simp: typ_heap_simps c_guard_clift) - apply (simp add: guard_is_UNIV_def) - apply simp - apply (wp threadGet_wp) - apply vcg - apply simp - apply (wp threadGet_wp) - apply vcg - apply (rule ccorres_return_Skip) - apply simp - apply (wp threadGet_wp) - apply vcg - by (fastforce simp: valid_objs'_def obj_at'_def ran_def projectKOs typ_at'_def - valid_obj'_def inQ_def - dest!: valid_queues_obj_at'D) -qed - lemma isStopped_spec: "\s. \ \ ({s} \ {s. cslift s (thread_' s) \ None}) Call isStopped_'proc {s'. ret__unsigned_long_' s' = from_bool (tsType_CL (thread_state_lift (tcbState_C (the (cslift s (thread_' s))))) \ @@ -1968,8 +1613,11 @@ lemma tcb_at_1: done lemma rescheduleRequired_ccorres: - "ccorres dc xfdc (valid_queues and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_objs') - UNIV [] rescheduleRequired (Call rescheduleRequired_'proc)" + "ccorres dc xfdc + ((\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_objs' + and pspace_aligned' and pspace_distinct') + UNIV [] + rescheduleRequired (Call rescheduleRequired_'proc)" apply cinit apply (rule ccorres_symb_exec_l) apply (rule ccorres_split_nothrow_novcg[where r'=dc and xf'=xfdc]) @@ -2079,10 +1727,12 @@ lemma cguard_UNIV: by fastforce lemma lookupBitmapPriority_le_maxPriority: - "\ ksReadyQueuesL1Bitmap s d \ 0 ; valid_queues s \ + "\ ksReadyQueuesL1Bitmap s d \ 0 ; + \d p. d > maxDomain \ p > maxPriority \ tcbQueueEmpty (ksReadyQueues s (d, p)); + valid_bitmaps s \ \ lookupBitmapPriority d s \ maxPriority" - unfolding valid_queues_def valid_queues_no_bitmap_def - by (fastforce dest!: bitmapQ_from_bitmap_lookup bitmapQ_ksReadyQueuesI intro: ccontr) + apply (clarsimp simp: valid_bitmaps_def) + by (fastforce dest!: bitmapQ_from_bitmap_lookup bitmapQ_ksReadyQueuesI intro: ccontr) lemma rf_sr_ksReadyQueuesL1Bitmap_not_zero: "\ (\, s') \ rf_sr ; d \ maxDomain ; ksReadyQueuesL1Bitmap_' (globals s').[unat d] \ 0 \ @@ -2092,10 +1742,10 @@ lemma rf_sr_ksReadyQueuesL1Bitmap_not_zero: done lemma ksReadyQueuesL1Bitmap_word_log2_max: - "\valid_queues s; ksReadyQueuesL1Bitmap s d \ 0\ - \ word_log2 (ksReadyQueuesL1Bitmap s d) < l2BitmapSize" - unfolding valid_queues_def - by (fastforce dest: word_log2_nth_same bitmapQ_no_L1_orphansD) + "\valid_bitmaps s; ksReadyQueuesL1Bitmap s d \ 0\ + \ word_log2 (ksReadyQueuesL1Bitmap s d) < l2BitmapSize" + unfolding valid_bitmaps_def + by (fastforce dest: word_log2_nth_same bitmapQ_no_L1_orphansD) lemma word_log2_max_word64[simp]: "word_log2 (w :: 64 word) < 64" @@ -2103,7 +1753,7 @@ lemma word_log2_max_word64[simp]: by (simp add: word_size) lemma rf_sr_ksReadyQueuesL2Bitmap_simp: - "\ (\, s') \ rf_sr ; d \ maxDomain ; valid_queues \ ; ksReadyQueuesL1Bitmap \ d \ 0 \ + "\ (\, s') \ rf_sr ; d \ maxDomain ; valid_bitmaps \ ; ksReadyQueuesL1Bitmap \ d \ 0 \ \ ksReadyQueuesL2Bitmap_' (globals s').[unat d].[word_log2 (ksReadyQueuesL1Bitmap \ d)] = ksReadyQueuesL2Bitmap \ (d, word_log2 (ksReadyQueuesL1Bitmap \ d))" apply (frule rf_sr_cbitmap_L2_relation) @@ -2112,9 +1762,9 @@ lemma rf_sr_ksReadyQueuesL2Bitmap_simp: done lemma ksReadyQueuesL2Bitmap_nonzeroI: - "\ d \ maxDomain ; valid_queues s ; ksReadyQueuesL1Bitmap s d \ 0 \ + "\ d \ maxDomain ; valid_bitmaps s ; ksReadyQueuesL1Bitmap s d \ 0 \ \ ksReadyQueuesL2Bitmap s (d, invertL1Index (word_log2 (ksReadyQueuesL1Bitmap s d))) \ 0" - unfolding valid_queues_def + unfolding valid_bitmaps_def apply clarsimp apply (frule bitmapQ_no_L1_orphansD) apply (erule word_log2_nth_same) @@ -2281,9 +1931,9 @@ lemma threadGet_get_obj_at'_has_domain: lemma possibleSwitchTo_ccorres: shows "ccorres dc xfdc - (valid_queues and (\s. weak_sch_act_wf (ksSchedulerAction s) s) + ((\s. weak_sch_act_wf (ksSchedulerAction s) s) and st_tcb_at' runnable' t and (\s. ksCurDomain s \ maxDomain) - and valid_objs') + and valid_objs' and pspace_aligned' and pspace_distinct') ({s. target_' s = tcb_ptr_to_ctcb_ptr t} \ UNIV) [] (possibleSwitchTo t ) @@ -2331,8 +1981,8 @@ lemma possibleSwitchTo_ccorres: lemma scheduleTCB_ccorres': "ccorres dc xfdc - (tcb_at' thread and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_queues - and valid_objs') + (tcb_at' thread and (\s. weak_sch_act_wf (ksSchedulerAction s) s) + and valid_objs' and pspace_aligned' and pspace_distinct') (UNIV \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) [] (do (runnable, curThread, action) \ do @@ -2382,24 +2032,26 @@ lemma scheduleTCB_ccorres': apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def cscheduler_action_relation_def) apply wp+ - apply (simp add: isRunnable_def isStopped_def) - apply wp + apply (simp add: isRunnable_def isStopped_def) apply (simp add: guard_is_UNIV_def) apply clarsimp apply (clarsimp simp: st_tcb_at'_def obj_at'_def weak_sch_act_wf_def) done lemma scheduleTCB_ccorres_valid_queues'_pre: - "ccorresG rf_sr \ dc xfdc (tcb_at' thread and st_tcb_at' (not runnable') thread and valid_queues' and valid_queues and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_objs') - (UNIV \ \\tptr = tcb_ptr_to_ctcb_ptr thread\) [] - (do (runnable, curThread, action) \ do - runnable \ isRunnable thread; - curThread \ getCurThread; - action \ getSchedulerAction; - return (runnable, curThread, action) od; - when (\ runnable \ curThread = thread \ action = ResumeCurrentThread) rescheduleRequired - od) - (Call scheduleTCB_'proc)" + "ccorresG rf_sr \ dc xfdc + (tcb_at' thread and st_tcb_at' (not runnable') thread + and (\s. weak_sch_act_wf (ksSchedulerAction s) s) + and valid_objs' and pspace_aligned' and pspace_distinct') + \\tptr = tcb_ptr_to_ctcb_ptr thread\ [] + (do (runnable, curThread, action) \ do runnable \ isRunnable thread; + curThread \ getCurThread; + action \ getSchedulerAction; + return (runnable, curThread, action) + od; + when (\ runnable \ curThread = thread \ action = ResumeCurrentThread) rescheduleRequired + od) + (Call scheduleTCB_'proc)" supply empty_fail_cond[simp] apply (cinit' lift: tptr_') apply (rule ccorres_rhs_assoc2)+ @@ -2440,17 +2092,17 @@ lemma scheduleTCB_ccorres_valid_queues'_pre: split: scheduler_action.split_asm) apply wp+ apply (simp add: isRunnable_def isStopped_def) - apply wp apply (simp add: guard_is_UNIV_def) apply (clarsimp simp: st_tcb_at'_def obj_at'_def) done - lemmas scheduleTCB_ccorres_valid_queues' = scheduleTCB_ccorres_valid_queues'_pre[unfolded bind_assoc return_bind split_conv] lemma rescheduleRequired_ccorres_valid_queues'_simple: - "ccorresG rf_sr \ dc xfdc (valid_queues' and sch_act_simple) UNIV [] rescheduleRequired (Call rescheduleRequired_'proc)" + "ccorresG rf_sr \ dc xfdc + sch_act_simple UNIV [] + rescheduleRequired (Call rescheduleRequired_'proc)" apply cinit apply (rule ccorres_symb_exec_l) apply (rule ccorres_split_nothrow_novcg[where r'=dc and xf'=xfdc]) @@ -2483,16 +2135,17 @@ lemma rescheduleRequired_ccorres_valid_queues'_simple: split: scheduler_action.split_asm) lemma scheduleTCB_ccorres_valid_queues'_pre_simple: - "ccorresG rf_sr \ dc xfdc (tcb_at' thread and st_tcb_at' (not runnable') thread and valid_queues' and sch_act_simple) - (UNIV \ \\tptr = tcb_ptr_to_ctcb_ptr thread\) [] - (do (runnable, curThread, action) \ do - runnable \ isRunnable thread; - curThread \ getCurThread; - action \ getSchedulerAction; - return (runnable, curThread, action) od; - when (\ runnable \ curThread = thread \ action = ResumeCurrentThread) rescheduleRequired - od) - (Call scheduleTCB_'proc)" + "ccorresG rf_sr \ dc xfdc + (tcb_at' thread and st_tcb_at' (not runnable') thread and valid_queues' and sch_act_simple) + \\tptr = tcb_ptr_to_ctcb_ptr thread\ [] + (do (runnable, curThread, action) \ do runnable \ isRunnable thread; + curThread \ getCurThread; + action \ getSchedulerAction; + return (runnable, curThread, action) + od; + when (\ runnable \ curThread = thread \ action = ResumeCurrentThread) rescheduleRequired + od) + (Call scheduleTCB_'proc)" supply empty_fail_cond[simp] apply (cinit' lift: tptr_' simp del: word_neq_0_conv) apply (rule ccorres_rhs_assoc2)+ @@ -2531,11 +2184,10 @@ lemma scheduleTCB_ccorres_valid_queues'_pre_simple: apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def cscheduler_action_relation_def) apply wp+ - apply (simp add: isRunnable_def isStopped_def) - apply wp + apply (simp add: isRunnable_def isStopped_def) apply (simp add: guard_is_UNIV_def) apply clarsimp - apply (clarsimp simp: st_tcb_at'_def obj_at'_def valid_queues'_def) + apply (clarsimp simp: st_tcb_at'_def obj_at'_def) done lemmas scheduleTCB_ccorres_valid_queues'_simple @@ -2555,47 +2207,34 @@ lemma threadSet_weak_sch_act_wf_runnable': apply (clarsimp) done -lemma threadSet_valid_queues_and_runnable': "\\s. valid_queues s \ (\p. thread \ set (ksReadyQueues s p) \ runnable' st)\ - threadSet (tcbState_update (\_. st)) thread - \\rv s. valid_queues s\" - apply (wp threadSet_valid_queues) - apply (clarsimp simp: inQ_def) -done - lemma setThreadState_ccorres[corres]: "ccorres dc xfdc - (\s. tcb_at' thread s \ valid_queues s \ valid_objs' s \ valid_tcb_state' st s \ - (ksSchedulerAction s = SwitchToThread thread \ runnable' st) \ - (\p. thread \ set (ksReadyQueues s p) \ runnable' st) \ - sch_act_wf (ksSchedulerAction s) s) - ({s'. (\cl fl. cthread_state_relation_lifted st (cl\tsType_CL := ts_' s' && mask 4\, fl))} + (\s. tcb_at' thread s \ valid_objs' s \ valid_tcb_state' st s + \ (ksSchedulerAction s = SwitchToThread thread \ runnable' st) + \ sch_act_wf (ksSchedulerAction s) s \ pspace_aligned' s \ pspace_distinct' s) + ({s'. (\cl fl. cthread_state_relation_lifted st (cl\tsType_CL := ts_' s' && mask 4\, fl))} \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) hs - (setThreadState st thread) (Call setThreadState_'proc)" + (setThreadState st thread) (Call setThreadState_'proc)" apply (cinit lift: tptr_' cong add: call_ignore_cong) apply (ctac (no_vcg) add: threadSet_tcbState_simple_corres) apply (ctac add: scheduleTCB_ccorres) - apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_queues_and_runnable' - threadSet_valid_objs') - by (clarsimp simp: weak_sch_act_wf_def valid_queues_def valid_tcb'_tcbState_update) - -lemma threadSet_valid_queues'_and_not_runnable': "\tcb_at' thread and valid_queues' and (\s. (\ runnable' st))\ - threadSet (tcbState_update (\_. st)) thread - \\rv. tcb_at' thread and st_tcb_at' (not runnable') thread and valid_queues' \" - - apply (wp threadSet_valid_queues' threadSet_tcbState_st_tcb_at') - apply (clarsimp simp: pred_neg_def valid_queues'_def inQ_def)+ -done + apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_objs') + apply (clarsimp simp: weak_sch_act_wf_def valid_tcb'_tcbState_update) + done lemma setThreadState_ccorres_valid_queues': - "ccorres dc xfdc - (\s. tcb_at' thread s \ valid_queues' s \ \ runnable' st \ weak_sch_act_wf (ksSchedulerAction s) s \ Invariants_H.valid_queues s \ (\p. thread \ set (ksReadyQueues s p)) \ sch_act_not thread s \ valid_objs' s \ valid_tcb_state' st s) + "ccorres dc xfdc + (\s. tcb_at' thread s \ \ runnable' st \ weak_sch_act_wf (ksSchedulerAction s) s + \ sch_act_not thread s \ valid_objs' s \ valid_tcb_state' st s + \ pspace_aligned' s \ pspace_distinct' s) ({s'. (\cl fl. cthread_state_relation_lifted st (cl\tsType_CL := ts_' s' && mask 4\, fl))} - \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) [] - (setThreadState st thread) (Call setThreadState_'proc)" + \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) [] + (setThreadState st thread) (Call setThreadState_'proc)" apply (cinit lift: tptr_' cong add: call_ignore_cong) apply (ctac (no_vcg) add: threadSet_tcbState_simple_corres) apply (ctac add: scheduleTCB_ccorres_valid_queues') - apply (wp threadSet_valid_queues'_and_not_runnable' threadSet_weak_sch_act_wf_runnable' threadSet_valid_queues_and_runnable' threadSet_valid_objs') + apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_objs' + threadSet_tcbState_st_tcb_at') by (clarsimp simp: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) lemma simp_list_case_return: @@ -2617,22 +2256,20 @@ lemma cancelSignal_ccorres [corres]: apply (rule ccorres_rhs_assoc2) apply (ctac (no_vcg) add: cancelSignal_ccorres_helper) apply (ctac add: setThreadState_ccorres_valid_queues') - apply ((wp setNotification_nosch setNotification_ksQ hoare_vcg_all_lift set_ntfn_valid_objs' | simp add: valid_tcb_state'_def split del: if_split)+)[1] + apply ((wp setNotification_nosch hoare_vcg_all_lift set_ntfn_valid_objs' | simp add: valid_tcb_state'_def split del: if_split)+)[1] apply (simp add: ThreadState_defs) apply (rule conjI, clarsimp, rule conjI, clarsimp) apply (frule (1) ko_at_valid_ntfn'[OF _ invs_valid_objs']) subgoal by ((auto simp: obj_at'_def projectKOs st_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of cthread_state_relation_def sch_act_wf_weak valid_ntfn'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] | - clarsimp simp: eq_commute)+) + | clarsimp simp: eq_commute)+) apply (clarsimp) apply (frule (1) ko_at_valid_ntfn'[OF _ invs_valid_objs']) apply (frule (2) ntfn_blocked_in_queueD) by (auto simp: obj_at'_def projectKOs st_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of valid_ntfn'_def cthread_state_relation_def sch_act_wf_weak isWaitingNtfn_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: ntfn.splits option.splits | clarsimp simp: eq_commute | drule_tac x=thread in bspec)+ @@ -2920,23 +2557,20 @@ lemma cancelIPC_ccorres_helper: cpspace_relation_def update_ep_map_tos typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - subgoal by (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - subgoal by (simp add: cendpoint_relation_def Let_def EPState_Idle_def) - subgoal by simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - subgoal by simp - apply (erule (1) map_to_ko_atI') - apply (simp add: heap_to_user_data_def Let_def) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - subgoal by (clarsimp simp: comp_def) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + subgoal by (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + subgoal by (simp add: cendpoint_relation_def Let_def EPState_Idle_def) + subgoal by simp + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + subgoal by simp + apply (erule (1) map_to_ko_atI') + apply (simp add: heap_to_user_data_def Let_def) subgoal by (clarsimp simp: carch_state_relation_def carch_globals_def packed_heap_update_collapse_hrs) subgoal by (simp add: cmachine_state_relation_def) @@ -2957,44 +2591,48 @@ lemma cancelIPC_ccorres_helper: cpspace_relation_def update_ep_map_tos typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - subgoal by (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (simp add: cendpoint_relation_def Let_def isSendEP_def isRecvEP_def split: endpoint.splits split del: if_split) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + subgoal by (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (simp add: cendpoint_relation_def Let_def isSendEP_def isRecvEP_def + split: endpoint.splits split del: if_split) \ \recv case\ - apply (subgoal_tac "pspace_canonical' \") - prefer 2 - apply fastforce - apply (clarsimp - simp: h_t_valid_clift_Some_iff ctcb_offset_defs mask_shiftl_decompose - tcb_queue_relation'_next_mask tcb_queue_relation'_prev_mask - tcb_queue_relation'_next_canonical tcb_queue_relation'_prev_canonical - simp flip: canonical_bit_def make_canonical_def - cong: tcb_queue_relation'_cong) - subgoal by (intro impI conjI; simp) - \ \send case\ - apply (subgoal_tac "pspace_canonical' \") - prefer 2 - apply fastforce - apply (clarsimp - simp: h_t_valid_clift_Some_iff ctcb_offset_defs mask_shiftl_decompose - tcb_queue_relation'_next_mask tcb_queue_relation'_prev_mask - tcb_queue_relation'_next_canonical tcb_queue_relation'_prev_canonical - simp flip: canonical_bit_def - cong: tcb_queue_relation'_cong) + apply (subgoal_tac "pspace_canonical' \") + prefer 2 + apply fastforce + apply (clarsimp simp: h_t_valid_clift_Some_iff ctcb_offset_defs mask_shiftl_decompose + tcb_queue_relation'_next_mask tcb_queue_relation'_prev_mask + tcb_queue_relation'_next_canonical tcb_queue_relation'_prev_canonical + simp flip: canonical_bit_def make_canonical_def + cong: tcb_queue_relation'_cong) subgoal by (intro impI conjI; simp) - subgoal by simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - apply simp - apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - subgoal by (clarsimp simp: comp_def) + \ \send case\ + apply (subgoal_tac "pspace_canonical' \") + prefer 2 + apply fastforce + apply (clarsimp simp: h_t_valid_clift_Some_iff ctcb_offset_defs mask_shiftl_decompose + tcb_queue_relation'_next_mask tcb_queue_relation'_prev_mask + tcb_queue_relation'_next_canonical tcb_queue_relation'_prev_canonical + simp flip: canonical_bit_def + cong: tcb_queue_relation'_cong) + subgoal by (intro impI conjI; simp) + \ \send case\ + apply (subgoal_tac "pspace_canonical' \") + prefer 2 + apply fastforce + apply (clarsimp simp: h_t_valid_clift_Some_iff ctcb_offset_defs + tcb_queue_relation'_next_mask tcb_queue_relation'_prev_mask + tcb_queue_relation'_next_canonical tcb_queue_relation'_prev_canonical + simp flip: canonical_bit_def + cong: tcb_queue_relation'_cong) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp + apply (erule (1) map_to_ko_atI') subgoal by (clarsimp simp: carch_state_relation_def carch_globals_def packed_heap_update_collapse_hrs) subgoal by (simp add: cmachine_state_relation_def) @@ -3207,37 +2845,35 @@ lemma cancelIPC_ccorres1: subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits) + split: thread_state.splits) apply clarsimp apply (frule (2) ep_blocked_in_queueD_recv) apply (frule (1) ko_at_valid_ep'[OF _ invs_valid_objs']) subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of isRecvEP_def cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits endpoint.splits) + split: thread_state.splits endpoint.splits) apply (rule conjI) apply (clarsimp simp: inQ_def) - apply (rule conjI) - apply clarsimp apply clarsimp apply (rule conjI) subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits) + split: thread_state.splits) apply clarsimp apply (rule conjI) subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits) + split: thread_state.splits) apply clarsimp apply (frule (2) ep_blocked_in_queueD_send) apply (frule (1) ko_at_valid_ep'[OF _ invs_valid_objs']) subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of isSendEP_def cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits endpoint.splits)[1] + split: thread_state.splits endpoint.splits)[1] apply (auto simp: isTS_defs cthread_state_relation_def typ_heap_simps weak_sch_act_wf_def) apply (case_tac ts, auto simp: isTS_defs cthread_state_relation_def typ_heap_simps) diff --git a/proof/crefine/AARCH64/Ipc_C.thy b/proof/crefine/AARCH64/Ipc_C.thy index 1293163cbc..792734f8c1 100644 --- a/proof/crefine/AARCH64/Ipc_C.thy +++ b/proof/crefine/AARCH64/Ipc_C.thy @@ -1385,18 +1385,14 @@ lemma getRestartPC_ccorres [corres]: done lemma asUser_tcbFault_obj_at: - "\obj_at' (\tcb. P (tcbFault tcb)) t\ asUser t' m - \\rv. obj_at' (\tcb. P (tcbFault tcb)) t\" + "asUser t' m \obj_at' (\tcb. P (tcbFault tcb)) t\" apply (simp add: asUser_def split_def) apply (wp threadGet_wp) apply (simp cong: if_cong) done lemma asUser_atcbContext_obj_at: - "t \ t' \ - \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ - asUser t' m - \\rv. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + "t \ t' \ asUser t' m \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" apply (simp add: asUser_def split_def atcbContextGet_def atcbContextSet_def) apply (wp threadGet_wp) apply simp @@ -4401,10 +4397,6 @@ lemma doReplyTransfer_ccorres [corres]: \ \\grant = from_bool grant\) hs (doReplyTransfer sender receiver slot grant) (Call doReplyTransfer_'proc)" -proof - - have invs_valid_queues_strg: "\s. invs' s \ valid_queues s" - by clarsimp - show ?thesis apply (cinit lift: sender_' receiver_' slot_' grant_') apply (rule getThreadState_ccorres_foo) apply (rule ccorres_assert2) @@ -4436,7 +4428,7 @@ proof - apply (ctac(no_vcg) add: cteDeleteOne_ccorres[where w="scast cap_reply_cap"]) apply (ctac(no_vcg) add: setThreadState_ccorres) apply (ctac(no_vcg) add: possibleSwitchTo_ccorres) - apply (wpsimp wp: sts_running_valid_queues setThreadState_st_tcb)+ + apply (wpsimp wp: sts_valid_objs' setThreadState_st_tcb)+ apply (wp cteDeleteOne_sch_act_wf) apply vcg apply (rule conseqPre, vcg) @@ -4445,8 +4437,7 @@ proof - apply wp apply (simp add: cap_get_tag_isCap) apply (strengthen invs_weak_sch_act_wf_strg - cte_wp_at_imp_consequent'[where P="\ct. Ex (ccap_relation (cteCap ct))" for ct] - invs_valid_queues_strg) + cte_wp_at_imp_consequent'[where P="\ct. Ex (ccap_relation (cteCap ct))" for ct]) apply (simp add: cap_reply_cap_def) apply (wp doIPCTransfer_reply_or_replyslot) apply (clarsimp simp: seL4_Fault_NullFault_def ccorres_cond_iffs @@ -4481,19 +4472,20 @@ proof - apply (ctac (no_vcg)) apply (simp only: K_bind_def) apply (ctac add: possibleSwitchTo_ccorres) - apply (wp sts_running_valid_queues setThreadState_st_tcb | simp)+ - apply (ctac add: setThreadState_ccorres_valid_queues'_simple) + apply (wp sts_valid_objs' setThreadState_st_tcb | simp)+ + apply (ctac add: setThreadState_ccorres_simple) apply wp - apply ((wp threadSet_valid_queues threadSet_sch_act threadSet_valid_queues' hoare_weak_lift_imp + apply ((wp threadSet_sch_act hoare_weak_lift_imp threadSet_valid_objs' threadSet_weak_sch_act_wf | simp add: valid_tcb_state'_def)+)[1] apply (clarsimp simp: guard_is_UNIV_def ThreadState_defs mask_def option_to_ctcb_ptr_def) - apply (rule_tac Q="\rv. valid_queues and tcb_at' receiver and valid_queues' and + apply (rule_tac Q="\rv. tcb_at' receiver and valid_objs' and sch_act_simple and (\s. ksCurDomain s \ maxDomain) and - (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) + (\s. sch_act_wf (ksSchedulerAction s) s) and + pspace_aligned' and pspace_distinct'" in hoare_post_imp) apply (clarsimp simp: inQ_def weak_sch_act_wf_def) - apply (wp threadSet_valid_queues threadSet_sch_act handleFaultReply_sch_act_wf) + apply (wp threadSet_sch_act handleFaultReply_sch_act_wf) apply (clarsimp simp: guard_is_UNIV_def) apply assumption apply clarsimp @@ -4502,7 +4494,7 @@ proof - apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_tcb]) apply (clarsimp simp: ctcb_relation_def typ_heap_simps) apply wp - apply (strengthen vp_invs_strg' invs_valid_queues') + apply (strengthen vp_invs_strg') apply (wp cteDeleteOne_tcbFault cteDeleteOne_sch_act_wf) apply vcg apply (rule conseqPre, vcg) @@ -4518,7 +4510,6 @@ proof - cap_get_tag_isCap) apply fastforce done -qed lemma ccorres_getCTE_cte_at: "ccorresG rf_sr \ r xf P P' hs (getCTE p >>= f) c @@ -4538,7 +4529,7 @@ lemma ccorres_getCTE_cte_at: done lemma setupCallerCap_ccorres [corres]: - "ccorres dc xfdc (valid_queues and valid_pspace' and (\s. \d p. sender \ set (ksReadyQueues s (d, p))) + "ccorres dc xfdc (valid_pspace' and (\s. sch_act_wf (ksSchedulerAction s) s) and sch_act_not sender and tcb_at' sender and tcb_at' receiver and tcb_at' sender and tcb_at' receiver) @@ -4670,23 +4661,20 @@ lemma sendIPC_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def - tcb_queue_relation'_def) - apply simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def + tcb_queue_relation'_def) apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - apply simp - apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp + apply (erule (1) map_to_ko_atI') apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -4710,31 +4698,27 @@ lemma sendIPC_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - isRecvEP_def isSendEP_def mask_shiftl_decompose - tcb_queue_relation'_def valid_ep'_def - simp flip: canonical_bit_def - split: endpoint.splits list.splits - split del: if_split) - apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") (* FIXME AARCH64: clean up names *) - apply (erule (1) tcb_and_not_mask_canonical[OF invs_pspace_canonical']) - apply (simp (no_asm) add: objBits_simps') - apply (clarsimp split: if_split) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + isRecvEP_def isSendEP_def mask_shiftl_decompose + tcb_queue_relation'_def valid_ep'_def + simp flip: canonical_bit_def + split: endpoint.splits list.splits) + apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") (* FIXME AARCH64: clean up names *) + apply (erule (1) tcb_and_not_mask_canonical[OF invs_pspace_canonical']) + apply (simp (no_asm) add: objBits_simps') + apply (clarsimp split: if_split) apply simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - apply simp - apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (erule (1) map_to_ko_atI') apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -4759,11 +4743,10 @@ lemma rf_sr_tcb_update_twice: packed_heap_update_collapse_hrs) lemma sendIPC_block_ccorres_helper: - "ccorres dc xfdc (tcb_at' thread and valid_queues and valid_objs' and - pspace_canonical' and + "ccorres dc xfdc (tcb_at' thread and valid_objs' and pspace_canonical' and + pspace_aligned' and pspace_distinct' and sch_act_not thread and ep_at' epptr and - (\s. sch_act_wf (ksSchedulerAction s) s \ - (\d p. thread \ set (ksReadyQueues s (d, p)))) and + (\s. sch_act_wf (ksSchedulerAction s) s) and K (bos = ThreadState_BlockedOnSend \ epptr' = epptr \ badge' = badge \ cg = from_bool canGrant \ cgr = from_bool canGrantReply @@ -4821,7 +4804,7 @@ lemma sendIPC_block_ccorres_helper: apply ceqv apply clarsimp apply ctac - apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_queues + apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_objs') apply (clarsimp simp: guard_is_UNIV_def) apply (clarsimp simp: sch_act_wf_weak valid_tcb'_def valid_tcb_state'_def @@ -4926,6 +4909,19 @@ lemma tcb_queue_relation_qend_valid': apply (simp add: h_t_valid_clift_Some_iff) done +lemma tcb_queue'_head_end_NULL: + assumes qr: "tcb_queue_relation' getNext getPrev mp queue qhead qend" + and tat: "\t\set queue. tcb_at' t s" + shows "(qend = NULL) = (qhead = NULL)" + using qr tat + apply - + apply (erule tcb_queue_relationE') + apply (simp add: tcb_queue_head_empty_iff split: if_splits) + apply (rule tcb_at_not_NULL) + apply (erule bspec) + apply simp + done + lemma tcbEPAppend_spec: "\s queue. \ \ \s. \t. (t, s) \ rf_sr \ (\tcb\set queue. tcb_at' tcb t) \ distinct queue @@ -5048,34 +5044,31 @@ lemma sendIPC_enqueue_ccorres_helper: apply (elim conjE) apply (intro conjI) \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep', assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - mask_def [where n=3] EPState_Send_def) - apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask) - apply (rule conjI, simp add: mask_def) - subgoal - apply (clarsimp simp: valid_pspace'_def objBits_simps' mask_shiftl_decompose - simp flip: canonical_bit_def) - apply (erule (1) tcb_and_not_mask_canonical) - by (simp (no_asm) add: tcbBlockSizeBits_def) + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep', assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + mask_def [where n=3] EPState_Send_def) + apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask) + apply (rule conjI, simp add: mask_def) + subgoal + apply (clarsimp simp: valid_pspace'_def objBits_simps' mask_shiftl_decompose + simp flip: canonical_bit_def) + apply (erule (1) tcb_and_not_mask_canonical) + by (simp (no_asm) add: tcbBlockSizeBits_def) + apply (simp add: isSendEP_def isRecvEP_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue, assumption+) apply (simp add: isSendEP_def isRecvEP_def) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_ep_queue, assumption+) - apply (simp add: isSendEP_def isRecvEP_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (simp only:projectKOs injectKO_ep objBits_simps) - apply clarsimp - apply (clarsimp simp: obj_at'_def) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (simp only:projectKOs injectKO_ep objBits_simps) + apply clarsimp + apply (clarsimp simp: obj_at'_def) apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) apply (simp add: typ_heap_simps') @@ -5092,44 +5085,41 @@ lemma sendIPC_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) \ \ep relation\ apply (rule cpspace_relation_ep_update_ep', assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - mask_def [where n=3] EPState_Send_def - split: if_split) - subgoal - apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask - valid_ep'_def - dest: tcb_queue_relation_next_not_NULL) - apply (rule conjI, clarsimp) - apply (rule conjI, fastforce simp: mask_def) - apply (clarsimp simp: valid_pspace'_def objBits_simps' mask_shiftl_decompose - simp flip: canonical_bit_def) - apply (erule (1) tcb_and_not_mask_canonical) - apply (simp (no_asm) add: tcbBlockSizeBits_def) + apply (clarsimp simp: cendpoint_relation_def Let_def + mask_def [where n=3] EPState_Send_def + split: if_split) + subgoal + apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask + valid_ep'_def + dest: tcb_queue_relation_next_not_NULL) + apply (rule conjI, clarsimp) + apply (rule conjI, fastforce simp: mask_def) apply (clarsimp simp: valid_pspace'_def objBits_simps' mask_shiftl_decompose simp flip: canonical_bit_def) - apply (rule conjI, solves \simp (no_asm) add: mask_def\) apply (erule (1) tcb_and_not_mask_canonical) apply (simp (no_asm) add: tcbBlockSizeBits_def) - done + apply (clarsimp simp: valid_pspace'_def objBits_simps' mask_shiftl_decompose + simp flip: canonical_bit_def) + apply (rule conjI, solves \simp (no_asm) add: mask_def\) + apply (erule (1) tcb_and_not_mask_canonical) + apply (simp (no_asm) add: tcbBlockSizeBits_def) + done + apply (simp add: isSendEP_def isRecvEP_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue, assumption+) apply (simp add: isSendEP_def isRecvEP_def) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_ep_queue, assumption+) - apply (simp add: isSendEP_def isRecvEP_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def) apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -5149,8 +5139,7 @@ lemma ctcb_relation_blockingIPCCanGrantD: lemma sendIPC_ccorres [corres]: "ccorres dc xfdc (invs' and st_tcb_at' simple' thread - and sch_act_not thread and ep_at' epptr and - (\s. \d p. thread \ set (ksReadyQueues s (d, p)))) + and sch_act_not thread and ep_at' epptr) (UNIV \ \\blocking = from_bool blocking\ \ \\do_call = from_bool do_call\ \ \\badge = badge\ @@ -5181,8 +5170,7 @@ lemma sendIPC_ccorres [corres]: apply ceqv apply (rule_tac A="invs' and st_tcb_at' simple' thread and sch_act_not thread and ko_at' ep epptr - and ep_at' epptr - and (\s. \d p. thread \ set (ksReadyQueues s (d, p)))" + and ep_at' epptr" in ccorres_guard_imp2 [where A'=UNIV]) apply wpc \ \RecvEP case\ @@ -5230,12 +5218,11 @@ lemma sendIPC_ccorres [corres]: apply (ctac add: setThreadState_ccorres) apply (rule ccorres_return_Skip) apply (wpsimp wp: hoare_drop_imps hoare_vcg_all_lift possibleSwitchTo_sch_act_not - possibleSwitchTo_sch_act_not sts_st_tcb' - possibleSwitchTo_ksQ' sts_valid_queues sts_ksQ' + possibleSwitchTo_sch_act_not sts_st_tcb' sts_valid_objs' simp: valid_tcb_state'_def)+ apply vcg - apply (wpsimp wp: doIPCTransfer_sch_act setEndpoint_ksQ hoare_vcg_all_lift - set_ep_valid_objs' setEndpoint_valid_mdb' + apply (wpsimp wp: doIPCTransfer_sch_act hoare_vcg_all_lift + set_ep_valid_objs' setEndpoint_valid_mdb' | wp (once) hoare_drop_imp | strengthen sch_act_wf_weak)+ apply (fastforce simp: guard_is_UNIV_def ThreadState_defs Collect_const_mem mask_def @@ -5356,11 +5343,10 @@ lemma ctcb_relation_blockingIPCCanGrantReplyD: done lemma receiveIPC_block_ccorres_helper: - "ccorres dc xfdc (tcb_at' thread and valid_queues and valid_objs' and - pspace_canonical' and + "ccorres dc xfdc (tcb_at' thread and valid_objs' and + pspace_canonical' and pspace_aligned' and pspace_distinct' and sch_act_not thread and ep_at' epptr and - (\s. sch_act_wf (ksSchedulerAction s) s \ - (\d p. thread \ set (ksReadyQueues s (d, p)))) and + (\s. sch_act_wf (ksSchedulerAction s) s) and K (epptr = epptr && ~~ mask 4) and K (isEndpointCap cap \ ccap_relation cap cap')) UNIV hs @@ -5402,7 +5388,7 @@ lemma receiveIPC_block_ccorres_helper: apply ceqv apply clarsimp apply ctac - apply (wp threadSet_valid_queues hoare_vcg_all_lift threadSet_valid_objs' + apply (wp hoare_vcg_all_lift threadSet_valid_objs' threadSet_weak_sch_act_wf_runnable') apply (clarsimp simp: guard_is_UNIV_def) apply (clarsimp simp: sch_act_wf_weak valid_tcb'_def valid_tcb_state'_def @@ -5468,44 +5454,41 @@ lemma receiveIPC_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep', assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - mask_def [where n=3] EPState_Recv_def - split: if_split) - subgoal - apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask - valid_ep'_def - dest: tcb_queue_relation_next_not_NULL) - apply (rule conjI, clarsimp) - apply (rule conjI, fastforce simp: mask_def) - apply (clarsimp simp: valid_pspace'_def objBits_simps' mask_shiftl_decompose - simp flip: canonical_bit_def) - apply (erule (1) tcb_and_not_mask_canonical) - apply (simp (no_asm) add: tcbBlockSizeBits_def) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep', assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + mask_def [where n=3] EPState_Recv_def + split: if_split) + subgoal + apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask + valid_ep'_def + dest: tcb_queue_relation_next_not_NULL) + apply (rule conjI, clarsimp) + apply (rule conjI, fastforce simp: mask_def) apply (clarsimp simp: valid_pspace'_def objBits_simps' mask_shiftl_decompose simp flip: canonical_bit_def) - apply (rule conjI, solves \simp (no_asm) add: mask_def\) apply (erule (1) tcb_and_not_mask_canonical) apply (simp (no_asm) add: tcbBlockSizeBits_def) - done + apply (clarsimp simp: valid_pspace'_def objBits_simps' mask_shiftl_decompose + simp flip: canonical_bit_def) + apply (rule conjI, solves \simp (no_asm) add: mask_def\) + apply (erule (1) tcb_and_not_mask_canonical) + apply (simp (no_asm) add: tcbBlockSizeBits_def) + done + apply (simp add: isSendEP_def isRecvEP_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue, assumption+) apply (simp add: isSendEP_def isRecvEP_def) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_ep_queue, assumption+) - apply (simp add: isSendEP_def isRecvEP_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def projectKOs) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def projectKOs) apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -5522,35 +5505,32 @@ lemma receiveIPC_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep', assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - mask_def [where n=3] EPState_Recv_def) - apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask - simp flip: canonical_bit_def) - subgoal - apply (rule conjI, solves\simp (no_asm) add: mask_def\) - apply (clarsimp simp: valid_pspace'_def mask_shiftl_decompose - simp flip: canonical_bit_def) - apply (erule (1) tcb_and_not_mask_canonical, simp (no_asm) add: tcbBlockSizeBits_def) - done + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep', assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + mask_def [where n=3] EPState_Recv_def) + apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask + simp flip: canonical_bit_def) + subgoal + apply (rule conjI, solves\simp (no_asm) add: mask_def\) + apply (clarsimp simp: valid_pspace'_def mask_shiftl_decompose + simp flip: canonical_bit_def) + apply (erule (1) tcb_and_not_mask_canonical, simp (no_asm) add: tcbBlockSizeBits_def) + done + apply (simp add: isSendEP_def isRecvEP_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue, assumption+) apply (simp add: isSendEP_def isRecvEP_def) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_ep_queue, assumption+) - apply (simp add: isSendEP_def isRecvEP_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def) apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) apply (simp add: typ_heap_simps') @@ -5619,23 +5599,20 @@ lemma receiveIPC_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def - tcb_queue_relation'_def) - apply simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def + tcb_queue_relation'_def) apply simp + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) apply (simp add: typ_heap_simps') @@ -5659,31 +5636,28 @@ lemma receiveIPC_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def mask_shiftl_decompose - isRecvEP_def isSendEP_def - tcb_queue_relation'_def valid_ep'_def - simp flip: canonical_bit_def - split: endpoint.splits list.splits - split del: if_split) - apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") (* FIXME AARCH64: clean up names *) - apply (erule (1) tcb_and_not_mask_canonical[OF invs_pspace_canonical']) - apply (simp (no_asm) add: objBits_simps') - apply (clarsimp split: if_split) - apply simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def mask_shiftl_decompose + isRecvEP_def isSendEP_def + tcb_queue_relation'_def valid_ep'_def + simp flip: canonical_bit_def + split: endpoint.splits list.splits + split del: if_split) + apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") (* FIXME AARCH64: clean up names *) + apply (erule (1) tcb_and_not_mask_canonical[OF invs_pspace_canonical']) + apply (simp (no_asm) add: objBits_simps') + apply (clarsimp split: if_split) apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - apply simp - apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp + apply (erule (1) map_to_ko_atI') apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) apply (simp add: typ_heap_simps') @@ -5800,7 +5774,6 @@ lemma receiveIPC_ccorres [corres]: notes option.case_cong_weak [cong] shows "ccorres dc xfdc (invs' and st_tcb_at' simple' thread and sch_act_not thread - and (\s. \d p. thread \ set (ksReadyQueues s (d, p))) and valid_cap' cap and K (isEndpointCap cap)) (UNIV \ \\thread = tcb_ptr_to_ctcb_ptr thread\ \ \ccap_relation cap \cap\ @@ -5876,7 +5849,6 @@ lemma receiveIPC_ccorres [corres]: apply ceqv apply (rule_tac A="invs' and st_tcb_at' simple' thread and sch_act_not thread - and (\s. \d p. thread \ set (ksReadyQueues s (d, p))) and ko_at' ep (capEPPtr cap)" in ccorres_guard_imp2 [where A'=UNIV]) apply wpc @@ -6016,27 +5988,25 @@ lemma receiveIPC_ccorres [corres]: apply ccorres_rewrite apply ctac apply (ctac add: possibleSwitchTo_ccorres) - apply (wpsimp wp: sts_st_tcb' sts_valid_queues) + apply (wpsimp wp: sts_st_tcb' sts_valid_objs') apply (vcg exspec=setThreadState_modifies) apply (fastforce simp: guard_is_UNIV_def ThreadState_defs mask_def cap_get_tag_isCap ccap_relation_ep_helpers) apply (clarsimp simp: valid_tcb_state'_def) - apply (rule_tac Q="\_. valid_pspace' and valid_queues + apply (rule_tac Q="\_. valid_pspace' and st_tcb_at' ((=) sendState) sender and tcb_at' thread and (\s. sch_act_wf (ksSchedulerAction s) s) - and (\s. (\a b. sender \ set (ksReadyQueues s (a, b)))) and sch_act_not sender and K (thread \ sender) and (\s. ksCurDomain s \ maxDomain)" in hoare_post_imp) - apply (clarsimp simp: valid_pspace_valid_objs' pred_tcb_at'_def sch_act_wf_weak - obj_at'_def) + apply (fastforce simp: valid_pspace_valid_objs' pred_tcb_at'_def sch_act_wf_weak + obj_at'_def) apply (wpsimp simp: guard_is_UNIV_def option_to_ptr_def option_to_0_def conj_ac)+ - apply (rule_tac Q="\rv. valid_queues and valid_pspace' + apply (rule_tac Q="\rv. valid_pspace' and cur_tcb' and tcb_at' sender and tcb_at' thread and sch_act_not sender and K (thread \ sender) and ep_at' (capEPPtr cap) and (\s. ksCurDomain s \ maxDomain) - and (\s. sch_act_wf (ksSchedulerAction s) s \ - (\d p. sender \ set (ksReadyQueues s (d, p))))" + and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) subgoal by (auto, auto simp: st_tcb_at'_def obj_at'_def) apply (wp hoare_vcg_all_lift set_ep_valid_objs') @@ -6072,14 +6042,11 @@ lemma receiveIPC_ccorres [corres]: split: if_split_asm bool.splits) (*very long *) apply (clarsimp simp: obj_at'_def state_refs_of'_def projectKOs) apply (frule(1) sym_refs_ko_atD' [OF _ invs_sym']) - apply (frule invs_queues) apply clarsimp apply (rename_tac list x xa) apply (rule_tac P="x\set list" in case_split) apply (clarsimp simp:st_tcb_at_refs_of_rev') apply (erule_tac x=x and P="\x. st_tcb_at' P x s" for P in ballE) - apply (drule_tac t=x in valid_queues_not_runnable'_not_ksQ) - apply (clarsimp simp: st_tcb_at'_def obj_at'_def) apply (subgoal_tac "sch_act_not x s") prefer 2 apply (frule invs_sch_act_wf') @@ -6157,23 +6124,20 @@ lemma sendSignal_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) - apply simp+ - apply (erule (1) map_to_ko_atI') - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) - apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def - tcb_queue_relation'_def make_canonical_def canonical_bit_def) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) + apply simp+ + apply (erule (1) map_to_ko_atI') + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) + apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def + tcb_queue_relation'_def make_canonical_def canonical_bit_def) + apply simp apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -6199,33 +6163,30 @@ lemma sendSignal_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) - apply simp+ - apply (erule (1) map_to_ko_atI') - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) - apply (clarsimp simp: cnotification_relation_def Let_def mask_shiftl_decompose - isWaitingNtfn_def - tcb_queue_relation'_def valid_ntfn'_def - split: Structures_H.notification.splits list.splits - split del: if_split) - apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") (* FIXME AARCH64: names *) - apply (rule conjI) - subgoal by (erule (1) tcb_ptr_canonical[OF invs_pspace_canonical']) - apply (rule context_conjI) - subgoal by (erule (1) tcb_ptr_canonical[OF invs_pspace_canonical']) - apply clarsimp - apply (clarsimp split: if_split) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) + apply simp+ + apply (erule (1) map_to_ko_atI') + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) + apply (clarsimp simp: cnotification_relation_def Let_def mask_shiftl_decompose + isWaitingNtfn_def + tcb_queue_relation'_def valid_ntfn'_def + split: Structures_H.notification.splits list.splits + split del: if_split) + apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") (* FIXME AARCH64: names *) + apply (rule conjI) + subgoal by (erule (1) tcb_ptr_canonical[OF invs_pspace_canonical']) + apply (rule context_conjI) + subgoal by (erule (1) tcb_ptr_canonical[OF invs_pspace_canonical']) + apply clarsimp + apply (clarsimp split: if_split) + apply simp apply (clarsimp simp: carch_state_relation_def) apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -6332,7 +6293,7 @@ lemma sendSignal_ccorres [corres]: apply (ctac(no_vcg) add: setThreadState_ccorres) apply (ctac(no_vcg) add: setRegister_ccorres) apply (ctac add: possibleSwitchTo_ccorres) - apply (wp sts_running_valid_queues sts_st_tcb_at'_cases + apply (wp sts_valid_objs' sts_st_tcb_at'_cases | simp add: option_to_ctcb_ptr_def split del: if_split)+ apply (rule_tac Q="\_. tcb_at' (the (ntfnBoundTCB ntfn)) and invs'" in hoare_post_imp) @@ -6398,10 +6359,8 @@ lemma sendSignal_ccorres [corres]: apply (ctac (no_vcg)) apply (ctac add: possibleSwitchTo_ccorres) apply (simp) - apply (wp weak_sch_act_wf_lift_linear - setThreadState_oa_queued - sts_valid_queues tcb_in_cur_domain'_lift)[1] - apply (wp sts_valid_queues sts_runnable) + apply (wp weak_sch_act_wf_lift_linear tcb_in_cur_domain'_lift)[1] + apply (wp sts_valid_objs' sts_runnable) apply (wp setThreadState_st_tcb set_ntfn_valid_objs' | clarsimp)+ apply (clarsimp simp: guard_is_UNIV_def ThreadState_defs mask_def badgeRegister_def C_register_defs @@ -6425,10 +6384,9 @@ lemma sendSignal_ccorres [corres]: done lemma receiveSignal_block_ccorres_helper: - "ccorres dc xfdc (tcb_at' thread and valid_queues and sch_act_not thread and - valid_objs' and ntfn_at' ntfnptr and pspace_canonical' and - (\s. sch_act_wf (ksSchedulerAction s) s \ - (\d p. thread \ set (ksReadyQueues s (d, p)))) and + "ccorres dc xfdc (tcb_at' thread and sch_act_not thread and valid_objs' and ntfn_at' ntfnptr and + pspace_canonical' and pspace_aligned' and pspace_distinct' and + (\s. sch_act_wf (ksSchedulerAction s) s) and K (ntfnptr = ntfnptr && ~~ mask 4)) UNIV hs (setThreadState (Structures_H.thread_state.BlockedOnNotification @@ -6465,7 +6423,7 @@ lemma receiveSignal_block_ccorres_helper: apply ceqv apply clarsimp apply ctac - apply (wp threadSet_valid_queues hoare_vcg_all_lift threadSet_valid_objs' + apply (wp hoare_vcg_all_lift threadSet_valid_objs' threadSet_weak_sch_act_wf_runnable') apply (clarsimp simp: guard_is_UNIV_def) apply (auto simp: weak_sch_act_wf_def valid_tcb'_def tcb_cte_cases_def @@ -6584,37 +6542,34 @@ lemma receiveSignal_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cendpoint_relation_ntfn_queue, assumption+) + apply (simp add: isWaitingNtfn_def) apply simp - apply (rule cendpoint_relation_ntfn_queue, assumption+) - apply (simp add: isWaitingNtfn_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def) - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn', assumption+) - apply (case_tac "ntfn", simp_all)[1] - apply (clarsimp simp: cnotification_relation_def Let_def - mask_def [where n=3] NtfnState_Waiting_def) - subgoal - apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask valid_ntfn'_def - dest: tcb_queue_relation_next_not_NULL) - apply (rule conjI, fastforce simp: mask_def) - apply (rule context_conjI) - subgoal by (fastforce simp: valid_pspace'_def objBits_simps' - intro!: tcb_ptr_canonical - dest!: st_tcb_strg'[rule_format]) - by clarsimp - apply (simp add: isWaitingNtfn_def) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - subgoal by (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def) + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn', assumption+) + apply (case_tac "ntfn", simp_all)[1] + apply (clarsimp simp: cnotification_relation_def Let_def + mask_def [where n=3] NtfnState_Waiting_def) + subgoal + apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask valid_ntfn'_def + dest: tcb_queue_relation_next_not_NULL) + apply (rule conjI, fastforce simp: mask_def) + apply (rule context_conjI) + subgoal by (fastforce simp: valid_pspace'_def objBits_simps' + intro!: tcb_ptr_canonical + dest!: st_tcb_strg'[rule_format]) + by clarsimp + apply (simp add: isWaitingNtfn_def) apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -6631,47 +6586,44 @@ lemma receiveSignal_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cendpoint_relation_ntfn_queue, assumption+) + apply (simp add: isWaitingNtfn_def) apply simp - apply (rule cendpoint_relation_ntfn_queue, assumption+) - apply (simp add: isWaitingNtfn_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def) - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn', assumption+) - apply (case_tac "ntfn", simp_all)[1] - apply (clarsimp simp: cnotification_relation_def Let_def - mask_def [where n=3] NtfnState_Waiting_def - split: if_split) - subgoal for _ _ ko' - apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask - dest: tcb_queue_relation_next_not_NULL) - apply (rule conjI, clarsimp) - apply (rule conjI, fastforce simp: mask_def) - apply (rule context_conjI) - subgoal by (fastforce intro!: tcb_ptr_canonical - dest!: st_tcb_strg'[rule_format]) - apply clarsimp - apply clarsimp + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def) + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn', assumption+) + apply (case_tac "ntfn", simp_all)[1] + apply (clarsimp simp: cnotification_relation_def Let_def + mask_def [where n=3] NtfnState_Waiting_def + split: if_split) + subgoal for _ _ ko' + apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask + dest: tcb_queue_relation_next_not_NULL) + apply (rule conjI, clarsimp) apply (rule conjI, fastforce simp: mask_def) - apply (rule conjI) + apply (rule context_conjI) subgoal by (fastforce intro!: tcb_ptr_canonical dest!: st_tcb_strg'[rule_format]) - apply (subgoal_tac "canonical_address (ntfnQueue_head_CL (notification_lift ko'))") - apply (clarsimp simp: canonical_make_canonical_idem) - apply (clarsimp simp: notification_lift_def canonical_address_mask_eq canonical_bit_def) - done - apply (simp add: isWaitingNtfn_def) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply clarsimp + apply clarsimp + apply (rule conjI, fastforce simp: mask_def) + apply (rule conjI) + subgoal by (fastforce intro!: tcb_ptr_canonical + dest!: st_tcb_strg'[rule_format]) + apply (subgoal_tac "canonical_address (ntfnQueue_head_CL (notification_lift ko'))") + apply (clarsimp simp: canonical_make_canonical_idem) + apply (clarsimp simp: notification_lift_def canonical_address_mask_eq canonical_bit_def) + done + apply (simp add: isWaitingNtfn_def) apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -6683,7 +6635,6 @@ lemma receiveSignal_enqueue_ccorres_helper: lemma receiveSignal_ccorres [corres]: "ccorres dc xfdc (invs' and valid_cap' cap and st_tcb_at' simple' thread and sch_act_not thread - and (\s. \d p. thread \ set (ksReadyQueues s (d, p))) and K (isNotificationCap cap)) (UNIV \ \\thread = tcb_ptr_to_ctcb_ptr thread\ \ \ccap_relation cap \cap\ diff --git a/proof/crefine/AARCH64/IsolatedThreadAction.thy b/proof/crefine/AARCH64/IsolatedThreadAction.thy index 528b57802e..9bcadc156e 100644 --- a/proof/crefine/AARCH64/IsolatedThreadAction.thy +++ b/proof/crefine/AARCH64/IsolatedThreadAction.thy @@ -68,12 +68,11 @@ lemma put_tcb_state_regs_twice[simp]: "put_tcb_state_regs tsr (put_tcb_state_regs tsr' tcb) = put_tcb_state_regs tsr tcb" apply (simp add: put_tcb_state_regs_def put_tcb_state_regs_tcb_def - atcbContextSet_def - makeObject_tcb newArchTCB_def newContext_def initContext_def + makeObject_tcb newArchTCB_def split: tcb_state_regs.split option.split Structures_H.kernel_object.split) - apply (intro all_tcbI impI allI) - apply (case_tac q, simp) + using atcbContextSet_def atcbContext_set_set + apply (intro all_tcbI impI allI conjI; simp) done lemma partial_overwrite_twice[simp]: @@ -1269,9 +1268,12 @@ lemma oblivious_switchToThread_schact: threadSet_def tcbSchedEnqueue_def unless_when asUser_def getQueue_def setQueue_def storeWordUser_def setRegister_def pointerInUserData_def isRunnable_def isStopped_def - getThreadState_def tcbSchedDequeue_def bitmap_fun_defs) + getThreadState_def tcbSchedDequeue_def bitmap_fun_defs + getThreadState_def tcbSchedDequeue_def tcbQueueRemove_def bitmap_fun_defs + ksReadyQueues_asrt_def) by (safe intro!: oblivious_bind - | simp_all add: oblivious_setVMRoot_schact oblivious_vcpuSwitch_schact)+ + | simp_all add: ready_qs_runnable_def idleThreadNotQueued_def + oblivious_setVMRoot_schact oblivious_vcpuSwitch_schact)+ (* FIXME move *) lemma empty_fail_getCurThread[intro!, wp, simp]: @@ -1311,9 +1313,7 @@ lemma tcbSchedEnqueue_tcbPriority[wp]: done crunch obj_at_prio[wp]: cteDeleteOne "obj_at' (\tcb. P (tcbPriority tcb)) t" - (wp: crunch_wps setEndpoint_obj_at'_tcb - setThreadState_obj_at_unchanged setNotification_tcb setBoundNotification_obj_at_unchanged - simp: crunch_simps unless_def) + (wp: crunch_wps setEndpoint_obj_at'_tcb setNotification_tcb simp: crunch_simps unless_def) lemma setThreadState_no_sch_change: "\\s. P (ksSchedulerAction s) \ (runnable' st \ t \ ksCurThread s)\ @@ -1432,8 +1432,6 @@ lemma setCTE_assert_modify: apply (rule word_and_le2) apply (simp add: objBits_simps mask_def field_simps) apply (simp add: simpler_modify_def cong: option.case_cong if_cong) - apply (rule kernel_state.fold_congs[OF refl refl]) - apply (clarsimp simp: projectKO_opt_tcb cong: if_cong) apply (clarsimp simp: lookupAround2_char1 word_and_le2) apply (rule ccontr, clarsimp) apply (erule(2) ps_clearD) @@ -1450,7 +1448,7 @@ lemma setCTE_assert_modify: apply (erule disjE) apply clarsimp apply (frule(1) tcb_cte_cases_aligned_helpers) - apply (clarsimp simp: domI[where m = cte_cte_cases] field_simps) + apply (clarsimp simp: domI field_simps) apply (clarsimp simp: lookupAround2_char1 obj_at'_def projectKOs objBits_simps) apply (clarsimp simp: obj_at'_def lookupAround2_char1 @@ -1572,11 +1570,14 @@ lemma thread_actions_isolatableD: lemma tcbSchedDequeue_rewrite: "monadic_rewrite True True (obj_at' (Not \ tcbQueued) t) (tcbSchedDequeue t) (return ())" apply (simp add: tcbSchedDequeue_def) - apply (wp_pre, monadic_rewrite_symb_exec_l_known False, simp) - apply (rule monadic_rewrite_refl) - apply (wpsimp wp: threadGet_const)+ + apply wp_pre + apply monadic_rewrite_symb_exec_l + apply (monadic_rewrite_symb_exec_l_known False, simp) + apply (rule monadic_rewrite_refl) + apply (wpsimp wp: threadGet_const)+ done +(* FIXME: improve automation here *) lemma switchToThread_rewrite: "monadic_rewrite True True (ct_in_state' (Not \ runnable') and cur_tcb' and obj_at' (Not \ tcbQueued) t) @@ -1584,7 +1585,9 @@ lemma switchToThread_rewrite: (do Arch.switchToThread t; setCurThread t od)" apply (simp add: switchToThread_def Thread_H.switchToThread_def) apply (monadic_rewrite_l tcbSchedDequeue_rewrite, simp) - apply (rule monadic_rewrite_refl) + (* strip LHS of getters and asserts until LHS and RHS are the same *) + apply (repeat_unless \rule monadic_rewrite_refl\ monadic_rewrite_symb_exec_l) + apply wpsimp+ apply (clarsimp simp: comp_def) done @@ -1626,9 +1629,33 @@ lemma switchToThread_isolatable: split: tcb_state_regs.split)+ done +lemma tcbQueued_put_tcb_state_regs_tcb: + "tcbQueued (put_tcb_state_regs_tcb tsr tcb) = tcbQueued tcb" + apply (clarsimp simp: put_tcb_state_regs_tcb_def) + by (cases tsr; clarsimp) + +lemma idleThreadNotQueued_isolatable: + "thread_actions_isolatable idx (stateAssert idleThreadNotQueued [])" + apply (simp add: stateAssert_def2 stateAssert_def) + apply (intro thread_actions_isolatable_bind[OF _ _ hoare_pre(1)] + gets_isolatable + thread_actions_isolatable_if + thread_actions_isolatable_returns + thread_actions_isolatable_fail) + unfolding idleThreadNotQueued_def + apply (clarsimp simp: obj_at_partial_overwrite_If) + apply (clarsimp simp: obj_at'_def tcbQueued_put_tcb_state_regs_tcb) + apply wpsimp+ + done + lemma setCurThread_isolatable: "thread_actions_isolatable idx (setCurThread t)" - by (simp add: setCurThread_def modify_isolatable) + unfolding setCurThread_def + apply (rule thread_actions_isolatable_bind) + apply (rule idleThreadNotQueued_isolatable) + apply (fastforce intro: modify_isolatable) + apply wpsimp + done lemma isolate_thread_actions_tcbs_at: assumes f: "\x. \tcb_at' (idx x)\ f \\rv. tcb_at' (idx x)\" shows diff --git a/proof/crefine/AARCH64/Recycle_C.thy b/proof/crefine/AARCH64/Recycle_C.thy index 777bfd491b..ce0e81ca3d 100644 --- a/proof/crefine/AARCH64/Recycle_C.thy +++ b/proof/crefine/AARCH64/Recycle_C.thy @@ -754,16 +754,6 @@ lemma cnotification_relation_q_cong: apply (auto intro: iffD1[OF tcb_queue_relation'_cong[OF refl refl refl]]) done -lemma tcbSchedEnqueue_ep_at: - "\obj_at' (P :: endpoint \ bool) ep\ - tcbSchedEnqueue t - \\rv. obj_at' P ep\" - including no_pre - apply (simp add: tcbSchedEnqueue_def unless_def null_def) - apply (wp threadGet_wp, clarsimp, wp+) - apply (clarsimp split: if_split, wp) - done - lemma ccorres_duplicate_guard: "ccorres r xf (P and P) Q hs f f' \ ccorres r xf P Q hs f f'" by (erule ccorres_guard_imp, auto) @@ -786,10 +776,11 @@ lemma cancelBadgedSends_ccorres: (UNIV \ {s. epptr_' s = Ptr ptr} \ {s. badge_' s = bdg}) [] (cancelBadgedSends ptr bdg) (Call cancelBadgedSends_'proc)" apply (cinit lift: epptr_' badge_' simp: whileAnno_def) + apply (rule ccorres_stateAssert) apply (simp add: list_case_return cong: list.case_cong Structures_H.endpoint.case_cong call_ignore_cong del: Collect_const) - apply (rule ccorres_pre_getEndpoint) + apply (rule ccorres_pre_getEndpoint, rename_tac ep) apply (rule_tac R="ko_at' ep ptr" and xf'="ret__unsigned_longlong_'" and val="case ep of RecvEP q \ scast EPState_Recv | IdleEP \ scast EPState_Idle | SendEP q \ scast EPState_Send" @@ -838,9 +829,9 @@ lemma cancelBadgedSends_ccorres: st_tcb_at' (\st. isBlockedOnSend st \ blockingObject st = ptr) x s) \ distinct (xs @ list) \ ko_at' IdleEP ptr s \ (\p. \x \ set (xs @ list). \rf. (x, rf) \ {r \ state_refs_of' s p. snd r \ NTFNBound}) - \ valid_queues s \ pspace_aligned' s \ pspace_distinct' s + \ pspace_aligned' s \ pspace_distinct' s \ pspace_canonical' s \ sch_act_wf (ksSchedulerAction s) s \ valid_objs' s - \ pspace_canonical' s" + \ ksReadyQueues_head_end s \ ksReadyQueues_head_end_tcb_at' s" and P'="\xs. {s. ep_queue_relation' (cslift s) (xs @ list) (head_C (queue_' s)) (end_C (queue_' s))} \ {s. thread_' s = (case list of [] \ tcb_Ptr 0 @@ -941,8 +932,9 @@ lemma cancelBadgedSends_ccorres: apply (rule_tac rrel=dc and xf=xfdc and P="\s. (\t \ set (x @ a # lista). tcb_at' t s) \ (\p. \t \ set (x @ a # lista). \rf. (t, rf) \ {r \ state_refs_of' s p. snd r \ NTFNBound}) - \ valid_queues s \ distinct (x @ a # lista) - \ pspace_aligned' s \ pspace_distinct' s" + \ distinct (x @ a # lista) + \ pspace_aligned' s \ pspace_distinct' s + \ ksReadyQueues_head_end s \ ksReadyQueues_head_end_tcb_at' s" and P'="{s. ep_queue_relation' (cslift s) (x @ a # lista) (head_C (queue_' s)) (end_C (queue_' s))}" in ccorres_from_vcg) @@ -958,8 +950,7 @@ lemma cancelBadgedSends_ccorres: apply (clarsimp simp: return_def rf_sr_def cstate_relation_def Let_def) apply (rule conjI) apply (clarsimp simp: cpspace_relation_def) - apply (rule conjI, erule ctcb_relation_null_queue_ptrs) - apply (rule null_ep_queue) + apply (rule conjI, erule ctcb_relation_null_ep_ptrs) subgoal by (simp add: o_def) apply (rule conjI) apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) @@ -982,9 +973,6 @@ lemma cancelBadgedSends_ccorres: apply (clarsimp simp: image_iff) apply (drule_tac x=p in spec) subgoal by fastforce - apply (rule conjI) - apply (erule cready_queues_relation_not_queue_ptrs, - auto dest: null_ep_schedD[unfolded o_def] simp: o_def)[1] apply (clarsimp simp: carch_state_relation_def cmachine_state_relation_def) apply (rule ccorres_symb_exec_r2) apply (erule spec) @@ -993,12 +981,11 @@ lemma cancelBadgedSends_ccorres: apply wp apply simp apply vcg - apply (wp hoare_vcg_const_Ball_lift tcbSchedEnqueue_ep_at - sch_act_wf_lift) + apply (wp hoare_vcg_const_Ball_lift sch_act_wf_lift) apply simp apply (vcg exspec=tcbSchedEnqueue_cslift_spec) apply (wp hoare_vcg_const_Ball_lift sts_st_tcb_at'_cases - sts_sch_act sts_valid_queues setThreadState_oa_queued) + sts_sch_act sts_valid_objs') apply (vcg exspec=setThreadState_cslift_spec) apply (simp add: ccorres_cond_iffs) apply (rule ccorres_symb_exec_r2) @@ -1021,14 +1008,11 @@ lemma cancelBadgedSends_ccorres: apply (clarsimp simp: cscheduler_action_relation_def st_tcb_at'_def split: scheduler_action.split_asm) apply (rename_tac word) - apply (frule_tac x=word in tcbSchedEnqueue_cslift_precond_discharge) - apply simp - subgoal by clarsimp - subgoal by clarsimp + apply (frule_tac x=word in tcbSchedEnqueue_cslift_precond_discharge; simp?) subgoal by clarsimp apply clarsimp apply (rule conjI) - apply (frule(3) tcbSchedEnqueue_cslift_precond_discharge) + apply (frule tcbSchedEnqueue_cslift_precond_discharge; simp?) subgoal by clarsimp apply clarsimp apply (rule context_conjI) @@ -1068,9 +1052,19 @@ lemma cancelBadgedSends_ccorres: apply (clarsimp split: if_split) apply (drule sym_refsD, clarsimp) apply (drule(1) bspec)+ - by (auto simp: obj_at'_def projectKOs state_refs_of'_def pred_tcb_at'_def tcb_bound_refs'_def - dest!: symreftype_inverse') - + apply (frule ksReadyQueues_asrt_ksReadyQueues_head_end) + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (frule (2) ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at') + apply (fastforce simp: obj_at'_def projectKOs state_refs_of'_def pred_tcb_at'_def + tcb_bound_refs'_def + dest!: symreftype_inverse') + apply (frule ksReadyQueues_asrt_ksReadyQueues_head_end) + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (frule (2) ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at') + apply fastforce + done lemma tcb_ptr_to_ctcb_ptr_force_fold: "x + 2 ^ ctcb_size_bits = ptr_val (tcb_ptr_to_ctcb_ptr x)" diff --git a/proof/crefine/AARCH64/Refine_C.thy b/proof/crefine/AARCH64/Refine_C.thy index 5650fe6b15..22686e0565 100644 --- a/proof/crefine/AARCH64/Refine_C.thy +++ b/proof/crefine/AARCH64/Refine_C.thy @@ -90,7 +90,7 @@ proof - apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply simp apply vcg apply vcg @@ -104,14 +104,12 @@ proof - apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply simp apply (rule_tac Q="\rv s. invs' s \ (\x. rv = Some x \ x \ AARCH64.maxIRQ) \ rv \ Some 0x3FF \ - sch_act_not (ksCurThread s) s \ - (\p. ksCurThread s \ set (ksReadyQueues s p))" in hoare_post_imp) + sch_act_not (ksCurThread s) s" in hoare_post_imp) apply (clarsimp simp: Kernel_C.maxIRQ_def AARCH64.maxIRQ_def) apply (wp getActiveIRQ_le_maxIRQ getActiveIRQ_neq_Some0xFF | simp)+ - apply (clarsimp simp: ct_not_ksQ) apply (clarsimp simp: invs'_def valid_state'_def) done qed @@ -137,14 +135,12 @@ lemma handleUnknownSyscall_ccorres: apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (clarsimp, vcg) apply (clarsimp, rule conseqPre, vcg, clarsimp) apply clarsimp apply (intro impI conjI allI) - apply fastforce - apply (clarsimp simp: ct_not_ksQ) - apply (clarsimp simp add: sch_act_simple_def split: scheduler_action.split) + apply fastforce apply (rule active_ex_cap') apply (erule active_from_running') apply (erule invs_iflive') @@ -195,13 +191,13 @@ lemma handleVMFaultEvent_ccorres: apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (case_tac x, clarsimp, wp) apply (clarsimp, wp, simp) apply wp apply (simp add: guard_is_UNIV_def) apply (clarsimp simp: simple_sane_strg[unfolded sch_act_sane_not]) - apply (auto simp: ct_in_state'_def cfault_rel_def is_cap_fault_def ct_not_ksQ + apply (auto simp: ct_in_state'_def cfault_rel_def is_cap_fault_def elim: pred_tcb'_weakenE st_tcb_ex_cap'' dest: st_tcb_at_idle_thread' rf_sr_ksCurThread) done @@ -227,16 +223,14 @@ lemma handleUserLevelFault_ccorres: apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (clarsimp, vcg) apply (clarsimp, rule conseqPre, vcg, clarsimp) apply clarsimp apply (intro impI conjI allI) - apply (simp add: ct_in_state'_def) - apply (erule pred_tcb'_weakenE) - apply simp - apply (clarsimp simp: ct_not_ksQ) - apply (clarsimp simp add: sch_act_simple_def split: scheduler_action.split) + apply (simp add: ct_in_state'_def) + apply (erule pred_tcb'_weakenE) + apply simp apply (rule active_ex_cap') apply (erule active_from_running') apply (erule invs_iflive') @@ -403,11 +397,10 @@ lemma handleSyscall_ccorres: apply wp[1] apply clarsimp apply wp - apply (rule_tac Q="\rv s. ct_in_state' simple' s \ sch_act_sane s \ - (\p. ksCurThread s \ set (ksReadyQueues s p))" + apply (rule_tac Q="\rv s. ct_in_state' simple' s \ sch_act_sane s" in hoare_post_imp) apply (simp add: ct_in_state'_def) - apply (wp handleReply_sane handleReply_ct_not_ksQ) + apply (wp handleReply_sane) \ \SysYield\ apply (clarsimp simp: syscall_from_H_def syscall_defs) apply (rule ccorres_cond_empty |rule ccorres_cond_univ)+ @@ -433,14 +426,14 @@ lemma handleSyscall_ccorres: apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg_throws) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) - apply (wp schedule_invs' schedule_sch_act_wf | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + apply (wp schedule_invs' schedule_sch_act_wf + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (wpsimp wp: hoare_vcg_if_lift3) apply (strengthen non_kernel_IRQs_strg[where Q=True, simplified]) apply (wpsimp wp: hoare_drop_imps) apply (simp | wpc | wp hoare_drop_imp handleReply_sane handleReply_nonz_cap_to_ct schedule_invs' - handleReply_ct_not_ksQ[simplified] | strengthen ct_active_not_idle'_strengthen invs_valid_objs_strengthen)+ apply (rule_tac Q="\rv. invs' and ct_active'" in hoare_post_imp, simp) apply (wp hy_invs') @@ -458,7 +451,7 @@ lemma handleSyscall_ccorres: apply (frule active_ex_cap') apply (clarsimp simp: invs'_def valid_state'_def) apply (clarsimp simp: simple_sane_strg ct_in_state'_def st_tcb_at'_def obj_at'_def - isReply_def ct_not_ksQ irqInvalid_def irqInvalid_def) + isReply_def irqInvalid_def) apply (auto simp: syscall_from_H_def Kernel_C.SysSend_def mask_def split: option.split_asm) done @@ -552,23 +545,20 @@ lemma handleUserLevelFault_ccorres': apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (clarsimp, vcg) apply (clarsimp, rule conseqPre, vcg, clarsimp) apply clarsimp apply (intro impI conjI allI) - apply (simp add: ct_in_state'_def) - apply (erule pred_tcb'_weakenE) - apply simp - apply (clarsimp simp: ct_not_ksQ) - apply (clarsimp simp add: sch_act_simple_def split: scheduler_action.split) + apply (simp add: ct_in_state'_def) + apply (erule pred_tcb'_weakenE) + apply simp apply (rule active_ex_cap') apply (erule active_from_running') apply (erule invs_iflive') apply (clarsimp simp: ct_in_state'_def) apply (frule st_tcb_idle'[rotated]) apply (erule invs_valid_idle') - apply simp apply (clarsimp simp: cfault_rel_def seL4_Fault_UserException_lift) apply (simp add: is_cap_fault_def) done @@ -770,12 +760,13 @@ lemma handleVCPUFault_ccorres: apply (ctac (no_vcg) add: activateThread_ccorres) apply (clarsimp, assumption) apply assumption - apply (wp schedule_sch_act_wf schedule_invs'|strengthen invs_queues invs_valid_objs')+ + apply (wp schedule_sch_act_wf schedule_invs' + | strengthen invs_valid_objs' invs_pspace_aligned' invs_pspace_distinct')+ apply vcg apply (clarsimp, rule conseqPre, vcg) apply clarsimp apply wpsimp - apply (clarsimp simp: ct_not_ksQ ct_running_imp_simple' ucast_and_mask_drop) + apply (clarsimp simp: ct_running_imp_simple' ucast_and_mask_drop) apply (clarsimp simp: cfault_rel_def seL4_Fault_VCPUFault_lift is_cap_fault_def) apply (subst (asm) up_ucast_inj_eq[symmetric, where 'b=machine_word_len]; simp) apply (rule active_ex_cap', erule active_from_running', fastforce) @@ -903,6 +894,7 @@ lemma callKernel_withFastpath_corres_C: apply (clarsimp simp: typ_heap_simps' ct_in_state'_def "StrictC'_register_defs" word_sle_def word_sless_def st_tcb_at'_opeq_simp) + apply (frule ready_qs_runnable_cross, (fastforce simp: valid_sched_def)+) apply (rule conjI, fastforce simp: st_tcb_at'_def) apply (auto elim!: pred_tcb'_weakenE cnode_caps_gsCNodes_from_sr[rotated]) done @@ -927,7 +919,7 @@ lemma threadSet_all_invs_triv': apply (wp thread_set_invs_trivial thread_set_ct_running thread_set_not_state_valid_sched threadSet_invs_trivial threadSet_ct_running' hoare_weak_lift_imp thread_set_ct_in_state - | simp add: tcb_cap_cases_def tcb_arch_ref_def + | simp add: tcb_cap_cases_def tcb_arch_ref_def exst_same_def | rule threadSet_ct_in_state' | wp (once) hoare_vcg_disj_lift)+ apply clarsimp @@ -1145,17 +1137,22 @@ lemma dmo_domain_user_mem'[wp]: done lemma do_user_op_corres_C: - "corres_underlying rf_sr False False (=) (invs' and ex_abs einvs) \ - (doUserOp f tc) (doUserOp_C f tc)" + "corres_underlying rf_sr False False (=) + (invs' and ksReadyQueues_asrt and ex_abs einvs) \ + (doUserOp f tc) (doUserOp_C f tc)" apply (simp only: doUserOp_C_def doUserOp_def split_def) apply (rule corres_guard_imp) apply (rule_tac P=\ and P'=\ and r'="(=)" in corres_split) apply (clarsimp simp: simpler_gets_def getCurThread_def corres_underlying_def rf_sr_def cstate_relation_def Let_def) - apply (rule_tac P=valid_state' and P'=\ and r'="(=)" in corres_split) + apply (rule_tac P="valid_state' and ksReadyQueues_asrt" + and P'=\ and r'="(=)" + in corres_split) apply (clarsimp simp: cstate_to_A_def absKState_def rf_sr_def cstate_to_H_correct ptable_lift_def) - apply (rule_tac P=valid_state' and P'=\ and r'="(=)" in corres_split) + apply (rule_tac P="valid_state' and ksReadyQueues_asrt" + and P'=\ and r'="(=)" + in corres_split) apply (clarsimp simp: cstate_to_A_def absKState_def rf_sr_def cstate_to_H_correct ptable_rights_def) apply (rule_tac P=pspace_distinct' and P'=\ and r'="(=)" @@ -1253,6 +1250,9 @@ lemma refinement2_both: apply (subst cstate_to_H_correct) apply (fastforce simp: full_invs'_def invs'_def) apply (clarsimp simp: rf_sr_def) + apply (clarsimp simp: lift_state_relation_def full_invs_def) + apply (rule ksReadyQueues_asrt_cross) + apply (erule state_relation_ready_queues_relation) apply (simp add:absKState_def observable_memory_def absExst_def) apply (rule MachineTypes.machine_state.equality,simp_all)[1] apply (rule ext) @@ -1279,13 +1279,35 @@ lemma refinement2_both: apply (clarsimp simp add: do_user_op_C_def do_user_op_H_def monad_to_transition_def) apply (rule rev_mp, rule_tac f="uop" and tc=af in do_user_op_corres_C) apply (clarsimp simp: corres_underlying_def invs_def ex_abs_def) - apply (fastforce simp: full_invs'_def ex_abs_def) + apply (drule bspec) + apply fastforce + apply clarsimp + apply (elim impE) + apply (clarsimp simp: full_invs'_def ex_abs_def) + apply (intro conjI) + apply (rule ksReadyQueues_asrt_cross) + apply (erule state_relation_ready_queues_relation) + apply (clarsimp simp: lift_state_relation_def full_invs_def) + apply (frule state_relation_ready_queues_relation) + apply (fastforce simp: ready_queues_relation_def Let_def tcbQueueEmpty_def) + apply fastforce apply (erule_tac P="a \ b \ c \ (\x. e x)" for a b c d e in disjE) apply (clarsimp simp add: do_user_op_C_def do_user_op_H_def monad_to_transition_def) apply (rule rev_mp, rule_tac f="uop" and tc=af in do_user_op_corres_C) apply (clarsimp simp: corres_underlying_def invs_def ex_abs_def) - apply (fastforce simp: full_invs'_def ex_abs_def) + apply (drule bspec) + apply fastforce + apply clarsimp + apply (elim impE) + apply (clarsimp simp: full_invs'_def ex_abs_def) + apply (intro conjI) + apply (rule ksReadyQueues_asrt_cross) + apply (erule state_relation_ready_queues_relation) + apply (clarsimp simp: lift_state_relation_def full_invs_def) + apply (frule state_relation_ready_queues_relation) + apply (fastforce simp: ready_queues_relation_def Let_def tcbQueueEmpty_def) + apply fastforce apply (clarsimp simp: check_active_irq_C_def check_active_irq_H_def) apply (rule rev_mp, rule check_active_irq_corres_C) diff --git a/proof/crefine/AARCH64/Retype_C.thy b/proof/crefine/AARCH64/Retype_C.thy index 113b78b271..c87b58ccef 100644 --- a/proof/crefine/AARCH64/Retype_C.thy +++ b/proof/crefine/AARCH64/Retype_C.thy @@ -3116,7 +3116,6 @@ lemma cnc_tcb_helper: assumes rfsr: "(\\ksPSpace := ks\, x) \ rf_sr" assumes al: "is_aligned (ctcb_ptr_to_tcb_ptr p) (objBitsKO kotcb)" assumes ptr0: "ctcb_ptr_to_tcb_ptr p \ 0" - assumes vq: "valid_queues \" assumes pal: "pspace_aligned' (\\ksPSpace := ks\)" assumes pno: "pspace_no_overlap' (ctcb_ptr_to_tcb_ptr p) (objBitsKO kotcb) (\\ksPSpace := ks\)" assumes pds: "pspace_distinct' (\\ksPSpace := ks\)" @@ -3486,21 +3485,21 @@ proof - unfolding ctcb_relation_def makeObject_tcb heap_updates_defs initContext_registers_def apply (simp add: fbtcb minBound_word) apply (intro conjI) - apply (simp add: cthread_state_relation_def thread_state_lift_def - eval_nat_numeral ThreadState_defs) - apply (clarsimp simp: ccontext_relation_def newContext_def2 carch_tcb_relation_def - newArchTCB_def fpu_relation_def cregs_relation_def atcbContextGet_def - index_foldr_update) - apply (case_tac r; simp add: C_register_defs index_foldr_update - atcbContext_def newArchTCB_def newContext_def - initContext_def) - apply clarsimp - apply (simp add: thread_state_lift_def index_foldr_update atcbContextGet_def) - apply (simp add: Kernel_Config.timeSlice_def) - apply (simp add: cfault_rel_def seL4_Fault_lift_def seL4_Fault_get_tag_def Let_def - lookup_fault_lift_def lookup_fault_get_tag_def lookup_fault_invalid_root_def - index_foldr_update seL4_Fault_NullFault_def option_to_ptr_def option_to_0_def - split: if_split)+ + apply (simp add: cthread_state_relation_def thread_state_lift_def + eval_nat_numeral ThreadState_defs) + apply (clarsimp simp: ccontext_relation_def newContext_def2 carch_tcb_relation_def + newArchTCB_def fpu_relation_def cregs_relation_def atcbContextGet_def + index_foldr_update) + apply (case_tac r; simp add: C_register_defs index_foldr_update + atcbContext_def newArchTCB_def newContext_def + initContext_def) + apply (simp add: thread_state_lift_def index_foldr_update atcbContextGet_def) + apply (simp add: Kernel_Config.timeSlice_def) + apply (simp add: cfault_rel_def seL4_Fault_lift_def seL4_Fault_get_tag_def Let_def + lookup_fault_lift_def lookup_fault_get_tag_def lookup_fault_invalid_root_def + index_foldr_update seL4_Fault_NullFault_def option_to_ptr_def option_to_0_def + split: if_split)+ + apply (simp add: option_to_ctcb_ptr_def) done have pks: "ks (ctcb_ptr_to_tcb_ptr p) = None" @@ -3551,15 +3550,6 @@ proof - apply (fastforce simp: dom_def) done - hence kstcb: "\qdom prio. ctcb_ptr_to_tcb_ptr p \ set (ksReadyQueues \ (qdom, prio))" using vq - apply (clarsimp simp add: valid_queues_def valid_queues_no_bitmap_def) - apply (drule_tac x = qdom in spec) - apply (drule_tac x = prio in spec) - apply clarsimp - apply (drule (1) bspec) - apply (simp add: obj_at'_def) - done - have ball_subsetE: "\P S R. \ \x \ S. P x; R \ S \ \ \x \ R. P x" by blast @@ -3701,7 +3691,7 @@ proof - apply (simp add: cl_cte [simplified] cl_tcb [simplified] cl_rest [simplified] tag_disj_via_td_name) apply (clarsimp simp: cready_queues_relation_def Let_def htd_safe[simplified] kernel_data_refs_domain_eq_rotate) - apply (simp add: heap_updates_def kstcb tcb_queue_update_other' hrs_htd_update + apply (simp add: heap_updates_def tcb_queue_update_other' hrs_htd_update ptr_retyp_to_array[simplified] irq[simplified]) done qed @@ -4696,7 +4686,8 @@ lemma Arch_initContext_spec': lemma ccorres_placeNewObject_tcb: "ccorresG rf_sr \ dc xfdc - (pspace_aligned' and pspace_distinct' and pspace_no_overlap' regionBase tcbBlockSizeBits and valid_queues and (\s. sym_refs (state_refs_of' s)) + (pspace_aligned' and pspace_distinct' and pspace_no_overlap' regionBase tcbBlockSizeBits + and (\s. sym_refs (state_refs_of' s)) and (\s. 2 ^ tcbBlockSizeBits \ gsMaxObjectSize s) and ret_zero regionBase (2 ^ tcbBlockSizeBits) and K (regionBase \ 0 \ range_cover regionBase tcbBlockSizeBits tcbBlockSizeBits 1 @@ -5014,7 +5005,7 @@ qed lemma placeNewObject_user_data: "ccorresG rf_sr \ dc xfdc (pspace_aligned' and pspace_distinct' and pspace_no_overlap' regionBase (pageBits+us) - and valid_queues and valid_machine_state' + and valid_machine_state' and ret_zero regionBase (2 ^ (pageBits+us)) and (\s. sym_refs (state_refs_of' s)) and (\s. 2^(pageBits + us) \ gsMaxObjectSize s) @@ -5153,7 +5144,7 @@ lemma placeNewObject_user_data_device: "ccorresG rf_sr \ dc xfdc (pspace_aligned' and pspace_distinct' and ret_zero regionBase (2 ^ (pageBits + us)) - and pspace_no_overlap' regionBase (pageBits+us) and valid_queues + and pspace_no_overlap' regionBase (pageBits+us) and (\s. sym_refs (state_refs_of' s)) and (\s. 2^(pageBits + us) \ gsMaxObjectSize s) and K (regionBase \ 0 \ range_cover regionBase (pageBits + us) (pageBits+us) (Suc 0) @@ -5922,7 +5913,7 @@ subgoal apply clarify apply (intro conjI) apply (clarsimp simp: invs_pspace_aligned' invs_pspace_distinct' invs_valid_global' - APIType_capBits_def invs_queues invs_valid_objs' + APIType_capBits_def invs_valid_objs' invs_urz) apply clarsimp apply (clarsimp simp: ccap_relation_def APIType_capBits_def @@ -6018,7 +6009,7 @@ subgoal apply clarify apply (intro conjI) apply (clarsimp simp: invs_pspace_aligned' invs_pspace_distinct' invs_valid_global' - APIType_capBits_def invs_queues invs_valid_objs' + APIType_capBits_def invs_valid_objs' invs_urz bit_simps) apply clarsimp apply (clarsimp simp: bit_simps ccap_relation_def APIType_capBits_def @@ -6111,15 +6102,11 @@ lemma threadSet_domain_ccorres [corres]: apply (simp add: map_to_ctes_upd_tcb_no_ctes map_to_tcbs_upd tcb_cte_cases_def cteSizeBits_def) apply (simp add: cep_relations_drop_fun_upd cvariable_relation_upd_const ko_at_projectKO_opt) - apply (rule conjI) - apply (drule ko_at_projectKO_opt) - apply (erule (2) cmap_relation_upd_relI) - subgoal by (simp add: ctcb_relation_def) - apply assumption - apply simp - apply (erule cready_queues_relation_not_queue_ptrs) - apply (rule ext, simp split: if_split) - apply (rule ext, simp split: if_split) + apply (drule ko_at_projectKO_opt) + apply (erule (2) cmap_relation_upd_relI) + subgoal by (simp add: ctcb_relation_def) + apply assumption + apply simp done lemma createObject_ccorres: @@ -6247,7 +6234,6 @@ proof - createObject_c_preconds_def) apply (frule invs_pspace_aligned') apply (frule invs_pspace_distinct') - apply (frule invs_queues) apply (frule invs_sym') apply (simp add: getObjectSize_def objBits_simps word_bits_conv apiGetObjectSize_def @@ -6292,7 +6278,6 @@ proof - apply (clarsimp simp: createObject_hs_preconds_def isFrameType_def) apply (frule invs_pspace_aligned') apply (frule invs_pspace_distinct') - apply (frule invs_queues) apply (frule invs_sym') apply (auto simp: getObjectSize_def objBits_simps apiGetObjectSize_def epSizeBits_def word_bits_conv @@ -6330,7 +6315,6 @@ proof - apply (clarsimp simp: createObject_hs_preconds_def isFrameType_def) apply (frule invs_pspace_aligned') apply (frule invs_pspace_distinct') - apply (frule invs_queues) apply (frule invs_sym') apply (auto simp: getObjectSize_def objBits_simps apiGetObjectSize_def @@ -6371,7 +6355,6 @@ proof - apply (clarsimp simp: createObject_hs_preconds_def isFrameType_def) apply (frule invs_pspace_aligned') apply (frule invs_pspace_distinct') - apply (frule invs_queues) apply (frule invs_sym') apply (frule(1) ghost_assertion_size_logic_no_unat) apply (clarsimp simp: getObjectSize_def objBits_simps diff --git a/proof/crefine/AARCH64/SR_lemmas_C.thy b/proof/crefine/AARCH64/SR_lemmas_C.thy index 98ce847f26..6dabdabd1a 100644 --- a/proof/crefine/AARCH64/SR_lemmas_C.thy +++ b/proof/crefine/AARCH64/SR_lemmas_C.thy @@ -411,11 +411,15 @@ lemma cmdbnode_relation_mdb_node_to_H [simp]: unfolding cmdbnode_relation_def mdb_node_to_H_def mdb_node_lift_def cte_lift_def by (fastforce split: option.splits) -definition - tcb_no_ctes_proj :: "tcb \ Structures_H.thread_state \ machine_word \ machine_word \ arch_tcb \ bool \ word8 \ word8 \ word8 \ nat \ fault option \ machine_word option" +definition tcb_no_ctes_proj :: + "tcb \ Structures_H.thread_state \ machine_word \ machine_word \ arch_tcb \ bool \ word8 + \ word8 \ word8 \ nat \ fault option \ machine_word option + \ machine_word option \ machine_word option" where - "tcb_no_ctes_proj t \ (tcbState t, tcbFaultHandler t, tcbIPCBuffer t, tcbArch t, tcbQueued t, - tcbMCP t, tcbPriority t, tcbDomain t, tcbTimeSlice t, tcbFault t, tcbBoundNotification t)" + "tcb_no_ctes_proj t \ + (tcbState t, tcbFaultHandler t, tcbIPCBuffer t, tcbArch t, tcbQueued t, + tcbMCP t, tcbPriority t, tcbDomain t, tcbTimeSlice t, tcbFault t, tcbBoundNotification t, + tcbSchedNext t, tcbSchedPrev t)" lemma tcb_cte_cases_proj_eq [simp]: "tcb_cte_cases p = Some (getF, setF) \ @@ -1551,9 +1555,9 @@ lemma cmap_relation_cong: apply (erule imageI) done -lemma ctcb_relation_null_queue_ptrs: +lemma ctcb_relation_null_ep_ptrs: assumes rel: "cmap_relation mp mp' tcb_ptr_to_ctcb_ptr ctcb_relation" - and same: "map_option tcb_null_queue_ptrs \ mp'' = map_option tcb_null_queue_ptrs \ mp'" + and same: "map_option tcb_null_ep_ptrs \ mp'' = map_option tcb_null_ep_ptrs \ mp'" shows "cmap_relation mp mp'' tcb_ptr_to_ctcb_ptr ctcb_relation" using rel apply (rule iffD1 [OF cmap_relation_cong, OF _ map_option_eq_dom_eq, rotated -1]) @@ -1561,7 +1565,7 @@ lemma ctcb_relation_null_queue_ptrs: apply (rule same [symmetric]) apply (drule compD [OF same]) apply (case_tac b, case_tac b') - apply (simp add: ctcb_relation_def tcb_null_queue_ptrs_def) + apply (simp add: ctcb_relation_def tcb_null_ep_ptrs_def) done lemma map_to_ctes_upd_tcb_no_ctes: @@ -2409,6 +2413,14 @@ lemma capTCBPtr_eq: apply clarsimp done +lemma rf_sr_ctcb_queue_relation: + "\ (s, s') \ rf_sr; d \ maxDomain; p \ maxPriority \ + \ ctcb_queue_relation (ksReadyQueues s (d, p)) + (index (ksReadyQueues_' (globals s')) (cready_queues_index_to_C d p))" + unfolding rf_sr_def cstate_relation_def cready_queues_relation_def + apply (clarsimp simp: Let_def seL4_MinPrio_def minDom_def maxDom_to_H maxPrio_to_H) + done + lemma rf_sr_sched_action_relation: "(s, s') \ rf_sr \ cscheduler_action_relation (ksSchedulerAction s) (ksSchedulerAction_' (globals s'))" @@ -2526,5 +2538,11 @@ lemma physBase_spec: apply (simp add: Kernel_Config.physBase_def) done +lemma rf_sr_obj_update_helper: + "(s, s'\ globals := globals s' \ t_hrs_' := t_hrs_' (globals (undefined + \ globals := (undefined \ t_hrs_' := f (globals s') (t_hrs_' (globals s')) \)\))\\) \ rf_sr + \ (s, globals_update (\v. t_hrs_'_update (f v) v) s') \ rf_sr" + by (simp cong: StateSpace.state.fold_congs globals.fold_congs) + end end diff --git a/proof/crefine/AARCH64/Schedule_C.thy b/proof/crefine/AARCH64/Schedule_C.thy index cad3f5a57b..4f4e7cb8e2 100644 --- a/proof/crefine/AARCH64/Schedule_C.thy +++ b/proof/crefine/AARCH64/Schedule_C.thy @@ -7,7 +7,7 @@ *) theory Schedule_C -imports Tcb_C +imports Tcb_C Detype_C begin instance tcb :: no_vcpu by intro_classes auto @@ -56,15 +56,17 @@ lemma switchToIdleThread_ccorres: "ccorres dc xfdc invs_no_cicd' UNIV hs switchToIdleThread (Call switchToIdleThread_'proc)" apply (cinit) + apply (rule ccorres_stateAssert) apply (rule ccorres_symb_exec_l) apply (ctac (no_vcg) add: Arch_switchToIdleThread_ccorres) apply (simp add: setCurThread_def) + apply (rule ccorres_stateAssert) apply (rule_tac P="\s. thread = ksIdleThread s" and P'=UNIV in ccorres_from_vcg) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: simpler_modify_def) apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def carch_state_relation_def cmachine_state_relation_def) - apply (wpsimp simp: AARCH64_H.switchToIdleThread_def)+ + apply (wpsimp simp: AARCH64_H.switchToIdleThread_def wp: hoare_drop_imps)+ done crunches vcpuSwitch @@ -100,6 +102,26 @@ lemma Arch_switchToThread_ccorres: apply (clarsimp simp: typ_heap_simps ctcb_relation_def carch_tcb_relation_def) done +lemma invs_no_cicd'_pspace_aligned': + "all_invs_but_ct_idle_or_in_cur_domain' s \ pspace_aligned' s" + by (simp add: all_invs_but_ct_idle_or_in_cur_domain'_def valid_pspace'_def) + +lemma invs_no_cicd'_pspace_distinct': + "all_invs_but_ct_idle_or_in_cur_domain' s \ pspace_distinct' s" + by (simp add: all_invs_but_ct_idle_or_in_cur_domain'_def valid_pspace'_def) + +lemma threadGet_exs_valid[wp]: + "tcb_at' t s \ \(=) s\ threadGet f t \\\r. (=) s\" + unfolding threadGet_def liftM_def + apply (wpsimp wp: exs_getObject) + apply (fastforce simp: obj_at'_def objBits_simps')+ + done + +lemma isRunnable_exs_valid[wp]: + "tcb_at' t s \ \(=) s\ isRunnable t \\\r. (=) s\" + unfolding isRunnable_def getThreadState_def + by (wpsimp wp: exs_getObject) + (* FIXME: move *) lemma switchToThread_ccorres: "ccorres dc xfdc @@ -108,23 +130,28 @@ lemma switchToThread_ccorres: hs (switchToThread t) (Call switchToThread_'proc)" - apply (cinit lift: thread_') + apply (clarsimp simp: switchToThread_def) + apply (rule ccorres_symb_exec_l'[OF _ _ isRunnable_sp]; (solves wpsimp)?) + apply (rule ccorres_symb_exec_l'[OF _ _ assert_sp]; (solves wpsimp)?) + apply (rule ccorres_stateAssert_fwd)+ + apply (cinit' lift: thread_') apply (ctac (no_vcg) add: Arch_switchToThread_ccorres) apply (ctac (no_vcg) add: tcbSchedDequeue_ccorres) + apply (simp add: setCurThread_def) + apply (rule ccorres_stateAssert) apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg) apply clarsimp apply (rule conseqPre, vcg) - apply (clarsimp simp: setCurThread_def simpler_modify_def) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def) - apply wp+ - apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def) + apply (clarsimp simp: setCurThread_def simpler_modify_def rf_sr_def cstate_relation_def + Let_def carch_state_relation_def cmachine_state_relation_def) + apply (wpsimp wp: Arch_switchToThread_invs_no_cicd' hoare_drop_imps + | strengthen invs_no_cicd'_pspace_aligned' invs_no_cicd'_pspace_distinct')+ done lemma activateThread_ccorres: "ccorres dc xfdc (ct_in_state' activatable' and (\s. sch_act_wf (ksSchedulerAction s) s) - and valid_queues and valid_objs') + and valid_objs' and pspace_aligned' and pspace_distinct') UNIV [] activateThread (Call activateThread_'proc)" @@ -216,13 +243,42 @@ lemma switchToThread_ccorres': lemmas word_log2_max_word_word_size = word_log2_max[where 'a=machine_word_len, simplified word_size, simplified] +lemma ccorres_pre_getQueue: + assumes cc: "\queue. ccorres r xf (P queue) (P' queue) hs (f queue) c" + shows "ccorres r xf (\s. P (ksReadyQueues s (d, p)) s \ d \ maxDomain \ p \ maxPriority) + {s'. \queue. (let cqueue = index (ksReadyQueues_' (globals s')) + (cready_queues_index_to_C d p) in + ctcb_queue_relation queue cqueue) \ s' \ P' queue} + hs (getQueue d p >>= (\queue. f queue)) c" + apply (rule ccorres_guard_imp2) + apply (rule ccorres_symb_exec_l2) + defer + defer + apply (rule gq_sp) + defer + apply (rule ccorres_guard_imp) + apply (rule cc) + apply clarsimp + apply assumption + apply assumption + apply (clarsimp simp: getQueue_def gets_exs_valid) + apply clarsimp + apply (drule spec, erule mp) + apply (erule rf_sr_ctcb_queue_relation) + apply (simp add: maxDom_to_H maxPrio_to_H)+ + done + lemma chooseThread_ccorres: - "ccorres dc xfdc all_invs_but_ct_idle_or_in_cur_domain' UNIV [] chooseThread (Call chooseThread_'proc)" + "ccorres dc xfdc all_invs_but_ct_idle_or_in_cur_domain' UNIV [] + chooseThread (Call chooseThread_'proc)" proof - note prio_and_dom_limit_helpers [simp] note ksReadyQueuesL2Bitmap_nonzeroI [simp] note Collect_const_mem [simp] + + note prio_and_dom_limit_helpers[simp] word_sle_def[simp] maxDom_to_H[simp] maxPrio_to_H[simp] + note invert_prioToL1Index_c_simp[simp] (* when numDomains = 1, array bounds checks would become _ = 0 rather than _ < 1, changing the shape of the proof compared to when numDomains > 1 *) include no_less_1_simps @@ -231,9 +287,22 @@ proof - "\s. invs_no_cicd' s \ ksCurDomain s \ maxDomain" by (simp add: invs_no_cicd'_def) + have invs_no_cicd'_valid_bitmaps: + "\s. invs_no_cicd' s \ valid_bitmaps s" + by (simp add: invs_no_cicd'_def) + + have invs_no_cicd'_pspace_aligned': + "\s. invs_no_cicd' s \ pspace_aligned' s" + by (simp add: invs_no_cicd'_def valid_pspace'_def) + + have invs_no_cicd'_pspace_distinct': + "\s. invs_no_cicd' s \ pspace_distinct' s" + by (simp add: invs_no_cicd'_def valid_pspace'_def) + show ?thesis supply if_split[split del] apply (cinit) + apply (rule ccorres_stateAssert)+ apply (simp add: numDomains_sge_1_simp) apply (rule_tac xf'=dom_' and r'="\rv rv'. rv' = ucast rv" in ccorres_split_nothrow_novcg) apply (rule ccorres_from_vcg[where P=\ and P'=UNIV]) @@ -266,7 +335,7 @@ proof - apply (rule_tac P="curdom \ maxDomain" in ccorres_cross_over_guard_no_st) apply (rule_tac P="prio \ maxPriority" in ccorres_cross_over_guard_no_st) apply (rule ccorres_pre_getQueue) - apply (rule_tac P="queue \ []" in ccorres_cross_over_guard_no_st) + apply (rule_tac P="\ tcbQueueEmpty queue" in ccorres_cross_over_guard_no_st) apply (rule ccorres_symb_exec_l) apply (rule ccorres_assert) apply (rule ccorres_symb_exec_r) @@ -281,37 +350,40 @@ proof - apply (rule conseqPre, vcg) apply (rule Collect_mono) apply clarsimp - apply (strengthen queue_in_range) apply assumption apply clarsimp apply (rule conseqPre, vcg) apply clarsimp apply (wp isRunnable_wp)+ apply (clarsimp simp: Let_def guard_is_UNIV_def) - apply (drule invs_no_cicd'_queues) - apply (case_tac queue, simp) - apply (clarsimp simp: tcb_queue_relation'_def cready_queues_index_to_C_def numPriorities_def) - apply (clarsimp simp add: maxDom_to_H maxPrio_to_H - queue_in_range[where qdom=0, simplified, simplified maxPrio_to_H]) - apply (clarsimp simp: le_maxDomain_eq_less_numDomains unat_trans_ucast_helper ) + apply (rule conjI) + apply (clarsimp simp: le_maxDomain_eq_less_numDomains unat_trans_ucast_helper) + apply (intro conjI impI) + apply (clarsimp simp: cready_queues_index_to_C_def numPriorities_def ctcb_queue_relation_def + tcbQueueEmpty_def option_to_ctcb_ptr_def) + apply (frule_tac qdom=curdom and prio=rv in cready_queues_index_to_C_in_range) + apply fastforce + apply (clarsimp simp: num_tcb_queues_def word_less_nat_alt cready_queues_index_to_C_def2) apply wpsimp apply (clarsimp simp: guard_is_UNIV_def le_maxDomain_eq_less_numDomains word_less_nat_alt numDomains_less_numeric_explicit) - apply (frule invs_no_cicd'_queues) + apply clarsimp apply (frule invs_no_cicd'_max_CurDomain) - apply (frule invs_no_cicd'_queues) - apply (clarsimp simp: valid_queues_def lookupBitmapPriority_le_maxPriority) + apply (frule invs_no_cicd'_pspace_aligned') + apply (frule invs_no_cicd'_pspace_distinct') + apply (frule invs_no_cicd'_valid_bitmaps) + apply (frule valid_bitmaps_bitmapQ_no_L1_orphans) + apply (frule valid_bitmaps_valid_bitmapQ) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def cong: conj_cong) apply (intro conjI impI) - apply (fastforce dest: bitmapQ_from_bitmap_lookup simp: valid_bitmapQ_bitmapQ_simp) - apply (fastforce dest: lookupBitmapPriority_obj_at' - simp: pred_conj_def obj_at'_def st_tcb_at'_def) - apply (fastforce dest: bitmapQ_from_bitmap_lookup simp: valid_bitmapQ_bitmapQ_simp) - apply (clarsimp simp: pred_conj_def obj_at'_def st_tcb_at'_def) - apply (clarsimp simp: not_less le_maxDomain_eq_less_numDomains) - apply (prop_tac "ksCurDomain s = 0") - using unsigned_eq_0_iff apply force - apply (cut_tac s=s in lookupBitmapPriority_obj_at'; simp?) - apply (clarsimp simp: pred_conj_def obj_at'_def st_tcb_at'_def) + apply (fastforce intro: lookupBitmapPriority_le_maxPriority) + apply (fastforce dest!: bitmapQ_from_bitmap_lookup valid_bitmapQ_bitmapQ_simp) + apply (fastforce dest!: lookupBitmapPriority_obj_at' + simp: ready_queue_relation_def ksReadyQueues_asrt_def st_tcb_at'_def obj_at'_def) + apply (fastforce dest: lookupBitmapPriority_le_maxPriority) + apply (fastforce dest!: bitmapQ_from_bitmap_lookup valid_bitmapQ_bitmapQ_simp) + apply (fastforce dest!: lookupBitmapPriority_obj_at' + simp: ready_queue_relation_def ksReadyQueues_asrt_def st_tcb_at'_def obj_at'_def) done qed @@ -635,7 +707,7 @@ lemma schedule_ccorres: apply (wp (once) hoare_drop_imps) apply wp apply (strengthen strenghten_False_imp[where P="a = ResumeCurrentThread" for a]) - apply (clarsimp simp: conj_ac invs_queues invs_valid_objs' cong: conj_cong) + apply (clarsimp simp: conj_ac invs_valid_objs' cong: conj_cong) apply wp apply (clarsimp, vcg exspec=tcbSchedEnqueue_modifies) apply (clarsimp, vcg exspec=tcbSchedEnqueue_modifies) @@ -655,9 +727,11 @@ lemma schedule_ccorres: apply wp apply vcg - apply (clarsimp simp: tcb_at_invs' rf_sr_ksCurThread if_apply_def2 invs_queues invs_valid_objs') + apply (clarsimp simp: tcb_at_invs' rf_sr_ksCurThread if_apply_def2 invs_valid_objs') apply (frule invs_sch_act_wf') apply (frule tcb_at_invs') + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') apply (rule conjI) apply (clarsimp dest!: rf_sr_cscheduler_relation simp: cscheduler_action_relation_def) apply (rule conjI; clarsimp) @@ -707,11 +781,7 @@ lemma threadSet_timeSlice_ccorres [corres]: apply (simp add: cep_relations_drop_fun_upd cvariable_relation_upd_const ko_at_projectKO_opt) - apply (rule conjI) defer - apply (erule cready_queues_relation_not_queue_ptrs) - apply (rule ext, simp split: if_split) - apply (rule ext, simp split: if_split) apply (drule ko_at_projectKO_opt) apply (erule (2) cmap_relation_upd_relI) apply (simp add: ctcb_relation_def) @@ -755,7 +825,7 @@ lemma timerTick_ccorres: apply simp apply (ctac (no_vcg) add: tcbSchedAppend_ccorres) apply (ctac add: rescheduleRequired_ccorres) - apply (wp weak_sch_act_wf_lift_linear threadSet_valid_queues + apply (wp weak_sch_act_wf_lift_linear threadSet_pred_tcb_at_state tcbSchedAppend_valid_objs' threadSet_valid_objs' threadSet_tcbDomain_triv | clarsimp simp: st_tcb_at'_def o_def split: if_splits)+ apply (vcg exspec=tcbSchedDequeue_modifies) @@ -806,8 +876,8 @@ lemma timerTick_ccorres: apply (rule conjI, clarsimp simp: invs'_def valid_state'_def valid_tcb'_def)+ apply (auto simp: obj_at'_def inQ_def weak_sch_act_wf_def st_tcb_at'_def valid_pspace'_def ct_idle_or_in_cur_domain'_def valid_tcb'_def valid_idle'_def projectKOs)[1] - apply (auto simp: invs'_def valid_state'_def valid_tcb'_def tcb_cte_cases_def - cteSizeBits_def)[1] + apply (auto simp: invs'_def valid_state'_def valid_tcb'_def tcb_cte_cases_def cur_tcb'_def + obj_at'_def cteSizeBits_def)[1] apply (frule invs_cur') apply (clarsimp simp: cur_tcb'_def) diff --git a/proof/crefine/AARCH64/StateRelation_C.thy b/proof/crefine/AARCH64/StateRelation_C.thy index 8dfbaef0fd..a92b71fda0 100644 --- a/proof/crefine/AARCH64/StateRelation_C.thy +++ b/proof/crefine/AARCH64/StateRelation_C.thy @@ -18,8 +18,7 @@ definition definition "array_relation r n a c \ \i \ n. r (a i) (index c (unat i))" -(* used for bound ntfn/tcb *) -definition +definition option_to_ctcb_ptr :: "machine_word option \ tcb_C ptr" where "option_to_ctcb_ptr x \ case x of None \ NULL | Some t \ tcb_ptr_to_ctcb_ptr t" @@ -391,7 +390,9 @@ where \ tcbTimeSlice atcb = unat (tcbTimeSlice_C ctcb) \ cfault_rel (tcbFault atcb) (seL4_Fault_lift (tcbFault_C ctcb)) (lookup_fault_lift (tcbLookupFailure_C ctcb)) - \ option_to_ptr (tcbBoundNotification atcb) = tcbBoundNotification_C ctcb" + \ option_to_ptr (tcbBoundNotification atcb) = tcbBoundNotification_C ctcb + \ option_to_ctcb_ptr (tcbSchedPrev atcb) = tcbSchedPrev_C ctcb + \ option_to_ctcb_ptr (tcbSchedNext atcb) = tcbSchedNext_C ctcb" abbreviation "ep_queue_relation' \ tcb_queue_relation' tcbEPNext_C tcbEPPrev_C" @@ -610,17 +611,17 @@ definition where "cready_queues_index_to_C qdom prio \ (unat qdom) * numPriorities + (unat prio)" -definition cready_queues_relation :: - "tcb_C typ_heap \ (tcb_queue_C[num_tcb_queues]) \ (domain \ priority \ ready_queue) \ bool" -where - "cready_queues_relation h_tcb queues aqueues \ - \qdom prio. ((qdom \ ucast minDom \ qdom \ ucast maxDom \ - prio \ ucast minPrio \ prio \ ucast maxPrio) \ - (let cqueue = index queues (cready_queues_index_to_C qdom prio) in - sched_queue_relation' h_tcb (aqueues (qdom, prio)) (head_C cqueue) (end_C cqueue))) - \ (\ (qdom \ ucast minDom \ qdom \ ucast maxDom \ - prio \ ucast minPrio \ prio \ ucast maxPrio) \ aqueues (qdom, prio) = [])" +definition ctcb_queue_relation :: "tcb_queue \ tcb_queue_C \ bool" where + "ctcb_queue_relation aqueue cqueue \ + head_C cqueue = option_to_ctcb_ptr (tcbQueueHead aqueue) + \ end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd aqueue)" +definition cready_queues_relation :: + "(domain \ priority \ ready_queue) \ (tcb_queue_C[num_tcb_queues]) \ bool" + where + "cready_queues_relation aqueues cqueues \ + \d p. d \ maxDomain \ p \ maxPriority + \ ctcb_queue_relation (aqueues (d, p)) (index cqueues (cready_queues_index_to_C d p))" abbreviation "cte_array_relation astate cstate @@ -759,9 +760,7 @@ where "cstate_relation astate cstate \ let cheap = t_hrs_' cstate in cpspace_relation (ksPSpace astate) (underlying_memory (ksMachineState astate)) cheap \ - cready_queues_relation (clift cheap) - (ksReadyQueues_' cstate) - (ksReadyQueues astate) \ + cready_queues_relation (ksReadyQueues astate) (ksReadyQueues_' cstate) \ zero_ranges_are_zero (gsUntypedZeroRanges astate) cheap \ cbitmap_L1_relation (ksReadyQueuesL1Bitmap_' cstate) (ksReadyQueuesL1Bitmap astate) \ cbitmap_L2_relation (ksReadyQueuesL2Bitmap_' cstate) (ksReadyQueuesL2Bitmap astate) \ diff --git a/proof/crefine/AARCH64/SyscallArgs_C.thy b/proof/crefine/AARCH64/SyscallArgs_C.thy index 7a38327aa9..54b5b56b9d 100644 --- a/proof/crefine/AARCH64/SyscallArgs_C.thy +++ b/proof/crefine/AARCH64/SyscallArgs_C.thy @@ -49,9 +49,7 @@ lemma replyOnRestart_invs'[wp]: including no_pre apply (simp add: replyOnRestart_def) apply (wp setThreadState_nonqueued_state_update rfk_invs' hoare_weak_lift_imp) - apply (rule hoare_vcg_all_lift) - apply (wp setThreadState_nonqueued_state_update rfk_invs' hoare_vcg_all_lift rfk_ksQ) - apply (rule hoare_strengthen_post, rule gts_sp') + apply (rule hoare_strengthen_post, rule gts_sp') apply (clarsimp simp: pred_tcb_at') apply (auto elim!: pred_tcb'_weakenE st_tcb_ex_cap'' dest: st_tcb_at_idle_thread') diff --git a/proof/crefine/AARCH64/Syscall_C.thy b/proof/crefine/AARCH64/Syscall_C.thy index 6e561786b8..f37a889251 100644 --- a/proof/crefine/AARCH64/Syscall_C.thy +++ b/proof/crefine/AARCH64/Syscall_C.thy @@ -50,8 +50,7 @@ lemma cap_cases_one_on_true_sum: lemma performInvocation_Endpoint_ccorres: "ccorres (K (K \) \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (invs' and st_tcb_at' simple' thread and ep_at' epptr - and sch_act_sane and (\s. thread = ksCurThread s - \ (\p. ksCurThread s \ set (ksReadyQueues s p)))) + and sch_act_sane and (\s. thread = ksCurThread s)) (UNIV \ {s. block_' s = from_bool blocking} \ {s. call_' s = from_bool do_call} \ {s. badge_' s = badge} @@ -123,7 +122,6 @@ lemma decodeInvocation_ccorres: and (\s. \v \ set extraCaps. ex_cte_cap_wp_to' isCNodeCap (snd v) s) and (\s. \v \ set extraCaps. s \' fst v \ cte_at' (snd v) s) and (\s. \v \ set extraCaps. \y \ zobj_refs' (fst v). ex_nonz_cap_to' y s) - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p)) and sysargs_rel args buffer) (UNIV \ {s. current_extra_caps_' (globals s) = extraCaps'} \ {s. call_' s = from_bool isCall} @@ -200,7 +198,7 @@ lemma decodeInvocation_ccorres: apply simp apply (rule hoare_use_eq[where f=ksCurThread]) apply (wp sts_invs_minor' sts_st_tcb_at'_cases - setThreadState_ct' hoare_vcg_all_lift sts_ksQ')+ + setThreadState_ct' hoare_vcg_all_lift)+ apply simp apply (vcg exspec=setThreadState_modifies) apply vcg @@ -507,7 +505,7 @@ lemma wordFromMessageInfo_spec: lemma handleDoubleFault_ccorres: "ccorres dc xfdc (invs' and tcb_at' tptr and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and - sch_act_not tptr and (\s. \p. tptr \ set (ksReadyQueues s p))) + sch_act_not tptr) (UNIV \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr tptr}) [] (handleDoubleFault tptr ex1 ex2) (Call handleDoubleFault_'proc)" @@ -572,8 +570,7 @@ lemma hrs_mem_update_use_hrs_mem: lemma sendFaultIPC_ccorres: "ccorres (cfault_rel2 \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') - (invs' and st_tcb_at' simple' tptr and sch_act_not tptr and - (\s. \p. tptr \ set (ksReadyQueues s p))) + (invs' and st_tcb_at' simple' tptr and sch_act_not tptr) (UNIV \ {s. (cfault_rel (Some fault) (seL4_Fault_lift(current_fault_' (globals s))) (lookup_fault_lift(current_lookup_fault_' (globals s))))} \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr tptr}) @@ -651,8 +648,8 @@ lemma sendFaultIPC_ccorres: apply (ctac (no_vcg) add: sendIPC_ccorres) apply (ctac (no_vcg) add: ccorres_return_CE [unfolded returnOk_def comp_def]) apply wp - apply (wp threadSet_pred_tcb_no_state threadSet_invs_trivial threadSet_typ_at_lifts - | simp)+ + apply (wpsimp wp: threadSet_invs_trivial) + apply (wpsimp wp: threadSet_pred_tcb_no_state threadSet_typ_at_lifts) apply (clarsimp simp: guard_is_UNIV_def) apply (subgoal_tac "capEPBadge epcap && mask 64 = capEPBadge epcap") @@ -685,8 +682,7 @@ lemma sendFaultIPC_ccorres: apply vcg apply (clarsimp simp: inQ_def) apply (rule_tac Q="\a b. invs' b \ st_tcb_at' simple' tptr b - \ sch_act_not tptr b \ valid_cap' a b - \ (\p. tptr \ set (ksReadyQueues b p))" + \ sch_act_not tptr b \ valid_cap' a b" and E="\ _. \" in hoare_post_impErr) apply (wp) @@ -701,8 +697,7 @@ lemma sendFaultIPC_ccorres: done lemma handleFault_ccorres: - "ccorres dc xfdc (invs' and st_tcb_at' simple' t and - sch_act_not t and (\s. \p. t \ set (ksReadyQueues s p))) + "ccorres dc xfdc (invs' and st_tcb_at' simple' t and sch_act_not t) (UNIV \ {s. (cfault_rel (Some flt) (seL4_Fault_lift(current_fault_' (globals s))) (lookup_fault_lift(current_lookup_fault_' (globals s))) )} \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr t}) @@ -766,9 +761,7 @@ lemma getMRs_length: lemma handleInvocation_ccorres: "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') - (invs' and - ct_active' and sch_act_simple and - (\s. \x. ksCurThread s \ set (ksReadyQueues s x))) + (invs' and ct_active' and sch_act_simple) (UNIV \ {s. isCall_' s = from_bool isCall} \ {s. isBlocking_' s = from_bool isBlocking}) [] (handleInvocation isCall isBlocking) (Call handleInvocation_'proc)" @@ -896,7 +889,7 @@ lemma handleInvocation_ccorres: apply (wp hoare_split_bind_case_sumE hoare_drop_imps setThreadState_nonqueued_state_update ct_in_state'_set setThreadState_st_tcb - hoare_vcg_all_lift sts_ksQ' + hoare_vcg_all_lift | wpc | wps)+ apply auto[1] apply clarsimp @@ -1155,9 +1148,6 @@ lemma ccorres_trim_redundant_throw_break: lemma invs_valid_objs_strengthen: "invs' s \ valid_objs' s" by fastforce -lemma ct_not_ksQ_strengthen: - "thread = ksCurThread s \ ksCurThread s \ set (ksReadyQueues s p) \ thread \ set (ksReadyQueues s p)" by fastforce - lemma option_to_ctcb_ptr_valid_ntfn: "valid_ntfn' ntfn s ==> (option_to_ctcb_ptr (ntfnBoundTCB ntfn) = NULL) = (ntfnBoundTCB ntfn = None)" apply (cases "ntfnBoundTCB ntfn", simp_all add: option_to_ctcb_ptr_def) @@ -1191,8 +1181,7 @@ lemma handleRecv_ccorres: notes rf_sr_upd_safe[simp del] shows "ccorres dc xfdc - (\s. invs' s \ st_tcb_at' simple' (ksCurThread s) s - \ sch_act_sane s \ (\p. ksCurThread s \ set (ksReadyQueues s p))) + (\s. invs' s \ st_tcb_at' simple' (ksCurThread s) s \ sch_act_sane s) {s. isBlocking_' s = from_bool isBlocking} [] (handleRecv isBlocking) @@ -1256,7 +1245,7 @@ lemma handleRecv_ccorres: apply (rule_tac P="\s. ksCurThread s = thread" in ccorres_cross_over_guard) apply (ctac add: receiveIPC_ccorres) - apply (wp deleteCallerCap_ksQ_ct' hoare_vcg_all_lift) + apply (wp hoare_vcg_all_lift) apply (rule conseqPost[where Q'=UNIV and A'="{}"], vcg exspec=deleteCallerCap_modifies) apply (clarsimp dest!: rf_sr_ksCurThread) apply simp @@ -1379,13 +1368,11 @@ lemma handleRecv_ccorres: apply clarsimp apply (rename_tac thread epCPtr) apply (rule_tac Q'="(\rv s. invs' s \ st_tcb_at' simple' thread s - \ sch_act_sane s \ (\p. thread \ set (ksReadyQueues s p)) \ thread = ksCurThread s + \ sch_act_sane s \ thread = ksCurThread s \ valid_cap' rv s)" in hoare_post_imp_R[rotated]) - apply (clarsimp simp: sch_act_sane_def) - apply (auto dest!: obj_at_valid_objs'[OF _ invs_valid_objs'] - simp: projectKOs valid_obj'_def, - auto simp: pred_tcb_at'_def obj_at'_def objBits_simps projectKOs ct_in_state'_def)[1] - apply wp + apply (intro conjI impI allI; clarsimp simp: sch_act_sane_def) + apply (fastforce dest: obj_at_valid_objs'[OF _ invs_valid_objs'] ko_at_valid_ntfn') + apply wp apply clarsimp apply (vcg exspec=isStopped_modifies exspec=lookupCap_modifies) @@ -1434,7 +1421,7 @@ lemma handleYield_ccorres: apply (ctac add: rescheduleRequired_ccorres) apply (wp weak_sch_act_wf_lift_linear tcbSchedAppend_valid_objs') apply (vcg exspec= tcbSchedAppend_modifies) - apply (wp weak_sch_act_wf_lift_linear tcbSchedDequeue_valid_queues) + apply (wp weak_sch_act_wf_lift_linear) apply (vcg exspec= tcbSchedDequeue_modifies) apply (clarsimp simp: tcb_at_invs' invs_valid_objs' valid_objs'_maxPriority valid_objs'_maxDomain) @@ -1699,8 +1686,7 @@ lemma ccorres_vgicMaintenance: notes virq_virq_pending_set_virqEOIIRQEN_spec = virq_virq_pending_set_virqEOIIRQEN_spec' shows "ccorres dc xfdc - (\s. invs' s \ sch_act_not (ksCurThread s) s - \ (\p. ksCurThread s \ set (ksReadyQueues s p))) + (\s. invs' s \ sch_act_not (ksCurThread s) s) UNIV hs vgicMaintenance (Call VGICMaintenance_'proc)" (is "ccorres _ _ ?PRE _ _ _ _") @@ -2123,9 +2109,7 @@ lemma ccorres_VPPIEvent: notes Collect_const[simp del] shows "ccorres dc xfdc - (\s. invs' s \ sch_act_not (ksCurThread s) s - \ (\p. ksCurThread s \ set (ksReadyQueues s p)) - \ irqVPPIEventIndex irq \ None) + (\s. invs' s \ sch_act_not (ksCurThread s) s \ irqVPPIEventIndex irq \ None) \\irq = ucast irq\ hs (vppiEvent irq) (Call VPPIEvent_'proc)" (is "ccorres _ _ ?PRE _ _ _ _") @@ -2206,8 +2190,7 @@ qed lemma ccorres_handleReservedIRQ: "ccorres dc xfdc - (invs' and (\s. irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s \ - (\p. ksCurThread s \ set (ksReadyQueues s p)))) + (invs' and (\s. irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s)) (UNIV \ {s. irq_' s = ucast irq}) hs (handleReservedIRQ irq) (Call handleReservedIRQ_'proc)" supply Collect_const[simp del] @@ -2245,8 +2228,7 @@ lemma ccorres_handleReservedIRQ: lemma handleInterrupt_ccorres: "ccorres dc xfdc - (invs' and (\s. irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s \ - (\p. ksCurThread s \ set (ksReadyQueues s p)))) + (invs' and (\s. irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s)) (UNIV \ \\irq = ucast irq\) hs (handleInterrupt irq) diff --git a/proof/crefine/AARCH64/TcbQueue_C.thy b/proof/crefine/AARCH64/TcbQueue_C.thy index 46f1e3b25c..660712b7d7 100644 --- a/proof/crefine/AARCH64/TcbQueue_C.thy +++ b/proof/crefine/AARCH64/TcbQueue_C.thy @@ -947,48 +947,6 @@ lemma tcb_queue_relation'_prev_canonical: \ make_canonical (ptr_val (getPrev tcb)) = ptr_val (getPrev tcb)" by (rule tcb_queue_relation_prev_canonical [OF tcb_queue_relation'_queue_rel]) -lemma cready_queues_relation_null_queue_ptrs: - assumes rel: "cready_queues_relation mp cq aq" - and same: "option_map tcb_null_ep_ptrs \ mp' = option_map tcb_null_ep_ptrs \ mp" - shows "cready_queues_relation mp' cq aq" - using rel - apply (clarsimp simp: cready_queues_relation_def Let_def all_conj_distrib) - apply (drule spec, drule spec, drule mp, (erule conjI)+, assumption) - apply (clarsimp simp: tcb_queue_relation'_def) - apply (erule iffD2 [OF tcb_queue_relation_only_next_prev, rotated -1]) - apply (rule ext) - apply (case_tac "mp' x") - apply (frule compD [OF same]) - apply simp - apply (frule compD [OF same]) - apply (clarsimp simp: tcb_null_ep_ptrs_def) - apply (case_tac z, case_tac a) - apply simp - \ \clag\ - apply (rule ext) - apply (case_tac "mp' x") - apply (frule compD [OF same]) - apply simp - apply (frule compD [OF same]) - apply (clarsimp simp: tcb_null_ep_ptrs_def) - apply (case_tac z, case_tac a) - apply simp - done - -lemma cready_queues_relation_not_queue_ptrs: - assumes rel: "cready_queues_relation mp cq aq" - and same: "option_map tcbSchedNext_C \ mp' = option_map tcbSchedNext_C \ mp" - "option_map tcbSchedPrev_C \ mp' = option_map tcbSchedPrev_C \ mp" - shows "cready_queues_relation mp' cq aq" - using rel - apply (clarsimp simp: cready_queues_relation_def tcb_queue_relation'_def Let_def all_conj_distrib) - apply (drule spec, drule spec, drule mp, (erule conjI)+, assumption) - apply clarsimp - apply (erule iffD2 [OF tcb_queue_relation_only_next_prev, rotated -1]) - apply (rule same) - apply (rule same) - done - lemma ntfn_ep_disjoint: assumes srs: "sym_refs (state_refs_of' s)" and epat: "ko_at' ep epptr s" @@ -1355,8 +1313,6 @@ lemma rf_sr_tcb_update_no_queue: (t_hrs_' (globals s')); tcbEPNext_C ctcb = tcbEPNext_C (the (cslift s' (tcb_ptr_to_ctcb_ptr thread))); tcbEPPrev_C ctcb = tcbEPPrev_C (the (cslift s' (tcb_ptr_to_ctcb_ptr thread))); - tcbSchedNext_C ctcb = tcbSchedNext_C (the (cslift s' (tcb_ptr_to_ctcb_ptr thread))); - tcbSchedPrev_C ctcb = tcbSchedPrev_C (the (cslift s' (tcb_ptr_to_ctcb_ptr thread))); (\x\ran tcb_cte_cases. (\(getF, setF). getF tcb' = getF tcb) x); ctcb_relation tcb' ctcb \ @@ -1371,31 +1327,22 @@ lemma rf_sr_tcb_update_no_queue: apply (clarsimp simp: map_comp_update projectKO_opt_tcb cvariable_relation_upd_const typ_heap_simps') apply (intro conjI) - subgoal by (clarsimp simp: cmap_relation_def map_comp_update projectKO_opts_defs inj_eq) - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_upd_tcb_no_queues, assumption+) - subgoal by fastforce - subgoal by fastforce + subgoal by (clarsimp simp: cmap_relation_def map_comp_update projectKO_opts_defs inj_eq) apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_upd_tcb_no_queues, assumption+) + apply (rule cendpoint_relation_upd_tcb_no_queues, assumption+) subgoal by fastforce subgoal by fastforce - apply (erule cready_queues_relation_not_queue_ptrs) + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_upd_tcb_no_queues, assumption+) subgoal by fastforce subgoal by fastforce subgoal by (clarsimp simp: carch_state_relation_def typ_heap_simps') by (simp add: cmachine_state_relation_def) -lemma rf_sr_tcb_update_no_queue_helper: - "(s, s'\ globals := globals s' \ t_hrs_' := t_hrs_' (globals (undefined - \ globals := (undefined \ t_hrs_' := f (globals s') (t_hrs_' (globals s')) \)\))\\) \ rf_sr - \ (s, globals_update (\v. t_hrs_'_update (f v) v) s') \ rf_sr" - by (simp cong: StateSpace.state.fold_congs globals.fold_congs) - -lemmas rf_sr_tcb_update_no_queue2 - = rf_sr_tcb_update_no_queue_helper [OF rf_sr_tcb_update_no_queue, simplified] +lemmas rf_sr_tcb_update_no_queue2 = + rf_sr_obj_update_helper[OF rf_sr_tcb_update_no_queue, simplified] lemma tcb_queue_relation_not_in_q: "ctcb_ptr_to_tcb_ptr x \ set xs \ @@ -1443,13 +1390,7 @@ lemma rf_sr_tcb_update_not_in_queue: apply (drule(1) map_to_ko_atI') apply (drule sym_refs_ko_atD', clarsimp+) subgoal by blast - apply (simp add: cready_queues_relation_def, erule allEI) apply (clarsimp simp: Let_def) - apply (subst tcb_queue_relation_not_in_q) - apply clarsimp - apply (drule valid_queues_obj_at'D, clarsimp) - apply (clarsimp simp: obj_at'_def inQ_def) - subgoal by simp apply (simp add: carch_state_relation_def) by (simp add: cmachine_state_relation_def) diff --git a/proof/crefine/AARCH64/Tcb_C.thy b/proof/crefine/AARCH64/Tcb_C.thy index f1406c13ad..7ed0ce328f 100644 --- a/proof/crefine/AARCH64/Tcb_C.thy +++ b/proof/crefine/AARCH64/Tcb_C.thy @@ -395,9 +395,10 @@ lemma hrs_mem_update_cong: lemma setPriority_ccorres: "ccorres dc xfdc - (\s. tcb_at' t s \ Invariants_H.valid_queues s \ ksCurDomain s \ maxDomain \ - valid_queues' s \ valid_objs' s \ weak_sch_act_wf (ksSchedulerAction s) s \ (priority \ maxPriority)) - (UNIV \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr t} \ {s. prio_' s = ucast priority}) + (\s. tcb_at' t s \ ksCurDomain s \ maxDomain \ + valid_objs' s \ weak_sch_act_wf (ksSchedulerAction s) s \ (priority \ maxPriority) \ + pspace_aligned' s \ pspace_distinct' s) + ({s. tptr_' s = tcb_ptr_to_ctcb_ptr t} \ {s. prio_' s = ucast priority}) [] (setPriority t priority) (Call setPriority_'proc)" apply (cinit lift: tptr_' prio_') apply (ctac(no_vcg) add: tcbSchedDequeue_ccorres) @@ -420,7 +421,7 @@ lemma setPriority_ccorres: apply (ctac add: possibleSwitchTo_ccorres) apply (rule ccorres_return_Skip') apply (wp isRunnable_wp) - apply (wpsimp wp: hoare_drop_imps threadSet_valid_queues threadSet_valid_objs' + apply (wpsimp wp: hoare_drop_imps threadSet_valid_objs' weak_sch_act_wf_lift_linear threadSet_pred_tcb_at_state threadSet_tcbDomain_triv simp: st_tcb_at'_def o_def split: if_splits) @@ -429,18 +430,13 @@ lemma setPriority_ccorres: where Q="\rv s. obj_at' (\_. True) t s \ priority \ maxPriority \ - Invariants_H.valid_queues s \ ksCurDomain s \ maxDomain \ valid_objs' s \ - valid_queues' s \ weak_sch_act_wf (ksSchedulerAction s) s \ - (\d p. \ t \ set (ksReadyQueues s (d, p)))"]) - apply (wp weak_sch_act_wf_lift_linear tcbSchedDequeue_valid_queues tcbSchedDequeue_nonq) + pspace_aligned' s \ pspace_distinct' s"]) + apply (wp weak_sch_act_wf_lift_linear valid_tcb'_def) apply (clarsimp simp: valid_tcb'_tcbPriority_update) apply clarsimp - apply (frule (1) valid_objs'_maxDomain[where t=t]) - apply (frule (1) valid_objs'_maxPriority[where t=t]) - apply simp done lemma setMCPriority_ccorres: @@ -679,12 +675,12 @@ lemma invokeTCB_ThreadControl_ccorres: apply (clarsimp simp : guard_is_UNIV_def Collect_const_mem) apply (rule hoare_strengthen_post[ where Q= "\rv s. - Invariants_H.valid_queues s \ valid_objs' s \ weak_sch_act_wf (ksSchedulerAction s) s \ ((\a b. priority = Some (a, b)) \ tcb_at' target s \ ksCurDomain s \ maxDomain \ - valid_queues' s \ fst (the priority) \ maxPriority)"]) + fst (the priority) \ maxPriority) \ + pspace_aligned' s \ pspace_distinct' s"]) apply (strengthen sch_act_wf_weak) apply (wp hoare_weak_lift_imp) apply (clarsimp split: if_splits) @@ -774,12 +770,12 @@ lemma invokeTCB_ThreadControl_ccorres: apply (clarsimp simp : guard_is_UNIV_def Collect_const_mem) apply (simp cong: conj_cong) apply (rule hoare_strengthen_post[ - where Q="\a b. (Invariants_H.valid_queues b \ - valid_objs' b \ + where Q="\a b. (valid_objs' b \ sch_act_wf (ksSchedulerAction b) b \ + pspace_aligned' b \ pspace_distinct' b \ ((\a b. priority = Some (a, b)) \ tcb_at' target b \ - ksCurDomain b \ maxDomain \ valid_queues' b \ + ksCurDomain b \ maxDomain \ fst (the priority) \ maxPriority)) \ ((case snd (the buf) of None \ 0 @@ -801,15 +797,15 @@ lemma invokeTCB_ThreadControl_ccorres: prefer 2 apply fastforce apply (strengthen cte_is_derived_capMasterCap_strg - invs_queues invs_weak_sch_act_wf invs_sch_act_wf' + invs_weak_sch_act_wf invs_sch_act_wf' invs_valid_objs' invs_mdb' invs_pspace_aligned', simp add: o_def) apply (rule_tac P="is_aligned (fst (the buf)) msg_align_bits" in hoare_gen_asm) apply (wp threadSet_ipcbuffer_trivial hoare_weak_lift_imp | simp - | strengthen invs_sch_act_wf' invs_valid_objs' invs_weak_sch_act_wf invs_queues - invs_valid_queues' | wp hoare_drop_imps)+ + | strengthen invs_sch_act_wf' invs_valid_objs' invs_weak_sch_act_wf + | wp hoare_drop_imps)+ apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem option_to_0_def split: option.split_asm) @@ -818,7 +814,7 @@ lemma invokeTCB_ThreadControl_ccorres: apply (rule ccorres_return_C_errorE, simp+)[1] apply vcg apply (simp add: conj_comms cong: conj_cong) - apply (strengthen invs_ksCurDomain_maxDomain') + apply (strengthen invs_ksCurDomain_maxDomain' invs_pspace_distinct') apply (wp hoare_vcg_const_imp_lift_R cteDelete_invs') apply simp apply (rule ccorres_split_nothrow_novcg_dc) @@ -835,8 +831,7 @@ lemma invokeTCB_ThreadControl_ccorres: apply (rule conjI) apply (clarsimp simp: objBits_simps' word_bits_conv case_option_If2 if_n_0_0 valid_cap'_def capAligned_def obj_at'_def projectKOs) - apply (clarsimp simp: invs_valid_objs' invs_valid_queues' - Invariants_H.invs_queues invs_ksCurDomain_maxDomain') + apply (fastforce simp: invs_valid_objs' invs_ksCurDomain_maxDomain') apply (rule ccorres_Cond_rhs_Seq) apply (rule ccorres_rhs_assoc)+ apply csymbr @@ -1071,7 +1066,7 @@ lemma restart_ccorres: apply (ctac(no_vcg) add: tcbSchedEnqueue_ccorres) apply (ctac add: possibleSwitchTo_ccorres) apply (wp weak_sch_act_wf_lift)[1] - apply (wp sts_valid_queues setThreadState_st_tcb)[1] + apply (wp sts_valid_objs' setThreadState_st_tcb)[1] apply (simp add: valid_tcb_state'_def) apply wp apply (wp (once) sch_act_wf_lift, (wp tcb_in_cur_domain'_lift)+) @@ -1688,7 +1683,7 @@ lemma invokeTCB_WriteRegisters_ccorres[where S=UNIV]: apply (clarsimp simp: frame_gp_registers_convs word_less_nat_alt sysargs_rel_def n_frameRegisters_def n_msgRegisters_def split: if_split_asm) - apply (simp add: invs_weak_sch_act_wf invs_valid_objs' invs_queues) + apply (simp add: invs_weak_sch_act_wf invs_valid_objs') apply (fastforce dest!: global'_no_ex_cap simp: invs'_def valid_state'_def) done @@ -3166,7 +3161,8 @@ lemma decodeTCBConfigure_ccorres: apply (rule conjI, fastforce) apply (drule interpret_excaps_eq) apply (clarsimp simp: cte_wp_at_ctes_of valid_tcb_state'_def numeral_eqs le_ucast_ucast_le - tcb_at_invs' invs_valid_objs' invs_queues invs_sch_act_wf' + tcb_at_invs' invs_valid_objs' invs_sch_act_wf' + invs_pspace_aligned' invs_pspace_distinct' ct_in_state'_def pred_tcb_at'_def obj_at'_def tcb_st_refs_of'_def) apply (erule disjE; simp add: objBits_defs mask_def) apply (clarsimp simp: idButNot_def interpret_excaps_test_null @@ -4453,9 +4449,9 @@ lemma invokeTCB_SetTLSBase_ccorres: apply (rule ccorres_return_CE, simp+)[1] apply (wpsimp wp: hoare_drop_imp simp: guard_is_UNIV_def)+ apply vcg - apply (clarsimp simp: tlsBaseRegister_def AARCH64.tlsBaseRegister_def - invs_weak_sch_act_wf invs_queues C_register_defs - split: if_split) + apply (fastforce simp: tlsBaseRegister_def AARCH64.tlsBaseRegister_def + invs_weak_sch_act_wf C_register_defs + split: if_split) done lemma decodeSetTLSBase_ccorres: diff --git a/proof/crefine/AARCH64/Wellformed_C.thy b/proof/crefine/AARCH64/Wellformed_C.thy index a6d00f17ff..9bbe8b1e99 100644 --- a/proof/crefine/AARCH64/Wellformed_C.thy +++ b/proof/crefine/AARCH64/Wellformed_C.thy @@ -215,9 +215,6 @@ where abbreviation "ep_queue_relation \ tcb_queue_relation tcbEPNext_C tcbEPPrev_C" -abbreviation - "sched_queue_relation \ tcb_queue_relation tcbSchedNext_C tcbSchedPrev_C" - definition capUntypedPtr_C :: "cap_CL \ word64" where "capUntypedPtr_C cap \ case cap of diff --git a/proof/crefine/ARM/ADT_C.thy b/proof/crefine/ARM/ADT_C.thy index 284ef17f60..890865b53b 100644 --- a/proof/crefine/ARM/ADT_C.thy +++ b/proof/crefine/ARM/ADT_C.thy @@ -75,8 +75,8 @@ lemma Basic_sem_eq: lemma setTCBContext_C_corres: "\ ccontext_relation tc tc'; t' = tcb_ptr_to_ctcb_ptr t \ \ - corres_underlying rf_sr nf nf' dc (pspace_domain_valid and tcb_at' t) \ - (threadSet (\tcb. tcb \ tcbArch := atcbContextSet tc (tcbArch tcb)\) t) (setTCBContext_C tc' t')" + corres_underlying rf_sr nf nf' dc (pspace_domain_valid and tcb_at' t) \ + (threadSet (\tcb. tcb \ tcbArch := atcbContextSet tc (tcbArch tcb)\) t) (setTCBContext_C tc' t')" apply (simp add: setTCBContext_C_def exec_C_def Basic_sem_eq corres_underlying_def) apply clarsimp apply (simp add: threadSet_def bind_assoc split_def exec_gets) @@ -105,8 +105,6 @@ lemma setTCBContext_C_corres: apply (simp add: map_to_ctes_upd_tcb_no_ctes map_to_tcbs_upd tcb_cte_cases_def cvariable_relation_upd_const ko_at_projectKO_opt cteSizeBits_def) apply (simp add: cep_relations_drop_fun_upd) - apply (apply_conjunct \match conclusion in \cready_queues_relation _ _ _\ \ - \erule cready_queues_relation_not_queue_ptrs; rule ext; simp split: if_split\\) apply (drule ko_at_projectKO_opt) apply (erule (2) cmap_relation_upd_relI) apply (simp add: ctcb_relation_def carch_tcb_relation_def) @@ -639,25 +637,50 @@ lemma tcb_queue_rel'_unique: apply (erule(2) tcb_queue_rel_unique) done -definition - cready_queues_to_H - :: "(tcb_C ptr \ tcb_C) \ (tcb_queue_C[num_tcb_queues]) \ word8 \ word8 \ word32 list" +definition tcb_queue_C_to_tcb_queue :: "tcb_queue_C \ tcb_queue" where + "tcb_queue_C_to_tcb_queue q \ + TcbQueue (if head_C q = NULL then None else Some (ctcb_ptr_to_tcb_ptr (head_C q))) + (if end_C q = NULL then None else Some (ctcb_ptr_to_tcb_ptr (end_C q)))" + +definition cready_queues_to_H :: + "tcb_queue_C[num_tcb_queues] \ (domain \ priority \ ready_queue)" where - "cready_queues_to_H h_tcb cs \ \(qdom, prio). if ucast minDom \ qdom \ qdom \ ucast maxDom - \ ucast seL4_MinPrio \ prio \ prio \ ucast seL4_MaxPrio - then THE aq. let cqueue = index cs (cready_queues_index_to_C qdom prio) - in sched_queue_relation' h_tcb aq (head_C cqueue) (StateRelation_C.end_C cqueue) - else []" + "cready_queues_to_H cs \ + \(qdom, prio). + if qdom \ maxDomain \ prio \ maxPriority + then let cqueue = index cs (cready_queues_index_to_C qdom prio) + in tcb_queue_C_to_tcb_queue cqueue + else TcbQueue None None" lemma cready_queues_to_H_correct: - "cready_queues_relation (clift s) cs as \ - cready_queues_to_H (clift s) cs = as" - apply (clarsimp simp: cready_queues_to_H_def cready_queues_relation_def - fun_eq_iff) - apply (rule the_equality) - apply simp - apply (clarsimp simp: Let_def) - apply (rule_tac hp="clift s" in tcb_queue_rel'_unique, simp_all add: lift_t_NULL) + "\cready_queues_relation (ksReadyQueues s) (ksReadyQueues_' ch); + no_0_obj' s; ksReadyQueues_asrt s; pspace_aligned' s; pspace_distinct' s\ + \ cready_queues_to_H (ksReadyQueues_' ch) = ksReadyQueues s" + apply (clarsimp simp: cready_queues_to_H_def cready_queues_relation_def Let_def) + apply (clarsimp simp: fun_eq_iff) + apply (rename_tac d p) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (frule (3) obj_at'_tcbQueueEnd_ksReadyQueues) + apply (frule tcbQueueHead_iff_tcbQueueEnd) + apply (rule conjI) + apply (clarsimp simp: tcb_queue_C_to_tcb_queue_def ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (case_tac "tcbQueueHead (ksReadyQueues s (d, p)) = None") + apply (clarsimp simp: tcb_queue.expand) + apply clarsimp + apply (rename_tac queue_head queue_end) + apply (prop_tac "tcb_at' queue_head s", fastforce simp: tcbQueueEmpty_def obj_at'_def) + apply (prop_tac "tcb_at' queue_end s", fastforce simp: tcbQueueEmpty_def obj_at'_def) + apply (drule kernel.tcb_at_not_NULL)+ + apply (fastforce simp: tcb_queue.expand kernel.ctcb_ptr_to_ctcb_ptr) + apply (clarsimp simp: tcbQueueEmpty_def ctcb_queue_relation_def option_to_ctcb_ptr_def + split: option.splits; + metis tcb_queue.exhaust_sel word_not_le) done (* showing that cpspace_relation is actually unique >>>*) @@ -769,42 +792,90 @@ lemma cthread_state_rel_imp_eq: apply (cases y, simp_all add: ThreadState_defs)+ done -lemma ksPSpace_valid_objs_tcbBoundNotification_nonzero: - "\s. ksPSpace s = ah \ no_0_obj' s \ valid_objs' s - \ map_to_tcbs ah p = Some tcb \ tcbBoundNotification tcb \ Some 0" +lemma map_to_tcbs_Some_refs_nonzero: + "\map_to_tcbs (ksPSpace s) p = Some tcb; no_0_obj' s; valid_objs' s\ + \ tcbBoundNotification tcb \ Some 0 + \ tcbSchedPrev tcb \ Some 0 + \ tcbSchedNext tcb \ Some 0" + supply word_neq_0_conv[simp del] apply (clarsimp simp: map_comp_def split: option.splits) - apply (erule(1) valid_objsE') - apply (clarsimp simp: projectKOs valid_obj'_def valid_tcb'_def) + apply (erule (1) valid_objsE') + apply (fastforce simp: projectKOs valid_obj'_def valid_tcb'_def) done +lemma ccontext_relation_imp_eq2: + "\ccontext_relation (atcbContextGet t) x; ccontext_relation (atcbContextGet t') x\ \ t = t'" + by (fastforce simp: atcbContextGet_def arch_tcb.expand ccontext_relation_imp_eq) + +lemma tcb_ptr_to_ctcb_ptr_inj: + "tcb_ptr_to_ctcb_ptr x = tcb_ptr_to_ctcb_ptr y \ x = y" + by (auto simp: tcb_ptr_to_ctcb_ptr_def ctcb_offset_def) + +lemma + assumes "pspace_aligned' as" "pspace_distinct' as" "valid_tcb' atcb as" + shows tcb_at'_tcbBoundNotification: + "bound (tcbBoundNotification atcb) \ ntfn_at' (the (tcbBoundNotification atcb)) as" + and tcb_at'_tcbSchedPrev: + "tcbSchedPrev atcb \ None \ tcb_at' (the (tcbSchedPrev atcb)) as" + and tcb_at'_tcbSchedNext: + "tcbSchedNext atcb \ None \ tcb_at' (the (tcbSchedNext atcb)) as" + using assms + by (clarsimp simp: valid_tcb'_def obj_at'_def)+ + lemma cpspace_tcb_relation_unique: - assumes tcbs: "cpspace_tcb_relation ah ch" "cpspace_tcb_relation ah' ch" - and vs: "\s. ksPSpace s = ah \ no_0_obj' s \ valid_objs' s" - and vs': "\s. ksPSpace s = ah' \ no_0_obj' s \ valid_objs' s" - assumes ctes: " \tcb tcb'. (\p. map_to_tcbs ah p = Some tcb \ - map_to_tcbs ah' p = Some tcb') \ - (\x\ran tcb_cte_cases. fst x tcb' = fst x tcb)" - shows "map_to_tcbs ah' = map_to_tcbs ah" + assumes tcbs: "cpspace_tcb_relation (ksPSpace as) ch" "cpspace_tcb_relation (ksPSpace as') ch" + assumes vs: "no_0_obj' as" "valid_objs' as" + assumes vs': "no_0_obj' as'" "valid_objs' as'" + assumes ad: "pspace_aligned' as" "pspace_distinct' as" + assumes ad': "pspace_aligned' as'" "pspace_distinct' as'" + assumes ctes: "\tcb tcb'. (\p. map_to_tcbs (ksPSpace as) p = Some tcb \ + map_to_tcbs (ksPSpace as') p = Some tcb') \ + (\x\ran tcb_cte_cases. fst x tcb' = fst x tcb)" + shows "map_to_tcbs (ksPSpace as') = map_to_tcbs (ksPSpace as)" using tcbs(2) tcbs(1) apply (clarsimp simp add: cmap_relation_def) apply (drule inj_image_inv[OF inj_tcb_ptr_to_ctcb_ptr])+ apply (simp add: tcb_ptr_to_ctcb_ptr_def[abs_def] ctcb_offset_def) apply (rule ext) - apply (case_tac "x:dom (map_to_tcbs ah)") + apply (case_tac "x \ dom (map_to_tcbs (ksPSpace as))") apply (drule bspec, assumption)+ apply (simp add: dom_def Collect_eq, drule_tac x=x in spec) apply clarsimp apply (rename_tac p x y) apply (cut_tac ctes) apply (drule_tac x=x in spec, drule_tac x=y in spec, erule impE, fastforce) - apply (frule ksPSpace_valid_objs_tcbBoundNotification_nonzero[OF vs]) - apply (frule ksPSpace_valid_objs_tcbBoundNotification_nonzero[OF vs']) + apply (frule map_to_tcbs_Some_refs_nonzero[OF _ vs]) + apply (frule map_to_tcbs_Some_refs_nonzero[OF _ vs']) + apply (rename_tac atcb atcb') + apply (prop_tac "valid_tcb' atcb as") + apply (fastforce intro: vs ad map_to_ko_atI tcb_ko_at_valid_objs_valid_tcb') + apply (prop_tac "valid_tcb' atcb' as'") + apply (fastforce intro: vs' ad' map_to_ko_atI tcb_ko_at_valid_objs_valid_tcb') + apply (frule tcb_at'_tcbSchedPrev[OF ad]) + apply (frule tcb_at'_tcbSchedPrev[OF ad']) + apply (frule tcb_at'_tcbSchedNext[OF ad]) + apply (frule tcb_at'_tcbSchedNext[OF ad']) apply (thin_tac "map_to_tcbs x y = Some z" for x y z)+ - apply (case_tac x, case_tac y, case_tac "the (clift ch (tcb_Ptr (p+0x100)))") + apply (case_tac "the (clift ch (tcb_Ptr (p + 2 ^ ctcb_size_bits)))") apply (clarsimp simp: ctcb_relation_def ran_tcb_cte_cases) - apply (clarsimp simp: option_to_ptr_def option_to_0_def split: option.splits) - apply (auto simp: cfault_rel_imp_eq cthread_state_rel_imp_eq carch_tcb_relation_imp_eq - ccontext_relation_imp_eq up_ucast_inj_eq ctcb_size_bits_def) + apply (clarsimp simp: option_to_ctcb_ptr_def option_to_ptr_def option_to_0_def) + apply (rule tcb.expand) + apply clarsimp + apply (intro conjI) + apply (simp add: cthread_state_rel_imp_eq) + apply (simp add: cfault_rel_imp_eq) + apply (case_tac "tcbBoundNotification atcb'", case_tac "tcbBoundNotification atcb"; clarsimp) + apply (clarsimp split: option.splits) + apply (case_tac "tcbSchedPrev atcb'"; case_tac "tcbSchedPrev atcb"; clarsimp) + apply (force dest!: kernel.tcb_at_not_NULL) + apply (force dest!: kernel.tcb_at_not_NULL) + apply (force simp: tcb_ptr_to_ctcb_ptr_inj) + apply (case_tac "tcbSchedNext atcb'"; case_tac "tcbSchedNext atcb"; clarsimp) + apply (force dest!: kernel.tcb_at_not_NULL) + apply (force dest!: kernel.tcb_at_not_NULL) + apply (force simp: tcb_ptr_to_ctcb_ptr_inj) + apply (force simp: carch_tcb_relation_def ccontext_relation_imp_eq2) + apply auto done lemma tcb_queue_rel_clift_unique: @@ -835,10 +906,6 @@ lemma ksPSpace_valid_pspace_ntfnBoundTCB_nonzero: apply (clarsimp simp: projectKOs valid_obj'_def valid_ntfn'_def) done -lemma tcb_ptr_to_ctcb_ptr_inj: - "tcb_ptr_to_ctcb_ptr x = tcb_ptr_to_ctcb_ptr y \ x = y" - by (auto simp: tcb_ptr_to_ctcb_ptr_def ctcb_offset_def) - lemma cpspace_ntfn_relation_unique: assumes ntfns: "cpspace_ntfn_relation ah ch" "cpspace_ntfn_relation ah' ch" and vs: "\s. ksPSpace s = ah \ valid_pspace' s" @@ -1090,8 +1157,8 @@ proof - OF valid_objs'_imp_wf_asid_pool'[OF valid_objs] valid_objs'_imp_wf_asid_pool'[OF valid_objs']]) apply (drule (1) cpspace_tcb_relation_unique) - apply (fastforce intro: no_0_objs no_0_objs' valid_objs valid_objs') - apply (fastforce intro: no_0_objs no_0_objs' valid_objs valid_objs') + apply (fastforce intro: no_0_objs no_0_objs' valid_objs valid_objs')+ + apply (fastforce intro: aligned distinct aligned' distinct')+ apply (intro allI impI,elim exE conjE) apply (rule_tac p=p in map_to_ctes_tcb_ctes, assumption) apply (frule (1) map_to_ko_atI[OF _ aligned distinct]) @@ -1299,7 +1366,7 @@ where ksDomSchedule = cDomSchedule_to_H kernel_all_global_addresses.ksDomSchedule, ksCurDomain = ucast (ksCurDomain_' s), ksDomainTime = ksDomainTime_' s, - ksReadyQueues = cready_queues_to_H (clift (t_hrs_' s)) (ksReadyQueues_' s), + ksReadyQueues = cready_queues_to_H (ksReadyQueues_' s), ksReadyQueuesL1Bitmap = cbitmap_L1_to_H (ksReadyQueuesL1Bitmap_' s), ksReadyQueuesL2Bitmap = cbitmap_L2_to_H (ksReadyQueuesL2Bitmap_' s), ksCurThread = ctcb_ptr_to_tcb_ptr (ksCurThread_' s), @@ -1315,16 +1382,16 @@ where lemma (in kernel_m) cstate_to_H_correct: assumes valid: "valid_state' as" assumes cstate_rel: "cstate_relation as cs" + assumes rdyqs: "ksReadyQueues_asrt as" shows "cstate_to_H cs = as \ksMachineState:= observable_memory (ksMachineState as) (user_mem' as)\" apply (subgoal_tac "cstate_to_machine_H cs = observable_memory (ksMachineState as) (user_mem' as)") apply (rule kernel_state.equality, simp_all add: cstate_to_H_def) - apply (rule cstate_to_pspace_H_correct) + apply (rule cstate_to_pspace_H_correct) using valid apply (simp add: valid_state'_def) using cstate_rel valid apply (clarsimp simp: cstate_relation_def cpspace_relation_def Let_def - observable_memory_def valid_state'_def - valid_pspace'_def) + observable_memory_def valid_state'_def valid_pspace'_def) using cstate_rel apply (clarsimp simp: cstate_relation_def cpspace_relation_def Let_def prod_eq_iff) using cstate_rel @@ -1348,8 +1415,13 @@ lemma (in kernel_m) cstate_to_H_correct: using cstate_rel apply (clarsimp simp: cstate_relation_def Let_def) apply (rule cready_queues_to_H_correct) - using cstate_rel - apply (clarsimp simp: cstate_relation_def Let_def) + using cstate_rel rdyqs + apply (fastforce intro!: cready_queues_to_H_correct + simp: cstate_relation_def Let_def) + using valid apply (fastforce simp: valid_state'_def) + using rdyqs apply fastforce + using valid apply (fastforce simp: valid_state'_def) + using valid apply (fastforce simp: valid_state'_def) using cstate_rel apply (clarsimp simp: cstate_relation_def Let_def) using cstate_rel diff --git a/proof/crefine/ARM/ArchMove_C.thy b/proof/crefine/ARM/ArchMove_C.thy index 938d1c8f2f..5095e3d70f 100644 --- a/proof/crefine/ARM/ArchMove_C.thy +++ b/proof/crefine/ARM/ArchMove_C.thy @@ -91,14 +91,9 @@ lemma empty_fail_findPDForASIDAssert[iff]: unfolding findPDForASIDAssert_def checkPDAt_def checkPDUniqueToASID_def checkPDASIDMapMembership_def by (wpsimp wp: empty_fail_getObject) -crunches Arch.switchToThread - for valid_queues'[wp]: valid_queues' - (simp: crunch_simps ignore: clearExMonitor) crunches switchToIdleThread for ksCurDomain[wp]: "\s. P (ksCurDomain s)" -crunches switchToIdleThread, switchToThread - for valid_pspace'[wp]: valid_pspace' - (simp: crunch_simps) + crunches switchToThread for valid_arch_state'[wp]: valid_arch_state' diff --git a/proof/crefine/ARM/Arch_C.thy b/proof/crefine/ARM/Arch_C.thy index 0833cdfec0..98e91e832e 100644 --- a/proof/crefine/ARM/Arch_C.thy +++ b/proof/crefine/ARM/Arch_C.thy @@ -1988,7 +1988,7 @@ lemma performPageGetAddress_ccorres: apply clarsimp apply (rule conseqPre, vcg) apply clarsimp - apply (clarsimp simp: invs_no_0_obj' tcb_at_invs' invs_queues invs_valid_objs' invs_sch_act_wf' + apply (clarsimp simp: invs_no_0_obj' tcb_at_invs' invs_valid_objs' invs_sch_act_wf' rf_sr_ksCurThread msgRegisters_unfold seL4_MessageInfo_lift_def message_info_to_H_def mask_def) apply (cases isCall) @@ -3134,8 +3134,8 @@ lemma decodeARMPageDirectoryInvocation_ccorres: st' \ Structures_H.thread_state.Inactive \ st' \ Structures_H.thread_state.IdleThreadState) thread and (\s. thread \ ksIdleThread s \ (obj_at' tcbQueued thread s \ st_tcb_at' runnable' thread s))"]]) - apply (clarsimp simp: invs_valid_objs' invs_sch_act_wf' - valid_tcb_state'_def invs_queues) + apply (clarsimp simp: invs_valid_objs' invs_sch_act_wf' valid_tcb_state'_def + invs_pspace_aligned' invs_pspace_distinct') apply (rule conjI) apply (erule flush_range_le) apply (simp add:linorder_not_le) @@ -3861,9 +3861,12 @@ lemma Arch_decodeInvocation_ccorres: apply (clarsimp simp: ex_cte_cap_wp_to'_def cte_wp_at_ctes_of invs_sch_act_wf' dest!: isCapDs(1)) apply (intro conjI) - apply (simp add: Invariants_H.invs_queues) - apply (simp add: valid_tcb_state'_def) - apply (fastforce elim!: pred_tcb'_weakenE dest!:st_tcb_at_idle_thread') + apply (simp add: valid_tcb_state'_def) + apply (fastforce elim!: pred_tcb'_weakenE dest!:st_tcb_at_idle_thread') + apply fastforce + apply (clarsimp simp: st_tcb_at'_def obj_at'_def) + apply (rename_tac obj) + apply (case_tac "tcbState obj", (simp add: runnable'_def)+)[1] apply (clarsimp simp: st_tcb_at'_def obj_at'_def) apply (rename_tac obj) apply (case_tac "tcbState obj", (simp add: runnable'_def)+)[1] diff --git a/proof/crefine/ARM/Detype_C.thy b/proof/crefine/ARM/Detype_C.thy index 78acb233ef..783bcaf7e8 100644 --- a/proof/crefine/ARM/Detype_C.thy +++ b/proof/crefine/ARM/Detype_C.thy @@ -1568,35 +1568,11 @@ proof - apply (rule cmap_array; simp add: pteBits_def) done moreover - from invs have "valid_queues s" .. - hence "\p. \t \ set (ksReadyQueues s p). tcb_at' t s \ ko_wp_at' live' t s" - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def) - apply (drule spec, drule spec) - apply clarsimp - apply (drule (1) bspec) - apply (rule conjI) - apply (erule obj_at'_weakenE) - apply simp - apply (simp add: obj_at'_real_def) - apply (erule ko_wp_at'_weakenE) - apply (clarsimp simp: projectKOs inQ_def) - done - hence tat: "\p. \t \ set (ksReadyQueues s p). tcb_at' t s" - and tlive: "\p. \t \ set (ksReadyQueues s p). ko_wp_at' live' t s" - by auto from sr have - "cready_queues_relation (clift ?th_s) - (ksReadyQueues_' (globals s')) (ksReadyQueues s)" + "cready_queues_relation (ksReadyQueues s) (ksReadyQueues_' (globals s'))" unfolding cready_queues_relation_def rf_sr_def cstate_relation_def cpspace_relation_def apply (clarsimp simp: Let_def all_conj_distrib) - apply (drule spec, drule spec, drule mp) - apply fastforce - apply ((subst lift_t_typ_region_bytes, rule cm_disj_tcb, assumption+, - simp_all add: objBits_simps archObjSize_def pageBits_def projectKOs)[1])+ - \ \waiting ...\ - apply (simp add: tcb_queue_relation_live_restrict - [OF D.valid_untyped tat tlive rl]) done moreover diff --git a/proof/crefine/ARM/Fastpath_C.thy b/proof/crefine/ARM/Fastpath_C.thy index cd2f746a82..6e09d6e161 100644 --- a/proof/crefine/ARM/Fastpath_C.thy +++ b/proof/crefine/ARM/Fastpath_C.thy @@ -39,11 +39,10 @@ lemma getEndpoint_obj_at': lemmas setEndpoint_obj_at_tcb' = setEndpoint_obj_at'_tcb lemma tcbSchedEnqueue_tcbContext[wp]: - "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ - tcbSchedEnqueue t' - \\rv. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" - apply (rule tcbSchedEnqueue_obj_at_unchangedT[OF all_tcbI]) - apply simp + "tcbSchedEnqueue t' \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_when) + apply (wp threadSet_obj_at' hoare_drop_imps threadGet_wp + | simp split: if_split)+ done lemma setCTE_tcbContext: @@ -55,20 +54,16 @@ lemma setCTE_tcbContext: done lemma setThreadState_tcbContext: - "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ - setThreadState a b - \\_. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" - apply (rule setThreadState_obj_at_unchanged) - apply (clarsimp simp: atcbContext_def)+ - done + "setThreadState a b \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + unfolding setThreadState_def rescheduleRequired_def tcbSchedEnqueue_def + tcbQueuePrepend_def rescheduleRequired_def + by (wp threadSet_obj_at' hoare_drop_imps threadGet_wp | wpc + | simp split: if_split)+ lemma setBoundNotification_tcbContext: - "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ - setBoundNotification a b - \\_. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" - apply (rule setBoundNotification_obj_at_unchanged) - apply (clarsimp simp: atcbContext_def)+ - done + "setBoundNotification a b \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + unfolding setBoundNotification_def + by wpsimp declare comp_apply [simp del] crunch tcbContext[wp]: deleteCallerCap "obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t" @@ -631,10 +626,10 @@ lemma dmo_clearExMonitor_setCurThread_swap: od) = (do _ \ setCurThread thread; doMachineOp ARM.clearExMonitor od)" - apply (simp add: setCurThread_def doMachineOp_def split_def) - apply (rule oblivious_modify_swap[symmetric]) - apply (intro oblivious_bind, - simp_all add: select_f_oblivious) + apply (clarsimp simp: ARM.clearExMonitor_def) + apply (simp add: doMachineOp_modify) + apply (rule oblivious_modify_swap) + apply (fastforce intro: oblivious_bind simp: setCurThread_def idleThreadNotQueued_def) done lemma pd_at_asid_inj': @@ -734,6 +729,8 @@ lemma switchToThread_fp_ccorres: del: Collect_const) apply (simp only: dmo_clearExMonitor_setCurThread_swap) apply (rule ccorres_split_nothrow_novcg_dc) + apply (clarsimp simp: setCurThread_def) + apply (rule ccorres_stateAssert) apply (rule ccorres_from_vcg[where P=\ and P'=UNIV]) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp del: rf_sr_upd_safe) @@ -743,7 +740,7 @@ lemma switchToThread_fp_ccorres: apply (ctac add: clearExMonitor_fp_ccorres) apply wp apply (simp add: guard_is_UNIV_def) - apply wp + apply (wp hoare_drop_imps) apply (simp add: bind_assoc checkPDNotInASIDMap_def checkPDASIDMapMembership_def) apply (rule ccorres_stateAssert) @@ -1200,8 +1197,8 @@ lemma fastpath_dequeue_ccorres: apply (rule conjI) apply (clarsimp simp: cpspace_relation_def update_ep_map_tos update_tcb_map_tos typ_heap_simps') - apply (rule conjI, erule ctcb_relation_null_queue_ptrs) - apply (rule ext, simp add: tcb_null_queue_ptrs_def + apply (rule conjI, erule ctcb_relation_null_ep_ptrs) + apply (rule ext, simp add: tcb_null_ep_ptrs_def split: if_split) apply (rule conjI) apply (rule cpspace_relation_ep_update_ep, assumption+) @@ -1217,8 +1214,6 @@ lemma fastpath_dequeue_ccorres: apply (simp add: carch_state_relation_def typ_heap_simps' cmachine_state_relation_def h_t_valid_clift_Some_iff update_ep_map_tos) - apply (erule cready_queues_relation_null_queue_ptrs) - apply (rule ext, simp add: tcb_null_ep_ptrs_def split: if_split) done lemma st_tcb_at_not_in_ep_queue: @@ -1356,8 +1351,8 @@ lemma fastpath_enqueue_ccorres: apply (rule conjI) apply (clarsimp simp: cpspace_relation_def update_ep_map_tos typ_heap_simps') - apply (rule conjI, erule ctcb_relation_null_queue_ptrs) - apply (rule ext, simp add: tcb_null_queue_ptrs_def + apply (rule conjI, erule ctcb_relation_null_ep_ptrs) + apply (rule ext, simp add: tcb_null_ep_ptrs_def split: if_split) apply (rule conjI) apply (rule_tac S="tcb_ptr_to_ctcb_ptr ` set (ksCurThread \ # list)" @@ -1396,8 +1391,6 @@ lemma fastpath_enqueue_ccorres: auto dest!: map_to_ko_atI)[1] apply (simp add: carch_state_relation_def typ_heap_simps' update_ep_map_tos cmachine_state_relation_def h_t_valid_clift_Some_iff) - apply (erule cready_queues_relation_null_queue_ptrs) - apply (rule ext, simp add: tcb_null_ep_ptrs_def split: if_split) apply (clarsimp simp: typ_heap_simps' EPState_Recv_def mask_def is_aligned_weaken[OF is_aligned_tcb_ptr_to_ctcb_ptr]) apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def) @@ -1405,8 +1398,8 @@ lemma fastpath_enqueue_ccorres: apply (rule conjI) apply (clarsimp simp: cpspace_relation_def update_ep_map_tos typ_heap_simps' ct_in_state'_def) - apply (rule conjI, erule ctcb_relation_null_queue_ptrs) - apply (rule ext, simp add: tcb_null_queue_ptrs_def + apply (rule conjI, erule ctcb_relation_null_ep_ptrs) + apply (rule ext, simp add: tcb_null_ep_ptrs_def split: if_split) apply (rule conjI) apply (rule_tac S="{tcb_ptr_to_ctcb_ptr (ksCurThread \)}" @@ -1426,8 +1419,6 @@ lemma fastpath_enqueue_ccorres: assumption+, auto dest!: map_to_ko_atI)[1] apply (simp add: carch_state_relation_def typ_heap_simps' update_ep_map_tos cmachine_state_relation_def h_t_valid_clift_Some_iff) - apply (erule cready_queues_relation_null_queue_ptrs) - apply (rule ext, simp add: tcb_null_ep_ptrs_def split: if_split) done lemma setCTE_rf_sr: @@ -2060,9 +2051,6 @@ proof - apply (erule cmap_relation_updI, erule ko_at_projectKO_opt) apply (simp add: ctcb_relation_def cthread_state_relation_def) apply simp - apply (rule conjI, erule cready_queues_relation_not_queue_ptrs) - apply (rule ext, simp split: if_split add: typ_heap_simps') - apply (rule ext, simp split: if_split add: typ_heap_simps') apply (simp add: carch_state_relation_def cmachine_state_relation_def typ_heap_simps' map_comp_update projectKO_opt_tcb cvariable_relation_upd_const ko_at_projectKO_opt) @@ -2187,9 +2175,6 @@ proof - apply (erule cmap_relation_updI, erule ko_at_projectKO_opt) apply (simp add: ctcb_relation_def cthread_state_relation_def) apply simp - apply (rule conjI, erule cready_queues_relation_not_queue_ptrs) - apply (rule ext, simp split: if_split) - apply (rule ext, simp split: if_split) apply (simp add: carch_state_relation_def cmachine_state_relation_def typ_heap_simps' map_comp_update projectKO_opt_tcb cvariable_relation_upd_const ko_at_projectKO_opt) @@ -2381,7 +2366,7 @@ proof - apply (rule conjI) (* isReceive on queued tcb state *) apply (fastforce simp: st_tcb_at_tcbs_of isBlockedOnReceive_def isReceive_def) apply clarsimp - apply (rule conjI, fastforce dest!: invs_queues simp: valid_queues_def) + apply (rule conjI, fastforce dest!: simp: valid_queues_def) apply (frule invs_mdb', clarsimp simp: valid_mdb'_def valid_mdb_ctes_def) apply (case_tac xb, clarsimp, drule(1) nullcapsD') apply (clarsimp simp: pde_stored_asid_def to_bool_def @@ -2870,9 +2855,6 @@ lemma fastpath_reply_recv_ccorres: ThreadState_defs) apply (clarsimp simp: ccap_relation_ep_helpers) apply simp - apply (rule conjI, erule cready_queues_relation_not_queue_ptrs) - apply (rule ext, simp split: if_split) - apply (rule ext, simp split: if_split) apply (simp add: carch_state_relation_def cmachine_state_relation_def typ_heap_simps' map_comp_update projectKO_opt_tcb cvariable_relation_upd_const ko_at_projectKO_opt) @@ -2949,9 +2931,6 @@ lemma fastpath_reply_recv_ccorres: apply (erule cmap_relation_updI, erule ko_at_projectKO_opt) apply (simp add: ctcb_relation_def cthread_state_relation_def) apply simp - apply (rule conjI, erule cready_queues_relation_not_queue_ptrs) - apply (rule ext, simp split: if_split) - apply (rule ext, simp split: if_split) apply (simp add: carch_state_relation_def cmachine_state_relation_def typ_heap_simps' map_comp_update projectKO_opt_tcb cvariable_relation_upd_const ko_at_projectKO_opt) @@ -3072,8 +3051,6 @@ lemma fastpath_reply_recv_ccorres: apply (clarsimp simp: ct_in_state'_def obj_at_tcbs_of word_sle_def) apply (clarsimp simp add: invs_ksCurDomain_maxDomain') apply (rule conjI, fastforce) - apply (frule invs_queues) - apply (simp add: valid_queues_def) apply (frule tcbs_of_aligned') apply (simp add:invs_pspace_aligned') apply (frule tcbs_of_cte_wp_at_caller) @@ -3103,6 +3080,11 @@ lemma fastpath_reply_recv_ccorres: invs_valid_pde_mappings' obj_at_tcbs_of dest!: isValidVTableRootD) apply (frule invs_mdb') + apply (frule invs_valid_objs') + apply (frule invs_valid_bitmaps) + apply (frule valid_bitmaps_bitmapQ_no_L1_orphans) + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') apply (clarsimp simp: cte_wp_at_ctes_of tcbSlots cte_level_bits_def makeObject_cte isValidVTableRoot_def @@ -3110,10 +3092,10 @@ lemma fastpath_reply_recv_ccorres: pde_stored_asid_def to_bool_def valid_mdb'_def valid_tcb_state'_def word_le_nat_alt[symmetric] length_msgRegisters) - apply (frule ko_at_valid_ep', fastforce) apply (rule conjI) - subgoal (* dest thread domain \ maxDomain *) - by (drule (1) tcbs_of_valid_tcb'[OF invs_valid_objs'], solves \clarsimp simp: valid_tcb'_def\) + apply (fastforce dest: tcbs_of_valid_tcb' simp: valid_tcb'_def opt_map_def + split: option.splits) + apply (frule ko_at_valid_ep', fastforce) apply clarsimp apply (safe del: notI disjE)[1] apply (simp add: isSendEP_def valid_ep'_def tcb_at_invs' diff --git a/proof/crefine/ARM/Fastpath_Equiv.thy b/proof/crefine/ARM/Fastpath_Equiv.thy index 036a334477..1c138569b5 100644 --- a/proof/crefine/ARM/Fastpath_Equiv.thy +++ b/proof/crefine/ARM/Fastpath_Equiv.thy @@ -31,13 +31,9 @@ lemma getEndpoint_obj_at': lemmas setEndpoint_obj_at_tcb' = setEndpoint_obj_at'_tcb -lemma tcbSchedEnqueue_tcbContext[wp]: - "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ - tcbSchedEnqueue t' - \\rv. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" - apply (rule tcbSchedEnqueue_obj_at_unchangedT[OF all_tcbI]) - apply simp - done +crunches tcbSchedEnqueue + for tcbContext[wp]: "obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t" + (simp: tcbQueuePrepend_def) lemma setCTE_tcbContext: "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ @@ -50,19 +46,17 @@ lemma setCTE_tcbContext: context begin interpretation Arch . (*FIXME: arch_split*) lemma setThreadState_tcbContext: - "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ - setThreadState a b - \\_. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" - apply (rule setThreadState_obj_at_unchanged) - apply (clarsimp simp: atcbContext_def)+ + "setThreadState st tptr \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + unfolding setThreadState_def rescheduleRequired_def + apply (wpsimp wp: threadSet_wp hoare_drop_imps) + apply (fastforce simp: obj_at'_def objBits_simps projectKOs atcbContext_def ps_clear_upd) done lemma setBoundNotification_tcbContext: - "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ - setBoundNotification a b - \\_. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" - apply (rule setBoundNotification_obj_at_unchanged) - apply (clarsimp simp: atcbContext_def)+ + "setBoundNotification ntfnPtr tptr \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + unfolding setBoundNotification_def + apply (wpsimp wp: threadSet_wp hoare_drop_imps) + apply (fastforce simp: obj_at'_def objBits_simps projectKOs) done declare comp_apply [simp del] @@ -127,13 +121,15 @@ lemma of_bl_from_bool: lemma dmo_clearExMonitor_setCurThread_swap: "(do _ \ doMachineOp ARM.clearExMonitor; - setCurThread thread - od) - = (do _ \ setCurThread thread; - doMachineOp ARM.clearExMonitor od)" - apply (simp add: setCurThread_def doMachineOp_def split_def) - apply (rule oblivious_modify_swap[symmetric]) - apply (intro oblivious_bind, simp_all) + setCurThread thread + od) + = (do _ \ setCurThread thread; + doMachineOp ARM.clearExMonitor + od)" + apply (clarsimp simp: ARM.clearExMonitor_def) + apply (simp add: doMachineOp_modify) + apply (rule oblivious_modify_swap) + apply (fastforce intro: oblivious_bind simp: setCurThread_def idleThreadNotQueued_def) done lemma pd_at_asid_inj': @@ -508,11 +504,39 @@ lemma setThreadState_runnable_bitmap_inv: crunches curDomain for (no_fail) no_fail[intro!, wp, simp] +lemma setThreadState_tcbDomain_tcbPriority_obj_at'[wp]: + "setThreadState ts t \obj_at' (\tcb. P (tcbDomain tcb) (tcbPriority tcb)) t'\" + unfolding setThreadState_def rescheduleRequired_def tcbSchedEnqueue_def tcbQueuePrepend_def + apply (wpsimp wp: threadSet_wp hoare_drop_imps threadGet_wp simp: setQueue_def bitmap_fun_defs) + apply (fastforce simp: obj_at'_def st_tcb_at'_def objBits_simps projectKOs) + done + +lemma setThreadState_tcbQueued_obj_at'[wp]: + "setThreadState ts t \obj_at' (\tcb. P (tcbQueued tcb)) t'\" + unfolding setThreadState_def rescheduleRequired_def tcbSchedEnqueue_def tcbQueuePrepend_def + apply (wpsimp wp: threadSet_wp hoare_drop_imps threadGet_wp simp: setQueue_def bitmap_fun_defs) + apply (fastforce simp: obj_at'_def st_tcb_at'_def objBits_simps projectKOs) + done + +lemma setThreadState_tcbFault_obj_at'[wp]: + "setThreadState ts t \obj_at' (\tcb. P (tcbFault tcb)) t'\" + unfolding setThreadState_def rescheduleRequired_def tcbSchedEnqueue_def tcbQueuePrepend_def + apply (wpsimp wp: threadSet_wp hoare_drop_imps threadGet_wp simp: setQueue_def bitmap_fun_defs) + apply (fastforce simp: obj_at'_def st_tcb_at'_def objBits_simps projectKOs) + done + +lemma setThreadState_tcbArch_obj_at'[wp]: + "setThreadState ts t \obj_at' (\tcb. P (tcbArch tcb)) t'\" + unfolding setThreadState_def rescheduleRequired_def tcbSchedEnqueue_def tcbQueuePrepend_def + apply (wpsimp wp: threadSet_wp hoare_drop_imps threadGet_wp simp: setQueue_def bitmap_fun_defs) + apply (fastforce simp: obj_at'_def st_tcb_at'_def objBits_simps projectKOs) + done + lemma fastpath_callKernel_SysCall_corres: "monadic_rewrite True False (invs' and ct_in_state' ((=) Running) and (\s. ksSchedulerAction s = ResumeCurrentThread) - and (\s. ksDomainTime s \ 0)) + and (\s. ksDomainTime s \ 0) and ready_qs_runnable) (callKernel (SyscallEvent SysCall)) (fastpaths SysCall)" supply if_cong[cong] option.case_cong[cong] if_split[split del] supply empty_fail_getMRs[wp] (* FIXME *) @@ -669,22 +693,18 @@ lemma fastpath_callKernel_SysCall_corres: apply wp[1] apply (simp cong: if_cong HOL.conj_cong add: if_bool_simps) apply (simp_all only:)[5] - apply ((wp setThreadState_oa_queued[of _ "\a _ _. \ a"] - setThreadState_obj_at_unchanged - asUser_obj_at_unchanged mapM_x_wp' + apply ((wp asUser_obj_at_unchanged mapM_x_wp' sts_st_tcb_at'_cases setThreadState_no_sch_change setEndpoint_obj_at_tcb' fastpathBestSwitchCandidate_lift[where f="setThreadState f t" for f t] - setThreadState_oa_queued fastpathBestSwitchCandidate_lift[where f="asUser t f" for f t] fastpathBestSwitchCandidate_lift[where f="setEndpoint a b" for a b] lookupBitmapPriority_lift setThreadState_runnable_bitmap_inv getEndpoint_obj_at' - | simp add: setMessageInfo_def + | simp add: setMessageInfo_def obj_at'_conj | wp (once) hoare_vcg_disj_lift)+) - apply (simp add: setThreadState_runnable_simp getThreadCallerSlot_def getThreadReplySlot_def locateSlot_conv bind_assoc) @@ -791,8 +811,6 @@ lemma fastpath_callKernel_SysCall_corres: prefer 2 apply normalise_obj_at' apply clarsimp - apply (frule_tac t="blockedThread" in valid_queues_not_runnable_not_queued, assumption) - subgoal by (fastforce simp: st_tcb_at'_def elim: obj_at'_weakenE) apply (subgoal_tac "fastpathBestSwitchCandidate blockedThread s") prefer 2 apply (rule_tac ttcb=tcbb and ctcb=tcb in fastpathBestSwitchCandidateI) @@ -801,6 +819,9 @@ lemma fastpath_callKernel_SysCall_corres: apply (clarsimp simp: st_tcb_at'_def obj_at'_def objBits_simps projectKOs valid_mdb'_def valid_mdb_ctes_def inj_case_bool split: bool.split)+ + apply (clarsimp simp: ready_qs_runnable_def) + apply (drule_tac x=blockedThread in spec) + apply (clarsimp simp: obj_at'_def projectKOs st_tcb_at'_def objBits_simps) done lemma capability_case_Null_ReplyCap: @@ -957,14 +978,16 @@ crunch tcbContext[wp]: possibleSwitchTo "obj_at' (\tcb. P ( (atcbContext crunch only_cnode_caps[wp]: doFaultTransfer "\s. P (only_cnode_caps (ctes_of s))" (wp: crunch_wps simp: crunch_simps) +(* FIXME: monadic_rewrite_l does not work with stateAssert here *) lemma tcbSchedDequeue_rewrite_not_queued: "monadic_rewrite True False (tcb_at' t and obj_at' (Not \ tcbQueued) t) (tcbSchedDequeue t) (return ())" - apply (simp add: tcbSchedDequeue_def when_def) - apply (monadic_rewrite_l monadic_rewrite_if_l_False \wp threadGet_const\) - apply (monadic_rewrite_symb_exec_l, rule monadic_rewrite_refl) - apply wp+ - apply clarsimp + apply (simp add: tcbSchedDequeue_def) + apply wp_pre + apply monadic_rewrite_symb_exec_l + apply (monadic_rewrite_symb_exec_l_known False, simp) + apply (rule monadic_rewrite_refl) + apply (wpsimp wp: threadGet_const)+ done lemma schedule_known_rewrite: @@ -1003,7 +1026,7 @@ lemma schedule_known_rewrite: \wpsimp wp: Arch_switchToThread_obj_at_pre\) (* remove no-ops *) apply simp - apply (repeat 9 \rule monadic_rewrite_symb_exec_l\) (* until switchToThread *) + apply (repeat 13 \rule monadic_rewrite_symb_exec_l\) (* until switchToThread *) apply (rule monadic_rewrite_refl) apply (wpsimp simp: isHighestPrio_def')+ apply (clarsimp simp: ct_in_state'_def not_pred_tcb_at'_strengthen @@ -1265,18 +1288,12 @@ crunches setThreadState, emptySlot, asUser (wp: obj_at_setObject2 crunch_wps simp: crunch_simps updateObject_default_def in_monad) -lemma st_tcb_at_is_Reply_imp_not_tcbQueued: "\s t.\ invs' s; st_tcb_at' isReply t s\ \ obj_at' (\a. \ tcbQueued a) t s" - apply (clarsimp simp: invs'_def valid_state'_def valid_queues_def st_tcb_at'_def valid_queues_no_bitmap_def) - apply (rule all_prio_not_inQ_not_tcbQueued) - apply (clarsimp simp: obj_at'_def) - apply (erule_tac x="d" in allE) - apply (erule_tac x="p" in allE) - apply (erule conjE) - apply (erule_tac x="t" in ballE) - apply (clarsimp simp: obj_at'_def runnable'_def isReply_def) - apply (case_tac "tcbState obj") - apply ((clarsimp simp: inQ_def)+)[8] - apply (clarsimp simp: valid_queues'_def obj_at'_def) +lemma st_tcb_at_is_Reply_imp_not_tcbQueued: + "\s t. \ ready_qs_runnable s; st_tcb_at' isReply t s\ \ obj_at' (\tcb. \ tcbQueued tcb) t s" + apply (clarsimp simp: ready_qs_runnable_def) + apply (drule_tac x=t in spec) + apply (clarsimp simp: st_tcb_at'_def obj_at'_def isReply_def) + apply (case_tac "tcbState obj"; clarsimp) done lemma valid_objs_ntfn_at_tcbBoundNotification: @@ -1332,7 +1349,7 @@ lemma tcbSchedEnqueue_tcbIPCBuffer: "\obj_at' (\tcb. P (tcbIPCBuffer tcb)) t\ tcbSchedEnqueue t' \\_. obj_at' (\tcb. P (tcbIPCBuffer tcb)) t\" - apply (simp add: tcbSchedEnqueue_def unless_when) + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_when) apply (wp threadSet_obj_at' hoare_drop_imps threadGet_wp |simp split: if_split)+ done @@ -1358,10 +1375,20 @@ crunch obj_at'_tcbIPCBuffer[wp]: emptySlot "obj_at' (\tcb. P (tcbIPCBuff crunches getBoundNotification for (no_fail) no_fail[intro!, wp, simp] +lemma threadSet_tcb_at'[wp]: + "threadSet f t' \\s. P (tcb_at' addr s)\" + apply (wpsimp wp: threadSet_wp) + apply (erule rsubst[where P=P]) + by (clarsimp simp: obj_at'_def projectKOs ps_clear_upd objBits_simps) + +crunches rescheduleRequired, tcbSchedDequeue, setThreadState, setBoundNotification + for tcb''[wp]: "\s. P (tcb_at' addr s)" + (wp: crunch_wps) + lemma fastpath_callKernel_SysReplyRecv_corres: "monadic_rewrite True False (invs' and ct_in_state' ((=) Running) and (\s. ksSchedulerAction s = ResumeCurrentThread) - and cnode_caps_gsCNodes') + and cnode_caps_gsCNodes' and ready_qs_runnable) (callKernel (SyscallEvent SysReplyRecv)) (fastpaths SysReplyRecv)" including classic_wp_pre supply if_cong[cong] option.case_cong[cong] @@ -1491,8 +1518,7 @@ lemma fastpath_callKernel_SysReplyRecv_corres: and thread=thread in possibleSwitchTo_rewrite)) | rule cteDeleteOne_replycap_rewrite | rule monadic_rewrite_bind monadic_rewrite_refl - | wp assert_inv mapM_x_wp' - setThreadState_obj_at_unchanged + | wp assert_inv mapM_x_wp' sts_valid_objs' asUser_obj_at_unchanged hoare_strengthen_post[OF _ obj_at_conj'[simplified atomize_conjL], rotated] lookupBitmapPriority_lift @@ -1558,8 +1584,8 @@ lemma fastpath_callKernel_SysReplyRecv_corres: | wps)+)[3] apply (simp cong: rev_conj_cong) apply (wpsimp wp: setThreadState_tcbContext[simplified comp_apply] - setThreadState_oa_queued user_getreg_rv - setThreadState_no_sch_change setThreadState_obj_at_unchanged + user_getreg_rv + setThreadState_no_sch_change sts_valid_objs' sts_st_tcb_at'_cases sts_bound_tcb_at' fastpathBestSwitchCandidate_lift[where f="setThreadState s t" for s t] hoare_weak_lift_imp hoare_vcg_all_lift hoare_vcg_imp_lift @@ -1567,8 +1593,7 @@ lemma fastpath_callKernel_SysReplyRecv_corres: hoare_vcg_ex_lift | wps)+ apply (strengthen imp_consequent[where Q="tcb_at' t s" for t s]) - apply ((wp setThreadState_oa_queued user_getreg_rv setThreadState_no_sch_change - setThreadState_obj_at_unchanged + apply ((wp user_getreg_rv setThreadState_no_sch_change sts_st_tcb_at'_cases sts_bound_tcb_at' emptySlot_obj_at'_not_queued emptySlot_obj_at_ep emptySlot_tcbContext[simplified comp_apply] @@ -1742,7 +1767,9 @@ lemma fastpath_callKernel_SysReplyRecv_corres: apply (clarsimp simp: obj_at_tcbs_of tcbSlots cte_level_bits_def) apply (frule(1) st_tcb_at_is_Reply_imp_not_tcbQueued) - apply (auto simp: obj_at_tcbs_of tcbSlots + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (auto simp: obj_at_tcbs_of tcbSlots projectKOs cte_level_bits_def) done diff --git a/proof/crefine/ARM/Finalise_C.thy b/proof/crefine/ARM/Finalise_C.thy index d37db8dded..ddcfe445e6 100644 --- a/proof/crefine/ARM/Finalise_C.thy +++ b/proof/crefine/ARM/Finalise_C.thy @@ -17,6 +17,108 @@ declare if_split [split del] definition "option_map2 f m = option_map f \ m" +definition ksReadyQueues_head_end_2 :: "(domain \ priority \ ready_queue) \ bool" where + "ksReadyQueues_head_end_2 qs \ + \d p. tcbQueueHead (qs (d, p)) \ None \ tcbQueueEnd (qs (d, p)) \ None" + +abbreviation "ksReadyQueues_head_end s \ ksReadyQueues_head_end_2 (ksReadyQueues s)" + +lemmas ksReadyQueues_head_end_def = ksReadyQueues_head_end_2_def + +lemma ksReadyQueues_asrt_ksReadyQueues_head_end: + "ksReadyQueues_asrt s \ ksReadyQueues_head_end s" + by (fastforce dest: tcbQueueHead_iff_tcbQueueEnd + simp: ready_queue_relation_def ksReadyQueues_asrt_def ksReadyQueues_head_end_def) + +lemma tcbSchedEnqueue_ksReadyQueues_head_end[wp]: + "tcbSchedEnqueue tcbPtr \ksReadyQueues_head_end\" + unfolding tcbSchedEnqueue_def tcbQueuePrepend_def setQueue_def + apply (wpsimp wp: threadSet_wp threadGet_wp simp: bitmap_fun_defs) + apply (clarsimp simp: tcbQueueEmpty_def obj_at'_def ksReadyQueues_head_end_def split: if_splits) + done + +lemma ksReadyQueues_head_end_ksSchedulerAction_update[simp]: + "ksReadyQueues_head_end (s\ksSchedulerAction := ChooseNewThread\) = ksReadyQueues_head_end s" + by (simp add: ksReadyQueues_head_end_def) + +crunches rescheduleRequired + for ksReadyQueues_head_end[wp]: ksReadyQueues_head_end + +lemma setThreadState_ksReadyQueues_head_end[wp]: + "setThreadState ts tcbPtr \ksReadyQueues_head_end\" + unfolding setThreadState_def + by (wpsimp wp: threadSet_wp threadGet_wp simp: bitmap_fun_defs) + +definition ksReadyQueues_head_end_tcb_at'_2 :: + "(domain \ priority \ ready_queue) \ (obj_ref \ tcb) \ bool" where + "ksReadyQueues_head_end_tcb_at'_2 qs tcbs \ + \d p. (\head. tcbQueueHead (qs (d, p)) = Some head \ tcbs head \ None) + \ (\end. tcbQueueEnd (qs (d, p)) = Some end \ tcbs end \ None)" + +abbreviation "ksReadyQueues_head_end_tcb_at' s \ + ksReadyQueues_head_end_tcb_at'_2 (ksReadyQueues s) (tcbs_of' s)" + +lemmas ksReadyQueues_head_end_tcb_at'_def = ksReadyQueues_head_end_tcb_at'_2_def + +lemma ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at': + "\ksReadyQueues_asrt s; pspace_aligned' s; pspace_distinct' s\ + \ ksReadyQueues_head_end_tcb_at' s" + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def + ksReadyQueues_head_end_tcb_at'_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: list_queue_relation_def) + apply (intro conjI impI allI) + apply (case_tac "ts = []", clarsimp) + apply (fastforce dest!: heap_path_head hd_in_set + simp: opt_pred_def tcbQueueEmpty_def split: option.splits) + apply (fastforce simp: queue_end_valid_def opt_pred_def tcbQueueEmpty_def + split: option.splits) + done + +lemma tcbSchedEnqueue_ksReadyQueues_head_end_tcb_at'[wp]: + "tcbSchedEnqueue tcbPtr \ksReadyQueues_head_end_tcb_at'\" + unfolding tcbSchedEnqueue_def tcbQueuePrepend_def setQueue_def + apply (wpsimp wp: threadSet_wp threadGet_wp simp: bitmap_fun_defs) + apply (clarsimp simp: ksReadyQueues_head_end_tcb_at'_def split: if_splits) + done + +lemma ksReadyQueues_head_end_tcb_at'_ksSchedulerAction_update[simp]: + "ksReadyQueues_head_end_tcb_at' (s\ksSchedulerAction := ChooseNewThread\) + = ksReadyQueues_head_end_tcb_at' s" + by (simp add: ksReadyQueues_head_end_tcb_at'_def) + +crunches rescheduleRequired + for ksReadyQueues_head_end_tcb_at'[wp]: ksReadyQueues_head_end_tcb_at' + +lemma setThreadState_ksReadyQueues_head_end_tcb_at'[wp]: + "setThreadState ts tcbPtr \ksReadyQueues_head_end_tcb_at'\" + unfolding setThreadState_def + apply (wpsimp wp: threadSet_wp) + apply (fastforce simp: ksReadyQueues_head_end_tcb_at'_def split: if_splits) + done + +lemma head_end_ksReadyQueues_': + "\ (s, s') \ rf_sr; ksReadyQueues_head_end s; ksReadyQueues_head_end_tcb_at' s; + pspace_aligned' s; pspace_distinct' s; + d \ maxDomain; p \ maxPriority \ + \ head_C (index (ksReadyQueues_' (globals s')) (cready_queues_index_to_C d p)) = NULL + \ end_C (index (ksReadyQueues_' (globals s')) (cready_queues_index_to_C d p)) = NULL" + apply (frule (2) rf_sr_ctcb_queue_relation[where d=d and p=p]) + apply (clarsimp simp: ksReadyQueues_head_end_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: ksReadyQueues_head_end_tcb_at'_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: ctcb_queue_relation_def option_to_ctcb_ptr_def split: option.splits) + apply (rename_tac "end" head end_tcb head_tcb) + apply (prop_tac "tcb_at' head s \ tcb_at' end s") + apply (fastforce intro!: aligned'_distinct'_ko_wp_at'I + simp: obj_at'_real_def opt_map_def split: option.splits) + apply (fastforce dest: tcb_at_not_NULL) + done + lemma tcbSchedEnqueue_cslift_spec: "\s. \\\<^bsub>/UNIV\<^esub> \s. \d v. option_map2 tcbPriority_C (cslift s) \tcb = Some v \ unat v \ numPriorities @@ -28,7 +130,9 @@ lemma tcbSchedEnqueue_cslift_spec: \ None \ option_map2 tcbDomain_C (cslift s) (head_C (index \ksReadyQueues (unat (d*0x100 + v)))) - \ None)\ + \ None) + \ (head_C (index \ksReadyQueues (unat (d * 0x100 + v))) \ NULL + \ end_C (index \ksReadyQueues (unat (d * 0x100 + v))) \ NULL)\ Call tcbSchedEnqueue_'proc {s'. option_map2 tcbEPNext_C (cslift s') = option_map2 tcbEPNext_C (cslift s) \ option_map2 tcbEPPrev_C (cslift s') = option_map2 tcbEPPrev_C (cslift s) @@ -45,8 +149,8 @@ lemma tcbSchedEnqueue_cslift_spec: apply (rule conjI) apply (clarsimp simp: typ_heap_simps cong: if_cong) apply (simp split: if_split) - apply (clarsimp simp: typ_heap_simps if_Some_helper cong: if_cong) - by (simp split: if_split) + by (auto simp: typ_heap_simps' if_Some_helper numPriorities_def + cong: if_cong split: if_splits) lemma setThreadState_cslift_spec: "\s. \\\<^bsub>/UNIV\<^esub> \s. s \\<^sub>c \tptr \ (\x. ksSchedulerAction_' (globals s) = tcb_Ptr x @@ -141,8 +245,9 @@ lemma ctcb_relation_tcbPriority_maxPriority_numPriorities: done lemma tcbSchedEnqueue_cslift_precond_discharge: - "\ (s, s') \ rf_sr; obj_at' (P :: tcb \ bool) x s; - valid_queues s; valid_objs' s \ \ + "\ (s, s') \ rf_sr; obj_at' (P :: tcb \ bool) x s; valid_objs' s ; + ksReadyQueues_head_end s; ksReadyQueues_head_end_tcb_at' s; + pspace_aligned' s; pspace_distinct' s\ \ (\d v. option_map2 tcbPriority_C (cslift s') (tcb_ptr_to_ctcb_ptr x) = Some v \ unat v < numPriorities \ option_map2 tcbDomain_C (cslift s') (tcb_ptr_to_ctcb_ptr x) = Some d @@ -153,31 +258,49 @@ lemma tcbSchedEnqueue_cslift_precond_discharge: \ None \ option_map2 tcbDomain_C (cslift s') (head_C (index (ksReadyQueues_' (globals s')) (unat (d*0x100 + v)))) - \ None))" + \ None) + \ (head_C (index (ksReadyQueues_' (globals s')) (unat (d * 0x100 + v))) \ NULL + \ end_C (index (ksReadyQueues_' (globals s')) (unat (d * 0x100 + v))) \ NULL))" apply (drule(1) obj_at_cslift_tcb) apply (clarsimp simp: typ_heap_simps' option_map2_def) + apply (rename_tac tcb tcb') apply (frule_tac t=x in valid_objs'_maxPriority, fastforce simp: obj_at'_def) apply (frule_tac t=x in valid_objs'_maxDomain, fastforce simp: obj_at'_def) apply (drule_tac P="\tcb. tcbPriority tcb \ maxPriority" in obj_at_ko_at2', simp) apply (drule_tac P="\tcb. tcbDomain tcb \ maxDomain" in obj_at_ko_at2', simp) apply (simp add: ctcb_relation_tcbDomain_maxDomain_numDomains ctcb_relation_tcbPriority_maxPriority_numPriorities) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) + apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" in rf_sr_ctcb_queue_relation) apply (simp add: maxDom_to_H maxPrio_to_H)+ + apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" in head_end_ksReadyQueues_', fastforce+) apply (simp add: cready_queues_index_to_C_def2 numPriorities_def le_maxDomain_eq_less_numDomains) apply (clarsimp simp: ctcb_relation_def) - apply (frule arg_cong[where f=unat], subst(asm) unat_ucast_8_32) - apply (frule tcb_queue'_head_end_NULL) - apply (erule conjunct1[OF valid_queues_valid_q]) - apply (frule(1) tcb_queue_relation_qhead_valid') - apply (simp add: valid_queues_valid_q) - apply (clarsimp simp: h_t_valid_clift_Some_iff) + apply (frule arg_cong[where f=unat], subst(asm) unat_ucast_up_simp, simp) + apply (frule (3) head_end_ksReadyQueues_', fastforce+) + apply (clarsimp simp: ksReadyQueues_head_end_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (prop_tac "\ tcbQueueEmpty ((ksReadyQueues s (tcbDomain tcb, tcbPriority tcb)))") + apply (clarsimp simp: tcbQueueEmpty_def ctcb_queue_relation_def option_to_ctcb_ptr_def + split: option.splits) + apply (clarsimp simp: ksReadyQueues_head_end_tcb_at'_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (clarsimp simp: tcbQueueEmpty_def) + apply (rename_tac head "end" head_tcb end_tcb) + apply (prop_tac "tcb_at' head s") + apply (fastforce intro: aligned'_distinct'_ko_wp_at'I + simp: obj_at'_real_def opt_map_def split: option.splits) + apply (frule_tac thread=head in obj_at_cslift_tcb) + apply fastforce + apply (clarsimp dest: obj_at_cslift_tcb simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) done lemma cancel_all_ccorres_helper: "ccorres dc xfdc - (\s. valid_objs' s \ valid_queues s + (\s. valid_objs' s \ pspace_aligned' s \ pspace_distinct' s + \ ksReadyQueues_head_end s \ ksReadyQueues_head_end_tcb_at' s \ (\t\set ts. tcb_at' t s \ t \ 0) \ sch_act_wf (ksSchedulerAction s) s) {s'. \p. ep_queue_relation (cslift s') ts @@ -232,11 +355,11 @@ next apply (erule cmap_relationE1 [OF cmap_relation_tcb]) apply (erule ko_at_projectKO_opt) apply (fastforce intro: typ_heap_simps) - apply (wp sts_running_valid_queues | simp)+ + apply (wp sts_valid_objs' | simp)+ apply (rule ceqv_refl) apply (rule "Cons.hyps") apply (wp sts_valid_objs' sts_sch_act sch_act_wf_lift hoare_vcg_const_Ball_lift - sts_running_valid_queues sts_st_tcb' setThreadState_oa_queued | simp)+ + sts_st_tcb' | simp)+ apply (vcg exspec=setThreadState_cslift_spec exspec=tcbSchedEnqueue_cslift_spec) apply (clarsimp simp: tcb_at_not_NULL Collect_const_mem valid_tcb_state'_def @@ -250,16 +373,13 @@ next st_tcb_at'_def split: scheduler_action.split_asm) apply (rename_tac word) - apply (frule_tac x=word in tcbSchedEnqueue_cslift_precond_discharge) - apply simp - apply clarsimp - apply clarsimp - apply clarsimp + apply (frule_tac x=word in tcbSchedEnqueue_cslift_precond_discharge; clarsimp?) + apply simp apply clarsimp apply (rule conjI) apply (frule(3) tcbSchedEnqueue_cslift_precond_discharge) apply clarsimp - apply clarsimp + apply clarsimp+ apply (subst ep_queue_relation_shift, fastforce) apply (drule_tac x="tcb_ptr_to_ctcb_ptr thread" in fun_cong)+ @@ -268,11 +388,17 @@ next done qed +crunches setEndpoint, setNotification + for ksReadyQueues_head_end[wp]: ksReadyQueues_head_end + and ksReadyQueues_head_end_tcb_at'[wp]: ksReadyQueues_head_end_tcb_at' + (simp: updateObject_default_def) + lemma cancelAllIPC_ccorres: "ccorres dc xfdc - (invs') (UNIV \ {s. epptr_' s = Ptr epptr}) [] + invs' (UNIV \ {s. epptr_' s = Ptr epptr}) [] (cancelAllIPC epptr) (Call cancelAllIPC_'proc)" apply (cinit lift: epptr_') + apply (rule ccorres_stateAssert) apply (rule ccorres_symb_exec_l [OF _ getEndpoint_inv _ empty_fail_getEndpoint]) apply (rule_tac xf'=ret__unsigned_' and val="case ep of IdleEP \ scast EPState_Idle @@ -287,7 +413,7 @@ lemma cancelAllIPC_ccorres: apply (simp add: cendpoint_relation_def Let_def split: endpoint.split_asm) apply ceqv - apply (rule_tac A="invs' and ko_at' ep epptr" + apply (rule_tac A="invs' and ksReadyQueues_asrt and ko_at' ep epptr" in ccorres_guard_imp2[where A'=UNIV]) apply wpc apply (rename_tac list) @@ -327,12 +453,11 @@ lemma cancelAllIPC_ccorres: apply ceqv apply (ctac add: rescheduleRequired_ccorres) apply (wp weak_sch_act_wf_lift_linear - cancelAllIPC_mapM_x_valid_queues | simp)+ apply (rule mapM_x_wp', wp)+ apply (wp sts_st_tcb') apply (clarsimp split: if_split) - apply (rule mapM_x_wp', wp)+ + apply (rule mapM_x_wp', wp sts_valid_objs')+ apply (clarsimp simp: valid_tcb_state'_def) apply (simp add: guard_is_UNIV_def) apply (wp set_ep_valid_objs' hoare_vcg_const_Ball_lift @@ -374,22 +499,26 @@ lemma cancelAllIPC_ccorres: apply (rule cancel_all_ccorres_helper) apply ceqv apply (ctac add: rescheduleRequired_ccorres) - apply (wp cancelAllIPC_mapM_x_valid_queues) - apply (wp mapM_x_wp' weak_sch_act_wf_lift_linear + apply (wp mapM_x_wp' weak_sch_act_wf_lift_linear sts_valid_objs' sts_st_tcb' | clarsimp simp: valid_tcb_state'_def split: if_split)+ apply (simp add: guard_is_UNIV_def) apply (wp set_ep_valid_objs' hoare_vcg_const_Ball_lift weak_sch_act_wf_lift_linear) apply vcg - apply (clarsimp simp: valid_ep'_def invs_valid_objs' invs_queues) + apply (clarsimp simp: valid_ep'_def invs_valid_objs') apply (rule cmap_relationE1[OF cmap_relation_ep], assumption) apply (erule ko_at_projectKO_opt) apply (frule obj_at_valid_objs', clarsimp+) - apply (clarsimp simp: projectKOs valid_obj'_def valid_ep'_def) - subgoal by (auto simp: typ_heap_simps cendpoint_relation_def - Let_def tcb_queue_relation'_def - invs_valid_objs' valid_objs'_maxDomain valid_objs'_maxPriority - intro!: obj_at_conj') + apply (clarsimp simp: valid_obj'_def valid_ep'_def) + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (frule ksReadyQueues_asrt_ksReadyQueues_head_end) + apply (frule (2) ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at') + subgoal + by (auto simp: typ_heap_simps cendpoint_relation_def + Let_def tcb_queue_relation'_def projectKOs + invs_valid_objs' valid_objs'_maxDomain valid_objs'_maxPriority + intro!: obj_at_conj') apply (clarsimp simp: guard_is_UNIV_def) apply (wp getEndpoint_wp) apply clarsimp @@ -397,9 +526,10 @@ lemma cancelAllIPC_ccorres: lemma cancelAllSignals_ccorres: "ccorres dc xfdc - (invs') (UNIV \ {s. ntfnPtr_' s = Ptr ntfnptr}) [] + invs' (UNIV \ {s. ntfnPtr_' s = Ptr ntfnptr}) [] (cancelAllSignals ntfnptr) (Call cancelAllSignals_'proc)" apply (cinit lift: ntfnPtr_') + apply (rule ccorres_stateAssert) apply (rule ccorres_symb_exec_l [OF _ get_ntfn_inv' _ empty_fail_getNotification]) apply (rule_tac xf'=ret__unsigned_' and val="case ntfnObj ntfn of IdleNtfn \ scast NtfnState_Idle @@ -414,7 +544,7 @@ lemma cancelAllSignals_ccorres: apply (simp add: cnotification_relation_def Let_def split: ntfn.split_asm) apply ceqv - apply (rule_tac A="invs' and ko_at' ntfn ntfnptr" + apply (rule_tac A="invs' and ksReadyQueues_asrt and ko_at' ntfn ntfnptr" in ccorres_guard_imp2[where A'=UNIV]) apply wpc apply (simp add: notification_state_defs ccorres_cond_iffs) @@ -453,8 +583,7 @@ lemma cancelAllSignals_ccorres: apply (rule cancel_all_ccorres_helper) apply ceqv apply (ctac add: rescheduleRequired_ccorres) - apply (wp cancelAllIPC_mapM_x_valid_queues) - apply (wp mapM_x_wp' weak_sch_act_wf_lift_linear + apply (wp mapM_x_wp' weak_sch_act_wf_lift_linear sts_valid_objs' sts_st_tcb' | clarsimp simp: valid_tcb_state'_def split: if_split)+ apply (simp add: guard_is_UNIV_def) apply (wp set_ntfn_valid_objs' hoare_vcg_const_Ball_lift @@ -464,11 +593,16 @@ lemma cancelAllSignals_ccorres: apply (rule cmap_relationE1[OF cmap_relation_ntfn], assumption) apply (erule ko_at_projectKO_opt) apply (frule obj_at_valid_objs', clarsimp+) - apply (clarsimp simp add: valid_obj'_def valid_ntfn'_def projectKOs) - subgoal by (auto simp: typ_heap_simps cnotification_relation_def - Let_def tcb_queue_relation'_def - invs_valid_objs' valid_objs'_maxDomain valid_objs'_maxPriority - intro!: obj_at_conj') + apply (clarsimp simp add: valid_obj'_def valid_ntfn'_def) + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (frule ksReadyQueues_asrt_ksReadyQueues_head_end) + apply (frule (2) ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at') + subgoal + by (auto simp: typ_heap_simps cnotification_relation_def + Let_def tcb_queue_relation'_def projectKOs + invs_valid_objs' valid_objs'_maxDomain valid_objs'_maxPriority + intro!: obj_at_conj') apply (clarsimp simp: guard_is_UNIV_def) apply (wp getNotification_wp) apply clarsimp @@ -515,16 +649,16 @@ lemma tcb_queue_relation2_concat: context kernel_m begin -lemma setThreadState_ccorres_valid_queues'_simple: - "ccorres dc xfdc (\s. tcb_at' thread s \ valid_queues' s \ \ runnable' st \ sch_act_simple s) +lemma setThreadState_ccorres_simple: + "ccorres dc xfdc (\s. tcb_at' thread s \ \ runnable' st \ sch_act_simple s) ({s'. (\cl fl. cthread_state_relation_lifted st (cl\tsType_CL := ts_' s' && mask 4\, fl))} \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) [] (setThreadState st thread) (Call setThreadState_'proc)" apply (cinit lift: tptr_' cong add: call_ignore_cong) apply (ctac (no_vcg) add: threadSet_tcbState_simple_corres) apply (ctac add: scheduleTCB_ccorres_valid_queues'_simple) - apply (wp threadSet_valid_queues'_and_not_runnable') - apply (clarsimp simp: weak_sch_act_wf_def valid_queues'_def) + apply (wp threadSet_tcbState_st_tcb_at') + apply (fastforce simp: weak_sch_act_wf_def) done lemma updateRestartPC_ccorres: @@ -540,9 +674,7 @@ lemma updateRestartPC_ccorres: done crunches updateRestartPC - for valid_queues'[wp]: valid_queues' - and sch_act_simple[wp]: sch_act_simple - and valid_queues[wp]: Invariants_H.valid_queues + for sch_act_simple[wp]: sch_act_simple and valid_objs'[wp]: valid_objs' and tcb_at'[wp]: "tcb_at' p" @@ -586,21 +718,12 @@ lemma suspend_ccorres: apply (ctac (no_vcg) add: updateRestartPC_ccorres) apply (rule ccorres_return_Skip) apply ceqv - apply (ctac(no_vcg) add: setThreadState_ccorres_valid_queues'_simple) - apply (ctac add: tcbSchedDequeue_ccorres') - apply (rule_tac Q="\_. - (\s. \t' d p. (t' \ set (ksReadyQueues s (d, p)) \ - obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d - \ tcbPriority tcb = p) t' s \ - (t' \ thread \ st_tcb_at' runnable' t' s)) \ - distinct (ksReadyQueues s (d, p))) and valid_queues' and valid_objs' and tcb_at' thread" - in hoare_post_imp) + apply (ctac(no_vcg) add: setThreadState_ccorres_simple) + apply (ctac add: tcbSchedDequeue_ccorres) + apply (rule_tac Q="\_. valid_objs' and tcb_at' thread and pspace_aligned' and pspace_distinct'" + in hoare_post_imp) apply clarsimp - apply (drule_tac x="t" in spec) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp elim!: obj_at'_weakenE simp: inQ_def) - apply (wp sts_valid_queues_partial)[1] + apply (wp sts_valid_objs')[1] apply clarsimp apply (wpsimp simp: valid_tcb_state'_def) apply clarsimp @@ -609,15 +732,13 @@ lemma suspend_ccorres: apply clarsimp apply (rule conseqPre, vcg) apply (rule subset_refl) - apply (rule hoare_strengthen_post) + apply (rule hoare_strengthen_post) apply (rule hoare_vcg_conj_lift) apply (rule hoare_vcg_conj_lift) apply (rule cancelIPC_sch_act_simple) apply (rule cancelIPC_tcb_at'[where t=thread]) apply (rule delete_one_conc_fr.cancelIPC_invs) - apply (fastforce simp: invs_valid_queues' invs_queues invs_valid_objs' - valid_tcb_state'_def) - apply clarsimp + apply (fastforce simp: invs_valid_objs' valid_tcb_state'_def) apply (auto simp: ThreadState_defs) done diff --git a/proof/crefine/ARM/Interrupt_C.thy b/proof/crefine/ARM/Interrupt_C.thy index 71b31a6b1f..1295d8af50 100644 --- a/proof/crefine/ARM/Interrupt_C.thy +++ b/proof/crefine/ARM/Interrupt_C.thy @@ -249,7 +249,7 @@ lemma decodeIRQHandlerInvocation_ccorres: apply (simp add: syscall_error_to_H_cases) apply simp apply (clarsimp simp: Collect_const_mem tcb_at_invs') - apply (clarsimp simp: invs_queues invs_valid_objs' + apply (clarsimp simp: invs_valid_objs' ct_in_state'_def ccap_rights_relation_def mask_def[where n=4] ThreadState_defs) @@ -265,7 +265,7 @@ lemma decodeIRQHandlerInvocation_ccorres: excaps_map_def excaps_in_mem_def word_less_nat_alt hd_conv_nth slotcap_in_mem_def valid_tcb_state'_def dest!: interpret_excaps_eq split: bool.splits)+ - apply (auto dest: st_tcb_at_idle_thread' ctes_of_valid')[4] + apply (auto dest: st_tcb_at_idle_thread' ctes_of_valid')[6] apply (drule ctes_of_valid') apply fastforce apply (clarsimp simp add:valid_cap_simps' ARM.maxIRQ_def) diff --git a/proof/crefine/ARM/Invoke_C.thy b/proof/crefine/ARM/Invoke_C.thy index 024e10c7b8..16c9d309fb 100644 --- a/proof/crefine/ARM/Invoke_C.thy +++ b/proof/crefine/ARM/Invoke_C.thy @@ -79,15 +79,14 @@ lemma setDomain_ccorres: and (\s. curThread = ksCurThread s)" in hoare_strengthen_post) apply (wp threadSet_all_invs_but_sch_extra) - apply (clarsimp simp: valid_pspace_valid_objs' st_tcb_at_def[symmetric] - sch_act_simple_def st_tcb_at'_def weak_sch_act_wf_def - split: if_splits) + apply (fastforce simp: valid_pspace_valid_objs' st_tcb_at_def[symmetric] + sch_act_simple_def st_tcb_at'_def weak_sch_act_wf_def + split: if_splits) apply (simp add: guard_is_UNIV_def) - apply (rule_tac Q="\_. invs' and tcb_at' t and sch_act_simple - and (\s. curThread = ksCurThread s \ (\p. t \ set (ksReadyQueues s p)))" + apply (rule_tac Q="\_. invs' and tcb_at' t and sch_act_simple and (\s. curThread = ksCurThread s)" in hoare_strengthen_post) apply (wp weak_sch_act_wf_lift_linear tcbSchedDequeue_not_queued - tcbSchedDequeue_not_in_queue hoare_vcg_imp_lift hoare_vcg_all_lift) + hoare_vcg_imp_lift hoare_vcg_all_lift) apply (clarsimp simp: invs'_def valid_pspace'_def valid_state'_def) apply (fastforce simp: valid_tcb'_def tcb_cte_cases_def invs'_def valid_state'_def valid_pspace'_def) @@ -195,8 +194,8 @@ lemma decodeDomainInvocation_ccorres: apply clarsimp apply (vcg exspec=getSyscallArg_modifies) - apply (clarsimp simp: valid_tcb_state'_def invs_valid_queues' invs_valid_objs' - invs_queues invs_sch_act_wf' ct_in_state'_def pred_tcb_at' + apply (clarsimp simp: valid_tcb_state'_def invs_valid_objs' + invs_sch_act_wf' ct_in_state'_def pred_tcb_at' rf_sr_ksCurThread word_sle_def word_sless_def sysargs_rel_to_n mask_eq_iff_w2p mask_eq_iff_w2p word_size ThreadState_defs) apply (rule conjI) @@ -206,7 +205,7 @@ lemma decodeDomainInvocation_ccorres: apply (drule_tac x="extraCaps ! 0" and P="\v. valid_cap' (fst v) s" in bspec) apply (clarsimp simp: nth_mem interpret_excaps_test_null excaps_map_def) apply (clarsimp simp: valid_cap_simps' pred_tcb'_weakenE active_runnable') - apply (rule conjI) + apply (intro conjI; fastforce?) apply (fastforce simp: tcb_st_refs_of'_def elim:pred_tcb'_weakenE) apply (simp add: word_le_nat_alt unat_ucast unat_numDomains_to_H le_maxDomain_eq_less_numDomains) apply (clarsimp simp: ccap_relation_def cap_to_H_simps cap_thread_cap_lift) @@ -750,15 +749,15 @@ lemma decodeCNodeInvocation_ccorres: apply simp apply (wp injection_wp_E[OF refl]) apply (rule hoare_post_imp_R) - apply (rule_tac Q'="\rv. valid_pspace' and valid_queues + apply (rule_tac Q'="\rv. valid_pspace' and valid_cap' rv and valid_objs' and tcb_at' thread and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_vcg_R_conj) apply (rule deriveCap_Null_helper[OF deriveCap_derived]) apply wp apply (clarsimp simp: cte_wp_at_ctes_of) - apply (simp add: is_derived'_def badge_derived'_def - valid_tcb_state'_def) + apply (fastforce simp: is_derived'_def badge_derived'_def + valid_tcb_state'_def) apply (simp add: Collect_const_mem all_ex_eq_helper) apply (vcg exspec=deriveCap_modifies) apply wp @@ -826,14 +825,14 @@ lemma decodeCNodeInvocation_ccorres: apply (simp add: conj_comms valid_tcb_state'_def) apply (wp injection_wp_E[OF refl]) apply (rule hoare_post_imp_R) - apply (rule_tac Q'="\rv. valid_pspace' and valid_queues + apply (rule_tac Q'="\rv. valid_pspace' and valid_cap' rv and valid_objs' and tcb_at' thread and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_vcg_R_conj) apply (rule deriveCap_Null_helper [OF deriveCap_derived]) apply wp apply (clarsimp simp: cte_wp_at_ctes_of) - apply (simp add: is_derived'_def badge_derived'_def) + apply (fastforce simp: is_derived'_def badge_derived'_def) apply (simp add: Collect_const_mem all_ex_eq_helper) apply (vcg exspec=deriveCap_modifies) apply (simp add: Collect_const_mem) @@ -941,12 +940,14 @@ lemma decodeCNodeInvocation_ccorres: apply (rule_tac Q'="\a b. cte_wp_at' (\x. True) a b \ invs' b \ tcb_at' thread b \ sch_act_wf (ksSchedulerAction b) b \ valid_tcb_state' Restart b \ Q2 b" for Q2 in hoare_post_imp_R) - prefer 2 - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (drule ctes_of_valid') - apply (erule invs_valid_objs') - apply (clarsimp simp:valid_updateCapDataI invs_queues invs_valid_objs' invs_valid_pspace') - apply (assumption) + prefer 2 + apply (clarsimp simp:cte_wp_at_ctes_of) + apply (drule ctes_of_valid') + apply (erule invs_valid_objs') + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (clarsimp simp:valid_updateCapDataI invs_valid_objs' invs_valid_pspace') + apply assumption apply (wp hoare_vcg_all_lift_R injection_wp_E[OF refl] lsfco_cte_at' hoare_vcg_const_imp_lift_R )+ @@ -1341,7 +1342,7 @@ lemma decodeCNodeInvocation_ccorres: apply simp apply (vcg exspec=getSyscallArg_modifies) apply (clarsimp simp: valid_tcb_state'_def invs_valid_objs' invs_valid_pspace' - ct_in_state'_def pred_tcb_at' invs_queues + ct_in_state'_def pred_tcb_at' cur_tcb'_def word_sle_def word_sless_def unat_lt2p[where 'a=32, folded word_bits_def]) apply (rule conjI) @@ -1372,9 +1373,6 @@ end context begin interpretation Arch . (*FIXME: arch_split*) -crunch valid_queues[wp]: insertNewCap "valid_queues" - (wp: crunch_wps) - lemma setCTE_sch_act_wf[wp]: "\ \s. sch_act_wf (ksSchedulerAction s) s \ setCTE src cte @@ -3099,8 +3097,7 @@ lemma decodeUntypedInvocation_ccorres_helper: | Some n \ args ! 4 + args ! 5 - 1 < 2 ^ n) and sch_act_simple and ct_active'" in hoare_post_imp_R) prefer 2 - apply (clarsimp simp: invs_valid_objs' invs_mdb' - invs_queues ct_in_state'_def pred_tcb_at') + apply (clarsimp simp: invs_valid_objs' invs_mdb' ct_in_state'_def pred_tcb_at') apply (subgoal_tac "ksCurThread s \ ksIdleThread sa") prefer 2 apply clarsimp diff --git a/proof/crefine/ARM/IpcCancel_C.thy b/proof/crefine/ARM/IpcCancel_C.thy index 8d60f75ba6..b872f9e13a 100644 --- a/proof/crefine/ARM/IpcCancel_C.thy +++ b/proof/crefine/ARM/IpcCancel_C.thy @@ -15,12 +15,12 @@ begin declare ctcb_size_bits_ge_4[simp] lemma cready_queues_index_to_C_in_range': - assumes prems: "qdom \ ucast maxDom" "prio \ ucast maxPrio" + assumes prems: "qdom \ maxDomain" "prio \ maxPriority" shows "cready_queues_index_to_C qdom prio < num_tcb_queues" proof - have P: "unat prio < numPriorities" using prems - by (simp add: numPriorities_def seL4_MaxPrio_def Suc_le_lessD unat_le_helper) + by (simp add: numPriorities_def Suc_le_lessD unat_le_helper maxDomain_def maxPriority_def) have Q: "unat qdom < numDomains" using prems by (simp add: maxDom_to_H le_maxDomain_eq_less_numDomains word_le_nat_alt) @@ -34,28 +34,18 @@ lemmas cready_queues_index_to_C_in_range = lemma cready_queues_index_to_C_inj: "\ cready_queues_index_to_C qdom prio = cready_queues_index_to_C qdom' prio'; - prio \ ucast maxPrio; prio' \ ucast maxPrio \ \ prio = prio' \ qdom = qdom'" + prio \ maxPriority; prio' \ maxPriority \ \ prio = prio' \ qdom = qdom'" apply (rule context_conjI) - apply (auto simp: cready_queues_index_to_C_def numPriorities_def + apply (auto simp: cready_queues_index_to_C_def numPriorities_def maxPriority_def seL4_MaxPrio_def word_le_nat_alt dest: arg_cong[where f="\x. x mod 256"]) done lemma cready_queues_index_to_C_distinct: - "\ qdom = qdom' \ prio \ prio'; prio \ ucast maxPrio; prio' \ ucast maxPrio \ + "\ qdom = qdom' \ prio \ prio'; prio \ maxPriority; prio' \ maxPriority \ \ cready_queues_index_to_C qdom prio \ cready_queues_index_to_C qdom' prio'" apply (auto simp: cready_queues_index_to_C_inj) done -lemma valid_queuesD': - "\ obj_at' (inQ d p) t s; valid_queues' s \ - \ t \ set (ksReadyQueues s (d, p))" - by (simp add: valid_queues'_def) - -lemma invs_valid_queues'[elim!]: - "invs' s \ valid_queues' s" - by (simp add: invs'_def valid_state'_def) - - lemma ntfn_ptr_get_queue_spec: "\s. \ \ {\. s = \ \ \ \\<^sub>c \<^bsup>\\<^esup>ntfnPtr} \ret__struct_tcb_queue_C :== PROC ntfn_ptr_get_queue(\ntfnPtr) \head_C \ret__struct_tcb_queue_C = Ptr (ntfnQueue_head_CL (notification_lift (the (cslift s \<^bsup>s\<^esup>ntfnPtr)))) \ @@ -200,22 +190,19 @@ lemma cancelSignal_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) apply simp - apply (erule (1) map_to_ko_atI') - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) - apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def) - apply (simp add: carch_state_relation_def carch_globals_def) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (erule (1) map_to_ko_atI') + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) + apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def) + apply (simp add: carch_state_relation_def carch_globals_def) apply (simp add: carch_state_relation_def carch_globals_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) @@ -238,30 +225,27 @@ lemma cancelSignal_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_ntfn_queue) - apply fastforce - apply assumption+ - apply simp - apply (erule (1) map_to_ko_atI') - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) - apply (simp add: cnotification_relation_def Let_def isWaitingNtfn_def - split: ntfn.splits split del: if_split) - apply (erule iffD1 [OF tcb_queue_relation'_cong [OF refl _ _ refl], rotated -1]) - apply (clarsimp simp add: Ptr_ptr_val h_t_valid_clift_Some_iff) - apply (simp add: tcb_queue_relation'_next_mask) - apply (clarsimp simp add: Ptr_ptr_val h_t_valid_clift_Some_iff) - apply (simp add: tcb_queue_relation'_prev_mask) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (rule cendpoint_relation_ntfn_queue) + apply fastforce + apply assumption+ + apply simp + apply (erule (1) map_to_ko_atI') + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) + apply (simp add: cnotification_relation_def Let_def isWaitingNtfn_def + split: ntfn.splits split del: if_split) + apply (erule iffD1 [OF tcb_queue_relation'_cong [OF refl _ _ refl], rotated -1]) + apply (clarsimp simp add: Ptr_ptr_val h_t_valid_clift_Some_iff) + apply (simp add: tcb_queue_relation'_next_mask) + apply (clarsimp simp add: Ptr_ptr_val h_t_valid_clift_Some_iff) + apply (simp add: tcb_queue_relation'_prev_mask) + apply simp apply (simp add: carch_state_relation_def carch_globals_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) @@ -387,68 +371,6 @@ lemma isRunnable_ccorres [corres]: apply (simp add: ThreadState_defs)+ done - - -lemma tcb_queue_relation_update_head: - fixes getNext_update :: "(tcb_C ptr \ tcb_C ptr) \ tcb_C \ tcb_C" and - getPrev_update :: "(tcb_C ptr \ tcb_C ptr) \ tcb_C \ tcb_C" - assumes qr: "tcb_queue_relation getNext getPrev mp queue NULL qhead" - and qh': "qhead' \ tcb_ptr_to_ctcb_ptr ` set queue" - and cs_tcb: "mp qhead' = Some tcb" - and valid_ep: "\t\set queue. tcb_at' t s" "distinct queue" - and qhN: "qhead' \ NULL" - and fgN: "fg_cons getNext (getNext_update \ (\x _. x))" - and fgP: "fg_cons getPrev (getPrev_update \ (\x _. x))" - and npu: "\f t. getNext (getPrev_update f t) = getNext t" - and pnu: "\f t. getPrev (getNext_update f t) = getPrev t" - shows "tcb_queue_relation getNext getPrev - (upd_unless_null qhead (getPrev_update (\_. qhead') (the (mp qhead))) - (mp(qhead' := Some (getPrev_update (\_. NULL) (getNext_update (\_. qhead) tcb))))) - (ctcb_ptr_to_tcb_ptr qhead' # queue) NULL qhead'" - using qr qh' cs_tcb valid_ep qhN - apply (subgoal_tac "qhead \ qhead'") - apply (clarsimp simp: pnu upd_unless_null_def fg_consD1 [OF fgN] fg_consD1 [OF fgP] pnu npu) - apply (cases queue) - apply simp - apply (frule (2) tcb_queue_relation_next_not_NULL) - apply simp - apply (clarsimp simp: fg_consD1 [OF fgN] fg_consD1 [OF fgP] pnu npu) - apply (subst tcb_queue_relation_cong [OF refl refl refl, where mp' = mp]) - apply (clarsimp simp: inj_eq) - apply (intro impI conjI) - apply (frule_tac x = x in imageI [where f = tcb_ptr_to_ctcb_ptr]) - apply simp - apply simp - apply simp - apply clarsimp - apply (cases queue) - apply simp - apply simp - done - -lemma tcbSchedEnqueue_update: - assumes sr: "sched_queue_relation' mp queue qhead qend" - and qh': "qhead' \ tcb_ptr_to_ctcb_ptr ` set queue" - and cs_tcb: "mp qhead' = Some tcb" - and valid_ep: "\t\set queue. tcb_at' t s" "distinct queue" - and qhN: "qhead' \ NULL" - shows - "sched_queue_relation' - (upd_unless_null qhead (tcbSchedPrev_C_update (\_. qhead') (the (mp qhead))) - (mp(qhead' \ tcb\tcbSchedNext_C := qhead, tcbSchedPrev_C := NULL\))) - (ctcb_ptr_to_tcb_ptr qhead' # queue) qhead' (if qend = NULL then qhead' else qend)" - using sr qh' cs_tcb valid_ep qhN - apply - - apply (erule tcb_queue_relationE') - apply (rule tcb_queue_relationI') - apply (erule (5) tcb_queue_relation_update_head - [where getNext_update = tcbSchedNext_C_update and getPrev_update = tcbSchedPrev_C_update], simp_all)[1] - apply simp - apply (intro impI) - apply (erule (1) tcb_queue_relation_not_NULL') - apply simp - done - lemma tcb_ptr_to_ctcb_ptr_imageD: "x \ tcb_ptr_to_ctcb_ptr ` S \ ctcb_ptr_to_tcb_ptr x \ S" apply (erule imageE) @@ -461,63 +383,8 @@ lemma ctcb_ptr_to_tcb_ptr_imageI: apply simp done -lemma tcb_queue'_head_end_NULL: - assumes qr: "tcb_queue_relation' getNext getPrev mp queue qhead qend" - and tat: "\t\set queue. tcb_at' t s" - shows "(qend = NULL) = (qhead = NULL)" - using qr tat - apply - - apply (erule tcb_queue_relationE') - apply (simp add: tcb_queue_head_empty_iff) - apply (rule impI) - apply (rule tcb_at_not_NULL) - apply (erule bspec) - apply simp - done - -lemma tcb_queue_relation_qhead_mem: - "\ tcb_queue_relation getNext getPrev mp queue NULL qhead; - (\tcb\set queue. tcb_at' tcb t) \ - \ qhead \ NULL \ ctcb_ptr_to_tcb_ptr qhead \ set queue" - by (clarsimp simp: tcb_queue_head_empty_iff tcb_queue_relation_head_hd) - -lemma tcb_queue_relation_qhead_valid: - "\ tcb_queue_relation getNext getPrev (cslift s') queue NULL qhead; - (s, s') \ rf_sr; (\tcb\set queue. tcb_at' tcb s) \ - \ qhead \ NULL \ s' \\<^sub>c qhead" - apply (frule (1) tcb_queue_relation_qhead_mem) - apply clarsimp - apply(drule (3) tcb_queue_memberD) - apply (simp add: h_t_valid_clift_Some_iff) - done - -lemmas tcb_queue_relation_qhead_mem' = tcb_queue_relation_qhead_mem [OF tcb_queue_relation'_queue_rel] -lemmas tcb_queue_relation_qhead_valid' = tcb_queue_relation_qhead_valid [OF tcb_queue_relation'_queue_rel] - - -lemma valid_queues_valid_q: - "valid_queues s \ (\tcb\set (ksReadyQueues s (qdom, prio)). tcb_at' tcb s) \ distinct (ksReadyQueues s (qdom, prio))" - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def) - apply (drule spec [where x = qdom]) - apply (drule spec [where x = prio]) - apply clarsimp - apply (drule (1) bspec, erule obj_at'_weakenE) - apply simp - done - declare unat_ucast_8_32[simp] -lemma rf_sr_sched_queue_relation: - "\ (s, s') \ rf_sr; d \ ucast maxDom; p \ ucast maxPrio \ - \ sched_queue_relation' (cslift s') (ksReadyQueues s (d, p)) - (head_C (index (ksReadyQueues_' (globals s')) - (cready_queues_index_to_C d p))) - (end_C (index (ksReadyQueues_' (globals s')) - (cready_queues_index_to_C d p)))" - unfolding rf_sr_def cstate_relation_def cready_queues_relation_def - apply (clarsimp simp: Let_def seL4_MinPrio_def minDom_def) - done - lemma threadSet_queued_ccorres [corres]: shows "ccorres dc xfdc (tcb_at' thread) {s. v32_' s = from_bool v \ thread_state_ptr_' s = Ptr &(tcb_ptr_to_ctcb_ptr thread\[''tcbState_C''])} [] @@ -537,139 +404,6 @@ lemma threadSet_queued_ccorres [corres]: apply (clarsimp simp: typ_heap_simps) done -lemma ccorres_pre_getQueue: - assumes cc: "\queue. ccorres r xf (P queue) (P' queue) hs (f queue) c" - shows "ccorres r xf (\s. P (ksReadyQueues s (d, p)) s \ d \ maxDomain \ p \ maxPriority) - {s'. \queue. (let cqueue = index (ksReadyQueues_' (globals s')) - (cready_queues_index_to_C d p) in - sched_queue_relation' (cslift s') queue (head_C cqueue) (end_C cqueue)) \ s' \ P' queue} - hs (getQueue d p >>= (\queue. f queue)) c" - apply (rule ccorres_guard_imp2) - apply (rule ccorres_symb_exec_l2) - defer - defer - apply (rule gq_sp) - defer - apply (rule ccorres_guard_imp) - apply (rule cc) - apply clarsimp - apply assumption - apply assumption - apply (clarsimp simp: getQueue_def gets_exs_valid) - apply clarsimp - apply (drule spec, erule mp) - apply (simp add: Let_def) - apply (erule rf_sr_sched_queue_relation) - apply (simp add: maxDom_to_H maxPrio_to_H)+ - done - -lemma state_relation_queue_update_helper': - "\ (s, s') \ rf_sr; - (\d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct (ksReadyQueues s (d, p))); - globals t = ksReadyQueues_'_update - (\_. Arrays.update (ksReadyQueues_' (globals s')) prio' q') - (t_hrs_'_update f (globals s')); - sched_queue_relation' (cslift t) q (head_C q') (end_C q'); - cslift t |` ( - tcb_ptr_to_ctcb_ptr ` S ) - = cslift s' |` ( - tcb_ptr_to_ctcb_ptr ` S ); - option_map tcb_null_sched_ptrs \ cslift t - = option_map tcb_null_sched_ptrs \ cslift s'; - cslift_all_but_tcb_C t s'; - zero_ranges_are_zero (gsUntypedZeroRanges s) (f (t_hrs_' (globals s'))) - = zero_ranges_are_zero (gsUntypedZeroRanges s) (t_hrs_' (globals s')); - hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s')); - prio' = cready_queues_index_to_C qdom prio; - \x \ S. obj_at' (inQ qdom prio) x s - \ (obj_at' (\tcb. tcbPriority tcb = prio) x s - \ obj_at' (\tcb. tcbDomain tcb = qdom) x s) - \ (tcb_at' x s \ (\d' p'. (d' \ qdom \ p' \ prio) - \ x \ set (ksReadyQueues s (d', p')))); - S \ {}; qdom \ ucast maxDom; prio \ ucast maxPrio \ - \ (s \ksReadyQueues := (ksReadyQueues s)((qdom, prio) := q)\, t) \ rf_sr" - apply (subst(asm) disj_imp_rhs) - apply (subst obj_at'_and[symmetric]) - apply (rule disjI1, erule obj_at'_weakenE, simp add: inQ_def) - apply (subst(asm) disj_imp_rhs) - apply (subst(asm) obj_at'_and[symmetric]) - apply (rule conjI, erule obj_at'_weakenE, simp) - apply (rule allI, rule allI) - apply (drule_tac x=d' in spec) - apply (drule_tac x=p' in spec) - apply clarsimp - apply (drule(1) bspec) - apply (clarsimp simp: inQ_def obj_at'_def) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def) - apply (intro conjI) - \ \cpspace_relation\ - apply (erule nonemptyE, drule(1) bspec) - apply (clarsimp simp: cpspace_relation_def) - apply (drule obj_at_ko_at', clarsimp) - apply (rule cmap_relationE1, assumption, - erule ko_at_projectKO_opt) - apply (frule null_sched_queue) - apply (frule null_sched_epD) - apply (intro conjI) - \ \tcb relation\ - apply (drule ctcb_relation_null_queue_ptrs, - simp_all)[1] - \ \endpoint relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (erule cendpoint_relation_upd_tcb_no_queues, simp+) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (erule cnotification_relation_upd_tcb_no_queues, simp+) - \ \ready queues\ - apply (simp add: cready_queues_relation_def Let_def cready_queues_index_to_C_in_range - seL4_MinPrio_def minDom_def) - apply clarsimp - apply (frule cready_queues_index_to_C_distinct, assumption+) - apply (clarsimp simp: cready_queues_index_to_C_in_range all_conj_distrib) - apply (rule iffD1 [OF tcb_queue_relation'_cong[OF refl], rotated -1], - drule spec, drule spec, erule mp, simp+) - apply clarsimp - apply (drule_tac x="tcb_ptr_to_ctcb_ptr x" in fun_cong)+ - apply (clarsimp simp: restrict_map_def - split: if_split_asm) - apply (simp_all add: carch_state_relation_def cmachine_state_relation_def - h_t_valid_clift_Some_iff) - done - -lemma state_relation_queue_update_helper: - "\ (s, s') \ rf_sr; valid_queues s; - globals t = ksReadyQueues_'_update - (\_. Arrays.update (ksReadyQueues_' (globals s')) prio' q') - (t_hrs_'_update f (globals s')); - sched_queue_relation' (cslift t) q (head_C q') (end_C q'); - cslift t |` ( - tcb_ptr_to_ctcb_ptr ` S ) - = cslift s' |` ( - tcb_ptr_to_ctcb_ptr ` S ); - option_map tcb_null_sched_ptrs \ cslift t - = option_map tcb_null_sched_ptrs \ cslift s'; - cslift_all_but_tcb_C t s'; - zero_ranges_are_zero (gsUntypedZeroRanges s) (f (t_hrs_' (globals s'))) - = zero_ranges_are_zero (gsUntypedZeroRanges s) (t_hrs_' (globals s')); - hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s')); - prio' = cready_queues_index_to_C qdom prio; - \x \ S. obj_at' (inQ qdom prio) x s - \ (obj_at' (\tcb. tcbPriority tcb = prio) x s - \ obj_at' (\tcb. tcbDomain tcb = qdom) x s) - \ (tcb_at' x s \ (\d' p'. (d' \ qdom \ p' \ prio) - \ x \ set (ksReadyQueues s (d', p')))); - S \ {}; qdom \ ucast maxDom; prio \ ucast maxPrio \ - \ (s \ksReadyQueues := (ksReadyQueues s)((qdom, prio) := q)\, t) \ rf_sr" - apply (subgoal_tac "\d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct(ksReadyQueues s (d, p))") - apply (erule(5) state_relation_queue_update_helper', simp_all) - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE, clarsimp) - done - declare fun_upd_restrict_conv[simp del] lemmas queue_in_range = of_nat_mono_maybe[OF _ cready_queues_index_to_C_in_range, @@ -693,8 +427,8 @@ lemma cready_queues_index_to_C_def2: lemma ready_queues_index_spec: "\s. \ \ {s'. s' = s \ (Kernel_Config.numDomains \ 1 \ dom_' s' = 0)} Call ready_queues_index_'proc - \\ret__unsigned_long = (dom_' s) * 0x100 + (prio_' s)\" - by vcg (simp add: numDomains_sge_1_simp) + \\ret__unsigned_long = (dom_' s) * word_of_nat numPriorities + (prio_' s)\" + by vcg (simp add: numDomains_sge_1_simp numPriorities_def) lemma prio_to_l1index_spec: "\s. \ \ {s} Call prio_to_l1index_'proc @@ -708,6 +442,22 @@ lemma invert_l1index_spec: by vcg (simp add: word_sle_def sdiv_int_def sdiv_word_def smod_word_def smod_int_def) +lemma cbitmap_L1_relation_update: + "\ (\, s) \ rf_sr ; cbitmap_L1_relation cupd aupd \ + \ (\\ksReadyQueuesL1Bitmap := aupd \, + globals_update (ksReadyQueuesL1Bitmap_'_update (\_. cupd)) s) + \ rf_sr" + by (simp add: rf_sr_def cstate_relation_def Let_def carch_state_relation_def + cmachine_state_relation_def) + +lemma cbitmap_L2_relation_update: + "\ (\, s) \ rf_sr ; cbitmap_L2_relation cupd aupd \ + \ (\\ksReadyQueuesL2Bitmap := aupd \, + globals_update (ksReadyQueuesL2Bitmap_'_update (\_. cupd)) s) + \ rf_sr" + by (simp add: rf_sr_def cstate_relation_def Let_def carch_state_relation_def + cmachine_state_relation_def) + lemma unat_ucast_prio_L1_cmask_simp: "unat (ucast (p::priority) && 0x1F :: machine_word) = unat (p && 0x1F)" using unat_ucast_prio_mask_simp[where m=5] @@ -833,15 +583,6 @@ lemma rf_sr_drop_bitmaps_enqueue_helper: carch_state_relation_def cmachine_state_relation_def by (clarsimp simp: rf_sr_cbitmap_L1_relation rf_sr_cbitmap_L2_relation) -lemma tcb_queue_relation'_empty_ksReadyQueues: - "\ sched_queue_relation' (cslift x) (q s) NULL NULL ; \t\ set (q s). tcb_at' t s \ \ q s = []" - apply (clarsimp simp add: tcb_queue_relation'_def) - apply (subst (asm) eq_commute) - apply (cases "q s" rule: rev_cases, simp) - apply (clarsimp simp: tcb_at_not_NULL) - done - - lemma invert_prioToL1Index_c_simp: "p \ maxPriority \ @@ -855,13 +596,247 @@ lemma c_invert_assist: "7 - (ucast (p :: priority) >> 5 :: machine_word) < 8" using prio_ucast_shiftr_wordRadix_helper'[simplified wordRadix_def] by - (rule word_less_imp_diff_less, simp_all) +lemma addToBitmap_ccorres: + "ccorres dc xfdc + (K (tdom \ maxDomain \ prio \ maxPriority)) (\\dom = ucast tdom\ \ \\prio = ucast prio\) hs + (addToBitmap tdom prio) (Call addToBitmap_'proc)" + supply prio_and_dom_limit_helpers[simp] invert_prioToL1Index_c_simp[simp] + apply (rule ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (frule maxDomain_le_unat_ucast_explicit) + apply (clarsimp simp: getQueue_def gets_def get_def setQueue_def modify_def + put_def bind_def return_def bitmap_fun_defs) + apply (intro conjI impI allI) + apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def + carch_state_relation_def cmachine_state_relation_def) + apply (rule conjI) + apply (clarsimp intro!: cbitmap_L1_relation_bit_set) + apply (fastforce dest!: cbitmap_L2_relation_bit_set simp: wordRadix_def mask_def) + done + +lemma rf_sr_tcb_update_twice: + "h_t_valid (hrs_htd (hrs2 (globals s') (t_hrs_' (gs2 (globals s'))))) c_guard + (ptr (t_hrs_' (gs2 (globals s'))) (globals s')) + \ ((s, globals_update (\gs. t_hrs_'_update (\ths. + hrs_mem_update (heap_update (ptr ths gs :: tcb_C ptr) (v ths gs)) + (hrs_mem_update (heap_update (ptr ths gs) (v' ths gs)) (hrs2 gs ths))) (gs2 gs)) s') \ rf_sr) + = ((s, globals_update (\gs. t_hrs_'_update (\ths. + hrs_mem_update (heap_update (ptr ths gs) (v ths gs)) (hrs2 gs ths)) (gs2 gs)) s') \ rf_sr)" + by (simp add: rf_sr_def cstate_relation_def Let_def + cpspace_relation_def typ_heap_simps' + carch_state_relation_def cmachine_state_relation_def + packed_heap_update_collapse_hrs) + +lemmas rf_sr_tcb_update_no_queue_gen2 = + rf_sr_obj_update_helper[OF rf_sr_tcb_update_no_queue_gen, simplified] + +lemma tcb_queue_prepend_ccorres: + "ccorres ctcb_queue_relation ret__struct_tcb_queue_C_' + (\s. tcb_at' tcbPtr s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None) + \ (\head. tcbQueueHead queue = Some head \ tcb_at' head s)) + (\ctcb_queue_relation queue \queue\ \ \\tcb = tcb_ptr_to_ctcb_ptr tcbPtr\) hs + (tcbQueuePrepend queue tcbPtr) (Call tcb_queue_prepend_'proc)" + (is "ccorres _ _ ?abs _ _ _ _") + supply if_split[split del] + apply (cinit lift: tcb_') + \ \cinit is not able to lift queue_' because queue_' is later modified in the C program\ + apply (rule_tac xf'=queue_' in ccorres_abstract, ceqv, rename_tac cqueue) + apply (rule_tac P="ctcb_queue_relation queue cqueue" in ccorres_gen_asm2) + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue)" + and R="?abs" + and R'="\\queue = cqueue\" + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + apply ceqv + apply (rule_tac r'=ctcb_queue_relation and xf'=queue_' in ccorres_split_nothrow) + apply (rule_tac Q="?abs" + and Q'="\s'. queue_' s' = cqueue" + in ccorres_cond_both') + apply fastforce + apply clarsimp + apply (rule ccorres_return[where R=\]) + apply (rule conseqPre, vcg) + apply (fastforce simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (rule ccorres_seq_skip'[THEN iffD1]) + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_Guard) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s + \ head_C cqueue = option_to_ctcb_ptr (tcbQueueHead queue)}" + and R="\head_C cqueue = option_to_ctcb_ptr (tcbQueueHead queue)\" + in threadSet_ccorres_lemma4[where P=\ and P'=\]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce intro!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' tcb_cte_cases_def cteSizeBits_def + ctcb_relation_def option_to_ctcb_ptr_def) + apply (clarsimp simp: ctcb_relation_def option_to_ctcb_ptr_def split: if_splits) + apply ceqv + apply simp + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_Guard) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr + \ ko_at' tcb (the (tcbQueueHead queue)) s + \ head_C cqueue = option_to_ctcb_ptr (tcbQueueHead queue)}" + and R="\head_C cqueue = option_to_ctcb_ptr (tcbQueueHead queue)\" + in threadSet_ccorres_lemma4[where P=\ and P'=\]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce intro!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' tcb_cte_cases_def cteSizeBits_def + ctcb_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + apply fastforce + apply ceqv + apply (rule ccorres_return_Skip') + apply wpsimp + apply vcg + apply wpsimp + apply vcg + apply ceqv + apply csymbr + apply (fastforce intro: ccorres_return_C') + apply wpsimp + apply vcg + apply clarsimp + apply (vcg exspec=tcb_queue_empty_modifies) + apply clarsimp + apply (frule (1) tcb_at_h_t_valid) + by (force dest: tcb_at_h_t_valid + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + +lemma tcb_queue_append_ccorres: + "ccorres ctcb_queue_relation ret__struct_tcb_queue_C_' + (\s. tcb_at' tcbPtr s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None) + \ (\head. tcbQueueHead queue = Some head \ tcb_at' head s) + \ (\end. tcbQueueEnd queue = Some end \ tcb_at' end s)) + (\ctcb_queue_relation queue \queue\ \ \\tcb = tcb_ptr_to_ctcb_ptr tcbPtr\) hs + (tcbQueueAppend queue tcbPtr) (Call tcb_queue_append_'proc)" + (is "ccorres _ _ ?abs _ _ _ _") + supply if_split[split del] + apply (cinit lift: tcb_') + \ \cinit is not able to lift queue_' because queue_' is later modified in the C program\ + apply (rule_tac xf'=queue_' in ccorres_abstract, ceqv, rename_tac cqueue) + apply (rule_tac P="ctcb_queue_relation queue cqueue + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None)" + in ccorres_gen_asm2) + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue)" + and R="?abs" + and R'="\\queue = cqueue\" + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + apply ceqv + apply (rule_tac r'=ctcb_queue_relation and xf'=queue_' in ccorres_split_nothrow) + apply (rule_tac Q="?abs" + and Q'="\s'. queue_' s' = cqueue" + in ccorres_cond_both') + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply clarsimp + apply (rule ccorres_return[where R=\]) + apply (rule conseqPre, vcg) + apply (fastforce simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (rule ccorres_seq_skip'[THEN iffD1]) + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_Guard) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s + \ end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd queue)}" + and R="\end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd queue)\" + in threadSet_ccorres_lemma4[where P=\ and P'=\]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce intro!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' tcb_cte_cases_def cteSizeBits_def + ctcb_relation_def option_to_ctcb_ptr_def) + apply (clarsimp simp: ctcb_relation_def option_to_ctcb_ptr_def split: if_splits) + apply ceqv + apply simp + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_Guard) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr + \ ko_at' tcb (the (tcbQueueEnd queue)) s + \ end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd queue)}" + and R="\end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd queue)\" + in threadSet_ccorres_lemma4[where P=\ and P'=\]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce intro!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' tcb_cte_cases_def cteSizeBits_def + ctcb_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + apply fastforce + apply ceqv + apply (rule ccorres_return_Skip') + apply wpsimp + apply vcg + apply wpsimp + apply vcg + apply ceqv + apply csymbr + apply (fastforce intro: ccorres_return_C') + apply wpsimp + apply vcg + apply (vcg exspec=tcb_queue_empty_modifies) + apply clarsimp + apply (frule (1) tcb_at_h_t_valid) + by (force dest: tcb_at_h_t_valid + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + +lemma getQueue_ccorres: + "ccorres ctcb_queue_relation queue_' + (K (tdom \ maxDomain \ prio \ maxPriority)) + \\idx = word_of_nat (cready_queues_index_to_C tdom prio)\ hs + (getQueue tdom prio) (\queue :== \ksReadyQueues.[unat \idx])" + apply (rule ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply (clarsimp simp: getQueue_def gets_def get_def bind_def return_def) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def) + apply (frule (1) cready_queues_index_to_C_in_range) + apply (clarsimp simp: unat_of_nat_eq cready_queues_relation_def) + done + +lemma setQueue_ccorres: + "ctcb_queue_relation queue cqueue \ + ccorres dc xfdc + (K (tdom \ maxDomain \ prio \ maxPriority)) + \\idx = word_of_nat (cready_queues_index_to_C tdom prio)\ hs + (setQueue tdom prio queue) + (Basic (\s. globals_update + (ksReadyQueues_'_update + (\_. Arrays.update (ksReadyQueues_' (globals s)) (unat (idx_' s)) cqueue)) s))" + apply (rule ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply (clarsimp simp: setQueue_def get_def modify_def put_def bind_def) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def + carch_state_relation_def cmachine_state_relation_def) + apply (frule (1) cready_queues_index_to_C_in_range) + apply (clarsimp simp: unat_of_nat_eq cready_queues_relation_def) + apply (frule cready_queues_index_to_C_distinct, assumption+) + apply (frule_tac qdom=d and prio=p in cready_queues_index_to_C_in_range) + apply fastforce + apply clarsimp + done + +crunch (empty_fail) empty_fail[wp]: isRunnable + lemma tcbSchedEnqueue_ccorres: "ccorres dc xfdc - (valid_queues and tcb_at' t and valid_objs') - (UNIV \ \\tcb = tcb_ptr_to_ctcb_ptr t\) - hs - (tcbSchedEnqueue t) - (Call tcbSchedEnqueue_'proc)" + (tcb_at' t and valid_objs' and pspace_aligned' and pspace_distinct') + \\tcb = tcb_ptr_to_ctcb_ptr t\ hs + (tcbSchedEnqueue t) (Call tcbSchedEnqueue_'proc)" proof - note prio_and_dom_limit_helpers[simp] word_sle_def[simp] maxDom_to_H[simp] maxPrio_to_H[simp] note invert_prioToL1Index_c_simp[simp] @@ -871,35 +846,13 @@ proof - note word_less_1[simp del] show ?thesis - apply (cinit lift: tcb_') - apply (rule_tac r'="\rv rv'. rv = to_bool rv'" - and xf'="ret__unsigned_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (simp add: when_def unless_def del: Collect_const split del: if_split) - apply (rule ccorres_cond[where R=\]) - apply (simp add: to_bool_def) - apply (rule ccorres_rhs_assoc)+ - apply csymbr - apply csymbr - apply csymbr - apply csymbr - apply (rule_tac r'="\rv rv'. rv' = ucast rv" - and xf'="dom_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (rule_tac r'="\rv rv'. rv' = ucast rv" - and xf'="prio_'" in ccorres_split_nothrow) + apply (cinit lift: tcb_') + apply (rule ccorres_stateAssert)+ + apply (rule ccorres_symb_exec_l) + apply (rule ccorres_assert) + apply (thin_tac runnable) + apply (rule_tac r'="\rv rv'. rv = to_bool rv'" and xf'="ret__unsigned_'" + in ccorres_split_nothrow) apply (rule threadGet_vcg_corres) apply (rule allI, rule conseqPre, vcg) apply clarsimp @@ -907,235 +860,246 @@ proof - apply (drule spec, drule(1) mp, clarsimp) apply (clarsimp simp: typ_heap_simps ctcb_relation_def) apply ceqv - apply (rule ccorres_rhs_assoc2)+ - apply (simp only: bind_assoc[symmetric]) - apply (rule ccorres_split_nothrow_novcg_dc) - prefer 2 - apply (rule ccorres_move_c_guard_tcb) - apply ctac - prefer 2 - apply (wp, clarsimp, wp+) - apply (rule_tac P="\s. valid_queues s \ (\p. t \ set (ksReadyQueues s p)) - \ (\tcb. ko_at' tcb t s \ tcbDomain tcb =rva - \ tcbPriority tcb = rvb \ valid_tcb' tcb s)" - and P'=UNIV in ccorres_from_vcg) - apply (rule allI, rule conseqPre, vcg) - apply (clarsimp simp: getQueue_def gets_def get_def setQueue_def modify_def - put_def bind_def return_def bitmap_fun_defs null_def) - apply (clarsimp simp: queue_in_range valid_tcb'_def) - apply (rule conjI; clarsimp simp: queue_in_range) - (* queue is empty, set t to be new queue *) - apply (drule (1) obj_at_cslift_tcb) - apply clarsimp - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply (subgoal_tac - "head_C (ksReadyQueues_' - (globals x).[cready_queues_index_to_C (tcbDomain tcb) (tcbPriority tcb)]) = NULL") - prefer 2 - apply (frule_tac s=\ in tcb_queue'_head_end_NULL; simp add: valid_queues_valid_q) - apply (subgoal_tac - "end_C (ksReadyQueues_' - (globals x).[cready_queues_index_to_C (tcbDomain tcb) (tcbPriority tcb)]) = NULL") - prefer 2 - apply (frule_tac s=\ in tcb_queue'_head_end_NULL[symmetric]; simp add: valid_queues_valid_q) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (frule maxDomain_le_unat_ucast_explicit) - apply (clarsimp simp: cready_queues_index_to_C_def numPriorities_def) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (simp add: t_hrs_ksReadyQueues_upd_absorb) - apply (rule conjI) - apply (clarsimp simp: l2BitmapSize_def' wordRadix_def c_invert_assist) - - apply (subst rf_sr_drop_bitmaps_enqueue_helper, assumption) - apply (fastforce intro: cbitmap_L1_relation_bit_set) - apply (fastforce intro: cbitmap_L2_relation_bit_set simp: wordRadix_def mask_def) - - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (drule_tac qhead'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedEnqueue_update, - simp_all add: valid_queues_valid_q)[1] - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - - apply (erule(1) state_relation_queue_update_helper[where S="{t}"], - (simp | rule globals.equality)+, - simp_all add: cready_queues_index_to_C_def2 numPriorities_def - t_hrs_ksReadyQueues_upd_absorb upd_unless_null_def - typ_heap_simps)[1] - apply (fastforce simp: tcb_null_sched_ptrs_def elim: obj_at'_weaken)+ - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply clarsimp - apply (rule conjI; clarsimp simp: queue_in_range) - (* invalid, disagreement between C and Haskell on emptiness of queue *) - apply (drule (1) obj_at_cslift_tcb) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (clarsimp simp: cready_queues_index_to_C_def numPriorities_def) - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply clarsimp - apply (drule tcb_queue_relation'_empty_ksReadyQueues; simp add: valid_queues_valid_q) - (* queue was not empty, add t to queue and leave bitmaps alone *) - apply (drule (1) obj_at_cslift_tcb) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (clarsimp simp: cready_queues_index_to_C_def numPriorities_def) - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply clarsimp - apply (frule_tac t=\ in tcb_queue_relation_qhead_mem') - apply (simp add: valid_queues_valid_q) - apply (frule(1) tcb_queue_relation_qhead_valid') - apply (simp add: valid_queues_valid_q) - apply (clarsimp simp: typ_heap_simps h_t_valid_clift_Some_iff numPriorities_def - cready_queues_index_to_C_def2) - apply (drule_tac qhead'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedEnqueue_update, - simp_all add: valid_queues_valid_q)[1] - apply clarsimp - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - apply (frule(2) obj_at_cslift_tcb[OF valid_queues_obj_at'D]) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (erule_tac S="{t, v}" for v in state_relation_queue_update_helper, - (simp | rule globals.equality)+, - simp_all add: typ_heap_simps if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 upd_unless_null_def - cong: if_cong split del: if_split - del: fun_upd_restrict_conv)[1] - apply simp - apply (rule conjI) + apply (simp add: when_def unless_def del: Collect_const split del: if_split) + apply (rule ccorres_cond[where R=\]) + apply (simp add: to_bool_def) + apply (rule ccorres_rhs_assoc)+ + apply csymbr + apply csymbr + apply csymbr + apply csymbr + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="dom_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) apply clarsimp - apply (drule_tac s="tcb_ptr_to_ctcb_ptr t" in sym, simp) - apply (clarsimp simp add: fun_upd_twist) - prefer 3 - apply (simp add: obj_at'_weakenE[OF _ TrueI]) - apply (rule disjI1, erule valid_queues_obj_at'D) - apply simp+ - apply (fastforce simp: tcb_null_sched_ptrs_def) - apply (simp add: guard_is_UNIV_def) - apply simp - apply (wp threadGet_wp) - apply vcg - apply simp - apply (wp threadGet_wp) - apply vcg - apply (rule ccorres_return_Skip) - apply simp - apply (wp threadGet_wp) - apply vcg - apply (fastforce simp: valid_objs'_def obj_at'_def ran_def projectKOs typ_at'_def - valid_obj'_def inQ_def - dest!: valid_queues_obj_at'D) - done + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="prio_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule ccorres_rhs_assoc2)+ + apply (simp only: bind_assoc[symmetric]) + apply (rule ccorres_split_nothrow_novcg_dc) + prefer 2 + apply (rule ccorres_move_c_guard_tcb) + apply (simp only: dc_def[symmetric]) + apply ctac + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_symb_exec_r) + apply (rule ccorres_Guard_Seq) + apply (simp add: bind_assoc) + apply (ctac add: getQueue_ccorres) + apply (rename_tac queue cqueue) + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue)" + and R="\s. \ tcbQueueEmpty queue \ tcb_at' (the (tcbQueueHead queue)) s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None)" + and R'="{s'. queue_' s' = cqueue}" + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def + tcbQueueEmpty_def) + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_cond[where R=\]) + apply fastforce + apply (ctac add: addToBitmap_ccorres) + apply (rule ccorres_return_Skip) + apply ceqv + apply (ctac add: tcb_queue_prepend_ccorres) + apply (rule ccorres_Guard) + apply (rule setQueue_ccorres) + apply fastforce + apply wpsimp + apply (vcg exspec=tcb_queue_prepend_modifies) + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift') + apply (vcg exspec=addToBitmap_modifies) + apply vcg + apply wpsimp + apply vcg + apply clarsimp + apply vcg + apply (rule conseqPre, vcg) + apply clarsimp + apply wpsimp + apply (clarsimp simp: guard_is_UNIV_def) + apply (wpsimp wp: threadGet_wp) + apply vcg + apply clarsimp + apply (wpsimp wp: threadGet_wp) + apply vcg + apply (rule ccorres_return_Skip) + apply (wpsimp wp: threadGet_wp) + apply (vcg expsec=thread_state_get_tcbQueued_modifies) + apply wpsimp + apply (wpsimp wp: isRunnable_wp) + apply wpsimp + apply normalise_obj_at' + apply (rename_tac tcb) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (clarsimp simp: valid_tcb'_def) + apply (frule (1) obj_at_cslift_tcb) + apply (rule conjI) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (force dest!: tcbQueueHead_iff_tcbQueueEnd simp: tcbQueueEmpty_def obj_at'_def) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply (rule conjI) + apply (clarsimp simp: maxDomain_def) + apply (cut_tac qdom="tcbDomain tcb" and prio="tcbPriority tcb" + in cready_queues_index_to_C_in_range) + apply fastforce + apply fastforce + apply (clarsimp simp: word_less_nat_alt cready_queues_index_to_C_def2) + done qed -lemmas tcbSchedDequeue_update - = tcbDequeue_update[where tn=tcbSchedNext_C and tn_update=tcbSchedNext_C_update - and tp=tcbSchedPrev_C and tp_update=tcbSchedPrev_C_update, - simplified] - -lemma tcb_queue_relation_prev_next: - "\ tcb_queue_relation tn tp mp queue qprev qhead; - tcbp \ set queue; distinct (ctcb_ptr_to_tcb_ptr qprev # queue); - \t \ set queue. tcb_at' t s; qprev \ tcb_Ptr 0 \ mp qprev \ None; - mp (tcb_ptr_to_ctcb_ptr tcbp) = Some tcb \ - \ (tn tcb \ tcb_Ptr 0 \ tn tcb \ tcb_ptr_to_ctcb_ptr ` set queue - \ mp (tn tcb) \ None \ tn tcb \ tcb_ptr_to_ctcb_ptr tcbp) - \ (tp tcb \ tcb_Ptr 0 \ (tp tcb \ tcb_ptr_to_ctcb_ptr ` set queue - \ tp tcb = qprev) - \ mp (tp tcb) \ None \ tp tcb \ tcb_ptr_to_ctcb_ptr tcbp) - \ (tn tcb \ tcb_Ptr 0 \ tn tcb \ tp tcb)" - apply (induct queue arbitrary: qprev qhead) - apply simp - apply simp - apply (erule disjE) - apply clarsimp - apply (case_tac "queue") - apply clarsimp - apply clarsimp - apply (rule conjI) - apply clarsimp - apply clarsimp - apply (drule_tac f=ctcb_ptr_to_tcb_ptr in arg_cong[where y="tp tcb"], simp) - apply clarsimp - apply fastforce - done - -lemma tcb_queue_relation_prev_next': - "\ tcb_queue_relation' tn tp mp queue qhead qend; tcbp \ set queue; distinct queue; - \t \ set queue. tcb_at' t s; mp (tcb_ptr_to_ctcb_ptr tcbp) = Some tcb \ - \ (tn tcb \ tcb_Ptr 0 \ tn tcb \ tcb_ptr_to_ctcb_ptr ` set queue - \ mp (tn tcb) \ None \ tn tcb \ tcb_ptr_to_ctcb_ptr tcbp) - \ (tp tcb \ tcb_Ptr 0 \ tp tcb \ tcb_ptr_to_ctcb_ptr ` set queue - \ mp (tp tcb) \ None \ tp tcb \ tcb_ptr_to_ctcb_ptr tcbp) - \ (tn tcb \ tcb_Ptr 0 \ tn tcb \ tp tcb)" - apply (clarsimp simp: tcb_queue_relation'_def split: if_split_asm) - apply (drule(1) tcb_queue_relation_prev_next, simp_all) - apply (fastforce dest: tcb_at_not_NULL) - apply clarsimp - done +lemma tcbSchedAppend_ccorres: + "ccorres dc xfdc + (tcb_at' t and valid_objs' and pspace_aligned' and pspace_distinct') + \\tcb = tcb_ptr_to_ctcb_ptr t\ hs + (tcbSchedAppend t) (Call tcbSchedAppend_'proc)" +proof - + note prio_and_dom_limit_helpers[simp] word_sle_def[simp] maxDom_to_H[simp] maxPrio_to_H[simp] + note invert_prioToL1Index_c_simp[simp] -(* L1 bitmap only updated if L2 entry bits end up all zero *) -lemma rf_sr_drop_bitmaps_dequeue_helper_L2: - "\ (\,\') \ rf_sr ; - cbitmap_L2_relation ksqL2upd' ksqL2upd \ - \ -((\\ksReadyQueues := ksqupd, - ksReadyQueuesL2Bitmap := ksqL2upd\, - \'\idx_' := i', - queue_' := queue_upd', - globals := globals \' - \ksReadyQueuesL2Bitmap_' := ksqL2upd', - ksReadyQueues_' := ksqupd'\\) - \ rf_sr) - = -((\\ksReadyQueues := ksqupd\, - \'\idx_' := i', - queue_' := queue_upd', - globals := globals \' - \ksReadyQueues_' := ksqupd'\\) \ rf_sr) -" - unfolding rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def - by (clarsimp simp: rf_sr_cbitmap_L1_relation rf_sr_cbitmap_L2_relation) + (* when numDomains = 1, array bounds checks would become _ = 0 rather than _ < 1, changing the + shape of the proof compared to when numDomains > 1 *) + note word_less_1[simp del] -lemma rf_sr_drop_bitmaps_dequeue_helper: - "\ (\,\') \ rf_sr ; - cbitmap_L1_relation ksqL1upd' ksqL1upd ; cbitmap_L2_relation ksqL2upd' ksqL2upd \ - \ -((\\ksReadyQueues := ksqupd, - ksReadyQueuesL2Bitmap := ksqL2upd, - ksReadyQueuesL1Bitmap := ksqL1upd\, - \'\idx_' := i', - queue_' := queue_upd', - globals := globals \' - \ksReadyQueuesL2Bitmap_' := ksqL2upd', - ksReadyQueuesL1Bitmap_' := ksqL1upd', - ksReadyQueues_' := ksqupd'\\) - \ rf_sr) - = -((\\ksReadyQueues := ksqupd\, - \'\idx_' := i', - queue_' := queue_upd', - globals := globals \' - \ksReadyQueues_' := ksqupd'\\) \ rf_sr) -" - unfolding rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def - by (clarsimp simp: rf_sr_cbitmap_L1_relation rf_sr_cbitmap_L2_relation) + show ?thesis + apply (cinit lift: tcb_') + apply (rule ccorres_stateAssert)+ + apply (rule ccorres_symb_exec_l) + apply (rule ccorres_assert) + apply (thin_tac "runnable") + apply (rule_tac r'="\rv rv'. rv = to_bool rv'" and xf'="ret__unsigned_'" + in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (simp add: when_def unless_def del: Collect_const split del: if_split) + apply (rule ccorres_cond[where R=\]) + apply (simp add: to_bool_def) + apply (rule ccorres_rhs_assoc)+ + apply csymbr + apply csymbr + apply csymbr + apply csymbr + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="dom_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="prio_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule ccorres_rhs_assoc2)+ + apply (simp only: bind_assoc[symmetric]) + apply (rule ccorres_split_nothrow_novcg_dc) + prefer 2 + apply (rule ccorres_move_c_guard_tcb) + apply (simp only: dc_def[symmetric]) + apply ctac + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_symb_exec_r) + apply (rule ccorres_Guard_Seq) + apply (simp add: bind_assoc) + apply (ctac add: getQueue_ccorres) + apply (rename_tac queue cqueue) + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue)" + and R="\s. \ tcbQueueEmpty queue \ tcb_at' (the (tcbQueueHead queue)) s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None)" + and R'="{s'. queue_' s' = cqueue}" + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def + tcbQueueEmpty_def) + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_cond[where R=\]) + apply (fastforce dest!: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (ctac add: addToBitmap_ccorres) + apply (rule ccorres_return_Skip) + apply ceqv + apply (ctac add: tcb_queue_append_ccorres) + apply (rule ccorres_Guard) + apply (rule setQueue_ccorres) + apply fastforce + apply wpsimp + apply (vcg exspec=tcb_queue_prepend_modifies) + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift') + apply (vcg exspec=addToBitmap_modifies) + apply vcg + apply wpsimp + apply vcg + apply clarsimp + apply vcg + apply (rule conseqPre, vcg) + apply clarsimp + apply wpsimp + apply (clarsimp simp: guard_is_UNIV_def) + apply (wpsimp wp: threadGet_wp) + apply vcg + apply clarsimp + apply (wpsimp wp: threadGet_wp) + apply clarsimp + apply vcg + apply (rule ccorres_return_Skip) + apply (wpsimp wp: threadGet_wp) + apply (vcg expsec=thread_state_get_tcbQueued_modifies) + apply wpsimp + apply (wpsimp wp: isRunnable_wp) + apply wpsimp + apply normalise_obj_at' + apply (rename_tac tcb) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (clarsimp simp: valid_tcb'_def) + apply (frule (1) obj_at_cslift_tcb) + apply (rule conjI) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (frule (3) obj_at'_tcbQueueEnd_ksReadyQueues) + apply (force dest!: tcbQueueHead_iff_tcbQueueEnd simp: tcbQueueEmpty_def obj_at'_def) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply (rule conjI) + apply (clarsimp simp: maxDomain_def) + apply (cut_tac qdom="tcbDomain tcb" and prio="tcbPriority tcb" + in cready_queues_index_to_C_in_range) + apply fastforce + apply fastforce + apply (clarsimp simp: word_less_nat_alt cready_queues_index_to_C_def2 tcbQueueEmpty_def) + done +qed (* FIXME same proofs as bit_set, maybe can generalise? *) lemma cbitmap_L1_relation_bit_clear: @@ -1152,27 +1116,6 @@ lemma cbitmap_L1_relation_bit_clear: invertL1Index_def l2BitmapSize_def' le_maxDomain_eq_less_numDomains word_le_nat_alt num_domains_index_updates) -lemma cready_queues_relation_empty_queue_helper: - "\ tcbDomain ko \ maxDomain ; tcbPriority ko \ maxPriority ; - cready_queues_relation (cslift \') (ksReadyQueues_' (globals \')) (ksReadyQueues \)\ - \ - cready_queues_relation (cslift \') - (Arrays.update (ksReadyQueues_' (globals \')) (unat (tcbDomain ko) * 256 + unat (tcbPriority ko)) - (tcb_queue_C.end_C_update (\_. NULL) - (head_C_update (\_. NULL) - (ksReadyQueues_' (globals \').[unat (tcbDomain ko) * 256 + unat (tcbPriority ko)])))) - ((ksReadyQueues \)((tcbDomain ko, tcbPriority ko) := []))" - unfolding cready_queues_relation_def Let_def - using maxPrio_to_H[simp] maxDom_to_H[simp] - apply clarsimp - apply (frule (1) cready_queues_index_to_C_in_range[simplified maxDom_to_H maxPrio_to_H]) - apply (fold cready_queues_index_to_C_def[simplified numPriorities_def]) - apply (case_tac "qdom = tcbDomain ko", - simp_all add: prio_and_dom_limit_helpers seL4_MinPrio_def - minDom_def) - apply (fastforce simp: cready_queues_index_to_C_in_range simp: cready_queues_index_to_C_distinct)+ - done - lemma cbitmap_L2_relationD: "\ cbitmap_L2_relation cbitmap2 abitmap2 ; d \ maxDomain ; i < l2BitmapSize \ \ cbitmap2.[unat d].[i] = abitmap2 (d, i)" @@ -1202,464 +1145,301 @@ lemma cbitmap_L2_relation_bit_clear: apply (case_tac "da = d" ; clarsimp simp: num_domains_index_updates) done -lemma tcbSchedDequeue_ccorres': +lemma removeFromBitmap_ccorres: "ccorres dc xfdc - ((\s. \d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct (ksReadyQueues s (d, p))) - and valid_queues' and tcb_at' t and valid_objs') - (UNIV \ \\tcb = tcb_ptr_to_ctcb_ptr t\) - [] - (tcbSchedDequeue t) - (Call tcbSchedDequeue_'proc)" + (K (tdom \ maxDomain \ prio \ maxPriority)) (\\dom = ucast tdom\ \ \\prio = ucast prio\) hs + (removeFromBitmap tdom prio) (Call removeFromBitmap_'proc)" proof - - note prio_and_dom_limit_helpers[simp] word_sle_def[simp] (* when numDomains = 1, array bounds checks would become _ = 0 rather than _ < 1, changing the shape of the proof compared to when numDomains > 1 *) include no_less_1_simps - have ksQ_tcb_at': "\s ko d p. - \d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct (ksReadyQueues s (d, p)) \ - \t\set (ksReadyQueues s (d, p)). tcb_at' t s" - by (fastforce dest: spec elim: obj_at'_weakenE) - - have invert_l1_index_limit: "\p. invertL1Index (prioToL1Index p) < 8" + have invert_l1_index_limit: "\p. invertL1Index (prioToL1Index p) < l2BitmapSize" unfolding invertL1Index_def l2BitmapSize_def' prioToL1Index_def by simp show ?thesis - apply (cinit lift: tcb_') - apply (rule_tac r'="\rv rv'. rv = to_bool rv'" - and xf'="ret__unsigned_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (simp add: when_def - del: Collect_const split del: if_split) - apply (rule ccorres_cond[where R=\]) - apply (simp add: to_bool_def) - apply (rule ccorres_rhs_assoc)+ - apply csymbr - apply csymbr - apply csymbr - apply csymbr - apply (rule_tac r'="\rv rv'. rv' = ucast rv" - and xf'="dom_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) + supply if_split[split del] + (* pull out static assms *) + apply simp + apply (rule ccorres_grab_asm[where P=\, simplified]) + apply (cinit lift: dom_' prio_') + apply clarsimp + apply csymbr + apply csymbr + (* we can clear up all C guards now *) + apply (clarsimp simp: maxDomain_le_unat_ucast_explicit word_and_less') + apply (simp add: invert_prioToL1Index_c_simp word_less_nat_alt) + apply (simp add: invert_l1_index_limit[simplified l2BitmapSize_def']) + apply ccorres_rewrite + (* handle L2 update *) + apply (rule_tac ccorres_split_nothrow_novcg_dc) + apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply (clarsimp simp: simpler_gets_def get_def modify_def + put_def bind_def return_def bitmap_fun_defs) + apply (frule rf_sr_cbitmap_L2_relation) + apply (erule cbitmap_L2_relation_update) + apply (erule (1) cbitmap_L2_relation_bit_clear) + (* the check on the C side is identical to checking the L2 entry, rewrite the condition *) + apply (simp add: getReadyQueuesL2Bitmap_def) + apply (rule ccorres_symb_exec_l3, rename_tac l2) + apply (rule_tac C'="{s. l2 = 0}" + and Q="\s. l2 = ksReadyQueuesL2Bitmap s (tdom, invertL1Index (prioToL1Index prio))" + in ccorres_rewrite_cond_sr[where Q'=UNIV]) + apply clarsimp + apply (frule rf_sr_cbitmap_L2_relation) + apply (clarsimp simp: cbitmap_L2_relationD invert_l1_index_limit split: if_split) + (* unset L1 bit when L2 entry is empty *) + apply (rule ccorres_from_vcg[where P=\ and P'=UNIV]) apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (rule_tac r'="\rv rv'. rv' = ucast rv" - and xf'="prio_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (rule ccorres_rhs_assoc2)+ - apply (simp only: bind_assoc[symmetric]) - apply (rule ccorres_split_nothrow_novcg_dc) - prefer 2 - apply (rule ccorres_move_c_guard_tcb) - apply ctac - prefer 2 - apply (wp, clarsimp, wp+) - apply (rule_tac P="(\s. \d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct(ksReadyQueues s (d, p))) - and valid_queues' and obj_at' (inQ rva rvb) t - and (\s. rva \ maxDomain \ rvb \ maxPriority)" - and P'=UNIV in ccorres_from_vcg) - apply (rule allI, rule conseqPre, vcg) - apply (clarsimp simp: getQueue_def gets_def get_def setQueue_def modify_def - put_def bind_def return_def bitmap_fun_defs when_def - null_def) - - apply (rule conjI; clarsimp simp: queue_in_range[simplified maxDom_to_H maxPrio_to_H]) - apply (rule conjI; clarsimp simp: queue_in_range[simplified maxDom_to_H maxPrio_to_H]) - apply (frule(1) valid_queuesD') - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) - apply (fastforce simp: maxDom_to_H maxPrio_to_H)+ - apply (frule_tac s=\ in tcb_queue_relation_prev_next'; (fastforce simp: ksQ_tcb_at')?) - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (intro conjI ; - clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift)+ - apply (drule(2) filter_empty_unfiltered_contr, simp)+ - apply (rule conjI; clarsimp) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (rule conjI; clarsimp) - apply (subst rf_sr_drop_bitmaps_dequeue_helper, assumption) - apply (fastforce intro: cbitmap_L1_relation_bit_clear) - apply (simp add: invert_prioToL1Index_c_simp) - apply (frule rf_sr_cbitmap_L2_relation) - apply (clarsimp simp: cbitmap_L2_relation_def - word_size prioToL1Index_def wordRadix_def mask_def - word_le_nat_alt - numPriorities_def wordBits_def l2BitmapSize_def' - invertL1Index_def numDomains_less_numeric_explicit) - apply (case_tac "d = tcbDomain ko" - ; fastforce simp: le_maxDomain_eq_less_numDomains - numDomains_less_numeric_explicit) - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: maxDom_to_H maxPrio_to_H)+ - - apply (frule_tac s=\ in tcb_queue_relation_prev_next', assumption) - prefer 3 - apply fastforce - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by ((fastforce simp: ksQ_tcb_at')+) - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - (* trivial case, setting queue to empty *) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def carch_state_relation_def - cmachine_state_relation_def) - apply (erule (2) cready_queues_relation_empty_queue_helper) - (* impossible case, C L2 update disagrees with Haskell update *) - apply (simp add: invert_prioToL1Index_c_simp) - apply (subst (asm) num_domains_index_updates) - subgoal by (simp add: le_maxDomain_eq_less_numDomains word_le_nat_alt) - apply (subst (asm) Arrays.index_update) - apply (simp add: invert_l1_index_limit) - - apply (frule rf_sr_cbitmap_L2_relation) - apply (drule_tac i="invertL1Index (prioToL1Index (tcbPriority ko))" - in cbitmap_L2_relationD, assumption) - apply (fastforce simp: l2BitmapSize_def' invert_l1_index_limit) - apply (fastforce simp: prioToL1Index_def invertL1Index_def mask_def wordRadix_def) - (* impossible case *) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (drule(2) filter_empty_unfiltered_contr, fastforce) - - apply (frule (1) valid_queuesD') - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) - apply fold_subgoals[2] - apply (fastforce simp: maxDom_to_H maxPrio_to_H)+ - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (frule_tac s=\ in tcb_queue_relation_prev_next', assumption) - prefer 3 - apply fastforce - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: ksQ_tcb_at')+ - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - apply (clarsimp simp: filter_noteq_op upd_unless_null_def) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI, clarsimp) - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (rule conjI; clarsimp) - apply (simp add: typ_heap_simps) - apply (clarsimp simp: h_t_valid_c_guard [OF h_t_valid_field, OF h_t_valid_clift] - h_t_valid_field[OF h_t_valid_clift] h_t_valid_clift) - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 typ_heap_simps - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: tcb_null_sched_ptrs_def)+ - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split, - simp_all add: typ_heap_simps')[1] - subgoal by (fastforce simp: tcb_null_sched_ptrs_def) - subgoal by fastforce + apply (clarsimp simp: simpler_gets_def get_def modify_def + put_def bind_def return_def bitmap_fun_defs) + apply (frule rf_sr_cbitmap_L1_relation) + apply (erule cbitmap_L1_relation_update) + apply (erule (1) cbitmap_L1_relation_bit_clear) + apply wpsimp+ + apply (fastforce simp: guard_is_UNIV_def) + apply clarsimp + done +qed +lemma ctcb_ptr_to_tcb_ptr_option_to_ctcb_ptr[simp]: + "ctcb_ptr_to_tcb_ptr (option_to_ctcb_ptr (Some ptr)) = ptr" + by (clarsimp simp: option_to_ctcb_ptr_def) + +lemma tcb_queue_remove_ccorres: + "ccorres ctcb_queue_relation ret__struct_tcb_queue_C_' + (\s. tcb_at' tcbPtr s \ valid_objs' s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None)) + (\ctcb_queue_relation queue \queue\ \ \\tcb = tcb_ptr_to_ctcb_ptr tcbPtr\) hs + (tcbQueueRemove queue tcbPtr) (Call tcb_queue_remove_'proc)" + (is "ccorres _ _ ?abs _ _ _ _") + supply if_split[split del] + apply (cinit' lift: tcb_') + apply (rename_tac tcb') + apply (simp only: tcbQueueRemove_def) + \ \cinit is not able to lift queue_' because queue_' is later modified in the C program\ + apply (rule_tac xf'=queue_' in ccorres_abstract, ceqv, rename_tac cqueue) + apply (rule_tac P="ctcb_queue_relation queue cqueue" in ccorres_gen_asm2) + apply (rule ccorres_pre_getObject_tcb, rename_tac tcb) + apply (rule ccorres_symb_exec_l, rename_tac beforePtrOpt) + apply (rule ccorres_symb_exec_l, rename_tac afterPtrOpt) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac xf'="before___ptr_to_struct_tcb_C_'" + and val="option_to_ctcb_ptr beforePtrOpt" + and R="ko_at' tcb tcbPtr and K (tcbSchedPrev tcb = beforePtrOpt)" + and R'=UNIV + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: obj_at_cslift_tcb simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac xf'="after___ptr_to_struct_tcb_C_'" + and val="option_to_ctcb_ptr afterPtrOpt" + and R="ko_at' tcb tcbPtr and K (tcbSchedNext tcb = afterPtrOpt)" + in ccorres_symb_exec_r_known_rv[where R'=UNIV]) + apply (rule conseqPre, vcg) + apply (fastforce dest: obj_at_cslift_tcb simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule ccorres_cond_seq) + apply (rule ccorres_cond[where R="?abs"]) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (rule ccorres_rhs_assoc)+ + apply csymbr + apply csymbr + apply (fastforce intro: ccorres_return_C') + apply (rule ccorres_cond_seq) + apply (rule_tac Q="?abs" and Q'=\ in ccorres_cond_both') + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def split: if_splits) apply clarsimp - apply (rule conjI; clarsimp) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (rule conjI; clarsimp) - (* invalid, missing bitmap updates on haskell side *) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems - by (fastforce dest!: tcb_queue_relation'_empty_ksReadyQueues - elim: obj_at'_weaken)+ - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - apply (fold_subgoals (prefix))[4] - subgoal premises prems using prems - by (fastforce simp: typ_heap_simps tcb_null_sched_ptrs_def)+ - apply (rule conjI; clarsimp simp: queue_in_range[simplified maxDom_to_H maxPrio_to_H]) - apply (frule (1) valid_queuesD') - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: maxDom_to_H maxPrio_to_H)+ - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (frule_tac s=\ in tcb_queue_relation_prev_next') + apply (rule ccorres_assert2) + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb)+ + apply (rule_tac P=\ and P'="tcb_at' tcbPtr" + and Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb (the afterPtrOpt) s}" + in threadSet_ccorres_lemma3) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) apply fastforce - prefer 3 - apply fastforce - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: ksQ_tcb_at')+ - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - apply (clarsimp simp: filter_noteq_op upd_unless_null_def) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI; clarsimp) - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (clarsimp simp: typ_heap_simps) - apply (rule conjI; clarsimp simp: typ_heap_simps) - apply (drule(2) filter_empty_unfiltered_contr[simplified filter_noteq_op], simp) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (rule conjI; clarsimp) - (* impossible case, C L2 update disagrees with Haskell update *) - apply (subst (asm) num_domains_index_updates) - apply (simp add: le_maxDomain_eq_less_numDomains word_le_nat_alt) - apply (subst (asm) Arrays.index_update) - subgoal using invert_l1_index_limit - by (fastforce simp add: invert_prioToL1Index_c_simp intro: nat_Suc_less_le_imp) - apply (frule rf_sr_cbitmap_L2_relation) - apply (simp add: invert_prioToL1Index_c_simp) - apply (drule_tac i="invertL1Index (prioToL1Index (tcbPriority ko))" - in cbitmap_L2_relationD, assumption) - subgoal by (simp add: invert_l1_index_limit l2BitmapSize_def') - apply (fastforce simp: prioToL1Index_def invertL1Index_def mask_def wordRadix_def) - - apply (simp add: invert_prioToL1Index_c_simp) - apply (subst rf_sr_drop_bitmaps_dequeue_helper_L2, assumption) - subgoal by (fastforce dest: rf_sr_cbitmap_L2_relation elim!: cbitmap_L2_relation_bit_clear) - - (* trivial case, setting queue to empty *) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def carch_state_relation_def - cmachine_state_relation_def) - apply (erule (2) cready_queues_relation_empty_queue_helper) - - apply (frule (1) valid_queuesD') - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: maxDom_to_H maxPrio_to_H)+ - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (simp add: invert_prioToL1Index_c_simp) - apply (frule_tac s=\ in tcb_queue_relation_prev_next') - apply (fastforce simp add: ksQ_tcb_at')+ - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - apply (clarsimp simp: filter_noteq_op upd_unless_null_def) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI, clarsimp) - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (clarsimp simp: typ_heap_simps) - apply (rule conjI; clarsimp simp: typ_heap_simps) - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - apply (fastforce simp: typ_heap_simps tcb_null_sched_ptrs_def)+ - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - apply (fold_subgoals (prefix))[4] - subgoal premises prems using prems - by (fastforce simp: typ_heap_simps tcb_null_sched_ptrs_def)+ - apply (clarsimp) - apply (rule conjI; clarsimp simp: typ_heap_simps) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (rule conjI; clarsimp) - (* invalid, missing bitmap updates on haskell side *) - apply (drule tcb_queue_relation'_empty_ksReadyQueues) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce elim: obj_at'_weaken)+ - (* invalid, missing bitmap updates on haskell side *) - apply (drule tcb_queue_relation'_empty_ksReadyQueues) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce elim: obj_at'_weaken)+ - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 typ_heap_simps - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems - by (fastforce simp: typ_heap_simps tcb_null_sched_ptrs_def)+ - apply (simp add: guard_is_UNIV_def) - apply simp - apply (wp threadGet_wp) - apply vcg - apply simp - apply (wp threadGet_wp) - apply vcg - apply (rule ccorres_return_Skip) - apply simp - apply (wp threadGet_wp) - apply vcg - by (fastforce simp: valid_objs'_def obj_at'_def ran_def projectKOs typ_at'_def - valid_obj'_def valid_tcb'_def inQ_def) -qed - -lemma tcbSchedDequeue_ccorres: - "ccorres dc xfdc - (valid_queues and valid_queues' and tcb_at' t and valid_objs') - (UNIV \ \\tcb = tcb_ptr_to_ctcb_ptr t\) - [] - (tcbSchedDequeue t) - (Call tcbSchedDequeue_'proc)" - apply (rule ccorres_guard_imp [OF tcbSchedDequeue_ccorres']) - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE) - apply (clarsimp)+ - done - -lemma tcb_queue_relation_append: - "\ tcb_queue_relation tn tp mp queue qprev qhead; queue \ []; - qend' \ tcb_ptr_to_ctcb_ptr ` set queue; mp qend' = Some tcb; - queue = queue' @ [ctcb_ptr_to_tcb_ptr qend]; distinct queue; - \x \ set queue. tcb_ptr_to_ctcb_ptr x \ NULL; qend' \ NULL; - \v f g. tn (tn_update f v) = f (tn v) \ tp (tp_update g v) = g (tp v) - \ tn (tp_update f v) = tn v \ tp (tn_update g v) = tp v \ - \ tcb_queue_relation tn tp - (mp (qend \ tn_update (\_. qend') (the (mp qend)), - qend' \ tn_update (\_. NULL) (tp_update (\_. qend) tcb))) - (queue @ [ctcb_ptr_to_tcb_ptr qend']) qprev qhead" - using [[hypsubst_thin = true]] - apply clarsimp - apply (induct queue' arbitrary: qprev qhead) - apply clarsimp - apply clarsimp - done - -lemma tcbSchedAppend_update: - assumes sr: "sched_queue_relation' mp queue qhead qend" - and qh': "qend' \ tcb_ptr_to_ctcb_ptr ` set queue" - and cs_tcb: "mp qend' = Some tcb" - and valid_ep: "\t\set queue. tcb_at' t s" "distinct queue" - and qhN: "qend' \ NULL" - shows - "sched_queue_relation' - (upd_unless_null qend (tcbSchedNext_C_update (\_. qend') (the (mp qend))) - (mp(qend' \ tcb\tcbSchedNext_C := NULL, tcbSchedPrev_C := qend\))) - (queue @ [ctcb_ptr_to_tcb_ptr qend']) (if queue = [] then qend' else qhead) qend'" - using sr qh' valid_ep cs_tcb qhN - apply - - apply (rule rev_cases[where xs=queue]) - apply (simp add: tcb_queue_relation'_def upd_unless_null_def) - apply (clarsimp simp: tcb_queue_relation'_def upd_unless_null_def tcb_at_not_NULL) - apply (drule_tac qend'=qend' and tn_update=tcbSchedNext_C_update - and tp_update=tcbSchedPrev_C_update and qend="tcb_ptr_to_ctcb_ptr y" - in tcb_queue_relation_append, simp_all) - apply (fastforce simp add: tcb_at_not_NULL) - apply (simp add: fun_upd_twist) - done - -lemma tcb_queue_relation_qend_mems: - "\ tcb_queue_relation' getNext getPrev mp queue qhead qend; - \x \ set queue. tcb_at' x s \ - \ (qend = NULL \ queue = []) - \ (qend \ NULL \ ctcb_ptr_to_tcb_ptr qend \ set queue)" - apply (clarsimp simp: tcb_queue_relation'_def) - apply (drule bspec, erule last_in_set) - apply (simp add: tcb_at_not_NULL) + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb[where thread=tcbPtr]) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule ccorres_symb_exec_r) + apply (fastforce intro: ccorres_return_C') + apply vcg + apply (rule conseqPre, vcg) + apply clarsimp + apply wpsimp + apply vcg + apply wpsimp + apply vcg + apply (rule ccorres_cond_seq) + apply (rule_tac Q="?abs" and Q'=\ in ccorres_cond_both') + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def split: if_splits) + apply clarsimp + apply (rule ccorres_assert2) + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb)+ + apply (rule_tac P=\ and P'="tcb_at' tcbPtr" + and Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb (the beforePtrOpt) s}" + in threadSet_ccorres_lemma3) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply fastforce + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb[where thread=tcbPtr]) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule ccorres_symb_exec_r) + apply (fastforce intro: ccorres_return_C') + apply vcg + apply (rule conseqPre, vcg) + apply clarsimp + apply wpsimp + apply vcg + apply wpsimp + apply vcg + apply clarsimp + apply (rule ccorres_assert2)+ + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb)+ + apply (rule_tac Q="\s tcb'. {s'. (s, s') \ rf_sr \ ko_at' tcb' (the beforePtrOpt) s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb)+ + apply (rule_tac P=\ and P'="tcb_at' tcbPtr" + and Q="\s tcb'. {s'. (s, s') \ rf_sr \ ko_at' tcb' (the afterPtrOpt) s}" + in threadSet_ccorres_lemma3) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb[where thread=tcbPtr]) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb[where thread=tcbPtr]) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply fastforce + apply ceqv + apply (fastforce intro: ccorres_return_C') + apply (wpsimp | vcg)+ + apply (clarsimp split: if_splits) + apply normalise_obj_at' + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + by (intro conjI impI; + clarsimp simp: ctcb_queue_relation_def typ_heap_simps option_to_ctcb_ptr_def + valid_tcb'_def valid_bound_tcb'_def) + +lemma tcbQueueRemove_tcb_at'_head: + "\\s. valid_objs' s \ (\head. tcbQueueHead queue = Some head \ tcb_at' head s)\ + tcbQueueRemove queue t + \\rv s. \ tcbQueueEmpty rv \ tcb_at' (the (tcbQueueHead rv)) s\" + unfolding tcbQueueRemove_def + apply (wpsimp wp: getTCB_wp haskell_assert_wp hoare_vcg_imp_lift') + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (fastforce simp: valid_tcb'_def valid_bound_tcb'_def tcbQueueEmpty_def obj_at'_def) done -lemma tcbSchedAppend_ccorres: +lemma tcbSchedDequeue_ccorres: "ccorres dc xfdc - (valid_queues and tcb_at' t and valid_objs') - (UNIV \ \\tcb = tcb_ptr_to_ctcb_ptr t\) - [] - (tcbSchedAppend t) - (Call tcbSchedAppend_'proc)" + (tcb_at' t and valid_objs' and pspace_aligned' and pspace_distinct') + \\tcb = tcb_ptr_to_ctcb_ptr t\ hs + (tcbSchedDequeue t) (Call tcbSchedDequeue_'proc)" proof - note prio_and_dom_limit_helpers[simp] word_sle_def[simp] maxDom_to_H[simp] maxPrio_to_H[simp] + note invert_prioToL1Index_c_simp[simp] (* when numDomains = 1, array bounds checks would become _ = 0 rather than _ < 1, changing the shape of the proof compared to when numDomains > 1 *) - include no_less_1_simps + note word_less_1[simp del] show ?thesis - apply (cinit lift: tcb_') - apply (rule_tac r'="\rv rv'. rv = to_bool rv'" - and xf'="ret__unsigned_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (simp add: when_def unless_def del: Collect_const split del: if_split) - apply (rule ccorres_cond[where R=\]) - apply (simp add: to_bool_def) - apply (rule ccorres_rhs_assoc)+ - apply csymbr - apply csymbr - apply csymbr - apply csymbr - apply (rule_tac r'="\rv rv'. rv' = ucast rv" - and xf'="dom_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (rule_tac r'="\rv rv'. rv' = ucast rv" - and xf'="prio_'" in ccorres_split_nothrow) + apply (cinit lift: tcb_') + apply (rule ccorres_stateAssert)+ + apply (rule_tac r'="\rv rv'. rv = to_bool rv'" and xf'="ret__unsigned_'" + in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (simp add: when_def del: Collect_const split del: if_split) + apply (rule ccorres_cond[where R=\]) + apply (simp add: to_bool_def) + apply (rule ccorres_rhs_assoc)+ + apply csymbr + apply csymbr + apply csymbr + apply csymbr + apply csymbr + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="dom_'" in ccorres_split_nothrow) apply (rule threadGet_vcg_corres) apply (rule allI, rule conseqPre, vcg) apply clarsimp @@ -1667,124 +1447,98 @@ proof - apply (drule spec, drule(1) mp, clarsimp) apply (clarsimp simp: typ_heap_simps ctcb_relation_def) apply ceqv - apply (rule ccorres_rhs_assoc2)+ - apply (simp only: bind_assoc[symmetric]) - apply (rule ccorres_split_nothrow_novcg_dc) - prefer 2 - apply (rule ccorres_move_c_guard_tcb) - apply ctac - prefer 2 - apply (wp, clarsimp, wp+) - apply (rule_tac P="\s. valid_queues s \ (\p. t \ set (ksReadyQueues s p)) - \ (\tcb. ko_at' tcb t s \ tcbDomain tcb =rva - \ tcbPriority tcb = rvb \ valid_tcb' tcb s)" - and P'=UNIV in ccorres_from_vcg) - apply (rule allI, rule conseqPre, vcg) - apply (clarsimp simp: getQueue_def gets_def get_def setQueue_def modify_def - put_def bind_def return_def bitmap_fun_defs null_def) - apply (clarsimp simp: queue_in_range valid_tcb'_def) - apply (rule conjI; clarsimp simp: queue_in_range) - apply (drule (1) obj_at_cslift_tcb) - apply clarsimp - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="prio_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) apply clarsimp - apply clarsimp - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply (frule_tac s=\ in tcb_queue_relation_qend_mems, simp add: valid_queues_valid_q) - apply (drule_tac qend'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedAppend_update, - simp_all add: valid_queues_valid_q)[1] - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (simp add: invert_prioToL1Index_c_simp) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI; clarsimp) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (simp add: t_hrs_ksReadyQueues_upd_absorb) - apply (subst rf_sr_drop_bitmaps_enqueue_helper, assumption) - apply (fastforce intro: cbitmap_L1_relation_bit_set) - subgoal by (fastforce intro: cbitmap_L2_relation_bit_set simp: wordRadix_def mask_def) - apply (erule(1) state_relation_queue_update_helper[where S="{t}"], - (simp | rule globals.equality)+, - simp_all add: cready_queues_index_to_C_def2 numPriorities_def - t_hrs_ksReadyQueues_upd_absorb upd_unless_null_def - typ_heap_simps)[1] - apply (fastforce simp: tcb_null_sched_ptrs_def elim: obj_at'_weaken)+ - apply (clarsimp simp: upd_unless_null_def cready_queues_index_to_C_def numPriorities_def) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI; clarsimp simp: queue_in_range) - apply (drule (1) obj_at_cslift_tcb) - apply clarsimp - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply (frule_tac s=\ in tcb_queue_relation_qend_mems, - simp add: valid_queues_valid_q) - apply (drule_tac qend'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedAppend_update, - simp_all add: valid_queues_valid_q)[1] - apply clarsimp - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (clarsimp simp: upd_unless_null_def cready_queues_index_to_C_def numPriorities_def) - apply (drule (1) obj_at_cslift_tcb) - apply clarsimp - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule ccorres_symb_exec_r) + apply (rule ccorres_Guard_Seq) + apply (simp add: bind_assoc) + apply (ctac add: getQueue_ccorres) + apply (rule_tac r'=ctcb_queue_relation and xf'=new_queue_' in ccorres_split_nothrow) + apply (ctac add: tcb_queue_remove_ccorres) + apply ceqv + apply (rename_tac queue' newqueue) + apply (rule ccorres_Guard_Seq) + apply (ctac add: setQueue_ccorres) + apply (rule ccorres_split_nothrow_novcg_dc) + apply ctac + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue')" + and R="\s. \ tcbQueueEmpty queue' \ tcb_at' (the (tcbQueueHead queue')) s" + in ccorres_symb_exec_r_known_rv[where R'=UNIV]) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def + tcbQueueEmpty_def split: option.splits) + apply ceqv + apply (rule ccorres_cond[where R=\]) + apply fastforce + apply (ctac add: removeFromBitmap_ccorres) + apply (rule ccorres_return_Skip) + apply vcg + apply (wpsimp wp: hoare_vcg_imp_lift') + apply (clarsimp simp: guard_is_UNIV_def) + apply (wpsimp wp: hoare_vcg_imp_lift') + apply vcg + apply ((wpsimp wp: tcbQueueRemove_tcb_at'_head | wp (once) hoare_drop_imps)+)[1] + apply (vcg exspec=tcb_queue_remove_modifies) + apply wpsimp + apply vcg + apply vcg + apply (rule conseqPre, vcg) apply clarsimp - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply (frule_tac s=\ in tcb_queue_relation_qend_mems, - simp add: valid_queues_valid_q) - apply (drule_tac qend'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedAppend_update, - simp_all add: valid_queues_valid_q)[1] - apply clarsimp - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - apply (clarsimp simp: cready_queues_index_to_C_def2 numPriorities_def) - apply (frule(2) obj_at_cslift_tcb[OF valid_queues_obj_at'D]) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (erule_tac S="{t, v}" for v in state_relation_queue_update_helper, - (simp | rule globals.equality)+, - simp_all add: typ_heap_simps if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 upd_unless_null_def - cong: if_cong split del: if_split - del: fun_upd_restrict_conv)[1] - apply simp - apply (rule conjI) - apply clarsimp - apply (drule_tac s="tcb_ptr_to_ctcb_ptr t" in sym, simp) - apply (clarsimp simp add: fun_upd_twist) - prefer 3 - apply (simp add: obj_at'_weakenE[OF _ TrueI]) - apply (rule disjI1, erule valid_queues_obj_at'D) - subgoal by simp - subgoal by simp - subgoal by (fastforce simp: tcb_null_sched_ptrs_def) - apply (simp add: guard_is_UNIV_def) - apply simp - apply (wp threadGet_wp) + apply (wpsimp wp: threadGet_wp) + apply vcg + apply clarsimp + apply (wpsimp wp: threadGet_wp) apply vcg - apply simp - apply (wp threadGet_wp) - apply vcg - apply (rule ccorres_return_Skip) - apply simp - apply (wp threadGet_wp) - apply vcg - by (fastforce simp: valid_objs'_def obj_at'_def ran_def projectKOs typ_at'_def - valid_obj'_def inQ_def - dest!: valid_queues_obj_at'D) + apply (rule ccorres_return_Skip) + apply (wpsimp wp: threadGet_wp) + apply (vcg expsec=thread_state_get_tcbQueued_modifies) + apply normalise_obj_at' + apply (rename_tac tcb) + apply (frule (1) obj_at_cslift_tcb) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (clarsimp simp: valid_tcb'_def) + apply (cut_tac qdom="tcbDomain tcb" and prio="tcbPriority tcb" + in cready_queues_index_to_C_in_range) + apply fastforce + apply fastforce + apply (rule conjI) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (force dest!: tcbQueueHead_iff_tcbQueueEnd simp: tcbQueueEmpty_def obj_at'_def) + by (fastforce simp: word_less_nat_alt + cready_queues_index_to_C_def2 ctcb_relation_def + typ_heap_simps le_maxDomain_eq_less_numDomains(2) unat_trans_ucast_helper) qed +lemma tcb_queue_relation_append: + "\ tcb_queue_relation tn tp' mp queue qprev qhead; queue \ []; + qend' \ tcb_ptr_to_ctcb_ptr ` set queue; mp qend' = Some tcb; + queue = queue' @ [ctcb_ptr_to_tcb_ptr qend]; distinct queue; + \x \ set queue. tcb_ptr_to_ctcb_ptr x \ NULL; qend' \ NULL; + \v f g. tn (tn_update f v) = f (tn v) \ tp' (tp_update g v) = g (tp' v) + \ tn (tp_update f v) = tn v \ tp' (tn_update g v) = tp' v \ + \ tcb_queue_relation tn tp' + (mp (qend \ tn_update (\_. qend') (the (mp qend)), + qend' \ tn_update (\_. NULL) (tp_update (\_. qend) tcb))) + (queue @ [ctcb_ptr_to_tcb_ptr qend']) qprev qhead" + using [[hypsubst_thin = true]] + apply clarsimp + apply (induct queue' arbitrary: qprev qhead) + apply clarsimp + apply clarsimp + done + lemma isRunnable_spec: "\s. \ \ ({s} \ {s. cslift s (thread_' s) \ None}) Call isRunnable_'proc {s'. ret__unsigned_long_' s' = from_bool (tsType_CL (thread_state_lift (tcbState_C (the (cslift s (thread_' s))))) \ @@ -1820,8 +1574,11 @@ lemma tcb_at_1: done lemma rescheduleRequired_ccorres: - "ccorres dc xfdc (valid_queues and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_objs') - UNIV [] rescheduleRequired (Call rescheduleRequired_'proc)" + "ccorres dc xfdc + ((\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_objs' + and pspace_aligned' and pspace_distinct') + UNIV [] + rescheduleRequired (Call rescheduleRequired_'proc)" apply cinit apply (rule ccorres_symb_exec_l) apply (rule ccorres_split_nothrow_novcg[where r'=dc and xf'=xfdc]) @@ -1927,16 +1684,18 @@ lemma rf_sr_ksReadyQueuesL1Bitmap_simp: done lemma lookupBitmapPriority_le_maxPriority: - "\ ksReadyQueuesL1Bitmap s d \ 0 ; valid_queues s \ + "\ ksReadyQueuesL1Bitmap s d \ 0 ; + \d p. d > maxDomain \ p > maxPriority \ tcbQueueEmpty (ksReadyQueues s (d, p)); + valid_bitmaps s \ \ lookupBitmapPriority d s \ maxPriority" - unfolding valid_queues_def valid_queues_no_bitmap_def - by (fastforce dest!: bitmapQ_from_bitmap_lookup bitmapQ_ksReadyQueuesI intro: ccontr) + apply (clarsimp simp: valid_bitmaps_def) + by (fastforce dest!: bitmapQ_from_bitmap_lookup bitmapQ_ksReadyQueuesI intro: ccontr) lemma ksReadyQueuesL1Bitmap_word_log2_max: - "\valid_queues s; ksReadyQueuesL1Bitmap s d \ 0\ - \ word_log2 (ksReadyQueuesL1Bitmap s d) < l2BitmapSize" - unfolding valid_queues_def - by (fastforce dest: word_log2_nth_same bitmapQ_no_L1_orphansD) + "\valid_bitmaps s; ksReadyQueuesL1Bitmap s d \ 0\ + \ word_log2 (ksReadyQueuesL1Bitmap s d) < l2BitmapSize" + unfolding valid_bitmaps_def + by (fastforce dest: word_log2_nth_same bitmapQ_no_L1_orphansD) lemma clzl_spec: "\s. \ \ {\. s = \ \ x___unsigned_long_' s \ 0} Call clzl_'proc @@ -2133,9 +1892,9 @@ lemma threadGet_get_obj_at'_has_domain: lemma possibleSwitchTo_ccorres: shows "ccorres dc xfdc - (valid_queues and (\s. weak_sch_act_wf (ksSchedulerAction s) s) + ((\s. weak_sch_act_wf (ksSchedulerAction s) s) and st_tcb_at' runnable' t and (\s. ksCurDomain s \ maxDomain) - and valid_objs') + and valid_objs' and pspace_aligned' and pspace_distinct') ({s. target_' s = tcb_ptr_to_ctcb_ptr t} \ UNIV) [] (possibleSwitchTo t ) @@ -2183,8 +1942,8 @@ lemma possibleSwitchTo_ccorres: lemma scheduleTCB_ccorres': "ccorres dc xfdc - (tcb_at' thread and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_queues - and valid_objs') + (tcb_at' thread and (\s. weak_sch_act_wf (ksSchedulerAction s) s) + and valid_objs' and pspace_aligned' and pspace_distinct') (UNIV \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) [] (do (runnable, curThread, action) \ do @@ -2234,24 +1993,26 @@ lemma scheduleTCB_ccorres': apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def cscheduler_action_relation_def) apply wp+ - apply (simp add: isRunnable_def isStopped_def) - apply wp + apply (simp add: isRunnable_def isStopped_def) apply (simp add: guard_is_UNIV_def) apply clarsimp apply (clarsimp simp: st_tcb_at'_def obj_at'_def weak_sch_act_wf_def) done lemma scheduleTCB_ccorres_valid_queues'_pre: - "ccorresG rf_sr \ dc xfdc (tcb_at' thread and st_tcb_at' (not runnable') thread and valid_queues' and valid_queues and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_objs') - (UNIV \ \\tptr = tcb_ptr_to_ctcb_ptr thread\) [] - (do (runnable, curThread, action) \ do - runnable \ isRunnable thread; - curThread \ getCurThread; - action \ getSchedulerAction; - return (runnable, curThread, action) od; - when (\ runnable \ curThread = thread \ action = ResumeCurrentThread) rescheduleRequired - od) - (Call scheduleTCB_'proc)" + "ccorresG rf_sr \ dc xfdc + (tcb_at' thread and st_tcb_at' (not runnable') thread + and (\s. weak_sch_act_wf (ksSchedulerAction s) s) + and valid_objs' and pspace_aligned' and pspace_distinct') + \\tptr = tcb_ptr_to_ctcb_ptr thread\ [] + (do (runnable, curThread, action) \ do runnable \ isRunnable thread; + curThread \ getCurThread; + action \ getSchedulerAction; + return (runnable, curThread, action) + od; + when (\ runnable \ curThread = thread \ action = ResumeCurrentThread) rescheduleRequired + od) + (Call scheduleTCB_'proc)" supply empty_fail_cond[simp] apply (cinit' lift: tptr_' simp del: word_neq_0_conv) apply (rule ccorres_rhs_assoc2)+ @@ -2292,17 +2053,17 @@ lemma scheduleTCB_ccorres_valid_queues'_pre: split: scheduler_action.split_asm) apply wp+ apply (simp add: isRunnable_def isStopped_def) - apply wp apply (simp add: guard_is_UNIV_def) apply (clarsimp simp: st_tcb_at'_def obj_at'_def) done - lemmas scheduleTCB_ccorres_valid_queues' = scheduleTCB_ccorres_valid_queues'_pre[unfolded bind_assoc return_bind split_conv] lemma rescheduleRequired_ccorres_valid_queues'_simple: - "ccorresG rf_sr \ dc xfdc (valid_queues' and sch_act_simple) UNIV [] rescheduleRequired (Call rescheduleRequired_'proc)" + "ccorresG rf_sr \ dc xfdc + sch_act_simple UNIV [] + rescheduleRequired (Call rescheduleRequired_'proc)" apply cinit apply (rule ccorres_symb_exec_l) apply (rule ccorres_split_nothrow_novcg[where r'=dc and xf'=xfdc]) @@ -2335,16 +2096,17 @@ lemma rescheduleRequired_ccorres_valid_queues'_simple: split: scheduler_action.split_asm) lemma scheduleTCB_ccorres_valid_queues'_pre_simple: - "ccorresG rf_sr \ dc xfdc (tcb_at' thread and st_tcb_at' (not runnable') thread and valid_queues' and sch_act_simple) - (UNIV \ \\tptr = tcb_ptr_to_ctcb_ptr thread\) [] - (do (runnable, curThread, action) \ do - runnable \ isRunnable thread; - curThread \ getCurThread; - action \ getSchedulerAction; - return (runnable, curThread, action) od; - when (\ runnable \ curThread = thread \ action = ResumeCurrentThread) rescheduleRequired - od) - (Call scheduleTCB_'proc)" + "ccorresG rf_sr \ dc xfdc + (tcb_at' thread and st_tcb_at' (not runnable') thread and valid_queues' and sch_act_simple) + \\tptr = tcb_ptr_to_ctcb_ptr thread\ [] + (do (runnable, curThread, action) \ do runnable \ isRunnable thread; + curThread \ getCurThread; + action \ getSchedulerAction; + return (runnable, curThread, action) + od; + when (\ runnable \ curThread = thread \ action = ResumeCurrentThread) rescheduleRequired + od) + (Call scheduleTCB_'proc)" supply empty_fail_cond[simp] apply (cinit' lift: tptr_' simp del: word_neq_0_conv) apply (rule ccorres_rhs_assoc2)+ @@ -2383,11 +2145,10 @@ lemma scheduleTCB_ccorres_valid_queues'_pre_simple: apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def cscheduler_action_relation_def) apply wp+ - apply (simp add: isRunnable_def isStopped_def) - apply wp + apply (simp add: isRunnable_def isStopped_def) apply (simp add: guard_is_UNIV_def) apply clarsimp - apply (clarsimp simp: st_tcb_at'_def obj_at'_def valid_queues'_def) + apply (clarsimp simp: st_tcb_at'_def obj_at'_def) done lemmas scheduleTCB_ccorres_valid_queues'_simple @@ -2407,48 +2168,35 @@ lemma threadSet_weak_sch_act_wf_runnable': apply (clarsimp) done -lemma threadSet_valid_queues_and_runnable': "\\s. valid_queues s \ (\p. thread \ set (ksReadyQueues s p) \ runnable' st)\ - threadSet (tcbState_update (\_. st)) thread - \\rv s. valid_queues s\" - apply (wp threadSet_valid_queues) - apply (clarsimp simp: inQ_def) -done - lemma setThreadState_ccorres[corres]: "ccorres dc xfdc - (\s. tcb_at' thread s \ valid_queues s \ valid_objs' s \ valid_tcb_state' st s \ - (ksSchedulerAction s = SwitchToThread thread \ runnable' st) \ - (\p. thread \ set (ksReadyQueues s p) \ runnable' st) \ - sch_act_wf (ksSchedulerAction s) s) - ({s'. (\cl fl. cthread_state_relation_lifted st (cl\tsType_CL := ts_' s' && mask 4\, fl))} - \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) [] - (setThreadState st thread) (Call setThreadState_'proc)" + (\s. tcb_at' thread s \ valid_objs' s \ valid_tcb_state' st s + \ (ksSchedulerAction s = SwitchToThread thread \ runnable' st) + \ sch_act_wf (ksSchedulerAction s) s \ pspace_aligned' s \ pspace_distinct' s) + ({s'. (\cl fl. cthread_state_relation_lifted st (cl\tsType_CL := ts_' s' && mask 4\, fl))} + \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) hs + (setThreadState st thread) (Call setThreadState_'proc)" apply (cinit lift: tptr_' cong add: call_ignore_cong) apply (ctac (no_vcg) add: threadSet_tcbState_simple_corres) apply (ctac add: scheduleTCB_ccorres) - apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_queues_and_runnable' - threadSet_valid_objs') - by (clarsimp simp: weak_sch_act_wf_def valid_queues_def valid_tcb'_tcbState_update) - -lemma threadSet_valid_queues'_and_not_runnable': "\tcb_at' thread and valid_queues' and (\s. (\ runnable' st))\ - threadSet (tcbState_update (\_. st)) thread - \\rv. tcb_at' thread and st_tcb_at' (not runnable') thread and valid_queues' \" - - apply (wp threadSet_valid_queues' threadSet_tcbState_st_tcb_at') - apply (clarsimp simp: pred_neg_def valid_queues'_def inQ_def)+ -done + apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_objs') + apply (clarsimp simp: weak_sch_act_wf_def valid_tcb'_tcbState_update) + done lemma setThreadState_ccorres_valid_queues': - "ccorres dc xfdc - (\s. tcb_at' thread s \ valid_queues' s \ \ runnable' st \ weak_sch_act_wf (ksSchedulerAction s) s \ Invariants_H.valid_queues s \ (\p. thread \ set (ksReadyQueues s p)) \ sch_act_not thread s \ valid_objs' s \ valid_tcb_state' st s) + "ccorres dc xfdc + (\s. tcb_at' thread s \ \ runnable' st \ weak_sch_act_wf (ksSchedulerAction s) s + \ sch_act_not thread s \ valid_objs' s \ valid_tcb_state' st s + \ pspace_aligned' s \ pspace_distinct' s) ({s'. (\cl fl. cthread_state_relation_lifted st (cl\tsType_CL := ts_' s' && mask 4\, fl))} - \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) [] - (setThreadState st thread) (Call setThreadState_'proc)" + \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) [] + (setThreadState st thread) (Call setThreadState_'proc)" apply (cinit lift: tptr_' cong add: call_ignore_cong) apply (ctac (no_vcg) add: threadSet_tcbState_simple_corres) apply (ctac add: scheduleTCB_ccorres_valid_queues') - apply (wp threadSet_valid_queues'_and_not_runnable' threadSet_weak_sch_act_wf_runnable' threadSet_valid_queues_and_runnable' threadSet_valid_objs') - by (clarsimp simp: valid_tcb'_def tcb_cte_cases_def) + apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_objs' + threadSet_tcbState_st_tcb_at') + by (clarsimp simp: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) lemma simp_list_case_return: "(case x of [] \ return e | y # ys \ return f) = return (if x = [] then e else f)" @@ -2469,14 +2217,13 @@ lemma cancelSignal_ccorres [corres]: apply (rule ccorres_rhs_assoc2) apply (ctac (no_vcg) add: cancelSignal_ccorres_helper) apply (ctac add: setThreadState_ccorres_valid_queues') - apply ((wp setNotification_ksQ hoare_vcg_all_lift set_ntfn_valid_objs' | simp add: valid_tcb_state'_def split del: if_split)+)[1] + apply ((wp hoare_vcg_all_lift set_ntfn_valid_objs' | simp add: valid_tcb_state'_def split del: if_split)+)[1] apply (simp add: "StrictC'_thread_state_defs") apply (rule conjI, clarsimp, rule conjI, clarsimp) apply (frule (1) ko_at_valid_ntfn'[OF _ invs_valid_objs']) subgoal by ((auto simp: obj_at'_def projectKOs st_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of - cthread_state_relation_def sch_act_wf_weak valid_ntfn'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] | + cthread_state_relation_def sch_act_wf_weak valid_ntfn'_def | clarsimp simp: eq_commute)+) apply (clarsimp) apply (frule (1) ko_at_valid_ntfn'[OF _ invs_valid_objs']) @@ -2484,9 +2231,8 @@ lemma cancelSignal_ccorres [corres]: by (auto simp: obj_at'_def projectKOs st_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of valid_ntfn'_def cthread_state_relation_def sch_act_wf_weak isWaitingNtfn_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] - split: ntfn.splits option.splits - | clarsimp simp: eq_commute + split: ntfn.splits option.splits + | clarsimp simp: eq_commute | drule_tac x=thread in bspec)+ lemma cmap_relation_ep: @@ -2788,23 +2534,20 @@ lemma cancelIPC_ccorres_helper: cpspace_relation_def update_ep_map_tos typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - subgoal by (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - subgoal by (simp add: cendpoint_relation_def Let_def EPState_Idle_def) - subgoal by simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - subgoal by simp - apply (erule (1) map_to_ko_atI') - apply (simp add: heap_to_user_data_def Let_def) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - subgoal by (clarsimp simp: comp_def) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + subgoal by (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + subgoal by (simp add: cendpoint_relation_def Let_def EPState_Idle_def) + subgoal by simp + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + subgoal by simp + apply (erule (1) map_to_ko_atI') + apply (simp add: heap_to_user_data_def Let_def) subgoal by (simp add: carch_state_relation_def carch_globals_def typ_heap_simps') subgoal by (simp add: cmachine_state_relation_def) @@ -2825,38 +2568,36 @@ lemma cancelIPC_ccorres_helper: cpspace_relation_def update_ep_map_tos typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - subgoal by (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (simp add: cendpoint_relation_def Let_def isSendEP_def isRecvEP_def split: endpoint.splits split del: if_split) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + subgoal by (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (simp add: cendpoint_relation_def Let_def isSendEP_def isRecvEP_def + split: endpoint.splits split del: if_split) \ \recv case\ - apply (clarsimp simp add: Ptr_ptr_val h_t_valid_clift_Some_iff - tcb_queue_relation'_next_mask tcb_queue_relation'_prev_mask cong: tcb_queue_relation'_cong) - subgoal by (intro impI conjI; simp) - \ \send case\ - apply (clarsimp simp add: Ptr_ptr_val h_t_valid_clift_Some_iff - tcb_queue_relation'_next_mask tcb_queue_relation'_prev_mask cong: tcb_queue_relation'_cong) + apply (clarsimp simp: Ptr_ptr_val h_t_valid_clift_Some_iff + tcb_queue_relation'_next_mask tcb_queue_relation'_prev_mask + cong: tcb_queue_relation'_cong) subgoal by (intro impI conjI; simp) - subgoal by simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - apply simp - apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - subgoal by (clarsimp simp: comp_def) - subgoal by (simp add: carch_state_relation_def carch_globals_def - typ_heap_simps') + \ \send case\ + apply (clarsimp simp: Ptr_ptr_val h_t_valid_clift_Some_iff + tcb_queue_relation'_next_mask tcb_queue_relation'_prev_mask cong: tcb_queue_relation'_cong) + subgoal by (intro impI conjI; simp) + subgoal by simp + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp + apply (erule (1) map_to_ko_atI') + subgoal by (simp add: carch_state_relation_def carch_globals_def typ_heap_simps') subgoal by (simp add: cmachine_state_relation_def) subgoal by (simp add: h_t_valid_clift_Some_iff) subgoal by (simp add: objBits_simps') subgoal by (simp add: objBits_simps) apply assumption - done + done declare empty_fail_get[iff] @@ -3063,37 +2804,35 @@ lemma cancelIPC_ccorres1: subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits) + split: thread_state.splits) apply clarsimp apply (frule (2) ep_blocked_in_queueD_recv) apply (frule (1) ko_at_valid_ep'[OF _ invs_valid_objs']) subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of isRecvEP_def cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits endpoint.splits) + split: thread_state.splits endpoint.splits) apply (rule conjI) apply (clarsimp simp: inQ_def) - apply (rule conjI) - apply clarsimp apply clarsimp apply (rule conjI) subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits) + split: thread_state.splits) apply clarsimp apply (rule conjI) subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits) + split: thread_state.splits) apply clarsimp apply (frule (2) ep_blocked_in_queueD_send) apply (frule (1) ko_at_valid_ep'[OF _ invs_valid_objs']) subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of isSendEP_def cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits endpoint.splits)[1] + split: thread_state.splits endpoint.splits)[1] apply (auto simp: isTS_defs cthread_state_relation_def typ_heap_simps weak_sch_act_wf_def) apply (case_tac ts, auto simp: isTS_defs cthread_state_relation_def typ_heap_simps) diff --git a/proof/crefine/ARM/Ipc_C.thy b/proof/crefine/ARM/Ipc_C.thy index 846ab97da4..886916933b 100644 --- a/proof/crefine/ARM/Ipc_C.thy +++ b/proof/crefine/ARM/Ipc_C.thy @@ -1207,18 +1207,14 @@ shows done lemma asUser_tcbFault_obj_at: - "\obj_at' (\tcb. P (tcbFault tcb)) t\ asUser t' m - \\rv. obj_at' (\tcb. P (tcbFault tcb)) t\" + "asUser t' m \obj_at' (\tcb. P (tcbFault tcb)) t\" apply (simp add: asUser_def split_def) apply (wp threadGet_wp) apply (simp cong: if_cong) done lemma asUser_atcbContext_obj_at: - "t \ t' \ - \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ - asUser t' m - \\rv. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + "t \ t' \ asUser t' m \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" apply (simp add: asUser_def split_def atcbContextGet_def atcbContextSet_def) apply (wp threadGet_wp) apply simp @@ -3934,10 +3930,6 @@ lemma doReplyTransfer_ccorres [corres]: \ \\grant = from_bool grant\) hs (doReplyTransfer sender receiver slot grant) (Call doReplyTransfer_'proc)" -proof - - have invs_valid_queues_strg: "\s. invs' s \ valid_queues s" - by clarsimp - show ?thesis apply (cinit lift: sender_' receiver_' slot_' grant_') apply (rule getThreadState_ccorres_foo) apply (rule ccorres_assert2) @@ -3969,7 +3961,7 @@ proof - apply (ctac(no_vcg) add: cteDeleteOne_ccorres[where w="scast cap_reply_cap"]) apply (ctac(no_vcg) add: setThreadState_ccorres) apply (ctac(no_vcg) add: possibleSwitchTo_ccorres) - apply (wpsimp wp: sts_running_valid_queues setThreadState_st_tcb)+ + apply (wpsimp wp: sts_valid_objs' setThreadState_st_tcb)+ apply (wp cteDeleteOne_sch_act_wf) apply vcg apply (rule conseqPre, vcg) @@ -3978,8 +3970,7 @@ proof - apply wp apply (simp add: cap_get_tag_isCap) apply (strengthen invs_weak_sch_act_wf_strg - cte_wp_at_imp_consequent'[where P="\ct. Ex (ccap_relation (cteCap ct))" for ct] - invs_valid_queues_strg) + cte_wp_at_imp_consequent'[where P="\ct. Ex (ccap_relation (cteCap ct))" for ct]) apply (simp add: cap_reply_cap_def) apply (wp doIPCTransfer_reply_or_replyslot) apply (clarsimp simp: seL4_Fault_NullFault_def ccorres_cond_iffs @@ -4014,19 +4005,20 @@ proof - apply (ctac (no_vcg)) apply (simp only: K_bind_def) apply (ctac add: possibleSwitchTo_ccorres) - apply (wp sts_running_valid_queues setThreadState_st_tcb | simp)+ - apply (ctac add: setThreadState_ccorres_valid_queues'_simple) + apply (wp sts_valid_objs' setThreadState_st_tcb | simp)+ + apply (ctac add: setThreadState_ccorres_simple) apply wp - apply ((wp threadSet_valid_queues threadSet_sch_act threadSet_valid_queues' hoare_weak_lift_imp + apply ((wp threadSet_sch_act hoare_weak_lift_imp threadSet_valid_objs' threadSet_weak_sch_act_wf | simp add: valid_tcb_state'_def)+)[1] apply (clarsimp simp: guard_is_UNIV_def ThreadState_defs mask_def option_to_ctcb_ptr_def) - apply (rule_tac Q="\rv. valid_queues and tcb_at' receiver and valid_queues' and + apply (rule_tac Q="\rv. tcb_at' receiver and valid_objs' and sch_act_simple and (\s. ksCurDomain s \ maxDomain) and - (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) + (\s. sch_act_wf (ksSchedulerAction s) s) and + pspace_aligned' and pspace_distinct'" in hoare_post_imp) apply (clarsimp simp: inQ_def weak_sch_act_wf_def) - apply (wp threadSet_valid_queues threadSet_sch_act handleFaultReply_sch_act_wf) + apply (wp threadSet_sch_act handleFaultReply_sch_act_wf) apply (clarsimp simp: guard_is_UNIV_def) apply assumption apply clarsimp @@ -4035,7 +4027,7 @@ proof - apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_tcb]) apply (clarsimp simp: ctcb_relation_def typ_heap_simps) apply wp - apply (strengthen vp_invs_strg' invs_valid_queues') + apply (strengthen vp_invs_strg') apply (wp cteDeleteOne_tcbFault cteDeleteOne_sch_act_wf) apply vcg apply (rule conseqPre, vcg) @@ -4051,7 +4043,6 @@ proof - cap_get_tag_isCap) apply fastforce done -qed lemma ccorres_getCTE_cte_at: "ccorresG rf_sr \ r xf P P' hs (getCTE p >>= f) c @@ -4071,7 +4062,7 @@ lemma ccorres_getCTE_cte_at: done lemma setupCallerCap_ccorres [corres]: - "ccorres dc xfdc (valid_queues and valid_pspace' and (\s. \d p. sender \ set (ksReadyQueues s (d, p))) + "ccorres dc xfdc (valid_pspace' and (\s. sch_act_wf (ksSchedulerAction s) s) and sch_act_not sender and tcb_at' sender and tcb_at' receiver and tcb_at' sender and tcb_at' receiver) @@ -4202,23 +4193,20 @@ lemma sendIPC_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def - tcb_queue_relation'_def) - apply simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def + tcb_queue_relation'_def) apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - apply simp - apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp + apply (erule (1) map_to_ko_atI') apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -4242,31 +4230,28 @@ lemma sendIPC_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - isRecvEP_def isSendEP_def - tcb_queue_relation'_def valid_ep'_def - split: endpoint.splits list.splits + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + isRecvEP_def isSendEP_def + tcb_queue_relation'_def valid_ep'_def + split: endpoint.splits list.splits + split del: if_split) + apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") + apply (clarsimp simp: is_aligned_neg_mask + dest!: is_aligned_tcb_ptr_to_ctcb_ptr split del: if_split) - apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") - apply (clarsimp simp: is_aligned_neg_mask - dest!: is_aligned_tcb_ptr_to_ctcb_ptr - split del: if_split) - apply (clarsimp split: if_split) - apply simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply (clarsimp split: if_split) apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - apply simp - apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp + apply (erule (1) map_to_ko_atI') apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -4289,10 +4274,9 @@ lemma rf_sr_tcb_update_twice: cmachine_state_relation_def) lemma sendIPC_block_ccorres_helper: - "ccorres dc xfdc (tcb_at' thread and valid_queues and valid_objs' and + "ccorres dc xfdc (tcb_at' thread and valid_objs' and pspace_aligned' and pspace_distinct' and sch_act_not thread and ep_at' epptr and - (\s. sch_act_wf (ksSchedulerAction s) s \ - (\d p. thread \ set (ksReadyQueues s (d, p)))) and + (\s. sch_act_wf (ksSchedulerAction s) s) and K (bos = ThreadState_BlockedOnSend \ epptr' = epptr \ badge' = badge \ cg = from_bool canGrant \ cgr = from_bool canGrantReply @@ -4348,7 +4332,7 @@ lemma sendIPC_block_ccorres_helper: apply ceqv apply clarsimp apply ctac - apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_queues + apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_objs') apply (clarsimp simp: guard_is_UNIV_def) apply (clarsimp simp: sch_act_wf_weak valid_tcb'_def valid_tcb_state'_def @@ -4452,6 +4436,19 @@ lemma tcb_queue_relation_qend_valid': apply (simp add: h_t_valid_clift_Some_iff) done +lemma tcb_queue'_head_end_NULL: + assumes qr: "tcb_queue_relation' getNext getPrev mp queue qhead qend" + and tat: "\t\set queue. tcb_at' t s" + shows "(qend = NULL) = (qhead = NULL)" + using qr tat + apply - + apply (erule tcb_queue_relationE') + apply (simp add: tcb_queue_head_empty_iff split: if_splits) + apply (rule tcb_at_not_NULL) + apply (erule bspec) + apply simp + done + lemma tcbEPAppend_spec: "\s queue. \ \ \s. \t. (t, s) \ rf_sr \ (\tcb\set queue. tcb_at' tcb t) \ distinct queue @@ -4572,29 +4569,26 @@ lemma sendIPC_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep', assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - mask_def [where n=2] EPState_Send_def) - apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep', assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + mask_def [where n=2] EPState_Send_def) + apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask) + apply (simp add: isSendEP_def isRecvEP_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue, assumption+) apply (simp add: isSendEP_def isRecvEP_def) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_ep_queue, assumption+) - apply (simp add: isSendEP_def isRecvEP_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (simp only:projectKOs injectKO_ep objBits_simps) - apply clarsimp - apply (clarsimp simp: obj_at'_def projectKOs) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (simp only:projectKOs injectKO_ep objBits_simps) + apply clarsimp + apply (clarsimp simp: obj_at'_def projectKOs) apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: typ_heap_simps') @@ -4611,31 +4605,28 @@ lemma sendIPC_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep', assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - mask_def [where n=2] EPState_Send_def - split: if_split) - apply (fastforce simp: tcb_queue_relation'_def is_aligned_neg_mask - valid_ep'_def - dest: tcb_queue_relation_next_not_NULL) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep', assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + mask_def [where n=2] EPState_Send_def + split: if_split) + apply (fastforce simp: tcb_queue_relation'_def is_aligned_neg_mask + valid_ep'_def + dest: tcb_queue_relation_next_not_NULL) + apply (simp add: isSendEP_def isRecvEP_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue, assumption+) apply (simp add: isSendEP_def isRecvEP_def) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_ep_queue, assumption+) - apply (simp add: isSendEP_def isRecvEP_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def projectKOs) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def projectKOs) apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -4655,8 +4646,7 @@ lemma ctcb_relation_blockingIPCCanGrantD: lemma sendIPC_ccorres [corres]: "ccorres dc xfdc (invs' and st_tcb_at' simple' thread - and sch_act_not thread and ep_at' epptr and - (\s. \d p. thread \ set (ksReadyQueues s (d, p)))) + and sch_act_not thread and ep_at' epptr) (UNIV \ \\blocking = from_bool blocking\ \ \\do_call = from_bool do_call\ \ \\badge = badge\ @@ -4687,8 +4677,7 @@ lemma sendIPC_ccorres [corres]: apply ceqv apply (rule_tac A="invs' and st_tcb_at' simple' thread and sch_act_not thread and ko_at' ep epptr - and ep_at' epptr - and (\s. \d p. thread \ set (ksReadyQueues s (d, p)))" + and ep_at' epptr" in ccorres_guard_imp2 [where A'=UNIV]) apply wpc \ \RecvEP case\ @@ -4736,12 +4725,11 @@ lemma sendIPC_ccorres [corres]: apply (ctac add: setThreadState_ccorres) apply (rule ccorres_return_Skip) apply (wpsimp wp: hoare_drop_imps hoare_vcg_all_lift possibleSwitchTo_sch_act_not - possibleSwitchTo_sch_act_not sts_st_tcb' - possibleSwitchTo_ksQ' sts_valid_queues sts_ksQ' + possibleSwitchTo_sch_act_not sts_st_tcb' sts_valid_objs' simp: valid_tcb_state'_def)+ apply vcg - apply (wpsimp wp: doIPCTransfer_sch_act setEndpoint_ksQ hoare_vcg_all_lift - set_ep_valid_objs' setEndpoint_valid_mdb' + apply (wpsimp wp: doIPCTransfer_sch_act hoare_vcg_all_lift + set_ep_valid_objs' setEndpoint_valid_mdb' | wp (once) hoare_drop_imp | strengthen sch_act_wf_weak)+ apply (fastforce simp: guard_is_UNIV_def ThreadState_defs Collect_const_mem @@ -4817,7 +4805,7 @@ lemma sendIPC_ccorres [corres]: st_tcb_at'_def valid_tcb_state'_def ko_wp_at'_def isBlockedOnSend_def projectKO_opt_tcb split: if_split_asm if_split) - apply (rule conjI, simp, rule impI, clarsimp simp: valid_pspace_valid_objs') + apply (rule conjI, simp, rule impI, clarsimp simp: valid_pspace'_def) apply (erule delta_sym_refs) apply (clarsimp split: if_split_asm dest!: symreftype_inverse')+ @@ -4861,10 +4849,9 @@ lemma ctcb_relation_blockingIPCCanGrantReplyD: done lemma receiveIPC_block_ccorres_helper: - "ccorres dc xfdc (tcb_at' thread and valid_queues and valid_objs' and + "ccorres dc xfdc (tcb_at' thread and valid_objs' and pspace_aligned' and pspace_distinct' and sch_act_not thread and ep_at' epptr and - (\s. sch_act_wf (ksSchedulerAction s) s \ - (\d p. thread \ set (ksReadyQueues s (d, p)))) and + (\s. sch_act_wf (ksSchedulerAction s) s) and K (epptr = epptr && ~~ mask 4) and K (isEndpointCap cap \ ccap_relation cap cap')) UNIV hs @@ -4902,7 +4889,7 @@ lemma receiveIPC_block_ccorres_helper: apply ceqv apply clarsimp apply ctac - apply (wp threadSet_valid_queues hoare_vcg_all_lift threadSet_valid_objs' + apply (wp hoare_vcg_all_lift threadSet_valid_objs' threadSet_weak_sch_act_wf_runnable') apply (clarsimp simp: guard_is_UNIV_def) apply (clarsimp simp: sch_act_wf_weak valid_tcb'_def valid_tcb_state'_def @@ -4967,31 +4954,28 @@ lemma receiveIPC_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep', assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - mask_def [where n=2] EPState_Recv_def - split: if_split) - apply (fastforce simp: tcb_queue_relation'_def is_aligned_neg_mask - valid_ep'_def - dest: tcb_queue_relation_next_not_NULL) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep', assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + mask_def [where n=2] EPState_Recv_def + split: if_split) + apply (fastforce simp: tcb_queue_relation'_def is_aligned_neg_mask + valid_ep'_def + dest: tcb_queue_relation_next_not_NULL) + apply (simp add: isSendEP_def isRecvEP_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue, assumption+) apply (simp add: isSendEP_def isRecvEP_def) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_ep_queue, assumption+) - apply (simp add: isSendEP_def isRecvEP_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def projectKOs) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def projectKOs) apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -5008,28 +4992,25 @@ lemma receiveIPC_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep', assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - mask_def [where n=2] EPState_Recv_def) - apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep', assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + mask_def [where n=2] EPState_Recv_def) + apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask) + apply (simp add: isSendEP_def isRecvEP_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue, assumption+) apply (simp add: isSendEP_def isRecvEP_def) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_ep_queue, assumption+) - apply (simp add: isSendEP_def isRecvEP_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def projectKOs) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def projectKOs) apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: typ_heap_simps') @@ -5097,23 +5078,20 @@ lemma receiveIPC_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def - tcb_queue_relation'_def) - apply simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def + tcb_queue_relation'_def) apply simp + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: typ_heap_simps') @@ -5137,31 +5115,28 @@ lemma receiveIPC_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - isRecvEP_def isSendEP_def - tcb_queue_relation'_def valid_ep'_def - split: endpoint.splits list.splits + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + isRecvEP_def isSendEP_def + tcb_queue_relation'_def valid_ep'_def + split: endpoint.splits list.splits + split del: if_split) + apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") + apply (clarsimp simp: is_aligned_neg_mask + dest!: is_aligned_tcb_ptr_to_ctcb_ptr split del: if_split) - apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") - apply (clarsimp simp: is_aligned_neg_mask - dest!: is_aligned_tcb_ptr_to_ctcb_ptr - split del: if_split) - apply (clarsimp split: if_split) - apply simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply (clarsimp split: if_split) apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - apply simp - apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp + apply (erule (1) map_to_ko_atI') apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: typ_heap_simps') @@ -5278,7 +5253,6 @@ lemma receiveIPC_ccorres [corres]: notes option.case_cong_weak [cong] shows "ccorres dc xfdc (invs' and st_tcb_at' simple' thread and sch_act_not thread - and (\s. \d p. thread \ set (ksReadyQueues s (d, p))) and valid_cap' cap and K (isEndpointCap cap)) (UNIV \ \\thread = tcb_ptr_to_ctcb_ptr thread\ \ \ccap_relation cap \cap\ @@ -5354,7 +5328,6 @@ lemma receiveIPC_ccorres [corres]: apply ceqv apply (rule_tac A="invs' and st_tcb_at' simple' thread and sch_act_not thread - and (\s. \d p. thread \ set (ksReadyQueues s (d, p))) and ko_at' ep (capEPPtr cap)" in ccorres_guard_imp2 [where A'=UNIV]) apply wpc @@ -5494,27 +5467,25 @@ lemma receiveIPC_ccorres [corres]: apply ccorres_rewrite apply ctac apply (ctac add: possibleSwitchTo_ccorres) - apply (wpsimp wp: sts_st_tcb' sts_valid_queues) + apply (wpsimp wp: sts_st_tcb' sts_valid_objs') apply (vcg exspec=setThreadState_modifies) apply (fastforce simp: guard_is_UNIV_def ThreadState_defs mask_def cap_get_tag_isCap ccap_relation_ep_helpers) apply (clarsimp simp: valid_tcb_state'_def) - apply (rule_tac Q="\_. valid_pspace' and valid_queues + apply (rule_tac Q="\_. valid_pspace' and st_tcb_at' ((=) sendState) sender and tcb_at' thread and (\s. sch_act_wf (ksSchedulerAction s) s) - and (\s. (\a b. sender \ set (ksReadyQueues s (a, b)))) and sch_act_not sender and K (thread \ sender) and (\s. ksCurDomain s \ maxDomain)" in hoare_post_imp) - apply (clarsimp simp: valid_pspace_valid_objs' pred_tcb_at'_def sch_act_wf_weak - obj_at'_def) + apply (fastforce simp: valid_pspace_valid_objs' pred_tcb_at'_def sch_act_wf_weak + obj_at'_def) apply (wpsimp simp: guard_is_UNIV_def option_to_ptr_def option_to_0_def conj_ac)+ - apply (rule_tac Q="\rv. valid_queues and valid_pspace' + apply (rule_tac Q="\rv. valid_pspace' and cur_tcb' and tcb_at' sender and tcb_at' thread and sch_act_not sender and K (thread \ sender) and ep_at' (capEPPtr cap) and (\s. ksCurDomain s \ maxDomain) - and (\s. sch_act_wf (ksSchedulerAction s) s \ - (\d p. sender \ set (ksReadyQueues s (d, p))))" + and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) subgoal by (auto, auto simp: st_tcb_at'_def obj_at'_def) apply (wp hoare_vcg_all_lift set_ep_valid_objs') @@ -5549,13 +5520,11 @@ lemma receiveIPC_ccorres [corres]: split: if_split_asm bool.splits) (*very long *) apply (clarsimp simp: obj_at'_def state_refs_of'_def projectKOs) apply (frule(1) sym_refs_ko_atD' [OF _ invs_sym']) - apply (frule invs_queues) apply clarsimp apply (rename_tac list x xa) apply (rule_tac P="x\set list" in case_split) apply (clarsimp simp:st_tcb_at_refs_of_rev') apply (erule_tac x=x and P="\x. st_tcb_at' P x s" for P in ballE) - apply (drule_tac t=x in valid_queues_not_runnable'_not_ksQ) apply (clarsimp simp: st_tcb_at'_def obj_at'_def) apply (subgoal_tac "sch_act_not x s") prefer 2 @@ -5634,23 +5603,20 @@ lemma sendSignal_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) - apply simp+ - apply (erule (1) map_to_ko_atI') - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) - apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def - tcb_queue_relation'_def) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) + apply simp+ + apply (erule (1) map_to_ko_atI') + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) + apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def + tcb_queue_relation'_def) + apply simp apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -5676,31 +5642,28 @@ lemma sendSignal_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) - apply simp+ - apply (erule (1) map_to_ko_atI') - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) - apply (clarsimp simp: cnotification_relation_def Let_def - isWaitingNtfn_def - tcb_queue_relation'_def valid_ntfn'_def - split: Structures_H.notification.splits list.splits - split del: if_split) - apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") - apply (clarsimp simp: is_aligned_neg_mask - dest!: is_aligned_tcb_ptr_to_ctcb_ptr - split del: if_split) - apply (clarsimp split: if_split) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) + apply simp+ + apply (erule (1) map_to_ko_atI') + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) + apply (clarsimp simp: cnotification_relation_def Let_def + isWaitingNtfn_def + tcb_queue_relation'_def valid_ntfn'_def + split: Structures_H.notification.splits list.splits + split del: if_split) + apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") + apply (clarsimp simp: is_aligned_neg_mask + dest!: is_aligned_tcb_ptr_to_ctcb_ptr + split del: if_split) + apply (clarsimp split: if_split) + apply simp apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -5802,7 +5765,7 @@ lemma sendSignal_ccorres [corres]: apply (ctac(no_vcg) add: setThreadState_ccorres) apply (ctac(no_vcg) add: setRegister_ccorres) apply (ctac add: possibleSwitchTo_ccorres) - apply (wp sts_running_valid_queues sts_st_tcb_at'_cases + apply (wp sts_valid_objs' sts_st_tcb_at'_cases | simp add: option_to_ctcb_ptr_def split del: if_split)+ apply (rule_tac Q="\_. tcb_at' (the (ntfnBoundTCB ntfn)) and invs'" in hoare_post_imp) @@ -5868,10 +5831,8 @@ lemma sendSignal_ccorres [corres]: apply (ctac (no_vcg)) apply (ctac add: possibleSwitchTo_ccorres) apply (simp) - apply (wp weak_sch_act_wf_lift_linear - setThreadState_oa_queued - sts_valid_queues tcb_in_cur_domain'_lift)[1] - apply (wp sts_valid_queues sts_runnable) + apply (wp weak_sch_act_wf_lift_linear tcb_in_cur_domain'_lift)[1] + apply (wp sts_valid_objs' sts_runnable) apply (wp setThreadState_st_tcb set_ntfn_valid_objs' | clarsimp)+ apply (clarsimp simp: guard_is_UNIV_def ThreadState_defs mask_def badgeRegister_def Kernel_C.badgeRegister_def @@ -5896,10 +5857,9 @@ lemma sendSignal_ccorres [corres]: done lemma receiveSignal_block_ccorres_helper: - "ccorres dc xfdc (tcb_at' thread and valid_queues and sch_act_not thread and - valid_objs' and ntfn_at' ntfnptr and - (\s. sch_act_wf (ksSchedulerAction s) s \ - (\d p. thread \ set (ksReadyQueues s (d, p)))) and + "ccorres dc xfdc (tcb_at' thread and sch_act_not thread and + valid_objs' and ntfn_at' ntfnptr and pspace_aligned' and pspace_distinct' and + (\s. sch_act_wf (ksSchedulerAction s) s) and K (ntfnptr = ntfnptr && ~~ mask 4)) UNIV hs (setThreadState (Structures_H.thread_state.BlockedOnNotification @@ -5932,7 +5892,7 @@ lemma receiveSignal_block_ccorres_helper: apply ceqv apply clarsimp apply ctac - apply (wp threadSet_valid_queues hoare_vcg_all_lift threadSet_valid_objs' + apply (wp hoare_vcg_all_lift threadSet_valid_objs' threadSet_weak_sch_act_wf_runnable') apply (clarsimp simp: guard_is_UNIV_def) apply (auto simp: weak_sch_act_wf_def valid_tcb'_def tcb_cte_cases_def @@ -6053,31 +6013,28 @@ lemma receiveSignal_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cendpoint_relation_ntfn_queue, assumption+) + apply (simp add: isWaitingNtfn_def) apply simp - apply (rule cendpoint_relation_ntfn_queue, assumption+) - apply (simp add: isWaitingNtfn_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def projectKOs) - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn', assumption+) - apply (case_tac "ntfn", simp_all)[1] - apply (clarsimp simp: cnotification_relation_def Let_def - mask_def [where n=2] NtfnState_Waiting_def) - subgoal by (fastforce simp: tcb_queue_relation'_def is_aligned_neg_mask_weaken - valid_ntfn'_def - dest: tcb_queue_relation_next_not_NULL) - apply (simp add: isWaitingNtfn_def) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - subgoal by (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def projectKOs) + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn', assumption+) + apply (case_tac "ntfn", simp_all)[1] + apply (clarsimp simp: cnotification_relation_def Let_def + mask_def [where n=2] NtfnState_Waiting_def) + subgoal by (fastforce simp: tcb_queue_relation'_def is_aligned_neg_mask_weaken + valid_ntfn'_def + dest: tcb_queue_relation_next_not_NULL) + apply (simp add: isWaitingNtfn_def) apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -6094,30 +6051,27 @@ lemma receiveSignal_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cendpoint_relation_ntfn_queue, assumption+) + apply (simp add: isWaitingNtfn_def) apply simp - apply (rule cendpoint_relation_ntfn_queue, assumption+) - apply (simp add: isWaitingNtfn_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def projectKOs) - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn', assumption+) - apply (case_tac "ntfn", simp_all)[1] - apply (clarsimp simp: cnotification_relation_def Let_def - mask_def [where n=2] NtfnState_Waiting_def - split: if_split) - apply (fastforce simp: tcb_queue_relation'_def is_aligned_neg_mask_weaken) - apply (simp add: isWaitingNtfn_def) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def projectKOs) + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn', assumption+) + apply (case_tac "ntfn", simp_all)[1] + apply (clarsimp simp: cnotification_relation_def Let_def + mask_def [where n=2] NtfnState_Waiting_def + split: if_split) + apply (fastforce simp: tcb_queue_relation'_def is_aligned_neg_mask_weaken) + apply (simp add: isWaitingNtfn_def) apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -6129,7 +6083,6 @@ lemma receiveSignal_enqueue_ccorres_helper: lemma receiveSignal_ccorres [corres]: "ccorres dc xfdc (invs' and valid_cap' cap and st_tcb_at' simple' thread and sch_act_not thread - and (\s. \d p. thread \ set (ksReadyQueues s (d, p))) and K (isNotificationCap cap)) (UNIV \ \\thread = tcb_ptr_to_ctcb_ptr thread\ \ \ccap_relation cap \cap\ diff --git a/proof/crefine/ARM/IsolatedThreadAction.thy b/proof/crefine/ARM/IsolatedThreadAction.thy index a4326bc4da..41ca7f5f0b 100644 --- a/proof/crefine/ARM/IsolatedThreadAction.thy +++ b/proof/crefine/ARM/IsolatedThreadAction.thy @@ -859,9 +859,11 @@ lemma oblivious_switchToThread_schact: threadSet_def tcbSchedEnqueue_def unless_when asUser_def getQueue_def setQueue_def storeWordUser_def setRegister_def pointerInUserData_def isRunnable_def isStopped_def - getThreadState_def tcbSchedDequeue_def bitmap_fun_defs) + getThreadState_def tcbSchedDequeue_def tcbQueueRemove_def bitmap_fun_defs + ksReadyQueues_asrt_def) by (safe intro!: oblivious_bind - | simp_all add: oblivious_setVMRoot_schact)+ + | simp_all add: ready_qs_runnable_def idleThreadNotQueued_def + oblivious_setVMRoot_schact)+ (* FIXME move *) lemma empty_fail_getCurThread[intro!, wp, simp]: @@ -901,9 +903,8 @@ lemma tcbSchedEnqueue_tcbPriority[wp]: done crunch obj_at_prio[wp]: cteDeleteOne "obj_at' (\tcb. P (tcbPriority tcb)) t" - (wp: crunch_wps setEndpoint_obj_at_tcb' - setThreadState_obj_at_unchanged setNotification_tcb setBoundNotification_obj_at_unchanged - simp: crunch_simps unless_def) + (wp: crunch_wps setEndpoint_obj_at'_tcb setNotification_tcb + simp: crunch_simps unless_def setBoundNotification_def) context notes if_cong[cong] @@ -1027,8 +1028,6 @@ lemma setCTE_assert_modify: apply (rule word_and_le2) apply (simp add: objBits_simps mask_def field_simps) apply (simp add: simpler_modify_def cong: option.case_cong if_cong) - apply (rule kernel_state.fold_congs[OF refl refl]) - apply (clarsimp simp: projectKO_opt_tcb cong: if_cong) apply (clarsimp simp: lookupAround2_char1 word_and_le2) apply (rule ccontr, clarsimp) apply (erule(2) ps_clearD) @@ -1167,11 +1166,14 @@ lemma thread_actions_isolatableD: lemma tcbSchedDequeue_rewrite: "monadic_rewrite True True (obj_at' (Not \ tcbQueued) t) (tcbSchedDequeue t) (return ())" apply (simp add: tcbSchedDequeue_def) - apply (wp_pre, monadic_rewrite_symb_exec_l_known False, simp) - apply (rule monadic_rewrite_refl) - apply (wpsimp wp: threadGet_const)+ + apply wp_pre + apply monadic_rewrite_symb_exec_l + apply (monadic_rewrite_symb_exec_l_known False, simp) + apply (rule monadic_rewrite_refl) + apply (wpsimp wp: threadGet_const)+ done +(* FIXME: improve automation here *) lemma switchToThread_rewrite: "monadic_rewrite True True (ct_in_state' (Not \ runnable') and cur_tcb' and obj_at' (Not \ tcbQueued) t) @@ -1179,7 +1181,9 @@ lemma switchToThread_rewrite: (do Arch.switchToThread t; setCurThread t od)" apply (simp add: switchToThread_def Thread_H.switchToThread_def) apply (monadic_rewrite_l tcbSchedDequeue_rewrite, simp) - apply (rule monadic_rewrite_refl) + (* strip LHS of getters and asserts until LHS and RHS are the same *) + apply (repeat_unless \rule monadic_rewrite_refl\ monadic_rewrite_symb_exec_l) + apply wpsimp+ apply (clarsimp simp: comp_def) done @@ -1223,9 +1227,33 @@ lemma threadGet_isolatable: split: tcb_state_regs.split)+ done +lemma tcbQueued_put_tcb_state_regs_tcb: + "tcbQueued (put_tcb_state_regs_tcb tsr tcb) = tcbQueued tcb" + apply (clarsimp simp: put_tcb_state_regs_tcb_def) + by (cases tsr; clarsimp) + +lemma idleThreadNotQueued_isolatable: + "thread_actions_isolatable idx (stateAssert idleThreadNotQueued [])" + apply (simp add: stateAssert_def2 stateAssert_def) + apply (intro thread_actions_isolatable_bind[OF _ _ hoare_pre(1)] + gets_isolatable + thread_actions_isolatable_if + thread_actions_isolatable_returns + thread_actions_isolatable_fail) + unfolding idleThreadNotQueued_def + apply (clarsimp simp: obj_at_partial_overwrite_If) + apply (clarsimp simp: obj_at'_def tcbQueued_put_tcb_state_regs_tcb) + apply wpsimp+ + done + lemma setCurThread_isolatable: "thread_actions_isolatable idx (setCurThread t)" - by (simp add: setCurThread_def modify_isolatable) + unfolding setCurThread_def + apply (rule thread_actions_isolatable_bind) + apply (rule idleThreadNotQueued_isolatable) + apply (fastforce intro: modify_isolatable) + apply wpsimp + done lemma isolate_thread_actions_tcbs_at: assumes f: "\x. \tcb_at' (idx x)\ f \\rv. tcb_at' (idx x)\" shows diff --git a/proof/crefine/ARM/Recycle_C.thy b/proof/crefine/ARM/Recycle_C.thy index 1eed49e966..bd9f5452c6 100644 --- a/proof/crefine/ARM/Recycle_C.thy +++ b/proof/crefine/ARM/Recycle_C.thy @@ -550,16 +550,6 @@ lemma cnotification_relation_q_cong: apply (auto intro: iffD1[OF tcb_queue_relation'_cong[OF refl refl refl]]) done -lemma tcbSchedEnqueue_ep_at: - "\obj_at' (P :: endpoint \ bool) ep\ - tcbSchedEnqueue t - \\rv. obj_at' P ep\" - including no_pre - apply (simp add: tcbSchedEnqueue_def unless_def null_def) - apply (wp threadGet_wp, clarsimp, wp+) - apply (clarsimp split: if_split, wp) - done - lemma ccorres_duplicate_guard: "ccorres r xf (P and P) Q hs f f' \ ccorres r xf P Q hs f f'" by (erule ccorres_guard_imp, auto) @@ -579,10 +569,11 @@ lemma cancelBadgedSends_ccorres: (UNIV \ {s. epptr_' s = Ptr ptr} \ {s. badge_' s = bdg}) [] (cancelBadgedSends ptr bdg) (Call cancelBadgedSends_'proc)" apply (cinit lift: epptr_' badge_' simp: whileAnno_def) + apply (rule ccorres_stateAssert) apply (simp add: list_case_return cong: list.case_cong Structures_H.endpoint.case_cong call_ignore_cong del: Collect_const) - apply (rule ccorres_pre_getEndpoint) + apply (rule ccorres_pre_getEndpoint, rename_tac ep) apply (rule_tac R="ko_at' ep ptr" and xf'="ret__unsigned_'" and val="case ep of RecvEP q \ scast EPState_Recv | IdleEP \ scast EPState_Idle | SendEP q \ scast EPState_Send" @@ -634,8 +625,9 @@ lemma cancelBadgedSends_ccorres: st_tcb_at' (\st. isBlockedOnSend st \ blockingObject st = ptr) x s) \ distinct (xs @ list) \ ko_at' IdleEP ptr s \ (\p. \x \ set (xs @ list). \rf. (x, rf) \ {r \ state_refs_of' s p. snd r \ NTFNBound}) - \ valid_queues s \ pspace_aligned' s \ pspace_distinct' s - \ sch_act_wf (ksSchedulerAction s) s \ valid_objs' s" + \ pspace_aligned' s \ pspace_distinct' s + \ sch_act_wf (ksSchedulerAction s) s \ valid_objs' s + \ ksReadyQueues_head_end s \ ksReadyQueues_head_end_tcb_at' s" and P'="\xs. {s. ep_queue_relation' (cslift s) (xs @ list) (head_C (queue_' s)) (end_C (queue_' s))} \ {s. thread_' s = (case list of [] \ tcb_Ptr 0 @@ -731,8 +723,9 @@ lemma cancelBadgedSends_ccorres: apply (rule_tac rrel=dc and xf=xfdc and P="\s. (\t \ set (x @ a # lista). tcb_at' t s) \ (\p. \t \ set (x @ a # lista). \rf. (t, rf) \ {r \ state_refs_of' s p. snd r \ NTFNBound}) - \ valid_queues s \ distinct (x @ a # lista) - \ pspace_aligned' s \ pspace_distinct' s" + \ distinct (x @ a # lista) + \ pspace_aligned' s \ pspace_distinct' s + \ ksReadyQueues_head_end s \ ksReadyQueues_head_end_tcb_at' s" and P'="{s. ep_queue_relation' (cslift s) (x @ a # lista) (head_C (queue_' s)) (end_C (queue_' s))}" in ccorres_from_vcg) @@ -748,8 +741,7 @@ lemma cancelBadgedSends_ccorres: apply (clarsimp simp: return_def rf_sr_def cstate_relation_def Let_def) apply (rule conjI) apply (clarsimp simp: cpspace_relation_def) - apply (rule conjI, erule ctcb_relation_null_queue_ptrs) - apply (rule null_ep_queue) + apply (rule conjI, erule ctcb_relation_null_ep_ptrs) subgoal by (simp add: o_def) apply (rule conjI) apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) @@ -771,9 +763,6 @@ lemma cancelBadgedSends_ccorres: apply (clarsimp simp: image_iff) apply (drule_tac x=p in spec) subgoal by fastforce - apply (rule conjI) - apply (erule cready_queues_relation_not_queue_ptrs; - fastforce dest: null_ep_schedD[unfolded o_def] simp: o_def) apply (simp add: carch_state_relation_def cmachine_state_relation_def h_t_valid_clift_Some_iff) @@ -784,12 +773,11 @@ lemma cancelBadgedSends_ccorres: apply wp apply simp apply vcg - apply (wp hoare_vcg_const_Ball_lift tcbSchedEnqueue_ep_at - sch_act_wf_lift) + apply (wp hoare_vcg_const_Ball_lift sch_act_wf_lift) apply simp apply (vcg exspec=tcbSchedEnqueue_cslift_spec) apply (wp hoare_vcg_const_Ball_lift sts_st_tcb_at'_cases - sts_sch_act sts_valid_queues setThreadState_oa_queued) + sts_sch_act sts_valid_objs') apply (vcg exspec=setThreadState_cslift_spec) apply (simp add: ccorres_cond_iffs) apply (rule ccorres_symb_exec_r2) @@ -813,14 +801,11 @@ lemma cancelBadgedSends_ccorres: apply (clarsimp simp: cscheduler_action_relation_def st_tcb_at'_def split: scheduler_action.split_asm) apply (rename_tac word) - apply (frule_tac x=word in tcbSchedEnqueue_cslift_precond_discharge) - apply simp - subgoal by clarsimp - subgoal by clarsimp + apply (frule_tac x=word in tcbSchedEnqueue_cslift_precond_discharge; simp?) subgoal by clarsimp apply clarsimp apply (rule conjI) - apply (frule(3) tcbSchedEnqueue_cslift_precond_discharge) + apply (frule(3) tcbSchedEnqueue_cslift_precond_discharge; simp?) subgoal by clarsimp apply clarsimp apply (rule context_conjI) @@ -860,8 +845,19 @@ lemma cancelBadgedSends_ccorres: apply (clarsimp split: if_split) apply (drule sym_refsD, clarsimp) apply (drule(1) bspec)+ - by (auto simp: obj_at'_def projectKOs state_refs_of'_def pred_tcb_at'_def tcb_bound_refs'_def - dest!: symreftype_inverse') + apply (frule ksReadyQueues_asrt_ksReadyQueues_head_end) + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (frule (2) ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at') + apply (fastforce simp: obj_at'_def projectKOs state_refs_of'_def pred_tcb_at'_def + tcb_bound_refs'_def + dest!: symreftype_inverse') + apply (frule ksReadyQueues_asrt_ksReadyQueues_head_end) + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (frule (2) ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at') + apply fastforce + done declare Kernel_C.tcb_C_size [simp del] diff --git a/proof/crefine/ARM/Refine_C.thy b/proof/crefine/ARM/Refine_C.thy index f7cfacf590..5cb531bcc8 100644 --- a/proof/crefine/ARM/Refine_C.thy +++ b/proof/crefine/ARM/Refine_C.thy @@ -72,7 +72,7 @@ proof - apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply simp apply vcg apply vcg @@ -86,7 +86,7 @@ proof - apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (rule_tac Q="\rv s. invs' s \ (\x. rv = Some x \ x \ ARM.maxIRQ) \ rv \ Some 0x3FF" in hoare_post_imp) apply (clarsimp simp: Kernel_C.maxIRQ_def ARM.maxIRQ_def) apply (wp getActiveIRQ_le_maxIRQ getActiveIRQ_neq_Some0xFF | simp)+ @@ -115,14 +115,12 @@ lemma handleUnknownSyscall_ccorres: apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (clarsimp, vcg) apply (clarsimp, rule conseqPre, vcg, clarsimp) apply clarsimp apply (intro impI conjI allI) - apply fastforce - apply (clarsimp simp: ct_not_ksQ) - apply (clarsimp simp add: sch_act_simple_def split: scheduler_action.split) + apply fastforce apply (rule active_ex_cap') apply (erule active_from_running') apply (erule invs_iflive') @@ -172,13 +170,13 @@ lemma handleVMFaultEvent_ccorres: apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (case_tac x, clarsimp, wp) apply (clarsimp, wp, simp) apply wp apply (simp add: guard_is_UNIV_def) apply (clarsimp simp: simple_sane_strg[unfolded sch_act_sane_not]) - by (auto simp: ct_in_state'_def cfault_rel_def is_cap_fault_def ct_not_ksQ + by (auto simp: ct_in_state'_def cfault_rel_def is_cap_fault_def elim: pred_tcb'_weakenE st_tcb_ex_cap'' dest: st_tcb_at_idle_thread' rf_sr_ksCurThread) @@ -204,16 +202,14 @@ lemma handleUserLevelFault_ccorres: apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (clarsimp, vcg) apply (clarsimp, rule conseqPre, vcg, clarsimp) apply clarsimp apply (intro impI conjI allI) - apply (simp add: ct_in_state'_def) - apply (erule pred_tcb'_weakenE) - apply simp - apply (clarsimp simp: ct_not_ksQ) - apply (clarsimp simp add: sch_act_simple_def split: scheduler_action.split) + apply (simp add: ct_in_state'_def) + apply (erule pred_tcb'_weakenE) + apply simp apply (rule active_ex_cap') apply (erule active_from_running') apply (erule invs_iflive') @@ -398,11 +394,10 @@ lemma handleSyscall_ccorres: apply wp[1] apply clarsimp apply wp - apply (rule_tac Q="\rv s. ct_in_state' simple' s \ sch_act_sane s \ - (\p. ksCurThread s \ set (ksReadyQueues s p))" + apply (rule_tac Q="\rv s. ct_in_state' simple' s \ sch_act_sane s" in hoare_post_imp) apply (simp add: ct_in_state'_def) - apply (wp handleReply_sane handleReply_ct_not_ksQ) + apply (wp handleReply_sane) \ \SysYield\ apply (clarsimp simp: syscall_from_H_def syscall_defs) apply (rule ccorres_cond_empty |rule ccorres_cond_univ)+ @@ -428,11 +423,11 @@ lemma handleSyscall_ccorres: apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg_throws) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) - apply (wp schedule_invs' schedule_sch_act_wf | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + apply (wp schedule_invs' schedule_sch_act_wf + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (simp | wpc | wp hoare_drop_imp handleReply_sane handleReply_nonz_cap_to_ct schedule_invs' - handleReply_ct_not_ksQ[simplified] | strengthen ct_active_not_idle'_strengthen invs_valid_objs_strengthen)+ apply (rule_tac Q="\rv. invs' and ct_active'" in hoare_post_imp, simp) apply (wp hy_invs') @@ -450,7 +445,7 @@ lemma handleSyscall_ccorres: apply (frule active_ex_cap') apply (clarsimp simp: invs'_def valid_state'_def) apply (clarsimp simp: simple_sane_strg ct_in_state'_def st_tcb_at'_def obj_at'_def - isReply_def ct_not_ksQ) + isReply_def) apply (rule conjI, fastforce) prefer 2 apply (cut_tac 'b=32 and x=a and n=10 and 'a=10 in ucast_leq_mask) @@ -539,7 +534,7 @@ lemma handleHypervisorEvent_ccorres: apply simp apply assumption apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply clarsimp+ done @@ -653,6 +648,7 @@ lemma callKernel_withFastpath_corres_C: apply (clarsimp simp: typ_heap_simps' ct_in_state'_def "StrictC'_register_defs" word_sle_def word_sless_def st_tcb_at'_opeq_simp) + apply (frule ready_qs_runnable_cross, (fastforce simp: valid_sched_def)+) apply (rule conjI, fastforce simp: st_tcb_at'_def) apply (auto elim!: pred_tcb'_weakenE cnode_caps_gsCNodes_from_sr[rotated]) done @@ -672,12 +668,12 @@ lemma threadSet_all_invs_triv': apply (wp thread_set_invs_trivial thread_set_ct_running thread_set_not_state_valid_sched threadSet_invs_trivial threadSet_ct_running' hoare_weak_lift_imp thread_set_ct_in_state - | simp add: tcb_cap_cases_def tcb_arch_ref_def + | simp add: tcb_cap_cases_def tcb_arch_ref_def exst_same_def | rule threadSet_ct_in_state' | wp (once) hoare_vcg_disj_lift)+ apply clarsimp apply (rule exI, rule conjI, assumption) - apply (clarsimp simp: invs_def invs'_def cur_tcb_def cur_tcb'_def) + apply (clarsimp simp: invs_def valid_state_def valid_pspace_def invs'_def cur_tcb_def cur_tcb'_def) apply (simp add: state_relation_def) done @@ -887,17 +883,22 @@ lemma dmo_domain_user_mem'[wp]: done lemma do_user_op_corres_C: - "corres_underlying rf_sr False False (=) (invs' and ex_abs einvs) \ - (doUserOp f tc) (doUserOp_C f tc)" + "corres_underlying rf_sr False False (=) + (invs' and ksReadyQueues_asrt and ex_abs einvs) \ + (doUserOp f tc) (doUserOp_C f tc)" apply (simp only: doUserOp_C_def doUserOp_def split_def) apply (rule corres_guard_imp) apply (rule_tac P=\ and P'=\ and r'="(=)" in corres_split) apply (clarsimp simp: simpler_gets_def getCurThread_def corres_underlying_def rf_sr_def cstate_relation_def Let_def) - apply (rule_tac P=valid_state' and P'=\ and r'="(=)" in corres_split) + apply (rule_tac P="valid_state' and ksReadyQueues_asrt" + and P'=\ and r'="(=)" + in corres_split) apply (clarsimp simp: cstate_to_A_def absKState_def rf_sr_def cstate_to_H_correct ptable_lift_def) - apply (rule_tac P=valid_state' and P'=\ and r'="(=)" in corres_split) + apply (rule_tac P="valid_state' and ksReadyQueues_asrt" + and P'=\ and r'="(=)" + in corres_split) apply (clarsimp simp: cstate_to_A_def absKState_def rf_sr_def cstate_to_H_correct ptable_rights_def) apply (rule_tac P=pspace_distinct' and P'=\ and r'="(=)" @@ -994,6 +995,9 @@ lemma refinement2_both: apply (subst cstate_to_H_correct) apply (fastforce simp: full_invs'_def invs'_def) apply (clarsimp simp: rf_sr_def) + apply (clarsimp simp: lift_state_relation_def full_invs_def) + apply (rule ksReadyQueues_asrt_cross) + apply (erule state_relation_ready_queues_relation) apply (simp add:absKState_def observable_memory_def absExst_def) apply (rule MachineTypes.machine_state.equality,simp_all)[1] apply (rule ext) @@ -1020,13 +1024,35 @@ lemma refinement2_both: apply (clarsimp simp add: do_user_op_C_def do_user_op_H_def monad_to_transition_def) apply (rule rev_mp, rule_tac f="uop" and tc=af in do_user_op_corres_C) apply (clarsimp simp: corres_underlying_def invs_def ex_abs_def) - apply (fastforce simp: full_invs'_def ex_abs_def) + apply (drule bspec) + apply fastforce + apply clarsimp + apply (elim impE) + apply (clarsimp simp: full_invs'_def ex_abs_def) + apply (intro conjI) + apply (rule ksReadyQueues_asrt_cross) + apply (erule state_relation_ready_queues_relation) + apply (clarsimp simp: lift_state_relation_def full_invs_def) + apply (frule state_relation_ready_queues_relation) + apply (fastforce simp: ready_queues_relation_def Let_def tcbQueueEmpty_def) + apply fastforce apply (erule_tac P="a \ b \ c \ (\x. e x)" for a b c d e in disjE) apply (clarsimp simp add: do_user_op_C_def do_user_op_H_def monad_to_transition_def) apply (rule rev_mp, rule_tac f="uop" and tc=af in do_user_op_corres_C) apply (clarsimp simp: corres_underlying_def invs_def ex_abs_def) - apply (fastforce simp: full_invs'_def ex_abs_def) + apply (drule bspec) + apply fastforce + apply clarsimp + apply (elim impE) + apply (clarsimp simp: full_invs'_def ex_abs_def) + apply (intro conjI) + apply (rule ksReadyQueues_asrt_cross) + apply (erule state_relation_ready_queues_relation) + apply (clarsimp simp: lift_state_relation_def full_invs_def) + apply (frule state_relation_ready_queues_relation) + apply (fastforce simp: ready_queues_relation_def Let_def tcbQueueEmpty_def) + apply fastforce apply (clarsimp simp: check_active_irq_C_def check_active_irq_H_def) apply (rule rev_mp, rule check_active_irq_corres_C) diff --git a/proof/crefine/ARM/Retype_C.thy b/proof/crefine/ARM/Retype_C.thy index 8b52dde04e..d25e6fbb8c 100644 --- a/proof/crefine/ARM/Retype_C.thy +++ b/proof/crefine/ARM/Retype_C.thy @@ -2597,7 +2597,6 @@ lemma cnc_tcb_helper: and al: "is_aligned (ctcb_ptr_to_tcb_ptr p) (objBitsKO kotcb)" and ptr0: "ctcb_ptr_to_tcb_ptr p \ 0" and ptrlb: "2^ctcb_size_bits \ ptr_val p" - and vq: "valid_queues \" and pal: "pspace_aligned' (\\ksPSpace := ks\)" and pno: "pspace_no_overlap' (ctcb_ptr_to_tcb_ptr p) (objBitsKO kotcb) (\\ksPSpace := ks\)" and pds: "pspace_distinct' (\\ksPSpace := ks\)" @@ -2911,21 +2910,20 @@ proof - unfolding ctcb_relation_def makeObject_tcb apply (simp add: fbtcb minBound_word) apply (intro conjI) - apply (simp add: cthread_state_relation_def thread_state_lift_def - eval_nat_numeral ThreadState_defs) - apply (simp add: ccontext_relation_def carch_tcb_relation_def) - apply (rule allI) - subgoal for r - by (case_tac r; - simp add: "StrictC'_register_defs" eval_nat_numeral atcbContext_def atcbContextGet_def - newArchTCB_def newContext_def initContext_def take_bit_Suc - del: unsigned_numeral) - apply (simp add: thread_state_lift_def eval_nat_numeral atcbContextGet_def)+ - apply (simp add: Kernel_Config.timeSlice_def) - apply (simp add: cfault_rel_def seL4_Fault_lift_def seL4_Fault_get_tag_def Let_def - lookup_fault_lift_def lookup_fault_get_tag_def lookup_fault_invalid_root_def - eval_nat_numeral seL4_Fault_NullFault_def option_to_ptr_def option_to_0_def - split: if_split)+ + apply (simp add: cthread_state_relation_def thread_state_lift_def + eval_nat_numeral ThreadState_Inactive_def) + apply (clarsimp simp: ccontext_relation_def carch_tcb_relation_def + newArchTCB_def atcbContextGet_def) + apply (case_tac r; simp add: C_register_defs index_foldr_update + atcbContext_def newArchTCB_def newContext_def + initContext_def) + apply (simp add: thread_state_lift_def index_foldr_update atcbContextGet_def) + apply (simp add: Kernel_Config.timeSlice_def) + apply (simp add: cfault_rel_def seL4_Fault_lift_def seL4_Fault_get_tag_def Let_def + lookup_fault_lift_def lookup_fault_get_tag_def lookup_fault_invalid_root_def + index_foldr_update seL4_Fault_NullFault_def option_to_ptr_def option_to_0_def + split: if_split)+ + apply (simp add: option_to_ctcb_ptr_def) done have pks: "ks (ctcb_ptr_to_tcb_ptr p) = None" @@ -2976,15 +2974,6 @@ proof - apply (fastforce simp: dom_def) done - hence kstcb: "\qdom prio. ctcb_ptr_to_tcb_ptr p \ set (ksReadyQueues \ (qdom, prio))" using vq - apply (clarsimp simp add: valid_queues_def valid_queues_no_bitmap_def) - apply (drule_tac x = qdom in spec) - apply (drule_tac x = prio in spec) - apply clarsimp - apply (drule (1) bspec) - apply (simp add: obj_at'_def) - done - have ball_subsetE: "\P S R. \ \x \ S. P x; R \ S \ \ \x \ R. P x" by blast @@ -3098,7 +3087,7 @@ proof - apply (simp add: cl_cte [simplified] cl_tcb [simplified] cl_rest [simplified] tag_disj_via_td_name) apply (clarsimp simp add: cready_queues_relation_def Let_def htd_safe[simplified] kernel_data_refs_domain_eq_rotate) - apply (simp add: kstcb tcb_queue_update_other' hrs_htd_update + apply (simp add: tcb_queue_update_other' hrs_htd_update ptr_retyp_to_array[simplified] irq[simplified]) done qed @@ -3978,7 +3967,7 @@ declare replicate_numeral [simp del] lemma ccorres_placeNewObject_tcb: "ccorresG rf_sr \ dc xfdc (pspace_aligned' and pspace_distinct' and pspace_no_overlap' regionBase tcbBlockSizeBits - and valid_queues and (\s. sym_refs (state_refs_of' s)) + and (\s. sym_refs (state_refs_of' s)) and (\s. 2 ^ tcbBlockSizeBits \ gsMaxObjectSize s) and ret_zero regionBase (2 ^ tcbBlockSizeBits) and K (regionBase \ 0 \ range_cover regionBase tcbBlockSizeBits tcbBlockSizeBits 1 @@ -4317,7 +4306,7 @@ qed lemma placeNewObject_user_data: "ccorresG rf_sr \ dc xfdc (pspace_aligned' and pspace_distinct' and pspace_no_overlap' regionBase (pageBits+us) - and valid_queues and valid_machine_state' + and valid_machine_state' and ret_zero regionBase (2 ^ (pageBits+us)) and (\s. sym_refs (state_refs_of' s)) and (\s. 2^(pageBits + us) \ gsMaxObjectSize s) @@ -4439,7 +4428,7 @@ lemma placeNewObject_user_data_device: "ccorresG rf_sr \ dc xfdc (pspace_aligned' and pspace_distinct' and ret_zero regionBase (2 ^ (pageBits + us)) - and pspace_no_overlap' regionBase (pageBits+us) and valid_queues + and pspace_no_overlap' regionBase (pageBits+us) and (\s. sym_refs (state_refs_of' s)) and (\s. 2^(pageBits + us) \ gsMaxObjectSize s) and K (regionBase \ 0 \ range_cover regionBase (pageBits + us) (pageBits+us) (Suc 0) @@ -4694,7 +4683,7 @@ proof - apply clarify apply (intro conjI) apply (clarsimp simp: invs_pspace_aligned' invs_pspace_distinct' invs_valid_global' - APIType_capBits_def invs_queues invs_valid_objs' + APIType_capBits_def invs_valid_objs' invs_urz) apply clarsimp apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def @@ -4827,11 +4816,6 @@ lemma threadSet_domain_ccorres [corres]: apply (simp add: map_to_ctes_upd_tcb_no_ctes map_to_tcbs_upd tcb_cte_cases_def) apply (simp add: cep_relations_drop_fun_upd cvariable_relation_upd_const ko_at_projectKO_opt) - apply (rule conjI) - defer - apply (erule cready_queues_relation_not_queue_ptrs) - apply (rule ext, simp split: if_split) - apply (rule ext, simp split: if_split) apply (drule ko_at_projectKO_opt) apply (erule (2) cmap_relation_upd_relI) subgoal by (simp add: ctcb_relation_def) @@ -4956,7 +4940,6 @@ proof - createObject_c_preconds_def) apply (frule invs_pspace_aligned') apply (frule invs_pspace_distinct') - apply (frule invs_queues) apply (frule invs_sym') apply (simp add: getObjectSize_def objBits_simps' word_bits_conv apiGetObjectSize_def new_cap_addrs_def projectKO_opt_tcb) @@ -5007,7 +4990,6 @@ proof - apply (clarsimp simp: createObject_hs_preconds_def isFrameType_def) apply (frule invs_pspace_aligned') apply (frule invs_pspace_distinct') - apply (frule invs_queues) apply (frule invs_sym') apply (auto simp: getObjectSize_def objBits_simps apiGetObjectSize_def @@ -5046,7 +5028,6 @@ proof - apply (clarsimp simp: createObject_hs_preconds_def isFrameType_def) apply (frule invs_pspace_aligned') apply (frule invs_pspace_distinct') - apply (frule invs_queues) apply (frule invs_sym') apply (auto simp: getObjectSize_def objBits_simps apiGetObjectSize_def ntfnSizeBits_def word_bits_conv @@ -5085,7 +5066,6 @@ proof - apply (clarsimp simp: createObject_hs_preconds_def isFrameType_def) apply (frule invs_pspace_aligned') apply (frule invs_pspace_distinct') - apply (frule invs_queues) apply (frule invs_sym') apply (frule(1) ghost_assertion_size_logic_no_unat) apply (clarsimp simp: getObjectSize_def objBits_simps apiGetObjectSize_def diff --git a/proof/crefine/ARM/SR_lemmas_C.thy b/proof/crefine/ARM/SR_lemmas_C.thy index 5fa807eab5..7857a68d4c 100644 --- a/proof/crefine/ARM/SR_lemmas_C.thy +++ b/proof/crefine/ARM/SR_lemmas_C.thy @@ -296,11 +296,15 @@ lemma cmdbnode_relation_mdb_node_to_H [simp]: unfolding cmdbnode_relation_def mdb_node_to_H_def mdb_node_lift_def cte_lift_def by (fastforce split: option.splits) -definition - tcb_no_ctes_proj :: "tcb \ Structures_H.thread_state \ word32 \ word32 \ arch_tcb \ bool \ word8 \ word8 \ word8 \ nat \ fault option \ word32 option" +definition tcb_no_ctes_proj :: + "tcb \ Structures_H.thread_state \ machine_word \ machine_word \ arch_tcb \ bool \ word8 + \ word8 \ word8 \ nat \ fault option \ machine_word option + \ machine_word option \ machine_word option" where - "tcb_no_ctes_proj t \ (tcbState t, tcbFaultHandler t, tcbIPCBuffer t, tcbArch t, tcbQueued t, - tcbMCP t, tcbPriority t, tcbDomain t, tcbTimeSlice t, tcbFault t, tcbBoundNotification t)" + "tcb_no_ctes_proj t \ + (tcbState t, tcbFaultHandler t, tcbIPCBuffer t, tcbArch t, tcbQueued t, + tcbMCP t, tcbPriority t, tcbDomain t, tcbTimeSlice t, tcbFault t, tcbBoundNotification t, + tcbSchedNext t, tcbSchedPrev t)" lemma tcb_cte_cases_proj_eq [simp]: "tcb_cte_cases p = Some (getF, setF) \ @@ -1384,9 +1388,9 @@ lemma cmap_relation_cong: apply (erule imageI) done -lemma ctcb_relation_null_queue_ptrs: +lemma ctcb_relation_null_ep_ptrs: assumes rel: "cmap_relation mp mp' tcb_ptr_to_ctcb_ptr ctcb_relation" - and same: "map_option tcb_null_queue_ptrs \ mp'' = map_option tcb_null_queue_ptrs \ mp'" + and same: "map_option tcb_null_ep_ptrs \ mp'' = map_option tcb_null_ep_ptrs \ mp'" shows "cmap_relation mp mp'' tcb_ptr_to_ctcb_ptr ctcb_relation" using rel apply (rule iffD1 [OF cmap_relation_cong, OF _ map_option_eq_dom_eq, rotated -1]) @@ -1394,7 +1398,7 @@ lemma ctcb_relation_null_queue_ptrs: apply (rule same [symmetric]) apply (drule compD [OF same]) apply (case_tac b, case_tac b') - apply (simp add: ctcb_relation_def tcb_null_queue_ptrs_def) + apply (simp add: ctcb_relation_def tcb_null_ep_ptrs_def) done (* Levity: added (20090419 09:44:27) *) @@ -2117,6 +2121,14 @@ lemma invs_urz[elim!]: "invs' s \ untyped_ranges_zero' s" by (clarsimp simp: invs'_def valid_state'_def) +lemma rf_sr_ctcb_queue_relation: + "\ (s, s') \ rf_sr; d \ maxDomain; p \ maxPriority \ + \ ctcb_queue_relation (ksReadyQueues s (d, p)) + (index (ksReadyQueues_' (globals s')) (cready_queues_index_to_C d p))" + unfolding rf_sr_def cstate_relation_def cready_queues_relation_def + apply (clarsimp simp: Let_def seL4_MinPrio_def minDom_def maxDom_to_H maxPrio_to_H) + done + lemma rf_sr_sched_action_relation: "(s, s') \ rf_sr \ cscheduler_action_relation (ksSchedulerAction s) (ksSchedulerAction_' (globals s'))" @@ -2143,5 +2155,11 @@ lemma physBase_spec: apply (simp add: Kernel_Config.physBase_def) done +lemma rf_sr_obj_update_helper: + "(s, s'\ globals := globals s' \ t_hrs_' := t_hrs_' (globals (undefined + \ globals := (undefined \ t_hrs_' := f (globals s') (t_hrs_' (globals s')) \)\))\\) \ rf_sr + \ (s, globals_update (\v. t_hrs_'_update (f v) v) s') \ rf_sr" + by (simp cong: StateSpace.state.fold_congs globals.fold_congs) + end end diff --git a/proof/crefine/ARM/Schedule_C.thy b/proof/crefine/ARM/Schedule_C.thy index ad4a8c857c..c9a827f206 100644 --- a/proof/crefine/ARM/Schedule_C.thy +++ b/proof/crefine/ARM/Schedule_C.thy @@ -6,7 +6,7 @@ *) theory Schedule_C -imports Tcb_C +imports Tcb_C Detype_C begin (*FIXME: arch_split: move up?*) @@ -33,18 +33,17 @@ lemma switchToIdleThread_ccorres: "ccorres dc xfdc invs_no_cicd' UNIV [] switchToIdleThread (Call switchToIdleThread_'proc)" apply (cinit) + apply (rule ccorres_stateAssert) apply (rule ccorres_symb_exec_l) apply (ctac (no_vcg) add: Arch_switchToIdleThread_ccorres) apply (simp add: setCurThread_def) + apply (rule ccorres_stateAssert) apply (rule_tac P="\s. thread = ksIdleThread s" and P'=UNIV in ccorres_from_vcg) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: simpler_modify_def) apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def carch_state_relation_def cmachine_state_relation_def) - apply (simp add: ARM_H.switchToIdleThread_def) - apply wp+ - apply simp - apply simp + apply (wpsimp simp: ARM_H.switchToIdleThread_def wp: hoare_drop_imps)+ done lemma Arch_switchToThread_ccorres: @@ -64,6 +63,13 @@ lemma Arch_switchToThread_ccorres: apply clarsimp done +lemma invs_no_cicd'_pspace_aligned': + "all_invs_but_ct_idle_or_in_cur_domain' s \ pspace_aligned' s" + by (simp add: all_invs_but_ct_idle_or_in_cur_domain'_def valid_pspace'_def) + +lemma invs_no_cicd'_pspace_distinct': + "all_invs_but_ct_idle_or_in_cur_domain' s \ pspace_distinct' s" + by (simp add: all_invs_but_ct_idle_or_in_cur_domain'_def valid_pspace'_def) (* FIXME: move *) lemma switchToThread_ccorres: @@ -73,23 +79,28 @@ lemma switchToThread_ccorres: hs (switchToThread t) (Call switchToThread_'proc)" - apply (cinit lift: thread_') + apply (clarsimp simp: switchToThread_def) + apply (rule ccorres_symb_exec_l'[OF _ _ isRunnable_sp]; (solves wpsimp)?) + apply (rule ccorres_symb_exec_l'[OF _ _ assert_sp]; (solves wpsimp)?) + apply (rule ccorres_stateAssert_fwd)+ + apply (cinit' lift: thread_') apply (ctac (no_vcg) add: Arch_switchToThread_ccorres) apply (ctac (no_vcg) add: tcbSchedDequeue_ccorres) + apply (simp add: setCurThread_def) + apply (rule ccorres_stateAssert) apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg) apply clarsimp apply (rule conseqPre, vcg) - apply (clarsimp simp: setCurThread_def simpler_modify_def) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def) - apply wp+ - apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def) + apply (clarsimp simp: setCurThread_def simpler_modify_def rf_sr_def cstate_relation_def + Let_def carch_state_relation_def cmachine_state_relation_def) + apply (wpsimp wp: Arch_switchToThread_invs_no_cicd' hoare_drop_imps + | strengthen invs_no_cicd'_pspace_aligned' invs_no_cicd'_pspace_distinct')+ done lemma activateThread_ccorres: "ccorres dc xfdc (ct_in_state' activatable' and (\s. sch_act_wf (ksSchedulerAction s) s) - and valid_queues and valid_objs') + and valid_objs' and pspace_aligned' and pspace_distinct') UNIV [] activateThread (Call activateThread_'proc)" @@ -159,6 +170,31 @@ lemma switchToThread_ccorres': apply auto done +lemma ccorres_pre_getQueue: + assumes cc: "\queue. ccorres r xf (P queue) (P' queue) hs (f queue) c" + shows "ccorres r xf (\s. P (ksReadyQueues s (d, p)) s \ d \ maxDomain \ p \ maxPriority) + {s'. \queue. (let cqueue = index (ksReadyQueues_' (globals s')) + (cready_queues_index_to_C d p) in + ctcb_queue_relation queue cqueue) \ s' \ P' queue} + hs (getQueue d p >>= (\queue. f queue)) c" + apply (rule ccorres_guard_imp2) + apply (rule ccorres_symb_exec_l2) + defer + defer + apply (rule gq_sp) + defer + apply (rule ccorres_guard_imp) + apply (rule cc) + apply clarsimp + apply assumption + apply assumption + apply (clarsimp simp: getQueue_def gets_exs_valid) + apply clarsimp + apply (drule spec, erule mp) + apply (erule rf_sr_ctcb_queue_relation) + apply (simp add: maxDom_to_H maxPrio_to_H)+ + done + lemma chooseThread_ccorres: "ccorres dc xfdc all_invs_but_ct_idle_or_in_cur_domain' UNIV [] chooseThread (Call chooseThread_'proc)" proof - @@ -174,9 +210,22 @@ proof - "\s. invs_no_cicd' s \ ksCurDomain s \ maxDomain" by (simp add: invs_no_cicd'_def) + have invs_no_cicd'_valid_bitmaps: + "\s. invs_no_cicd' s \ valid_bitmaps s" + by (simp add: invs_no_cicd'_def) + + have invs_no_cicd'_pspace_aligned': + "\s. invs_no_cicd' s \ pspace_aligned' s" + by (simp add: invs_no_cicd'_def valid_pspace'_def) + + have invs_no_cicd'_pspace_distinct': + "\s. invs_no_cicd' s \ pspace_distinct' s" + by (simp add: invs_no_cicd'_def valid_pspace'_def) + show ?thesis supply if_split[split del] apply (cinit) + apply (rule ccorres_stateAssert)+ apply (simp add: numDomains_sge_1_simp) apply (rule_tac xf'=dom_' and r'="\rv rv'. rv' = ucast rv" in ccorres_split_nothrow_novcg) apply (rule ccorres_from_vcg[where P=\ and P'=UNIV]) @@ -209,7 +258,7 @@ proof - apply (rule_tac P="curdom \ maxDomain" in ccorres_cross_over_guard_no_st) apply (rule_tac P="prio \ maxPriority" in ccorres_cross_over_guard_no_st) apply (rule ccorres_pre_getQueue) - apply (rule_tac P="queue \ []" in ccorres_cross_over_guard_no_st) + apply (rule_tac P="\ tcbQueueEmpty queue" in ccorres_cross_over_guard_no_st) apply (rule ccorres_symb_exec_l) apply (rule ccorres_assert) apply (rule ccorres_symb_exec_r) @@ -224,37 +273,40 @@ proof - apply (rule conseqPre, vcg) apply (rule Collect_mono) apply clarsimp - apply (strengthen queue_in_range) apply assumption apply clarsimp apply (rule conseqPre, vcg) apply clarsimp apply (wp isRunnable_wp)+ apply (clarsimp simp: Let_def guard_is_UNIV_def) - apply (drule invs_no_cicd'_queues) - apply (case_tac queue, simp) - apply (clarsimp simp: tcb_queue_relation'_def cready_queues_index_to_C_def numPriorities_def) - apply (clarsimp simp add: maxDom_to_H maxPrio_to_H - queue_in_range[where qdom=0, simplified, simplified maxPrio_to_H]) - apply (clarsimp simp: le_maxDomain_eq_less_numDomains unat_trans_ucast_helper ) + apply (rule conjI) + apply (clarsimp simp: le_maxDomain_eq_less_numDomains unat_trans_ucast_helper) + apply (intro conjI impI) + apply (clarsimp simp: cready_queues_index_to_C_def numPriorities_def ctcb_queue_relation_def + tcbQueueEmpty_def option_to_ctcb_ptr_def) + apply (frule_tac qdom=curdom and prio=rv in cready_queues_index_to_C_in_range') + apply fastforce + apply (clarsimp simp: num_tcb_queues_val word_less_nat_alt cready_queues_index_to_C_def2) apply wpsimp apply (clarsimp simp: guard_is_UNIV_def le_maxDomain_eq_less_numDomains word_less_nat_alt numDomains_less_numeric_explicit) - apply (frule invs_no_cicd'_queues) + apply clarsimp apply (frule invs_no_cicd'_max_CurDomain) - apply (frule invs_no_cicd'_queues) - apply (clarsimp simp: valid_queues_def lookupBitmapPriority_le_maxPriority) + apply (frule invs_no_cicd'_pspace_aligned') + apply (frule invs_no_cicd'_pspace_distinct') + apply (frule invs_no_cicd'_valid_bitmaps) + apply (frule valid_bitmaps_bitmapQ_no_L1_orphans) + apply (frule valid_bitmaps_valid_bitmapQ) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def cong: conj_cong) apply (intro conjI impI) - apply (fastforce dest: bitmapQ_from_bitmap_lookup simp: valid_bitmapQ_bitmapQ_simp) - apply (fastforce dest: lookupBitmapPriority_obj_at' - simp: pred_conj_def obj_at'_def st_tcb_at'_def) - apply (fastforce dest: bitmapQ_from_bitmap_lookup simp: valid_bitmapQ_bitmapQ_simp) - apply (clarsimp simp: pred_conj_def obj_at'_def st_tcb_at'_def) - apply (clarsimp simp: not_less le_maxDomain_eq_less_numDomains) - apply (prop_tac "ksCurDomain s = 0") - using unsigned_eq_0_iff apply force - apply (cut_tac s=s in lookupBitmapPriority_obj_at'; simp?) - apply (clarsimp simp: pred_conj_def obj_at'_def st_tcb_at'_def) + apply (fastforce intro: lookupBitmapPriority_le_maxPriority) + apply (fastforce dest!: bitmapQ_from_bitmap_lookup valid_bitmapQ_bitmapQ_simp) + apply (fastforce dest!: lookupBitmapPriority_obj_at' + simp: ready_queue_relation_def ksReadyQueues_asrt_def st_tcb_at'_def obj_at'_def) + apply (fastforce dest: lookupBitmapPriority_le_maxPriority) + apply (fastforce dest!: bitmapQ_from_bitmap_lookup valid_bitmapQ_bitmapQ_simp) + apply (fastforce dest!: lookupBitmapPriority_obj_at' + simp: ready_queue_relation_def ksReadyQueues_asrt_def st_tcb_at'_def obj_at'_def) done qed @@ -574,7 +626,7 @@ lemma schedule_ccorres: apply (wp (once) hoare_drop_imps) apply wp apply (strengthen strenghten_False_imp[where P="a = ResumeCurrentThread" for a]) - apply (clarsimp simp: conj_ac invs_queues invs_valid_objs' cong: conj_cong) + apply (clarsimp simp: conj_ac invs_valid_objs' cong: conj_cong) apply wp apply (clarsimp, vcg exspec=tcbSchedEnqueue_modifies) apply (clarsimp, vcg exspec=tcbSchedEnqueue_modifies) @@ -594,9 +646,11 @@ lemma schedule_ccorres: apply wp apply vcg - apply (clarsimp simp: tcb_at_invs' rf_sr_ksCurThread if_apply_def2 invs_queues invs_valid_objs') + apply (clarsimp simp: tcb_at_invs' rf_sr_ksCurThread if_apply_def2 invs_valid_objs') apply (frule invs_sch_act_wf') apply (frule tcb_at_invs') + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') apply (rule conjI) apply (clarsimp dest!: rf_sr_cscheduler_relation simp: cscheduler_action_relation_def) apply (rule conjI; clarsimp) @@ -645,11 +699,7 @@ lemma threadSet_timeSlice_ccorres [corres]: map_to_tcbs_upd) apply (simp add: cep_relations_drop_fun_upd cvariable_relation_upd_const ko_at_projectKO_opt) - apply (rule conjI) defer - apply (erule cready_queues_relation_not_queue_ptrs) - apply (rule ext, simp split: if_split) - apply (rule ext, simp split: if_split) apply (drule ko_at_projectKO_opt) apply (erule (2) cmap_relation_upd_relI) apply (simp add: ctcb_relation_def) @@ -693,7 +743,7 @@ lemma timerTick_ccorres: apply simp apply (ctac (no_vcg) add: tcbSchedAppend_ccorres) apply (ctac add: rescheduleRequired_ccorres) - apply (wp weak_sch_act_wf_lift_linear threadSet_valid_queues + apply (wp weak_sch_act_wf_lift_linear threadSet_pred_tcb_at_state tcbSchedAppend_valid_objs' threadSet_valid_objs' threadSet_tcbDomain_triv | clarsimp simp: st_tcb_at'_def o_def split: if_splits)+ apply (vcg exspec=tcbSchedDequeue_modifies) diff --git a/proof/crefine/ARM/StateRelation_C.thy b/proof/crefine/ARM/StateRelation_C.thy index 1f68d18a5b..da94c204a4 100644 --- a/proof/crefine/ARM/StateRelation_C.thy +++ b/proof/crefine/ARM/StateRelation_C.thy @@ -20,8 +20,7 @@ definition definition "option_to_ptr \ Ptr o option_to_0" -(* used for bound ntfn/tcb *) -definition +definition option_to_ctcb_ptr :: "machine_word option \ tcb_C ptr" where "option_to_ctcb_ptr x \ case x of None \ NULL | Some t \ tcb_ptr_to_ctcb_ptr t" @@ -344,7 +343,9 @@ where \ tcbTimeSlice atcb = unat (tcbTimeSlice_C ctcb) \ cfault_rel (tcbFault atcb) (seL4_Fault_lift (tcbFault_C ctcb)) (lookup_fault_lift (tcbLookupFailure_C ctcb)) - \ option_to_ptr (tcbBoundNotification atcb) = tcbBoundNotification_C ctcb" + \ option_to_ptr (tcbBoundNotification atcb) = tcbBoundNotification_C ctcb + \ option_to_ctcb_ptr (tcbSchedPrev atcb) = tcbSchedPrev_C ctcb + \ option_to_ctcb_ptr (tcbSchedNext atcb) = tcbSchedNext_C ctcb" abbreviation "ep_queue_relation' \ tcb_queue_relation' tcbEPNext_C tcbEPPrev_C" @@ -567,17 +568,17 @@ definition where "cready_queues_index_to_C qdom prio \ (unat qdom) * numPriorities + (unat prio)" -definition cready_queues_relation :: - "tcb_C typ_heap \ (tcb_queue_C[num_tcb_queues]) \ (domain \ priority \ ready_queue) \ bool" -where - "cready_queues_relation h_tcb queues aqueues \ - \qdom prio. ((qdom \ ucast minDom \ qdom \ ucast maxDom \ - prio \ ucast minPrio \ prio \ ucast maxPrio) \ - (let cqueue = index queues (cready_queues_index_to_C qdom prio) in - sched_queue_relation' h_tcb (aqueues (qdom, prio)) (head_C cqueue) (end_C cqueue))) - \ (\ (qdom \ ucast minDom \ qdom \ ucast maxDom \ - prio \ ucast minPrio \ prio \ ucast maxPrio) \ aqueues (qdom, prio) = [])" +definition ctcb_queue_relation :: "tcb_queue \ tcb_queue_C \ bool" where + "ctcb_queue_relation aqueue cqueue \ + head_C cqueue = option_to_ctcb_ptr (tcbQueueHead aqueue) + \ end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd aqueue)" +definition cready_queues_relation :: + "(domain \ priority \ ready_queue) \ (tcb_queue_C[num_tcb_queues]) \ bool" + where + "cready_queues_relation aqueues cqueues \ + \d p. d \ maxDomain \ p \ maxPriority + \ ctcb_queue_relation (aqueues (d, p)) (index cqueues (cready_queues_index_to_C d p))" abbreviation "cte_array_relation astate cstate @@ -715,9 +716,7 @@ where "cstate_relation astate cstate \ let cheap = t_hrs_' cstate in cpspace_relation (ksPSpace astate) (underlying_memory (ksMachineState astate)) cheap \ - cready_queues_relation (clift cheap) - (ksReadyQueues_' cstate) - (ksReadyQueues astate) \ + cready_queues_relation (ksReadyQueues astate) (ksReadyQueues_' cstate) \ zero_ranges_are_zero (gsUntypedZeroRanges astate) cheap \ cbitmap_L1_relation (ksReadyQueuesL1Bitmap_' cstate) (ksReadyQueuesL1Bitmap astate) \ cbitmap_L2_relation (ksReadyQueuesL2Bitmap_' cstate) (ksReadyQueuesL2Bitmap astate) \ diff --git a/proof/crefine/ARM/SyscallArgs_C.thy b/proof/crefine/ARM/SyscallArgs_C.thy index 59b471f7a0..716eafd867 100644 --- a/proof/crefine/ARM/SyscallArgs_C.thy +++ b/proof/crefine/ARM/SyscallArgs_C.thy @@ -48,9 +48,7 @@ lemma replyOnRestart_invs'[wp]: including no_pre apply (simp add: replyOnRestart_def) apply (wp setThreadState_nonqueued_state_update rfk_invs' hoare_weak_lift_imp) - apply (rule hoare_vcg_all_lift) - apply (wp setThreadState_nonqueued_state_update rfk_invs' hoare_vcg_all_lift rfk_ksQ) - apply (rule hoare_strengthen_post, rule gts_sp') + apply (rule hoare_strengthen_post, rule gts_sp') apply (clarsimp simp: pred_tcb_at') apply (auto elim!: pred_tcb'_weakenE st_tcb_ex_cap'' dest: st_tcb_at_idle_thread') diff --git a/proof/crefine/ARM/Syscall_C.thy b/proof/crefine/ARM/Syscall_C.thy index 94d8afeedb..31431e2787 100644 --- a/proof/crefine/ARM/Syscall_C.thy +++ b/proof/crefine/ARM/Syscall_C.thy @@ -43,8 +43,7 @@ lemma cap_cases_one_on_true_sum: lemma performInvocation_Endpoint_ccorres: "ccorres (K (K \) \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (invs' and st_tcb_at' simple' thread and ep_at' epptr - and sch_act_sane and (\s. thread = ksCurThread s - \ (\p. ksCurThread s \ set (ksReadyQueues s p)))) + and sch_act_sane and (\s. thread = ksCurThread s)) (UNIV \ {s. block_' s = from_bool blocking} \ {s. call_' s = from_bool do_call} \ {s. badge_' s = badge} @@ -117,7 +116,6 @@ lemma decodeInvocation_ccorres: and (\s. \v \ set extraCaps. ex_cte_cap_wp_to' isCNodeCap (snd v) s) and (\s. \v \ set extraCaps. s \' fst v \ cte_at' (snd v) s) and (\s. \v \ set extraCaps. \y \ zobj_refs' (fst v). ex_nonz_cap_to' y s) - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p)) and sysargs_rel args buffer) (UNIV \ {s. call_' s = from_bool isCall} \ {s. block_' s = from_bool isBlocking} @@ -194,7 +192,7 @@ lemma decodeInvocation_ccorres: apply simp apply (rule hoare_use_eq[where f=ksCurThread]) apply (wp sts_invs_minor' sts_st_tcb_at'_cases - setThreadState_ct' hoare_vcg_all_lift sts_ksQ')+ + setThreadState_ct' hoare_vcg_all_lift)+ apply simp apply (vcg exspec=setThreadState_modifies) apply vcg @@ -461,7 +459,7 @@ lemma wordFromMessageInfo_spec: lemma handleDoubleFault_ccorres: "ccorres dc xfdc (invs' and tcb_at' tptr and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and - sch_act_not tptr and (\s. \p. tptr \ set (ksReadyQueues s p))) + sch_act_not tptr) (UNIV \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr tptr}) [] (handleDoubleFault tptr ex1 ex2) (Call handleDoubleFault_'proc)" @@ -539,8 +537,7 @@ lemma hrs_mem_update_use_hrs_mem: lemma sendFaultIPC_ccorres: "ccorres (cfault_rel2 \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') - (invs' and st_tcb_at' simple' tptr and sch_act_not tptr and - (\s. \p. tptr \ set (ksReadyQueues s p))) + (invs' and st_tcb_at' simple' tptr and sch_act_not tptr) (UNIV \ {s. (cfault_rel (Some fault) (seL4_Fault_lift(current_fault_' (globals s))) (lookup_fault_lift(current_lookup_fault_' (globals s))))} \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr tptr}) @@ -619,8 +616,8 @@ lemma sendFaultIPC_ccorres: apply (ctac (no_vcg) add: sendIPC_ccorres) apply (ctac (no_vcg) add: ccorres_return_CE [unfolded returnOk_def comp_def]) apply wp - apply (wp threadSet_pred_tcb_no_state threadSet_invs_trivial threadSet_typ_at_lifts - | simp)+ + apply (wpsimp wp: threadSet_invs_trivial) + apply (wpsimp wp: threadSet_pred_tcb_no_state threadSet_typ_at_lifts) apply (clarsimp simp: guard_is_UNIV_def) apply (subgoal_tac "capEPBadge epcap && mask 28 = capEPBadge epcap") @@ -655,8 +652,7 @@ lemma sendFaultIPC_ccorres: apply vcg apply (clarsimp simp: inQ_def) apply (rule_tac Q="\a b. invs' b \ st_tcb_at' simple' tptr b - \ sch_act_not tptr b \ valid_cap' a b - \ (\p. tptr \ set (ksReadyQueues b p))" + \ sch_act_not tptr b \ valid_cap' a b" and E="\ _. \" in hoare_post_impErr) apply (wp) @@ -677,8 +673,7 @@ lemma sendFaultIPC_ccorres: done lemma handleFault_ccorres: - "ccorres dc xfdc (invs' and st_tcb_at' simple' t and - sch_act_not t and (\s. \p. t \ set (ksReadyQueues s p))) + "ccorres dc xfdc (invs' and st_tcb_at' simple' t and sch_act_not t) (UNIV \ {s. (cfault_rel (Some flt) (seL4_Fault_lift(current_fault_' (globals s))) (lookup_fault_lift(current_lookup_fault_' (globals s))) )} \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr t}) @@ -753,8 +748,7 @@ lemma getMessageInfo_msgLength': lemma handleInvocation_ccorres: "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (invs' and (\s. vs_valid_duplicates' (ksPSpace s)) and - ct_active' and sch_act_simple and - (\s. \x. ksCurThread s \ set (ksReadyQueues s x))) + ct_active' and sch_act_simple) (UNIV \ {s. isCall_' s = from_bool isCall} \ {s. isBlocking_' s = from_bool isBlocking}) [] (handleInvocation isCall isBlocking) (Call handleInvocation_'proc)" @@ -883,7 +877,7 @@ lemma handleInvocation_ccorres: apply (wp hoare_split_bind_case_sumE hoare_drop_imps setThreadState_nonqueued_state_update ct_in_state'_set setThreadState_st_tcb - hoare_vcg_all_lift sts_ksQ' + hoare_vcg_all_lift | wpc | wps)+ apply auto[1] apply clarsimp @@ -1140,8 +1134,7 @@ lemma handleRecv_ccorres: notes rf_sr_upd_safe[simp del] shows "ccorres dc xfdc - (\s. invs' s \ st_tcb_at' simple' (ksCurThread s) s - \ sch_act_sane s \ (\p. ksCurThread s \ set (ksReadyQueues s p))) + (\s. invs' s \ st_tcb_at' simple' (ksCurThread s) s \ sch_act_sane s) {s. isBlocking_' s = from_bool isBlocking} [] (handleRecv isBlocking) @@ -1205,7 +1198,7 @@ lemma handleRecv_ccorres: apply (rule_tac P="\s. ksCurThread s = thread" in ccorres_cross_over_guard) apply (ctac add: receiveIPC_ccorres) - apply (wp deleteCallerCap_ksQ_ct' hoare_vcg_all_lift) + apply (wp hoare_vcg_all_lift) apply (rule conseqPost[where Q'=UNIV and A'="{}"], vcg exspec=deleteCallerCap_modifies) apply (clarsimp dest!: rf_sr_ksCurThread) apply simp @@ -1328,13 +1321,11 @@ lemma handleRecv_ccorres: apply clarsimp apply (rename_tac thread epCPtr) apply (rule_tac Q'="(\rv s. invs' s \ st_tcb_at' simple' thread s - \ sch_act_sane s \ (\p. thread \ set (ksReadyQueues s p)) \ thread = ksCurThread s + \ sch_act_sane s \ thread = ksCurThread s \ valid_cap' rv s)" in hoare_post_imp_R[rotated]) - apply (clarsimp simp: sch_act_sane_def) - apply (auto dest!: obj_at_valid_objs'[OF _ invs_valid_objs'] - simp: projectKOs valid_obj'_def, - auto simp: pred_tcb_at'_def obj_at'_def objBits_simps projectKOs ct_in_state'_def)[1] - apply wp + apply (intro conjI impI allI; clarsimp simp: sch_act_sane_def) + apply (fastforce dest: obj_at_valid_objs'[OF _ invs_valid_objs'] ko_at_valid_ntfn') + apply wp apply clarsimp apply (vcg exspec=isStopped_modifies exspec=lookupCap_modifies) @@ -1383,7 +1374,7 @@ lemma handleYield_ccorres: apply (ctac add: rescheduleRequired_ccorres) apply (wp weak_sch_act_wf_lift_linear tcbSchedAppend_valid_objs') apply (vcg exspec= tcbSchedAppend_modifies) - apply (wp weak_sch_act_wf_lift_linear tcbSchedDequeue_valid_queues) + apply (wp weak_sch_act_wf_lift_linear) apply (vcg exspec= tcbSchedDequeue_modifies) apply (clarsimp simp: tcb_at_invs' invs_valid_objs' valid_objs'_maxPriority valid_objs'_maxDomain) diff --git a/proof/crefine/ARM/TcbAcc_C.thy b/proof/crefine/ARM/TcbAcc_C.thy index 8b5e2a2234..29de58180a 100644 --- a/proof/crefine/ARM/TcbAcc_C.thy +++ b/proof/crefine/ARM/TcbAcc_C.thy @@ -203,6 +203,27 @@ lemma sanitiseRegister_spec: split: register.split) done +lemma ccorres_pre_getObject_tcb: + assumes cc: "\rv. ccorres r xf (P rv) (P' rv) hs (f rv) c" + shows "ccorres r xf + (\s. (\tcb. ko_at' tcb p s \ P tcb s)) + {s. \ tcb tcb'. cslift s (tcb_ptr_to_ctcb_ptr p) = Some tcb' \ ctcb_relation tcb tcb' + \ s \ P' tcb} + hs (getObject p >>= (\rv :: tcb. f rv)) c" + apply (rule ccorres_guard_imp2) + apply (rule ccorres_symb_exec_l) + apply (rule ccorres_guard_imp2) + apply (rule cc) + apply (rule conjI) + apply (rule_tac Q="ko_at' rv p s" in conjunct1) + apply assumption + apply assumption + apply (wpsimp wp: empty_fail_getObject getTCB_wp)+ + apply (erule cmap_relationE1[OF cmap_relation_tcb], + erule ko_at_projectKO_opt) + apply simp + done + end end diff --git a/proof/crefine/ARM/TcbQueue_C.thy b/proof/crefine/ARM/TcbQueue_C.thy index e14fa45ae9..6bbacbab10 100644 --- a/proof/crefine/ARM/TcbQueue_C.thy +++ b/proof/crefine/ARM/TcbQueue_C.thy @@ -844,49 +844,6 @@ lemma tcb_queue_relation'_prev_mask: shows "ptr_val (getPrev tcb) && ~~ mask bits = ptr_val (getPrev tcb)" by (rule tcb_queue_relation_prev_mask [OF tcb_queue_relation'_queue_rel], fact+) - -lemma cready_queues_relation_null_queue_ptrs: - assumes rel: "cready_queues_relation mp cq aq" - and same: "option_map tcb_null_ep_ptrs \ mp' = option_map tcb_null_ep_ptrs \ mp" - shows "cready_queues_relation mp' cq aq" - using rel - apply (clarsimp simp: cready_queues_relation_def Let_def all_conj_distrib) - apply (drule spec, drule spec, drule mp, (erule conjI)+, assumption) - apply (clarsimp simp: tcb_queue_relation'_def) - apply (erule iffD2 [OF tcb_queue_relation_only_next_prev, rotated -1]) - apply (rule ext) - apply (case_tac "mp' x") - apply (frule compD [OF same]) - apply simp - apply (frule compD [OF same]) - apply (clarsimp simp: tcb_null_ep_ptrs_def) - apply (case_tac z, case_tac a) - apply simp - \ \clag\ - apply (rule ext) - apply (case_tac "mp' x") - apply (frule compD [OF same]) - apply simp - apply (frule compD [OF same]) - apply (clarsimp simp: tcb_null_ep_ptrs_def) - apply (case_tac z, case_tac a) - apply simp - done - -lemma cready_queues_relation_not_queue_ptrs: - assumes rel: "cready_queues_relation mp cq aq" - and same: "option_map tcbSchedNext_C \ mp' = option_map tcbSchedNext_C \ mp" - "option_map tcbSchedPrev_C \ mp' = option_map tcbSchedPrev_C \ mp" - shows "cready_queues_relation mp' cq aq" - using rel - apply (clarsimp simp: cready_queues_relation_def tcb_queue_relation'_def Let_def all_conj_distrib) - apply (drule spec, drule spec, drule mp, (erule conjI)+, assumption) - apply clarsimp - apply (erule iffD2 [OF tcb_queue_relation_only_next_prev, rotated -1]) - apply (rule same) - apply (rule same) - done - lemma ntfn_ep_disjoint: assumes srs: "sym_refs (state_refs_of' s)" and epat: "ko_at' ep epptr s" @@ -1054,8 +1011,6 @@ lemma rf_sr_tcb_update_no_queue: (tcb_ptr_to_ctcb_ptr thread) ctcb) (t_hrs_' (globals s')); tcbEPNext_C ctcb = tcbEPNext_C (the (cslift s' (tcb_ptr_to_ctcb_ptr thread))); tcbEPPrev_C ctcb = tcbEPPrev_C (the (cslift s' (tcb_ptr_to_ctcb_ptr thread))); - tcbSchedNext_C ctcb = tcbSchedNext_C (the (cslift s' (tcb_ptr_to_ctcb_ptr thread))); - tcbSchedPrev_C ctcb = tcbSchedPrev_C (the (cslift s' (tcb_ptr_to_ctcb_ptr thread))); (\x\ran tcb_cte_cases. (\(getF, setF). getF tcb' = getF tcb) x); ctcb_relation tcb' ctcb \ @@ -1069,31 +1024,22 @@ lemma rf_sr_tcb_update_no_queue: apply (clarsimp simp: map_comp_update projectKO_opt_tcb cvariable_relation_upd_const typ_heap_simps') apply (intro conjI) - subgoal by (clarsimp simp: cmap_relation_def map_comp_update projectKO_opts_defs inj_eq) - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_upd_tcb_no_queues, assumption+) - subgoal by (clarsimp intro!: ext) - subgoal by (clarsimp intro!: ext) + subgoal by (clarsimp simp: cmap_relation_def map_comp_update projectKO_opts_defs inj_eq) apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_upd_tcb_no_queues, assumption+) + apply (rule cendpoint_relation_upd_tcb_no_queues, assumption+) subgoal by (clarsimp intro!: ext) subgoal by (clarsimp intro!: ext) - apply (erule cready_queues_relation_not_queue_ptrs) + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_upd_tcb_no_queues, assumption+) subgoal by (clarsimp intro!: ext) subgoal by (clarsimp intro!: ext) subgoal by (simp add: carch_state_relation_def typ_heap_simps') by (simp add: cmachine_state_relation_def) -lemma rf_sr_tcb_update_no_queue_helper: - "(s, s'\ globals := globals s' \ t_hrs_' := t_hrs_' (globals (undefined - \ globals := (undefined \ t_hrs_' := f (globals s') (t_hrs_' (globals s')) \)\))\\) \ rf_sr - \ (s, globals_update (\v. t_hrs_'_update (f v) v) s') \ rf_sr" - by (simp cong: StateSpace.state.fold_congs globals.fold_congs) - -lemmas rf_sr_tcb_update_no_queue2 - = rf_sr_tcb_update_no_queue_helper [OF rf_sr_tcb_update_no_queue, simplified] +lemmas rf_sr_tcb_update_no_queue2 = + rf_sr_obj_update_helper[OF rf_sr_tcb_update_no_queue, simplified] lemma tcb_queue_relation_not_in_q: "ctcb_ptr_to_tcb_ptr x \ set xs \ @@ -1122,31 +1068,24 @@ lemma rf_sr_tcb_update_not_in_queue: prefer 2 apply (auto simp: obj_at'_def ko_wp_at'_def)[1] apply (intro conjI) - subgoal by (clarsimp simp: cmap_relation_def map_comp_update projectKO_opts_defs inj_eq) - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply clarsimp - apply (subgoal_tac "thread \ (fst ` ep_q_refs_of' a)") - apply (clarsimp simp: cendpoint_relation_def Let_def split: Structures_H.endpoint.split) - subgoal by (intro conjI impI allI, simp_all add: image_def tcb_queue_relation_not_in_q)[1] - apply (drule(1) map_to_ko_atI') - apply (drule sym_refs_ko_atD', clarsimp+) - subgoal by blast + subgoal by (clarsimp simp: cmap_relation_def map_comp_update projectKO_opts_defs inj_eq) apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply clarsimp - apply (subgoal_tac "thread \ (fst ` ntfn_q_refs_of' (ntfnObj a))") - apply (clarsimp simp: cnotification_relation_def Let_def - split: ntfn.splits) - subgoal by (simp add: image_def tcb_queue_relation_not_in_q)[1] + apply (subgoal_tac "thread \ (fst ` ep_q_refs_of' a)") + apply (clarsimp simp: cendpoint_relation_def Let_def split: Structures_H.endpoint.split) + subgoal by (intro conjI impI allI, simp_all add: image_def tcb_queue_relation_not_in_q)[1] apply (drule(1) map_to_ko_atI') apply (drule sym_refs_ko_atD', clarsimp+) subgoal by blast - apply (simp add: cready_queues_relation_def, erule allEI) - apply (clarsimp simp: Let_def) - apply (subst tcb_queue_relation_not_in_q) - apply clarsimp - apply (drule valid_queues_obj_at'D, clarsimp) - apply (clarsimp simp: obj_at'_def projectKOs inQ_def) - subgoal by simp + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply clarsimp + apply (subgoal_tac "thread \ (fst ` ntfn_q_refs_of' (ntfnObj a))") + apply (clarsimp simp: cnotification_relation_def Let_def + split: ntfn.splits) + subgoal by (simp add: image_def tcb_queue_relation_not_in_q)[1] + apply (drule(1) map_to_ko_atI') + apply (drule sym_refs_ko_atD', clarsimp+) + subgoal by blast subgoal by (simp add: carch_state_relation_def carch_globals_def typ_heap_simps') by (simp add: cmachine_state_relation_def) diff --git a/proof/crefine/ARM/Tcb_C.thy b/proof/crefine/ARM/Tcb_C.thy index 091e0f0967..ca08f2af4a 100644 --- a/proof/crefine/ARM/Tcb_C.thy +++ b/proof/crefine/ARM/Tcb_C.thy @@ -59,8 +59,6 @@ lemma doMachineOp_sched: done context begin interpretation Arch . (*FIXME: arch_split*) -crunch queues[wp]: setupReplyMaster "valid_queues" - (simp: crunch_simps wp: crunch_wps) crunch curThread [wp]: restart "\s. P (ksCurThread s)" (wp: crunch_wps simp: crunch_simps) @@ -353,9 +351,10 @@ lemma ccorres_abstract_known: lemma setPriority_ccorres: "ccorres dc xfdc - (\s. tcb_at' t s \ Invariants_H.valid_queues s \ ksCurDomain s \ maxDomain \ - valid_queues' s \ valid_objs' s \ weak_sch_act_wf (ksSchedulerAction s) s \ (priority \ maxPriority)) - (UNIV \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr t} \ {s. prio_' s = ucast priority}) + (\s. tcb_at' t s \ ksCurDomain s \ maxDomain \ + valid_objs' s \ weak_sch_act_wf (ksSchedulerAction s) s \ (priority \ maxPriority) \ + pspace_aligned' s \ pspace_distinct' s) + ({s. tptr_' s = tcb_ptr_to_ctcb_ptr t} \ {s. prio_' s = ucast priority}) [] (setPriority t priority) (Call setPriority_'proc)" apply (cinit lift: tptr_' prio_') apply (ctac(no_vcg) add: tcbSchedDequeue_ccorres) @@ -378,7 +377,7 @@ lemma setPriority_ccorres: apply (ctac add: possibleSwitchTo_ccorres) apply (rule ccorres_return_Skip') apply (wp isRunnable_wp) - apply (wpsimp wp: hoare_drop_imps threadSet_valid_queues threadSet_valid_objs' + apply (wpsimp wp: hoare_drop_imps threadSet_valid_objs' weak_sch_act_wf_lift_linear threadSet_pred_tcb_at_state threadSet_tcbDomain_triv simp: st_tcb_at'_def o_def split: if_splits) @@ -387,18 +386,13 @@ lemma setPriority_ccorres: where Q="\rv s. obj_at' (\_. True) t s \ priority \ maxPriority \ - Invariants_H.valid_queues s \ ksCurDomain s \ maxDomain \ valid_objs' s \ - valid_queues' s \ weak_sch_act_wf (ksSchedulerAction s) s \ - (\d p. \ t \ set (ksReadyQueues s (d, p)))"]) - apply (wp weak_sch_act_wf_lift_linear tcbSchedDequeue_valid_queues tcbSchedDequeue_nonq) + pspace_aligned' s \ pspace_distinct' s"]) + apply (wp weak_sch_act_wf_lift_linear valid_tcb'_def) apply (clarsimp simp: valid_tcb'_tcbPriority_update) apply clarsimp - apply (frule (1) valid_objs'_maxDomain[where t=t]) - apply (frule (1) valid_objs'_maxPriority[where t=t]) - apply simp done lemma setMCPriority_ccorres: @@ -613,12 +607,12 @@ lemma invokeTCB_ThreadControl_ccorres: apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem) apply (rule hoare_strengthen_post[ where Q= "\rv s. - Invariants_H.valid_queues s \ valid_objs' s \ weak_sch_act_wf (ksSchedulerAction s) s \ ((\a b. priority = Some (a, b)) \ tcb_at' target s \ ksCurDomain s \ maxDomain \ - valid_queues' s \ fst (the priority) \ maxPriority)"]) + fst (the priority) \ maxPriority) \ + pspace_aligned' s \ pspace_distinct' s"]) apply (strengthen sch_act_wf_weak) apply (wp hoare_weak_lift_imp) apply (clarsimp split: if_splits) @@ -703,12 +697,12 @@ lemma invokeTCB_ThreadControl_ccorres: apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem) apply (simp cong: conj_cong) apply (rule hoare_strengthen_post[ - where Q="\a b. (Invariants_H.valid_queues b \ - valid_objs' b \ + where Q="\a b. (valid_objs' b \ sch_act_wf (ksSchedulerAction b) b \ + pspace_aligned' b \ pspace_distinct' b \ ((\a b. priority = Some (a, b)) \ tcb_at' target b \ - ksCurDomain b \ maxDomain \ valid_queues' b \ + ksCurDomain b \ maxDomain \ fst (the priority) \ maxPriority)) \ ((case snd (the buf) of None \ 0 @@ -731,15 +725,15 @@ lemma invokeTCB_ThreadControl_ccorres: prefer 2 apply fastforce apply (strengthen cte_is_derived_capMasterCap_strg - invs_queues invs_weak_sch_act_wf invs_sch_act_wf' + invs_weak_sch_act_wf invs_sch_act_wf' invs_valid_objs' invs_mdb' invs_pspace_aligned', simp add: o_def) apply (rule_tac P="is_aligned (fst (the buf)) msg_align_bits" in hoare_gen_asm) apply (wp threadSet_ipcbuffer_trivial hoare_weak_lift_imp | simp - | strengthen invs_sch_act_wf' invs_valid_objs' invs_weak_sch_act_wf invs_queues - invs_valid_queues' | wp hoare_drop_imps)+ + | strengthen invs_sch_act_wf' invs_valid_objs' invs_weak_sch_act_wf + | wp hoare_drop_imps)+ (* \ P *) apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem option_to_0_def @@ -749,7 +743,7 @@ lemma invokeTCB_ThreadControl_ccorres: apply (rule ccorres_return_C_errorE, simp+)[1] apply vcg apply (simp add: conj_comms cong: conj_cong) - apply (strengthen invs_ksCurDomain_maxDomain') + apply (strengthen invs_ksCurDomain_maxDomain' invs_pspace_distinct') apply (wp hoare_vcg_const_imp_lift_R cteDelete_invs') apply simp apply (rule ccorres_split_nothrow_novcg_dc) @@ -766,8 +760,7 @@ lemma invokeTCB_ThreadControl_ccorres: apply (rule conjI) apply (clarsimp simp: case_option_If2 if_n_0_0 objBits_simps' valid_cap'_def capAligned_def word_bits_conv obj_at'_def projectKOs) - apply (clarsimp simp: invs_valid_objs' invs_valid_queues' - Invariants_H.invs_queues invs_ksCurDomain_maxDomain') + apply (fastforce simp: invs_valid_objs' invs_ksCurDomain_maxDomain') apply (rule ccorres_Cond_rhs_Seq) apply (rule ccorres_rhs_assoc)+ apply csymbr @@ -997,7 +990,7 @@ lemma restart_ccorres: apply (ctac(no_vcg) add: tcbSchedEnqueue_ccorres) apply (ctac add: possibleSwitchTo_ccorres) apply (wp weak_sch_act_wf_lift)[1] - apply (wp sts_valid_queues setThreadState_st_tcb)[1] + apply (wp sts_valid_objs' setThreadState_st_tcb)[1] apply (simp add: valid_tcb_state'_def) apply wp apply (wp (once) sch_act_wf_lift, (wp tcb_in_cur_domain'_lift)+) @@ -1593,7 +1586,7 @@ lemma invokeTCB_WriteRegisters_ccorres[where S=UNIV]: apply (clarsimp simp: frame_gp_registers_convs word_less_nat_alt sysargs_rel_def n_frameRegisters_def n_msgRegisters_def split: if_split_asm) - apply (simp add: invs_weak_sch_act_wf invs_valid_objs' invs_queues) + apply (simp add: invs_weak_sch_act_wf invs_valid_objs') apply (fastforce dest!: global'_no_ex_cap simp: invs'_def valid_state'_def) done @@ -3098,7 +3091,8 @@ lemma decodeTCBConfigure_ccorres: apply (rule conjI, fastforce) apply (drule interpret_excaps_eq) apply (clarsimp simp: cte_wp_at_ctes_of valid_tcb_state'_def numeral_eqs le_ucast_ucast_le - tcb_at_invs' invs_valid_objs' invs_queues invs_sch_act_wf' + tcb_at_invs' invs_valid_objs' invs_sch_act_wf' + invs_pspace_aligned' invs_pspace_distinct' ct_in_state'_def pred_tcb_at'_def obj_at'_def tcb_st_refs_of'_def) apply (erule disjE; simp add: objBits_defs mask_def) apply (clarsimp simp: idButNot_def interpret_excaps_test_null @@ -4359,9 +4353,9 @@ lemma invokeTCB_SetTLSBase_ccorres: apply (rule ccorres_return_CE, simp+)[1] apply (wpsimp wp: hoare_drop_imp simp: guard_is_UNIV_def)+ apply vcg - apply (clarsimp simp: tlsBaseRegister_def ARM.tlsBaseRegister_def - invs_weak_sch_act_wf invs_queues TLS_BASE_def TPIDRURW_def - split: if_split) + apply (fastforce simp: tlsBaseRegister_def ARM.tlsBaseRegister_def + invs_weak_sch_act_wf TLS_BASE_def TPIDRURW_def + split: if_split) done lemma decodeSetTLSBase_ccorres: diff --git a/proof/crefine/ARM/Wellformed_C.thy b/proof/crefine/ARM/Wellformed_C.thy index 4e964d3559..3ff73b7118 100644 --- a/proof/crefine/ARM/Wellformed_C.thy +++ b/proof/crefine/ARM/Wellformed_C.thy @@ -139,10 +139,6 @@ where abbreviation "ep_queue_relation \ tcb_queue_relation tcbEPNext_C tcbEPPrev_C" -abbreviation - "sched_queue_relation \ tcb_queue_relation tcbSchedNext_C tcbSchedPrev_C" - - definition wordSizeCase :: "'a \ 'a \ 'a" where "wordSizeCase a b \ (if bitSize (undefined::word32) = 32 diff --git a/proof/crefine/ARM_HYP/ADT_C.thy b/proof/crefine/ARM_HYP/ADT_C.thy index 9044dc136f..6a0395b0bf 100644 --- a/proof/crefine/ARM_HYP/ADT_C.thy +++ b/proof/crefine/ARM_HYP/ADT_C.thy @@ -114,11 +114,6 @@ lemma setTCBContext_C_corres: apply (simp add: map_to_ctes_upd_tcb_no_ctes map_to_tcbs_upd tcb_cte_cases_def cvariable_relation_upd_const ko_at_projectKO_opt) apply (simp add: cep_relations_drop_fun_upd) - apply (rule conjI) - defer - apply (erule cready_queues_relation_not_queue_ptrs) - apply (rule ext, simp split: if_split) - apply (rule ext, simp split: if_split) apply (drule ko_at_projectKO_opt) apply (erule (2) cmap_relation_upd_relI) apply (simp add: ctcb_relation_def carch_tcb_relation_def) @@ -661,25 +656,50 @@ lemma tcb_queue_rel'_unique: apply (erule(2) tcb_queue_rel_unique) done -definition - cready_queues_to_H - :: "(tcb_C ptr \ tcb_C) \ (tcb_queue_C[num_tcb_queues]) \ word8 \ word8 \ word32 list" +definition tcb_queue_C_to_tcb_queue :: "tcb_queue_C \ tcb_queue" where + "tcb_queue_C_to_tcb_queue q \ + TcbQueue (if head_C q = NULL then None else Some (ctcb_ptr_to_tcb_ptr (head_C q))) + (if end_C q = NULL then None else Some (ctcb_ptr_to_tcb_ptr (end_C q)))" + +definition cready_queues_to_H :: + "tcb_queue_C[num_tcb_queues] \ (domain \ priority \ ready_queue)" where - "cready_queues_to_H h_tcb cs \ \(qdom, prio). if ucast minDom \ qdom \ qdom \ ucast maxDom - \ ucast seL4_MinPrio \ prio \ prio \ ucast seL4_MaxPrio - then THE aq. let cqueue = index cs (cready_queues_index_to_C qdom prio) - in sched_queue_relation' h_tcb aq (head_C cqueue) (StateRelation_C.end_C cqueue) - else []" + "cready_queues_to_H cs \ + \(qdom, prio). + if qdom \ maxDomain \ prio \ maxPriority + then let cqueue = index cs (cready_queues_index_to_C qdom prio) + in tcb_queue_C_to_tcb_queue cqueue + else TcbQueue None None" lemma cready_queues_to_H_correct: - "cready_queues_relation (clift s) cs as \ - cready_queues_to_H (clift s) cs = as" - apply (clarsimp simp: cready_queues_to_H_def cready_queues_relation_def - fun_eq_iff) - apply (rule the_equality) - apply simp - apply (clarsimp simp: Let_def) - apply (rule_tac hp="clift s" in tcb_queue_rel'_unique, simp_all add: lift_t_NULL) + "\cready_queues_relation (ksReadyQueues s) (ksReadyQueues_' ch); + no_0_obj' s; ksReadyQueues_asrt s; pspace_aligned' s; pspace_distinct' s\ + \ cready_queues_to_H (ksReadyQueues_' ch) = ksReadyQueues s" + apply (clarsimp simp: cready_queues_to_H_def cready_queues_relation_def Let_def) + apply (clarsimp simp: fun_eq_iff) + apply (rename_tac d p) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (frule (3) obj_at'_tcbQueueEnd_ksReadyQueues) + apply (frule tcbQueueHead_iff_tcbQueueEnd) + apply (rule conjI) + apply (clarsimp simp: tcb_queue_C_to_tcb_queue_def ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (case_tac "tcbQueueHead (ksReadyQueues s (d, p)) = None") + apply (clarsimp simp: tcb_queue.expand) + apply clarsimp + apply (rename_tac queue_head queue_end) + apply (prop_tac "tcb_at' queue_head s", fastforce simp: tcbQueueEmpty_def obj_at'_def) + apply (prop_tac "tcb_at' queue_end s", fastforce simp: tcbQueueEmpty_def obj_at'_def) + apply (drule kernel.tcb_at_not_NULL)+ + apply (fastforce simp: tcb_queue.expand kernel.ctcb_ptr_to_ctcb_ptr) + apply (clarsimp simp: tcbQueueEmpty_def ctcb_queue_relation_def option_to_ctcb_ptr_def + split: option.splits; + metis tcb_queue.exhaust_sel word_not_le) done (* showing that cpspace_relation is actually unique >>>*) @@ -816,17 +836,20 @@ lemma cthread_state_rel_imp_eq: apply (cases y, simp_all add: ThreadState_defs)+ done -lemma ksPSpace_valid_objs_tcbBoundNotification_nonzero: - "\s. ksPSpace s = ah \ no_0_obj' s \ valid_objs' s - \ map_to_tcbs ah p = Some tcb \ tcbBoundNotification tcb \ Some 0" +lemma map_to_tcbs_Some_refs_nonzero: + "\map_to_tcbs (ksPSpace s) p = Some tcb; no_0_obj' s; valid_objs' s\ + \ tcbBoundNotification tcb \ Some 0 + \ tcbSchedPrev tcb \ Some 0 + \ tcbSchedNext tcb \ Some 0" + supply word_neq_0_conv[simp del] apply (clarsimp simp: map_comp_def split: option.splits) - apply (erule(1) valid_objsE') - apply (clarsimp simp: projectKOs valid_obj'_def valid_tcb'_def) + apply (erule (1) valid_objsE') + apply (fastforce simp: projectKOs valid_obj'_def valid_tcb'_def) done lemma ksPSpace_valid_objs_atcbVCPUPtr_nonzero: - "\s. ksPSpace s = ah \ no_0_obj' s \ valid_objs' s - \ map_to_tcbs ah p = Some tcb \ atcbVCPUPtr (tcbArch tcb) \ Some 0" + "\no_0_obj' s; valid_objs' s; map_to_tcbs (ksPSpace s) p = Some tcb\ + \ atcbVCPUPtr (tcbArch tcb) \ Some 0" apply (clarsimp simp: map_comp_def split: option.splits) apply (erule(1) valid_objsE') apply (clarsimp simp: projectKOs valid_obj'_def valid_tcb'_def valid_arch_tcb'_def) @@ -851,36 +874,77 @@ lemma carch_tcb_relation_imp_eq: apply (case_tac vcpuptr2 ; simp) done +lemma tcb_ptr_to_ctcb_ptr_inj: + "tcb_ptr_to_ctcb_ptr x = tcb_ptr_to_ctcb_ptr y \ x = y" + by (auto simp: tcb_ptr_to_ctcb_ptr_def ctcb_offset_def) + +lemma + assumes "pspace_aligned' as" "pspace_distinct' as" "valid_tcb' atcb as" + shows tcb_at'_tcbBoundNotification: + "bound (tcbBoundNotification atcb) \ ntfn_at' (the (tcbBoundNotification atcb)) as" + and tcb_at'_tcbSchedPrev: + "tcbSchedPrev atcb \ None \ tcb_at' (the (tcbSchedPrev atcb)) as" + and tcb_at'_tcbSchedNext: + "tcbSchedNext atcb \ None \ tcb_at' (the (tcbSchedNext atcb)) as" + using assms + by (clarsimp simp: valid_tcb'_def obj_at'_def)+ + lemma cpspace_tcb_relation_unique: - assumes tcbs: "cpspace_tcb_relation ah ch" "cpspace_tcb_relation ah' ch" - and vs: "\s. ksPSpace s = ah \ no_0_obj' s \ valid_objs' s" - and vs': "\s. ksPSpace s = ah' \ no_0_obj' s \ valid_objs' s" - assumes ctes: " \tcb tcb'. (\p. map_to_tcbs ah p = Some tcb \ - map_to_tcbs ah' p = Some tcb') \ - (\x\ran tcb_cte_cases. fst x tcb' = fst x tcb)" - shows "map_to_tcbs ah' = map_to_tcbs ah" + assumes tcbs: "cpspace_tcb_relation (ksPSpace as) ch" "cpspace_tcb_relation (ksPSpace as') ch" + assumes vs: "no_0_obj' as" "valid_objs' as" + assumes vs': "no_0_obj' as'" "valid_objs' as'" + assumes ad: "pspace_aligned' as" "pspace_distinct' as" + assumes ad': "pspace_aligned' as'" "pspace_distinct' as'" + assumes ctes: "\tcb tcb'. (\p. map_to_tcbs (ksPSpace as) p = Some tcb \ + map_to_tcbs (ksPSpace as') p = Some tcb') \ + (\x\ran tcb_cte_cases. fst x tcb' = fst x tcb)" + shows "map_to_tcbs (ksPSpace as') = map_to_tcbs (ksPSpace as)" using tcbs(2) tcbs(1) apply (clarsimp simp add: cmap_relation_def) apply (drule inj_image_inv[OF inj_tcb_ptr_to_ctcb_ptr])+ apply (simp add: tcb_ptr_to_ctcb_ptr_def[abs_def] ctcb_offset_def) apply (rule ext) - apply (case_tac "x:dom (map_to_tcbs ah)") + apply (case_tac "x \ dom (map_to_tcbs (ksPSpace as))") apply (drule bspec, assumption)+ apply (simp add: dom_def Collect_eq, drule_tac x=x in spec) apply clarsimp apply (rename_tac p x y) apply (cut_tac ctes) apply (drule_tac x=x in spec, drule_tac x=y in spec, erule impE, fastforce) - apply (frule ksPSpace_valid_objs_tcbBoundNotification_nonzero[OF vs]) - apply (frule ksPSpace_valid_objs_tcbBoundNotification_nonzero[OF vs']) + apply (frule map_to_tcbs_Some_refs_nonzero[OF _ vs]) + apply (frule map_to_tcbs_Some_refs_nonzero[OF _ vs']) apply (frule ksPSpace_valid_objs_atcbVCPUPtr_nonzero[OF vs]) apply (frule ksPSpace_valid_objs_atcbVCPUPtr_nonzero[OF vs']) + apply (rename_tac atcb atcb') + apply (prop_tac "valid_tcb' atcb as") + apply (fastforce intro: vs ad map_to_ko_atI tcb_ko_at_valid_objs_valid_tcb') + apply (prop_tac "valid_tcb' atcb' as'") + apply (fastforce intro: vs' ad' map_to_ko_atI tcb_ko_at_valid_objs_valid_tcb') + apply (frule tcb_at'_tcbSchedPrev[OF ad]) + apply (frule tcb_at'_tcbSchedPrev[OF ad']) + apply (frule tcb_at'_tcbSchedNext[OF ad]) + apply (frule tcb_at'_tcbSchedNext[OF ad']) apply (thin_tac "map_to_tcbs x y = Some z" for x y z)+ - apply (case_tac x, case_tac y, case_tac "the (clift ch (tcb_Ptr (p+0x100)))") + apply (case_tac "the (clift ch (tcb_Ptr (p + 2 ^ ctcb_size_bits)))") apply (clarsimp simp: ctcb_relation_def ran_tcb_cte_cases) - apply (clarsimp simp: option_to_ptr_def option_to_0_def split: option.splits) - apply (auto simp: cfault_rel_imp_eq cthread_state_rel_imp_eq carch_tcb_relation_imp_eq - ccontext_relation_imp_eq up_ucast_inj_eq ctcb_size_bits_def) + apply (clarsimp simp: option_to_ctcb_ptr_def option_to_ptr_def option_to_0_def) + apply (rule tcb.expand) + apply clarsimp + apply (intro conjI) + apply (simp add: cthread_state_rel_imp_eq) + apply (simp add: cfault_rel_imp_eq) + apply (case_tac "tcbBoundNotification atcb'", case_tac "tcbBoundNotification atcb"; clarsimp) + apply (clarsimp split: option.splits) + apply (case_tac "tcbSchedPrev atcb'"; case_tac "tcbSchedPrev atcb"; clarsimp) + apply (force dest!: kernel.tcb_at_not_NULL) + apply (force dest!: kernel.tcb_at_not_NULL) + apply (force simp: tcb_ptr_to_ctcb_ptr_inj) + apply (case_tac "tcbSchedNext atcb'"; case_tac "tcbSchedNext atcb"; clarsimp) + apply (force dest!: kernel.tcb_at_not_NULL) + apply (force dest!: kernel.tcb_at_not_NULL) + apply (force simp: tcb_ptr_to_ctcb_ptr_inj) + apply (force simp: carch_tcb_relation_imp_eq) + apply (force simp: carch_tcb_relation_def ) done lemma tcb_queue_rel_clift_unique: @@ -911,10 +975,6 @@ lemma ksPSpace_valid_pspace_ntfnBoundTCB_nonzero: apply (clarsimp simp: projectKOs valid_obj'_def valid_ntfn'_def) done -lemma tcb_ptr_to_ctcb_ptr_inj: - "tcb_ptr_to_ctcb_ptr x = tcb_ptr_to_ctcb_ptr y \ x = y" - by (auto simp: tcb_ptr_to_ctcb_ptr_def ctcb_offset_def) - lemma cpspace_ntfn_relation_unique: assumes ntfns: "cpspace_ntfn_relation ah ch" "cpspace_ntfn_relation ah' ch" and vs: "\s. ksPSpace s = ah \ valid_pspace' s" @@ -1258,8 +1318,8 @@ proof - OF valid_objs'_imp_wf_asid_pool'[OF valid_objs] valid_objs'_imp_wf_asid_pool'[OF valid_objs']]) apply (drule (1) cpspace_tcb_relation_unique) - apply (fastforce intro: no_0_objs no_0_objs' valid_objs valid_objs') - apply (fastforce intro: no_0_objs no_0_objs' valid_objs valid_objs') + apply (fastforce intro: no_0_objs no_0_objs' valid_objs valid_objs' + aligned aligned' distinct distinct')+ apply (intro allI impI,elim exE conjE) apply (rule_tac p=p in map_to_ctes_tcb_ctes, assumption) apply (frule (1) map_to_ko_atI[OF _ aligned distinct]) @@ -1478,7 +1538,7 @@ where ksDomSchedule = cDomSchedule_to_H kernel_all_global_addresses.ksDomSchedule, ksCurDomain = ucast (ksCurDomain_' s), ksDomainTime = ksDomainTime_' s, - ksReadyQueues = cready_queues_to_H (clift (t_hrs_' s)) (ksReadyQueues_' s), + ksReadyQueues = cready_queues_to_H (ksReadyQueues_' s), ksReadyQueuesL1Bitmap = cbitmap_L1_to_H (ksReadyQueuesL1Bitmap_' s), ksReadyQueuesL2Bitmap = cbitmap_L2_to_H (ksReadyQueuesL2Bitmap_' s), ksCurThread = ctcb_ptr_to_tcb_ptr (ksCurThread_' s), @@ -1497,16 +1557,16 @@ lemma trivial_eq_conj: "B = C \ (A \ B) = (A \ C)" lemma (in kernel_m) cstate_to_H_correct: assumes valid: "valid_state' as" assumes cstate_rel: "cstate_relation as cs" + assumes rdyqs: "ksReadyQueues_asrt as" shows "cstate_to_H cs = as \ksMachineState:= observable_memory (ksMachineState as) (user_mem' as)\" apply (subgoal_tac "cstate_to_machine_H cs = observable_memory (ksMachineState as) (user_mem' as)") apply (rule kernel_state.equality, simp_all add: cstate_to_H_def) - apply (rule cstate_to_pspace_H_correct) + apply (rule cstate_to_pspace_H_correct) using valid apply (simp add: valid_state'_def) using cstate_rel valid apply (clarsimp simp: cstate_relation_def cpspace_relation_def Let_def - observable_memory_def valid_state'_def - valid_pspace'_def) + observable_memory_def valid_state'_def valid_pspace'_def) using cstate_rel apply (clarsimp simp: cstate_relation_def cpspace_relation_def Let_def prod_eq_iff) using cstate_rel @@ -1530,8 +1590,13 @@ lemma (in kernel_m) cstate_to_H_correct: using cstate_rel apply (clarsimp simp: cstate_relation_def Let_def) apply (rule cready_queues_to_H_correct) - using cstate_rel - apply (clarsimp simp: cstate_relation_def Let_def) + using cstate_rel rdyqs + apply (fastforce intro!: cready_queues_to_H_correct + simp: cstate_relation_def Let_def) + using valid apply (fastforce simp: valid_state'_def) + using rdyqs apply fastforce + using valid apply (fastforce simp: valid_state'_def) + using valid apply (fastforce simp: valid_state'_def) using cstate_rel apply (clarsimp simp: cstate_relation_def Let_def) using cstate_rel diff --git a/proof/crefine/ARM_HYP/ArchMove_C.thy b/proof/crefine/ARM_HYP/ArchMove_C.thy index 573715c6f8..0211f89ddf 100644 --- a/proof/crefine/ARM_HYP/ArchMove_C.thy +++ b/proof/crefine/ARM_HYP/ArchMove_C.thy @@ -408,12 +408,6 @@ lemma ko_at'_tcb_vcpu_not_NULL: by (fastforce simp: valid_tcb'_def valid_arch_tcb'_def word_gt_0 typ_at'_no_0_objD dest: valid_objs_valid_tcb') - -(* FIXME move *) -lemma setVMRoot_valid_queues': - "\ valid_queues' \ setVMRoot a \ \_. valid_queues' \" - by (rule valid_queues_lift'; wp) - lemma vcpuEnable_valid_pspace' [wp]: "\ valid_pspace' \ vcpuEnable a \\_. valid_pspace' \" by (wpsimp simp: valid_pspace'_def valid_mdb'_def) @@ -443,8 +437,6 @@ crunch ko_at'2[wp]: doMachineOp "\s. P (ko_at' p t s)" crunch pred_tcb_at'2[wp]: doMachineOp "\s. P (pred_tcb_at' a b p s)" (simp: crunch_simps) -crunch valid_queues'[wp]: readVCPUReg "\s. valid_queues s" - crunch valid_objs'[wp]: readVCPUReg "\s. valid_objs' s" crunch sch_act_wf'[wp]: readVCPUReg "\s. P (sch_act_wf (ksSchedulerAction s) s)" diff --git a/proof/crefine/ARM_HYP/Arch_C.thy b/proof/crefine/ARM_HYP/Arch_C.thy index c792bc031a..7eceede15b 100644 --- a/proof/crefine/ARM_HYP/Arch_C.thy +++ b/proof/crefine/ARM_HYP/Arch_C.thy @@ -2230,7 +2230,7 @@ lemma performPageGetAddress_ccorres: apply clarsimp apply (rule conseqPre, vcg) apply clarsimp - apply (clarsimp simp: invs_no_0_obj' tcb_at_invs' invs_queues invs_valid_objs' invs_sch_act_wf' + apply (clarsimp simp: invs_no_0_obj' tcb_at_invs' invs_valid_objs' invs_sch_act_wf' rf_sr_ksCurThread msgRegisters_unfold seL4_MessageInfo_lift_def message_info_to_H_def mask_def) apply (cases isCall) @@ -3503,8 +3503,8 @@ lemma decodeARMPageDirectoryInvocation_ccorres: st' \ Structures_H.thread_state.Inactive \ st' \ Structures_H.thread_state.IdleThreadState) thread and (\s. thread \ ksIdleThread s \ (obj_at' tcbQueued thread s \ st_tcb_at' runnable' thread s))"]]) - apply (clarsimp simp: invs_valid_objs' invs_sch_act_wf' - valid_tcb_state'_def invs_queues) + apply (clarsimp simp: invs_valid_objs' invs_sch_act_wf' invs_pspace_distinct' + invs_pspace_aligned' valid_tcb_state'_def) \ \cache flush constraints\ subgoal for _ _ _ _ _ _ sz p @@ -4233,9 +4233,12 @@ lemma decodeARMMMUInvocation_ccorres: apply (clarsimp simp: ex_cte_cap_wp_to'_def cte_wp_at_ctes_of invs_sch_act_wf' dest!: isCapDs(1)) apply (intro conjI) - apply (simp add: Invariants_H.invs_queues) - apply (simp add: valid_tcb_state'_def) - apply (fastforce elim!: pred_tcb'_weakenE dest!:st_tcb_at_idle_thread') + apply (simp add: valid_tcb_state'_def) + apply (fastforce elim!: pred_tcb'_weakenE dest!:st_tcb_at_idle_thread') + apply fastforce + apply (clarsimp simp: st_tcb_at'_def obj_at'_def) + apply (rename_tac obj) + apply (case_tac "tcbState obj", (simp add: runnable'_def)+)[1] apply (clarsimp simp: st_tcb_at'_def obj_at'_def) apply (rename_tac obj) apply (case_tac "tcbState obj", (simp add: runnable'_def)+)[1] @@ -4421,6 +4424,9 @@ lemma readVCPUReg_ccorres: apply fastforce done +crunches readVCPUReg + for pspace_aligned'[wp]: pspace_aligned' + and pspace_distinct'[wp]: pspace_distinct' lemma invokeVCPUReadReg_ccorres: (* styled after invokeTCB_ReadRegisters_ccorres *) notes Collect_const[simp del] @@ -4509,7 +4515,8 @@ lemma invokeVCPUReadReg_ccorres: (* styled after invokeTCB_ReadRegisters_ccorres apply clarsimp apply (rule conseqPre, vcg) apply clarsimp - apply (clarsimp simp: invs_no_0_obj' tcb_at_invs' invs_queues invs_valid_objs' invs_sch_act_wf' + apply (clarsimp simp: invs_no_0_obj' tcb_at_invs' invs_valid_objs' invs_sch_act_wf' + invs_pspace_aligned' invs_pspace_distinct' rf_sr_ksCurThread msgRegisters_unfold ThreadState_defs seL4_MessageInfo_lift_def message_info_to_H_def mask_def) apply (cases isCall; clarsimp) @@ -4603,7 +4610,7 @@ lemma decodeVCPUWriteReg_ccorres: apply (vcg exspec=getSyscallArg_modifies) apply (clarsimp simp: word_less_nat_alt word_le_nat_alt conj_commute - invs_no_0_obj' tcb_at_invs' invs_queues invs_valid_objs' invs_sch_act_wf' + invs_no_0_obj' tcb_at_invs' invs_valid_objs' invs_sch_act_wf' rf_sr_ksCurThread msgRegisters_unfold valid_tcb_state'_def ThreadState_defs mask_def) apply (rule conjI; clarsimp) \ \not enough args\ @@ -4846,7 +4853,7 @@ lemma decodeVCPUInjectIRQ_ccorres: apply (vcg exspec=getSyscallArg_modifies) apply (clarsimp simp: word_less_nat_alt word_le_nat_alt conj_commute - invs_no_0_obj' tcb_at_invs' invs_queues invs_valid_objs' invs_sch_act_wf' + invs_no_0_obj' tcb_at_invs' invs_valid_objs' invs_sch_act_wf' rf_sr_ksCurThread msgRegisters_unfold valid_tcb_state'_def ThreadState_defs mask_def) @@ -4953,7 +4960,7 @@ lemma decodeVCPUReadReg_ccorres: apply (vcg exspec=getSyscallArg_modifies) apply (clarsimp simp: word_le_nat_alt conj_commute - invs_no_0_obj' tcb_at_invs' invs_queues invs_valid_objs' invs_sch_act_wf' + invs_no_0_obj' tcb_at_invs' invs_valid_objs' invs_sch_act_wf' rf_sr_ksCurThread msgRegisters_unfold valid_tcb_state'_def ThreadState_defs mask_def) @@ -5057,7 +5064,8 @@ lemma decodeVCPUSetTCB_ccorres: apply vcg apply (clarsimp simp: word_less_nat_alt word_le_nat_alt conj_commute - invs_no_0_obj' tcb_at_invs' invs_queues invs_valid_objs' invs_sch_act_wf' + invs_no_0_obj' tcb_at_invs' invs_valid_objs' invs_sch_act_wf' + invs_pspace_aligned' invs_pspace_distinct' rf_sr_ksCurThread msgRegisters_unfold valid_tcb_state'_def ThreadState_defs mask_def) apply (clarsimp simp: idButNot_def interpret_excaps_test_null @@ -5208,7 +5216,7 @@ proof - (* Haskell side *) apply (clarsimp simp: excaps_in_mem_def slotcap_in_mem_def isCap_simps ctes_of_cte_at) apply (clarsimp simp: word_le_nat_alt conj_commute - invs_no_0_obj' tcb_at_invs' invs_queues invs_valid_objs' invs_sch_act_wf' + invs_no_0_obj' tcb_at_invs' invs_valid_objs' invs_sch_act_wf' rf_sr_ksCurThread msgRegisters_unfold valid_tcb_state'_def mask_def valid_cap'_def ct_in_state'_def sysargs_rel_to_n st_tcb_at'_def comp_def @@ -5216,7 +5224,7 @@ proof - apply (fastforce elim: obj_at'_weakenE) (* C side *) apply (clarsimp simp: word_le_nat_alt conj_commute - invs_no_0_obj' tcb_at_invs' invs_queues invs_valid_objs' invs_sch_act_wf' + invs_no_0_obj' tcb_at_invs' invs_valid_objs' invs_sch_act_wf' rf_sr_ksCurThread msgRegisters_unfold valid_tcb_state'_def ThreadState_defs Kernel_C.maxIRQ_def and_mask_eq_iff_le_mask capVCPUPtr_eq) diff --git a/proof/crefine/ARM_HYP/Detype_C.thy b/proof/crefine/ARM_HYP/Detype_C.thy index 1d6349e303..a2634411f7 100644 --- a/proof/crefine/ARM_HYP/Detype_C.thy +++ b/proof/crefine/ARM_HYP/Detype_C.thy @@ -1675,35 +1675,11 @@ proof - done moreover - from invs have "valid_queues s" .. - hence "\p. \t \ set (ksReadyQueues s p). tcb_at' t s \ ko_wp_at' live' t s" - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def) - apply (drule spec, drule spec) - apply clarsimp - apply (drule (1) bspec) - apply (rule conjI) - apply (erule obj_at'_weakenE) - apply simp - apply (simp add: obj_at'_real_def) - apply (erule ko_wp_at'_weakenE) - apply (clarsimp simp: live'_def projectKOs inQ_def) - done - hence tat: "\p. \t \ set (ksReadyQueues s p). tcb_at' t s" - and tlive: "\p. \t \ set (ksReadyQueues s p). ko_wp_at' live' t s" - by auto from sr have - "cready_queues_relation (clift ?th_s) - (ksReadyQueues_' (globals s')) (ksReadyQueues s)" + "cready_queues_relation (ksReadyQueues s) (ksReadyQueues_' (globals s'))" unfolding cready_queues_relation_def rf_sr_def cstate_relation_def cpspace_relation_def apply (clarsimp simp: Let_def all_conj_distrib) - apply (drule spec, drule spec, drule mp) - apply fastforce - apply ((subst lift_t_typ_region_bytes, rule cm_disj_tcb, assumption+, - simp_all add: objBits_simps archObjSize_def pageBits_def projectKOs)[1])+ - \ \waiting ...\ - apply (simp add: tcb_queue_relation_live_restrict - [OF D.valid_untyped tat tlive rl]) done moreover diff --git a/proof/crefine/ARM_HYP/Fastpath_C.thy b/proof/crefine/ARM_HYP/Fastpath_C.thy index 117979ae1a..546ec82a90 100644 --- a/proof/crefine/ARM_HYP/Fastpath_C.thy +++ b/proof/crefine/ARM_HYP/Fastpath_C.thy @@ -39,11 +39,10 @@ lemma getEndpoint_obj_at': lemmas setEndpoint_obj_at_tcb' = setEndpoint_obj_at'_tcb lemma tcbSchedEnqueue_tcbContext[wp]: - "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ - tcbSchedEnqueue t' - \\rv. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" - apply (rule tcbSchedEnqueue_obj_at_unchangedT[OF all_tcbI]) - apply simp + "tcbSchedEnqueue t' \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_when) + apply (wp threadSet_obj_at' hoare_drop_imps threadGet_wp + | simp split: if_split)+ done lemma setCTE_tcbContext: @@ -55,20 +54,16 @@ lemma setCTE_tcbContext: done lemma setThreadState_tcbContext: - "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ - setThreadState a b - \\_. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" - apply (rule setThreadState_obj_at_unchanged) - apply (clarsimp simp: atcbContext_def)+ - done + "setThreadState a b \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + unfolding setThreadState_def rescheduleRequired_def tcbSchedEnqueue_def + tcbQueuePrepend_def rescheduleRequired_def + by (wp threadSet_obj_at' hoare_drop_imps threadGet_wp | wpc + | simp split: if_split)+ lemma setBoundNotification_tcbContext: - "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ - setBoundNotification a b - \\_. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" - apply (rule setBoundNotification_obj_at_unchanged) - apply (clarsimp simp: atcbContext_def)+ - done + "setBoundNotification a b \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + unfolding setBoundNotification_def + by wpsimp declare comp_apply [simp del] crunch tcbContext[wp]: deleteCallerCap "obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t" @@ -626,14 +621,15 @@ lemmas stored_hw_asid_get_ccorres_split lemma dmo_clearExMonitor_setCurThread_swap: "(do _ \ doMachineOp ARM_HYP.clearExMonitor; - setCurThread thread - od) + setCurThread thread + od) = (do _ \ setCurThread thread; - doMachineOp ARM_HYP.clearExMonitor od)" - apply (simp add: setCurThread_def doMachineOp_def split_def) - apply (rule oblivious_modify_swap[symmetric]) - apply (intro oblivious_bind, - simp_all add: select_f_oblivious) + doMachineOp ARM_HYP.clearExMonitor + od)" + apply (clarsimp simp: ARM_HYP.clearExMonitor_def) + apply (simp add: doMachineOp_modify) + apply (rule oblivious_modify_swap) + apply (fastforce intro: oblivious_bind simp: setCurThread_def idleThreadNotQueued_def) done lemma pd_at_asid_inj': @@ -771,15 +767,17 @@ lemma switchToThread_fp_ccorres: apply (simp add: storeWordUser_def bind_assoc case_option_If2 split_def del: Collect_const) apply (simp only: dmo_clearExMonitor_setCurThread_swap) apply (rule ccorres_split_nothrow_novcg_dc) + apply (clarsimp simp: setCurThread_def) + apply (rule ccorres_stateAssert) apply (rule ccorres_from_vcg[where P=\ and P'=UNIV]) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp del: rf_sr_upd_safe) - apply (clarsimp simp: setCurThread_def simpler_modify_def rf_sr_def cstate_relation_def + apply (clarsimp simp: simpler_modify_def rf_sr_def cstate_relation_def Let_def carch_state_relation_def cmachine_state_relation_def) apply (ctac add: clearExMonitor_fp_ccorres) apply wp apply (simp add: guard_is_UNIV_def) - apply (wpsimp wp: dmo_contextSwitch_HWASID_atcbVCPUPtr_cases_helper hoare_vcg_all_lift + apply (wpsimp wp: hoare_drop_imps dmo_contextSwitch_HWASID_atcbVCPUPtr_cases_helper hoare_vcg_all_lift hoare_vcg_imp_lift) apply (rule conseqPre, vcg, simp, rule subset_refl) apply (rule conseqPre, vcg, clarsimp) @@ -1245,8 +1243,8 @@ lemma fastpath_dequeue_ccorres: apply (rule conjI) apply (clarsimp simp: cpspace_relation_def update_ep_map_tos update_tcb_map_tos typ_heap_simps') - apply (rule conjI, erule ctcb_relation_null_queue_ptrs) - apply (rule ext, simp add: tcb_null_queue_ptrs_def + apply (rule conjI, erule ctcb_relation_null_ep_ptrs) + apply (rule ext, simp add: tcb_null_ep_ptrs_def split: if_split) apply (rule conjI) apply (rule cpspace_relation_ep_update_ep, assumption+) @@ -1262,8 +1260,6 @@ lemma fastpath_dequeue_ccorres: apply (simp add: carch_state_relation_def typ_heap_simps' cmachine_state_relation_def h_t_valid_clift_Some_iff update_ep_map_tos) - apply (erule cready_queues_relation_null_queue_ptrs) - apply (rule ext, simp add: tcb_null_ep_ptrs_def split: if_split) done lemma st_tcb_at_not_in_ep_queue: @@ -1401,8 +1397,8 @@ lemma fastpath_enqueue_ccorres: apply (rule conjI) apply (clarsimp simp: cpspace_relation_def update_ep_map_tos typ_heap_simps') - apply (rule conjI, erule ctcb_relation_null_queue_ptrs) - apply (rule ext, simp add: tcb_null_queue_ptrs_def + apply (rule conjI, erule ctcb_relation_null_ep_ptrs) + apply (rule ext, simp add: tcb_null_ep_ptrs_def split: if_split) apply (rule conjI) apply (rule_tac S="tcb_ptr_to_ctcb_ptr ` set (ksCurThread \ # list)" @@ -1441,8 +1437,6 @@ lemma fastpath_enqueue_ccorres: auto dest!: map_to_ko_atI)[1] apply (simp add: carch_state_relation_def typ_heap_simps' update_ep_map_tos cmachine_state_relation_def h_t_valid_clift_Some_iff) - apply (erule cready_queues_relation_null_queue_ptrs) - apply (rule ext, simp add: tcb_null_ep_ptrs_def split: if_split) apply (clarsimp simp: typ_heap_simps' EPState_Recv_def mask_def is_aligned_weaken[OF is_aligned_tcb_ptr_to_ctcb_ptr]) apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def) @@ -1450,8 +1444,8 @@ lemma fastpath_enqueue_ccorres: apply (rule conjI) apply (clarsimp simp: cpspace_relation_def update_ep_map_tos typ_heap_simps' ct_in_state'_def) - apply (rule conjI, erule ctcb_relation_null_queue_ptrs) - apply (rule ext, simp add: tcb_null_queue_ptrs_def + apply (rule conjI, erule ctcb_relation_null_ep_ptrs) + apply (rule ext, simp add: tcb_null_ep_ptrs_def split: if_split) apply (rule conjI) apply (rule_tac S="{tcb_ptr_to_ctcb_ptr (ksCurThread \)}" @@ -1471,8 +1465,6 @@ lemma fastpath_enqueue_ccorres: assumption+, auto dest!: map_to_ko_atI)[1] apply (simp add: carch_state_relation_def typ_heap_simps' update_ep_map_tos cmachine_state_relation_def h_t_valid_clift_Some_iff) - apply (erule cready_queues_relation_null_queue_ptrs) - apply (rule ext, simp add: tcb_null_ep_ptrs_def split: if_split) done lemma setCTE_rf_sr: @@ -2105,9 +2097,6 @@ proof - apply (erule cmap_relation_updI, erule ko_at_projectKO_opt) apply (simp add: ctcb_relation_def cthread_state_relation_def) apply simp - apply (rule conjI, erule cready_queues_relation_not_queue_ptrs) - apply (rule ext, simp split: if_split add: typ_heap_simps') - apply (rule ext, simp split: if_split add: typ_heap_simps') apply (simp add: carch_state_relation_def cmachine_state_relation_def typ_heap_simps' map_comp_update projectKO_opt_tcb cvariable_relation_upd_const ko_at_projectKO_opt) @@ -2232,9 +2221,6 @@ proof - apply (erule cmap_relation_updI, erule ko_at_projectKO_opt) apply (simp add: ctcb_relation_def cthread_state_relation_def) apply simp - apply (rule conjI, erule cready_queues_relation_not_queue_ptrs) - apply (rule ext, simp split: if_split) - apply (rule ext, simp split: if_split) apply (simp add: carch_state_relation_def cmachine_state_relation_def typ_heap_simps' map_comp_update projectKO_opt_tcb cvariable_relation_upd_const ko_at_projectKO_opt) @@ -2424,7 +2410,7 @@ proof - apply (rule conjI) (* isReceive on queued tcb state *) apply (fastforce simp: st_tcb_at_tcbs_of isBlockedOnReceive_def isReceive_def) apply clarsimp - apply (rule conjI, fastforce dest!: invs_queues simp: valid_queues_def) + apply (rule conjI, fastforce dest!: simp: valid_queues_def) apply (frule invs_mdb', clarsimp simp: valid_mdb'_def valid_mdb_ctes_def) apply (case_tac xb, clarsimp, drule(1) nullcapsD') apply (clarsimp simp: pde_stored_asid_def to_bool_def @@ -2913,9 +2899,6 @@ lemma fastpath_reply_recv_ccorres: ThreadState_defs) apply (clarsimp simp: ccap_relation_ep_helpers) apply simp - apply (rule conjI, erule cready_queues_relation_not_queue_ptrs) - apply (rule ext, simp split: if_split) - apply (rule ext, simp split: if_split) apply (simp add: carch_state_relation_def cmachine_state_relation_def typ_heap_simps' map_comp_update projectKO_opt_tcb cvariable_relation_upd_const ko_at_projectKO_opt) @@ -2992,9 +2975,6 @@ lemma fastpath_reply_recv_ccorres: apply (erule cmap_relation_updI, erule ko_at_projectKO_opt) apply (simp add: ctcb_relation_def cthread_state_relation_def) apply simp - apply (rule conjI, erule cready_queues_relation_not_queue_ptrs) - apply (rule ext, simp split: if_split) - apply (rule ext, simp split: if_split) apply (simp add: carch_state_relation_def cmachine_state_relation_def typ_heap_simps' map_comp_update projectKO_opt_tcb cvariable_relation_upd_const ko_at_projectKO_opt) @@ -3115,8 +3095,6 @@ lemma fastpath_reply_recv_ccorres: apply (clarsimp simp: ct_in_state'_def obj_at_tcbs_of word_sle_def) apply (clarsimp simp add: invs_ksCurDomain_maxDomain') apply (rule conjI, fastforce) - apply (frule invs_queues) - apply (simp add: valid_queues_def) apply (frule tcbs_of_aligned') apply (simp add:invs_pspace_aligned') apply (frule tcbs_of_cte_wp_at_caller) @@ -3146,6 +3124,11 @@ lemma fastpath_reply_recv_ccorres: invs_valid_pde_mappings' obj_at_tcbs_of dest!: isValidVTableRootD) apply (frule invs_mdb') + apply (frule invs_valid_objs') + apply (frule invs_valid_bitmaps) + apply (frule valid_bitmaps_bitmapQ_no_L1_orphans) + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') apply (clarsimp simp: cte_wp_at_ctes_of tcbSlots cte_level_bits_def makeObject_cte isValidVTableRoot_def @@ -3153,10 +3136,10 @@ lemma fastpath_reply_recv_ccorres: pde_stored_asid_def to_bool_def valid_mdb'_def valid_tcb_state'_def word_le_nat_alt[symmetric] length_msgRegisters) - apply (frule ko_at_valid_ep', fastforce) apply (rule conjI) - subgoal (* dest thread domain \ maxDomain *) - by (drule (1) tcbs_of_valid_tcb'[OF invs_valid_objs'], solves \clarsimp simp: valid_tcb'_def\) + apply (fastforce dest: tcbs_of_valid_tcb' simp: valid_tcb'_def opt_map_def + split: option.splits) + apply (frule ko_at_valid_ep', fastforce) apply clarsimp apply (safe del: notI disjE)[1] apply (simp add: isSendEP_def valid_ep'_def tcb_at_invs' diff --git a/proof/crefine/ARM_HYP/Fastpath_Equiv.thy b/proof/crefine/ARM_HYP/Fastpath_Equiv.thy index 826695fab6..c42fcbc9fc 100644 --- a/proof/crefine/ARM_HYP/Fastpath_Equiv.thy +++ b/proof/crefine/ARM_HYP/Fastpath_Equiv.thy @@ -31,13 +31,9 @@ lemma getEndpoint_obj_at': lemmas setEndpoint_obj_at_tcb' = setEndpoint_obj_at'_tcb -lemma tcbSchedEnqueue_tcbContext[wp]: - "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ - tcbSchedEnqueue t' - \\rv. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" - apply (rule tcbSchedEnqueue_obj_at_unchangedT[OF all_tcbI]) - apply simp - done +crunches tcbSchedEnqueue + for tcbContext[wp]: "obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t" + (simp: tcbQueuePrepend_def) lemma setCTE_tcbContext: "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ @@ -50,19 +46,17 @@ lemma setCTE_tcbContext: context begin interpretation Arch . (*FIXME: arch_split*) lemma setThreadState_tcbContext: - "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ - setThreadState a b - \\_. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" - apply (rule setThreadState_obj_at_unchanged) - apply (clarsimp simp: atcbContext_def)+ + "setThreadState st tptr \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + unfolding setThreadState_def rescheduleRequired_def + apply (wpsimp wp: threadSet_wp hoare_drop_imps) + apply (fastforce simp: obj_at'_def objBits_simps projectKOs atcbContext_def ps_clear_upd) done lemma setBoundNotification_tcbContext: - "\obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ - setBoundNotification a b - \\_. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" - apply (rule setBoundNotification_obj_at_unchanged) - apply (clarsimp simp: atcbContext_def)+ + "setBoundNotification ntfnPtr tptr \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + unfolding setBoundNotification_def + apply (wpsimp wp: threadSet_wp hoare_drop_imps) + apply (fastforce simp: obj_at'_def objBits_simps projectKOs) done declare comp_apply [simp del] @@ -127,13 +121,15 @@ lemma of_bl_from_bool: lemma dmo_clearExMonitor_setCurThread_swap: "(do _ \ doMachineOp ARM_HYP.clearExMonitor; - setCurThread thread - od) + setCurThread thread + od) = (do _ \ setCurThread thread; - doMachineOp ARM_HYP.clearExMonitor od)" - apply (simp add: setCurThread_def doMachineOp_def split_def) - apply (rule oblivious_modify_swap[symmetric]) - apply (intro oblivious_bind, simp_all) + doMachineOp ARM_HYP.clearExMonitor + od)" + apply (clarsimp simp: ARM_HYP.clearExMonitor_def) + apply (simp add: doMachineOp_modify) + apply (rule oblivious_modify_swap) + apply (fastforce intro: oblivious_bind simp: setCurThread_def idleThreadNotQueued_def) done lemma pd_at_asid_inj': @@ -508,11 +504,39 @@ lemma setThreadState_runnable_bitmap_inv: crunches curDomain for (no_fail) no_fail[intro!, wp, simp] +lemma setThreadState_tcbDomain_tcbPriority_obj_at'[wp]: + "setThreadState ts t \obj_at' (\tcb. P (tcbDomain tcb) (tcbPriority tcb)) t'\" + unfolding setThreadState_def rescheduleRequired_def tcbSchedEnqueue_def tcbQueuePrepend_def + apply (wpsimp wp: threadSet_wp hoare_drop_imps threadGet_wp simp: setQueue_def bitmap_fun_defs) + apply (fastforce simp: obj_at'_def st_tcb_at'_def objBits_simps projectKOs) + done + +lemma setThreadState_tcbQueued_obj_at'[wp]: + "setThreadState ts t \obj_at' (\tcb. P (tcbQueued tcb)) t'\" + unfolding setThreadState_def rescheduleRequired_def tcbSchedEnqueue_def tcbQueuePrepend_def + apply (wpsimp wp: threadSet_wp hoare_drop_imps threadGet_wp simp: setQueue_def bitmap_fun_defs) + apply (fastforce simp: obj_at'_def st_tcb_at'_def objBits_simps projectKOs) + done + +lemma setThreadState_tcbFault_obj_at'[wp]: + "setThreadState ts t \obj_at' (\tcb. P (tcbFault tcb)) t'\" + unfolding setThreadState_def rescheduleRequired_def tcbSchedEnqueue_def tcbQueuePrepend_def + apply (wpsimp wp: threadSet_wp hoare_drop_imps threadGet_wp simp: setQueue_def bitmap_fun_defs) + apply (fastforce simp: obj_at'_def st_tcb_at'_def objBits_simps projectKOs) + done + +lemma setThreadState_tcbArch_obj_at'[wp]: + "setThreadState ts t \obj_at' (\tcb. P (tcbArch tcb)) t'\" + unfolding setThreadState_def rescheduleRequired_def tcbSchedEnqueue_def tcbQueuePrepend_def + apply (wpsimp wp: threadSet_wp hoare_drop_imps threadGet_wp simp: setQueue_def bitmap_fun_defs) + apply (fastforce simp: obj_at'_def st_tcb_at'_def objBits_simps projectKOs) + done + lemma fastpath_callKernel_SysCall_corres: "monadic_rewrite True False (invs' and ct_in_state' ((=) Running) and (\s. ksSchedulerAction s = ResumeCurrentThread) - and (\s. ksDomainTime s \ 0)) + and (\s. ksDomainTime s \ 0) and ready_qs_runnable) (callKernel (SyscallEvent SysCall)) (fastpaths SysCall)" supply if_cong[cong] option.case_cong[cong] if_split[split del] supply empty_fail_getMRs[wp] (* FIXME *) @@ -669,22 +693,18 @@ lemma fastpath_callKernel_SysCall_corres: apply wp[1] apply (simp cong: if_cong HOL.conj_cong add: if_bool_simps) apply (simp_all only:)[5] - apply ((wp setThreadState_oa_queued[of _ "\a _ _. \ a"] - setThreadState_obj_at_unchanged - asUser_obj_at_unchanged mapM_x_wp' + apply ((wp asUser_obj_at_unchanged mapM_x_wp' sts_st_tcb_at'_cases setThreadState_no_sch_change setEndpoint_obj_at_tcb' fastpathBestSwitchCandidate_lift[where f="setThreadState f t" for f t] - setThreadState_oa_queued fastpathBestSwitchCandidate_lift[where f="asUser t f" for f t] fastpathBestSwitchCandidate_lift[where f="setEndpoint a b" for a b] lookupBitmapPriority_lift setThreadState_runnable_bitmap_inv getEndpoint_obj_at' - | simp add: setMessageInfo_def + | simp add: setMessageInfo_def obj_at'_conj | wp (once) hoare_vcg_disj_lift)+) - apply (simp add: setThreadState_runnable_simp getThreadCallerSlot_def getThreadReplySlot_def locateSlot_conv bind_assoc) @@ -794,8 +814,6 @@ lemma fastpath_callKernel_SysCall_corres: prefer 2 apply normalise_obj_at' apply clarsimp - apply (frule_tac t="blockedThread" in valid_queues_not_runnable_not_queued, assumption) - subgoal by (fastforce simp: st_tcb_at'_def elim: obj_at'_weakenE) apply (subgoal_tac "fastpathBestSwitchCandidate blockedThread s") prefer 2 apply (rule_tac ttcb=tcbb and ctcb=tcb in fastpathBestSwitchCandidateI) @@ -804,6 +822,9 @@ lemma fastpath_callKernel_SysCall_corres: apply (clarsimp simp: st_tcb_at'_def obj_at'_def objBits_simps projectKOs valid_mdb'_def valid_mdb_ctes_def inj_case_bool split: bool.split)+ + apply (clarsimp simp: ready_qs_runnable_def) + apply (drule_tac x=blockedThread in spec) + apply (clarsimp simp: obj_at'_def projectKOs st_tcb_at'_def objBits_simps) done lemma capability_case_Null_ReplyCap: @@ -960,14 +981,16 @@ crunch tcbContext[wp]: possibleSwitchTo "obj_at' (\tcb. P ( (atcbContext crunch only_cnode_caps[wp]: doFaultTransfer "\s. P (only_cnode_caps (ctes_of s))" (wp: crunch_wps simp: crunch_simps) +(* FIXME: monadic_rewrite_l does not work with stateAssert here *) lemma tcbSchedDequeue_rewrite_not_queued: "monadic_rewrite True False (tcb_at' t and obj_at' (Not \ tcbQueued) t) (tcbSchedDequeue t) (return ())" - apply (simp add: tcbSchedDequeue_def when_def) - apply (monadic_rewrite_l monadic_rewrite_if_l_False \wp threadGet_const\) - apply (monadic_rewrite_symb_exec_l, rule monadic_rewrite_refl) - apply wp+ - apply clarsimp + apply (simp add: tcbSchedDequeue_def) + apply wp_pre + apply monadic_rewrite_symb_exec_l + apply (monadic_rewrite_symb_exec_l_known False, simp) + apply (rule monadic_rewrite_refl) + apply (wpsimp wp: threadGet_const)+ done lemma schedule_known_rewrite: @@ -1006,7 +1029,7 @@ lemma schedule_known_rewrite: \wpsimp wp: Arch_switchToThread_obj_at_pre\) (* remove no-ops *) apply simp - apply (repeat 9 \rule monadic_rewrite_symb_exec_l\) (* until switchToThread *) + apply (repeat 13 \rule monadic_rewrite_symb_exec_l\) (* until switchToThread *) apply (rule monadic_rewrite_refl) apply (wpsimp simp: isHighestPrio_def')+ apply (clarsimp simp: ct_in_state'_def not_pred_tcb_at'_strengthen @@ -1268,18 +1291,12 @@ crunches setThreadState, emptySlot, asUser (wp: obj_at_setObject2 crunch_wps simp: crunch_simps updateObject_default_def in_monad) -lemma st_tcb_at_is_Reply_imp_not_tcbQueued: "\s t.\ invs' s; st_tcb_at' isReply t s\ \ obj_at' (\a. \ tcbQueued a) t s" - apply (clarsimp simp: invs'_def valid_state'_def valid_queues_def st_tcb_at'_def valid_queues_no_bitmap_def) - apply (rule all_prio_not_inQ_not_tcbQueued) - apply (clarsimp simp: obj_at'_def) - apply (erule_tac x="d" in allE) - apply (erule_tac x="p" in allE) - apply (erule conjE) - apply (erule_tac x="t" in ballE) - apply (clarsimp simp: obj_at'_def runnable'_def isReply_def) - apply (case_tac "tcbState obj") - apply ((clarsimp simp: inQ_def)+)[8] - apply (clarsimp simp: valid_queues'_def obj_at'_def) +lemma st_tcb_at_is_Reply_imp_not_tcbQueued: + "\s t. \ ready_qs_runnable s; st_tcb_at' isReply t s\ \ obj_at' (\tcb. \ tcbQueued tcb) t s" + apply (clarsimp simp: ready_qs_runnable_def) + apply (drule_tac x=t in spec) + apply (clarsimp simp: st_tcb_at'_def obj_at'_def isReply_def) + apply (case_tac "tcbState obj"; clarsimp) done lemma valid_objs_ntfn_at_tcbBoundNotification: @@ -1335,7 +1352,7 @@ lemma tcbSchedEnqueue_tcbIPCBuffer: "\obj_at' (\tcb. P (tcbIPCBuffer tcb)) t\ tcbSchedEnqueue t' \\_. obj_at' (\tcb. P (tcbIPCBuffer tcb)) t\" - apply (simp add: tcbSchedEnqueue_def unless_when) + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_when) apply (wp threadSet_obj_at' hoare_drop_imps threadGet_wp |simp split: if_split)+ done @@ -1361,10 +1378,20 @@ crunch obj_at'_tcbIPCBuffer[wp]: emptySlot "obj_at' (\tcb. P (tcbIPCBuff crunches getBoundNotification for (no_fail) no_fail[intro!, wp, simp] +lemma threadSet_tcb_at'[wp]: + "threadSet f t' \\s. P (tcb_at' addr s)\" + apply (wpsimp wp: threadSet_wp) + apply (erule rsubst[where P=P]) + by (clarsimp simp: obj_at'_def projectKOs ps_clear_upd objBits_simps) + +crunches rescheduleRequired, tcbSchedDequeue, setThreadState, setBoundNotification + for tcb''[wp]: "\s. P (tcb_at' addr s)" + (wp: crunch_wps) + lemma fastpath_callKernel_SysReplyRecv_corres: "monadic_rewrite True False (invs' and ct_in_state' ((=) Running) and (\s. ksSchedulerAction s = ResumeCurrentThread) - and cnode_caps_gsCNodes') + and cnode_caps_gsCNodes' and ready_qs_runnable) (callKernel (SyscallEvent SysReplyRecv)) (fastpaths SysReplyRecv)" including classic_wp_pre supply if_cong[cong] option.case_cong[cong] @@ -1494,8 +1521,7 @@ lemma fastpath_callKernel_SysReplyRecv_corres: and thread=thread in possibleSwitchTo_rewrite)) | rule cteDeleteOne_replycap_rewrite | rule monadic_rewrite_bind monadic_rewrite_refl - | wp assert_inv mapM_x_wp' - setThreadState_obj_at_unchanged + | wp assert_inv mapM_x_wp' sts_valid_objs' asUser_obj_at_unchanged hoare_strengthen_post[OF _ obj_at_conj'[simplified atomize_conjL], rotated] lookupBitmapPriority_lift @@ -1561,8 +1587,8 @@ lemma fastpath_callKernel_SysReplyRecv_corres: | wps)+)[3] apply (simp cong: rev_conj_cong) apply (wpsimp wp: setThreadState_tcbContext[simplified comp_apply] - setThreadState_oa_queued user_getreg_rv - setThreadState_no_sch_change setThreadState_obj_at_unchanged + user_getreg_rv + setThreadState_no_sch_change sts_valid_objs' sts_st_tcb_at'_cases sts_bound_tcb_at' fastpathBestSwitchCandidate_lift[where f="setThreadState s t" for s t] hoare_weak_lift_imp hoare_vcg_all_lift hoare_vcg_imp_lift @@ -1570,8 +1596,7 @@ lemma fastpath_callKernel_SysReplyRecv_corres: hoare_vcg_ex_lift | wps)+ apply (strengthen imp_consequent[where Q="tcb_at' t s" for t s]) - apply ((wp setThreadState_oa_queued user_getreg_rv setThreadState_no_sch_change - setThreadState_obj_at_unchanged + apply ((wp user_getreg_rv setThreadState_no_sch_change sts_st_tcb_at'_cases sts_bound_tcb_at' emptySlot_obj_at'_not_queued emptySlot_obj_at_ep emptySlot_tcbContext[simplified comp_apply] @@ -1748,7 +1773,9 @@ lemma fastpath_callKernel_SysReplyRecv_corres: apply (clarsimp simp: obj_at_tcbs_of tcbSlots cte_level_bits_def) apply (frule(1) st_tcb_at_is_Reply_imp_not_tcbQueued) - apply (auto simp: obj_at_tcbs_of tcbSlots + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (auto simp: obj_at_tcbs_of tcbSlots projectKOs cte_level_bits_def) done diff --git a/proof/crefine/ARM_HYP/Finalise_C.thy b/proof/crefine/ARM_HYP/Finalise_C.thy index 8795ff253e..aa8408d67c 100644 --- a/proof/crefine/ARM_HYP/Finalise_C.thy +++ b/proof/crefine/ARM_HYP/Finalise_C.thy @@ -17,6 +17,108 @@ declare if_split [split del] definition "option_map2 f m = option_map f \ m" +definition ksReadyQueues_head_end_2 :: "(domain \ priority \ ready_queue) \ bool" where + "ksReadyQueues_head_end_2 qs \ + \d p. tcbQueueHead (qs (d, p)) \ None \ tcbQueueEnd (qs (d, p)) \ None" + +abbreviation "ksReadyQueues_head_end s \ ksReadyQueues_head_end_2 (ksReadyQueues s)" + +lemmas ksReadyQueues_head_end_def = ksReadyQueues_head_end_2_def + +lemma ksReadyQueues_asrt_ksReadyQueues_head_end: + "ksReadyQueues_asrt s \ ksReadyQueues_head_end s" + by (fastforce dest: tcbQueueHead_iff_tcbQueueEnd + simp: ready_queue_relation_def ksReadyQueues_asrt_def ksReadyQueues_head_end_def) + +lemma tcbSchedEnqueue_ksReadyQueues_head_end[wp]: + "tcbSchedEnqueue tcbPtr \ksReadyQueues_head_end\" + unfolding tcbSchedEnqueue_def tcbQueuePrepend_def setQueue_def + apply (wpsimp wp: threadSet_wp threadGet_wp simp: bitmap_fun_defs) + apply (clarsimp simp: tcbQueueEmpty_def obj_at'_def ksReadyQueues_head_end_def split: if_splits) + done + +lemma ksReadyQueues_head_end_ksSchedulerAction_update[simp]: + "ksReadyQueues_head_end (s\ksSchedulerAction := ChooseNewThread\) = ksReadyQueues_head_end s" + by (simp add: ksReadyQueues_head_end_def) + +crunches rescheduleRequired + for ksReadyQueues_head_end[wp]: ksReadyQueues_head_end + +lemma setThreadState_ksReadyQueues_head_end[wp]: + "setThreadState ts tcbPtr \ksReadyQueues_head_end\" + unfolding setThreadState_def + by (wpsimp wp: threadSet_wp threadGet_wp simp: bitmap_fun_defs) + +definition ksReadyQueues_head_end_tcb_at'_2 :: + "(domain \ priority \ ready_queue) \ (obj_ref \ tcb) \ bool" where + "ksReadyQueues_head_end_tcb_at'_2 qs tcbs \ + \d p. (\head. tcbQueueHead (qs (d, p)) = Some head \ tcbs head \ None) + \ (\end. tcbQueueEnd (qs (d, p)) = Some end \ tcbs end \ None)" + +abbreviation "ksReadyQueues_head_end_tcb_at' s \ + ksReadyQueues_head_end_tcb_at'_2 (ksReadyQueues s) (tcbs_of' s)" + +lemmas ksReadyQueues_head_end_tcb_at'_def = ksReadyQueues_head_end_tcb_at'_2_def + +lemma ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at': + "\ksReadyQueues_asrt s; pspace_aligned' s; pspace_distinct' s\ + \ ksReadyQueues_head_end_tcb_at' s" + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def + ksReadyQueues_head_end_tcb_at'_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: list_queue_relation_def) + apply (intro conjI impI allI) + apply (case_tac "ts = []", clarsimp) + apply (fastforce dest!: heap_path_head hd_in_set + simp: opt_pred_def tcbQueueEmpty_def split: option.splits) + apply (fastforce simp: queue_end_valid_def opt_pred_def tcbQueueEmpty_def + split: option.splits) + done + +lemma tcbSchedEnqueue_ksReadyQueues_head_end_tcb_at'[wp]: + "tcbSchedEnqueue tcbPtr \ksReadyQueues_head_end_tcb_at'\" + unfolding tcbSchedEnqueue_def tcbQueuePrepend_def setQueue_def + apply (wpsimp wp: threadSet_wp threadGet_wp simp: bitmap_fun_defs) + apply (clarsimp simp: ksReadyQueues_head_end_tcb_at'_def split: if_splits) + done + +lemma ksReadyQueues_head_end_tcb_at'_ksSchedulerAction_update[simp]: + "ksReadyQueues_head_end_tcb_at' (s\ksSchedulerAction := ChooseNewThread\) + = ksReadyQueues_head_end_tcb_at' s" + by (simp add: ksReadyQueues_head_end_tcb_at'_def) + +crunches rescheduleRequired + for ksReadyQueues_head_end_tcb_at'[wp]: ksReadyQueues_head_end_tcb_at' + +lemma setThreadState_ksReadyQueues_head_end_tcb_at'[wp]: + "setThreadState ts tcbPtr \ksReadyQueues_head_end_tcb_at'\" + unfolding setThreadState_def + apply (wpsimp wp: threadSet_wp) + apply (fastforce simp: ksReadyQueues_head_end_tcb_at'_def split: if_splits) + done + +lemma head_end_ksReadyQueues_': + "\ (s, s') \ rf_sr; ksReadyQueues_head_end s; ksReadyQueues_head_end_tcb_at' s; + pspace_aligned' s; pspace_distinct' s; + d \ maxDomain; p \ maxPriority \ + \ head_C (index (ksReadyQueues_' (globals s')) (cready_queues_index_to_C d p)) = NULL + \ end_C (index (ksReadyQueues_' (globals s')) (cready_queues_index_to_C d p)) = NULL" + apply (frule (2) rf_sr_ctcb_queue_relation[where d=d and p=p]) + apply (clarsimp simp: ksReadyQueues_head_end_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: ksReadyQueues_head_end_tcb_at'_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: ctcb_queue_relation_def option_to_ctcb_ptr_def split: option.splits) + apply (rename_tac "end" head end_tcb head_tcb) + apply (prop_tac "tcb_at' head s \ tcb_at' end s") + apply (fastforce intro!: aligned'_distinct'_ko_wp_at'I + simp: obj_at'_real_def opt_map_def split: option.splits) + apply (fastforce dest: tcb_at_not_NULL) + done + lemma tcbSchedEnqueue_cslift_spec: "\s. \\\<^bsub>/UNIV\<^esub> \s. \d v. option_map2 tcbPriority_C (cslift s) \tcb = Some v \ unat v \ numPriorities @@ -28,7 +130,9 @@ lemma tcbSchedEnqueue_cslift_spec: \ None \ option_map2 tcbDomain_C (cslift s) (head_C (index \ksReadyQueues (unat (d*0x100 + v)))) - \ None)\ + \ None) + \ (head_C (index \ksReadyQueues (unat (d * 0x100 + v))) \ NULL + \ end_C (index \ksReadyQueues (unat (d * 0x100 + v))) \ NULL)\ Call tcbSchedEnqueue_'proc {s'. option_map2 tcbEPNext_C (cslift s') = option_map2 tcbEPNext_C (cslift s) \ option_map2 tcbEPPrev_C (cslift s') = option_map2 tcbEPPrev_C (cslift s) @@ -45,8 +149,8 @@ lemma tcbSchedEnqueue_cslift_spec: apply (rule conjI) apply (clarsimp simp: typ_heap_simps cong: if_cong) apply (simp split: if_split) - apply (clarsimp simp: typ_heap_simps if_Some_helper cong: if_cong) - by (simp split: if_split) + by (auto simp: typ_heap_simps' if_Some_helper numPriorities_def + cong: if_cong split: if_splits) lemma setThreadState_cslift_spec: "\s. \\\<^bsub>/UNIV\<^esub> \s. s \\<^sub>c \tptr \ (\x. ksSchedulerAction_' (globals s) = tcb_Ptr x @@ -141,8 +245,9 @@ lemma ctcb_relation_tcbPriority_maxPriority_numPriorities: done lemma tcbSchedEnqueue_cslift_precond_discharge: - "\ (s, s') \ rf_sr; obj_at' (P :: tcb \ bool) x s; - valid_queues s; valid_objs' s \ \ + "\ (s, s') \ rf_sr; obj_at' (P :: tcb \ bool) x s; valid_objs' s ; + ksReadyQueues_head_end s; ksReadyQueues_head_end_tcb_at' s; + pspace_aligned' s; pspace_distinct' s\ \ (\d v. option_map2 tcbPriority_C (cslift s') (tcb_ptr_to_ctcb_ptr x) = Some v \ unat v < numPriorities \ option_map2 tcbDomain_C (cslift s') (tcb_ptr_to_ctcb_ptr x) = Some d @@ -153,31 +258,49 @@ lemma tcbSchedEnqueue_cslift_precond_discharge: \ None \ option_map2 tcbDomain_C (cslift s') (head_C (index (ksReadyQueues_' (globals s')) (unat (d*0x100 + v)))) - \ None))" + \ None) + \ (head_C (index (ksReadyQueues_' (globals s')) (unat (d * 0x100 + v))) \ NULL + \ end_C (index (ksReadyQueues_' (globals s')) (unat (d * 0x100 + v))) \ NULL))" apply (drule(1) obj_at_cslift_tcb) apply (clarsimp simp: typ_heap_simps' option_map2_def) + apply (rename_tac tcb tcb') apply (frule_tac t=x in valid_objs'_maxPriority, fastforce simp: obj_at'_def) apply (frule_tac t=x in valid_objs'_maxDomain, fastforce simp: obj_at'_def) apply (drule_tac P="\tcb. tcbPriority tcb \ maxPriority" in obj_at_ko_at2', simp) apply (drule_tac P="\tcb. tcbDomain tcb \ maxDomain" in obj_at_ko_at2', simp) apply (simp add: ctcb_relation_tcbDomain_maxDomain_numDomains ctcb_relation_tcbPriority_maxPriority_numPriorities) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) + apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" in rf_sr_ctcb_queue_relation) apply (simp add: maxDom_to_H maxPrio_to_H)+ + apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" in head_end_ksReadyQueues_', fastforce+) apply (simp add: cready_queues_index_to_C_def2 numPriorities_def le_maxDomain_eq_less_numDomains) apply (clarsimp simp: ctcb_relation_def) - apply (frule arg_cong[where f=unat], subst(asm) unat_ucast_8_32) - apply (frule tcb_queue'_head_end_NULL) - apply (erule conjunct1[OF valid_queues_valid_q]) - apply (frule(1) tcb_queue_relation_qhead_valid') - apply (simp add: valid_queues_valid_q) - apply (clarsimp simp: h_t_valid_clift_Some_iff) + apply (frule arg_cong[where f=unat], subst(asm) unat_ucast_up_simp, simp) + apply (frule (3) head_end_ksReadyQueues_', fastforce+) + apply (clarsimp simp: ksReadyQueues_head_end_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (prop_tac "\ tcbQueueEmpty ((ksReadyQueues s (tcbDomain tcb, tcbPriority tcb)))") + apply (clarsimp simp: tcbQueueEmpty_def ctcb_queue_relation_def option_to_ctcb_ptr_def + split: option.splits) + apply (clarsimp simp: ksReadyQueues_head_end_tcb_at'_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (clarsimp simp: tcbQueueEmpty_def) + apply (rename_tac head "end" head_tcb end_tcb) + apply (prop_tac "tcb_at' head s") + apply (fastforce intro: aligned'_distinct'_ko_wp_at'I + simp: obj_at'_real_def opt_map_def split: option.splits) + apply (frule_tac thread=head in obj_at_cslift_tcb) + apply fastforce + apply (clarsimp dest: obj_at_cslift_tcb simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) done lemma cancel_all_ccorres_helper: "ccorres dc xfdc - (\s. valid_objs' s \ valid_queues s + (\s. valid_objs' s \ pspace_aligned' s \ pspace_distinct' s + \ ksReadyQueues_head_end s \ ksReadyQueues_head_end_tcb_at' s \ (\t\set ts. tcb_at' t s \ t \ 0) \ sch_act_wf (ksSchedulerAction s) s) {s'. \p. ep_queue_relation (cslift s') ts @@ -232,11 +355,11 @@ next apply (erule cmap_relationE1 [OF cmap_relation_tcb]) apply (erule ko_at_projectKO_opt) apply (fastforce intro: typ_heap_simps) - apply (wp sts_running_valid_queues | simp)+ + apply (wp sts_valid_objs' | simp)+ apply (rule ceqv_refl) apply (rule "Cons.hyps") apply (wp sts_valid_objs' sts_sch_act sch_act_wf_lift hoare_vcg_const_Ball_lift - sts_running_valid_queues sts_st_tcb' setThreadState_oa_queued | simp)+ + sts_st_tcb' | simp)+ apply (vcg exspec=setThreadState_cslift_spec exspec=tcbSchedEnqueue_cslift_spec) apply (clarsimp simp: tcb_at_not_NULL Collect_const_mem valid_tcb_state'_def @@ -250,16 +373,13 @@ next st_tcb_at'_def split: scheduler_action.split_asm) apply (rename_tac word) - apply (frule_tac x=word in tcbSchedEnqueue_cslift_precond_discharge) - apply simp - apply clarsimp - apply clarsimp - apply clarsimp + apply (frule_tac x=word in tcbSchedEnqueue_cslift_precond_discharge; clarsimp?) + apply simp apply clarsimp apply (rule conjI) apply (frule(3) tcbSchedEnqueue_cslift_precond_discharge) apply clarsimp - apply clarsimp + apply clarsimp+ apply (subst ep_queue_relation_shift, fastforce) apply (drule_tac x="tcb_ptr_to_ctcb_ptr thread" in fun_cong)+ @@ -268,11 +388,17 @@ next done qed +crunches setEndpoint, setNotification + for ksReadyQueues_head_end[wp]: ksReadyQueues_head_end + and ksReadyQueues_head_end_tcb_at'[wp]: ksReadyQueues_head_end_tcb_at' + (simp: updateObject_default_def) + lemma cancelAllIPC_ccorres: "ccorres dc xfdc - (invs') (UNIV \ {s. epptr_' s = Ptr epptr}) [] + invs' (UNIV \ {s. epptr_' s = Ptr epptr}) [] (cancelAllIPC epptr) (Call cancelAllIPC_'proc)" apply (cinit lift: epptr_') + apply (rule ccorres_stateAssert) apply (rule ccorres_symb_exec_l [OF _ getEndpoint_inv _ empty_fail_getEndpoint]) apply (rule_tac xf'=ret__unsigned_' and val="case ep of IdleEP \ scast EPState_Idle @@ -287,7 +413,7 @@ lemma cancelAllIPC_ccorres: apply (simp add: cendpoint_relation_def Let_def split: endpoint.split_asm) apply ceqv - apply (rule_tac A="invs' and ko_at' ep epptr" + apply (rule_tac A="invs' and ksReadyQueues_asrt and ko_at' ep epptr" in ccorres_guard_imp2[where A'=UNIV]) apply wpc apply (rename_tac list) @@ -327,12 +453,11 @@ lemma cancelAllIPC_ccorres: apply ceqv apply (ctac add: rescheduleRequired_ccorres) apply (wp weak_sch_act_wf_lift_linear - cancelAllIPC_mapM_x_valid_queues | simp)+ apply (rule mapM_x_wp', wp)+ apply (wp sts_st_tcb') apply (clarsimp split: if_split) - apply (rule mapM_x_wp', wp)+ + apply (rule mapM_x_wp', wp sts_valid_objs')+ apply (clarsimp simp: valid_tcb_state'_def) apply (simp add: guard_is_UNIV_def) apply (wp set_ep_valid_objs' hoare_vcg_const_Ball_lift @@ -374,22 +499,26 @@ lemma cancelAllIPC_ccorres: apply (rule cancel_all_ccorres_helper) apply ceqv apply (ctac add: rescheduleRequired_ccorres) - apply (wp cancelAllIPC_mapM_x_valid_queues) - apply (wp mapM_x_wp' weak_sch_act_wf_lift_linear + apply (wp mapM_x_wp' weak_sch_act_wf_lift_linear sts_valid_objs' sts_st_tcb' | clarsimp simp: valid_tcb_state'_def split: if_split)+ apply (simp add: guard_is_UNIV_def) apply (wp set_ep_valid_objs' hoare_vcg_const_Ball_lift weak_sch_act_wf_lift_linear) apply vcg - apply (clarsimp simp: valid_ep'_def invs_valid_objs' invs_queues) + apply (clarsimp simp: valid_ep'_def invs_valid_objs') apply (rule cmap_relationE1[OF cmap_relation_ep], assumption) apply (erule ko_at_projectKO_opt) apply (frule obj_at_valid_objs', clarsimp+) - apply (clarsimp simp: projectKOs valid_obj'_def valid_ep'_def) - subgoal by (auto simp: typ_heap_simps cendpoint_relation_def - Let_def tcb_queue_relation'_def - invs_valid_objs' valid_objs'_maxDomain valid_objs'_maxPriority - intro!: obj_at_conj') + apply (clarsimp simp: valid_obj'_def valid_ep'_def) + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (frule ksReadyQueues_asrt_ksReadyQueues_head_end) + apply (frule (2) ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at') + subgoal + by (auto simp: typ_heap_simps cendpoint_relation_def + Let_def tcb_queue_relation'_def projectKOs + invs_valid_objs' valid_objs'_maxDomain valid_objs'_maxPriority + intro!: obj_at_conj') apply (clarsimp simp: guard_is_UNIV_def) apply (wp getEndpoint_wp) apply clarsimp @@ -397,9 +526,10 @@ lemma cancelAllIPC_ccorres: lemma cancelAllSignals_ccorres: "ccorres dc xfdc - (invs') (UNIV \ {s. ntfnPtr_' s = Ptr ntfnptr}) [] + invs' (UNIV \ {s. ntfnPtr_' s = Ptr ntfnptr}) [] (cancelAllSignals ntfnptr) (Call cancelAllSignals_'proc)" apply (cinit lift: ntfnPtr_') + apply (rule ccorres_stateAssert) apply (rule ccorres_symb_exec_l [OF _ get_ntfn_inv' _ empty_fail_getNotification]) apply (rule_tac xf'=ret__unsigned_' and val="case ntfnObj ntfn of IdleNtfn \ scast NtfnState_Idle @@ -414,7 +544,7 @@ lemma cancelAllSignals_ccorres: apply (simp add: cnotification_relation_def Let_def split: ntfn.split_asm) apply ceqv - apply (rule_tac A="invs' and ko_at' ntfn ntfnptr" + apply (rule_tac A="invs' and ksReadyQueues_asrt and ko_at' ntfn ntfnptr" in ccorres_guard_imp2[where A'=UNIV]) apply wpc apply (simp add: notification_state_defs ccorres_cond_iffs) @@ -453,8 +583,7 @@ lemma cancelAllSignals_ccorres: apply (rule cancel_all_ccorres_helper) apply ceqv apply (ctac add: rescheduleRequired_ccorres) - apply (wp cancelAllIPC_mapM_x_valid_queues) - apply (wp mapM_x_wp' weak_sch_act_wf_lift_linear + apply (wp mapM_x_wp' weak_sch_act_wf_lift_linear sts_valid_objs' sts_st_tcb' | clarsimp simp: valid_tcb_state'_def split: if_split)+ apply (simp add: guard_is_UNIV_def) apply (wp set_ntfn_valid_objs' hoare_vcg_const_Ball_lift @@ -464,11 +593,16 @@ lemma cancelAllSignals_ccorres: apply (rule cmap_relationE1[OF cmap_relation_ntfn], assumption) apply (erule ko_at_projectKO_opt) apply (frule obj_at_valid_objs', clarsimp+) - apply (clarsimp simp add: valid_obj'_def valid_ntfn'_def projectKOs) - subgoal by (auto simp: typ_heap_simps cnotification_relation_def - Let_def tcb_queue_relation'_def - invs_valid_objs' valid_objs'_maxDomain valid_objs'_maxPriority - intro!: obj_at_conj') + apply (clarsimp simp add: valid_obj'_def valid_ntfn'_def) + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (frule ksReadyQueues_asrt_ksReadyQueues_head_end) + apply (frule (2) ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at') + subgoal + by (auto simp: typ_heap_simps cnotification_relation_def + Let_def tcb_queue_relation'_def projectKOs + invs_valid_objs' valid_objs'_maxDomain valid_objs'_maxPriority + intro!: obj_at_conj') apply (clarsimp simp: guard_is_UNIV_def) apply (wp getNotification_wp) apply clarsimp @@ -549,16 +683,16 @@ lemma tcb_queue_relation2_cong: context kernel_m begin -lemma setThreadState_ccorres_valid_queues'_simple: - "ccorres dc xfdc (\s. tcb_at' thread s \ valid_queues' s \ \ runnable' st \ sch_act_simple s) +lemma setThreadState_ccorres_simple: + "ccorres dc xfdc (\s. tcb_at' thread s \ \ runnable' st \ sch_act_simple s) ({s'. (\cl fl. cthread_state_relation_lifted st (cl\tsType_CL := ts_' s' && mask 4\, fl))} \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) [] (setThreadState st thread) (Call setThreadState_'proc)" apply (cinit lift: tptr_' cong add: call_ignore_cong) apply (ctac (no_vcg) add: threadSet_tcbState_simple_corres) apply (ctac add: scheduleTCB_ccorres_valid_queues'_simple) - apply (wp threadSet_valid_queues'_and_not_runnable') - apply (clarsimp simp: weak_sch_act_wf_def valid_queues'_def) + apply (wp threadSet_tcbState_st_tcb_at') + apply (fastforce simp: weak_sch_act_wf_def) done lemma updateRestartPC_ccorres: @@ -574,9 +708,7 @@ lemma updateRestartPC_ccorres: done crunches updateRestartPC - for valid_queues'[wp]: valid_queues' - and sch_act_simple[wp]: sch_act_simple - and valid_queues[wp]: Invariants_H.valid_queues + for sch_act_simple[wp]: sch_act_simple and valid_objs'[wp]: valid_objs' and tcb_at'[wp]: "tcb_at' p" @@ -620,21 +752,12 @@ lemma suspend_ccorres: apply (ctac (no_vcg) add: updateRestartPC_ccorres) apply (rule ccorres_return_Skip) apply ceqv - apply (ctac(no_vcg) add: setThreadState_ccorres_valid_queues'_simple) - apply (ctac add: tcbSchedDequeue_ccorres') - apply (rule_tac Q="\_. - (\s. \t' d p. (t' \ set (ksReadyQueues s (d, p)) \ - obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d - \ tcbPriority tcb = p) t' s \ - (t' \ thread \ st_tcb_at' runnable' t' s)) \ - distinct (ksReadyQueues s (d, p))) and valid_queues' and valid_objs' and tcb_at' thread" - in hoare_post_imp) + apply (ctac(no_vcg) add: setThreadState_ccorres_simple) + apply (ctac add: tcbSchedDequeue_ccorres) + apply (rule_tac Q="\_. valid_objs' and tcb_at' thread and pspace_aligned' and pspace_distinct'" + in hoare_post_imp) apply clarsimp - apply (drule_tac x="t" in spec) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp elim!: obj_at'_weakenE simp: inQ_def) - apply (wp sts_valid_queues_partial)[1] + apply (wp sts_valid_objs')[1] apply clarsimp apply (wpsimp simp: valid_tcb_state'_def) apply clarsimp @@ -643,15 +766,13 @@ lemma suspend_ccorres: apply clarsimp apply (rule conseqPre, vcg) apply (rule subset_refl) - apply (rule hoare_strengthen_post) + apply (rule hoare_strengthen_post) apply (rule hoare_vcg_conj_lift) apply (rule hoare_vcg_conj_lift) apply (rule cancelIPC_sch_act_simple) apply (rule cancelIPC_tcb_at'[where t=thread]) apply (rule delete_one_conc_fr.cancelIPC_invs) - apply (fastforce simp: invs_valid_queues' invs_queues invs_valid_objs' - valid_tcb_state'_def) - apply clarsimp + apply (fastforce simp: invs_valid_objs' valid_tcb_state'_def) apply (auto simp: ThreadState_defs) done @@ -1724,23 +1845,6 @@ lemma ep_queue_relation_shift2: apply (clarsimp split: option.split_asm) done -lemma sched_queue_relation_shift: - "(option_map2 tcbSchedNext_C (f (cslift s)) - = option_map2 tcbSchedNext_C (cslift s) - \ option_map2 tcbSchedPrev_C (f (cslift s)) - = option_map2 tcbSchedPrev_C (cslift s)) - \ sched_queue_relation (f (cslift s)) ts qPrev qHead - = sched_queue_relation (cslift s) ts qPrev qHead" - apply clarsimp - apply (induct ts arbitrary: qPrev qHead) - apply simp - apply simp - apply (simp add: option_map2_def fun_eq_iff - map_option_case) - apply (drule_tac x=qHead in spec)+ - apply (clarsimp split: option.split_asm) - done - lemma cendpoint_relation_udpate_arch: "\ cslift x p = Some tcb ; cendpoint_relation (cslift x) v v' \ \ cendpoint_relation ((cslift x)(p \ tcbArch_C_update f tcb)) v v'" @@ -1787,10 +1891,7 @@ lemma archThreadSet_tcbVCPU_Basic_ccorres: apply clarsimp apply (rule cmap_relation_rel_upd[OF _ cendpoint_relation_udpate_arch], simp+) apply (rule cmap_relation_rel_upd[OF _ cnotification_relation_udpate_arch], simp+) - apply (clarsimp simp add: cready_queues_relation_def Let_def tcb_queue_relation'_def) - apply (subst sched_queue_relation_shift; simp add: fun_eq_iff) - apply (safe ; case_tac "xa = tcb_ptr_to_ctcb_ptr tptr" ; clarsimp simp: option_map2_def map_option_case) - apply (clarsimp simp: cvariable_relation_upd_const) + apply (clarsimp simp: cvariable_relation_upd_const) done lemma setObject_vcpuTCB_updated_Basic_ccorres: diff --git a/proof/crefine/ARM_HYP/Interrupt_C.thy b/proof/crefine/ARM_HYP/Interrupt_C.thy index 5adca7f4ad..1befc2efcc 100644 --- a/proof/crefine/ARM_HYP/Interrupt_C.thy +++ b/proof/crefine/ARM_HYP/Interrupt_C.thy @@ -257,7 +257,7 @@ lemma decodeIRQHandlerInvocation_ccorres: apply (simp add: syscall_error_to_H_cases) apply simp apply (clarsimp simp: Collect_const_mem tcb_at_invs') - apply (clarsimp simp: invs_queues invs_valid_objs' + apply (clarsimp simp: invs_valid_objs' ct_in_state'_def ccap_rights_relation_def mask_def[where n=4] ThreadState_defs) @@ -273,7 +273,7 @@ lemma decodeIRQHandlerInvocation_ccorres: excaps_map_def excaps_in_mem_def word_less_nat_alt hd_conv_nth slotcap_in_mem_def valid_tcb_state'_def dest!: interpret_excaps_eq split: bool.splits)+ - apply (auto dest: st_tcb_at_idle_thread' ctes_of_valid')[4] + apply (auto dest: st_tcb_at_idle_thread' ctes_of_valid')[6] apply (drule ctes_of_valid') apply fastforce apply (clarsimp simp add:valid_cap_simps' ARM_HYP.maxIRQ_def) diff --git a/proof/crefine/ARM_HYP/Invoke_C.thy b/proof/crefine/ARM_HYP/Invoke_C.thy index 53a670fcc8..76797adaa9 100644 --- a/proof/crefine/ARM_HYP/Invoke_C.thy +++ b/proof/crefine/ARM_HYP/Invoke_C.thy @@ -79,15 +79,14 @@ lemma setDomain_ccorres: and (\s. curThread = ksCurThread s)" in hoare_strengthen_post) apply (wp threadSet_all_invs_but_sch_extra) - apply (clarsimp simp: valid_pspace_valid_objs' st_tcb_at_def[symmetric] - sch_act_simple_def st_tcb_at'_def weak_sch_act_wf_def - split: if_splits) + apply (fastforce simp: valid_pspace_valid_objs' st_tcb_at_def[symmetric] + sch_act_simple_def st_tcb_at'_def weak_sch_act_wf_def + split: if_splits) apply (simp add: guard_is_UNIV_def) - apply (rule_tac Q="\_. invs' and tcb_at' t and sch_act_simple - and (\s. curThread = ksCurThread s \ (\p. t \ set (ksReadyQueues s p)))" + apply (rule_tac Q="\_. invs' and tcb_at' t and sch_act_simple and (\s. curThread = ksCurThread s)" in hoare_strengthen_post) apply (wp weak_sch_act_wf_lift_linear tcbSchedDequeue_not_queued - tcbSchedDequeue_not_in_queue hoare_vcg_imp_lift hoare_vcg_all_lift) + hoare_vcg_imp_lift hoare_vcg_all_lift) apply (clarsimp simp: invs'_def valid_pspace'_def valid_state'_def) apply (fastforce simp: valid_tcb'_def tcb_cte_cases_def invs'_def valid_state'_def valid_pspace'_def) @@ -195,8 +194,8 @@ lemma decodeDomainInvocation_ccorres: apply clarsimp apply (vcg exspec=getSyscallArg_modifies) - apply (clarsimp simp: valid_tcb_state'_def invs_valid_queues' invs_valid_objs' - invs_queues invs_sch_act_wf' ct_in_state'_def pred_tcb_at' + apply (clarsimp simp: valid_tcb_state'_def invs_valid_objs' + invs_sch_act_wf' ct_in_state'_def pred_tcb_at' rf_sr_ksCurThread word_sle_def word_sless_def sysargs_rel_to_n mask_eq_iff_w2p mask_eq_iff_w2p word_size ThreadState_defs) apply (rule conjI) @@ -206,7 +205,7 @@ lemma decodeDomainInvocation_ccorres: apply (drule_tac x="extraCaps ! 0" and P="\v. valid_cap' (fst v) s" in bspec) apply (clarsimp simp: nth_mem interpret_excaps_test_null excaps_map_def) apply (clarsimp simp: valid_cap_simps' pred_tcb'_weakenE active_runnable') - apply (rule conjI) + apply (intro conjI; fastforce?) apply (fastforce simp: tcb_st_refs_of'_def elim:pred_tcb'_weakenE) apply (simp add: word_le_nat_alt unat_ucast unat_numDomains_to_H le_maxDomain_eq_less_numDomains) apply (clarsimp simp: ccap_relation_def cap_to_H_simps cap_thread_cap_lift) @@ -768,15 +767,15 @@ lemma decodeCNodeInvocation_ccorres: apply simp apply (wp injection_wp_E[OF refl]) apply (rule hoare_post_imp_R) - apply (rule_tac Q'="\rv. valid_pspace' and valid_queues + apply (rule_tac Q'="\rv. valid_pspace' and valid_cap' rv and valid_objs' and tcb_at' thread and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_vcg_R_conj) apply (rule deriveCap_Null_helper[OF deriveCap_derived]) apply wp apply (clarsimp simp: cte_wp_at_ctes_of) - apply (simp add: is_derived'_def badge_derived'_def - valid_tcb_state'_def) + apply (fastforce simp: is_derived'_def badge_derived'_def + valid_tcb_state'_def) apply (simp add: Collect_const_mem all_ex_eq_helper) apply (vcg exspec=deriveCap_modifies) apply wp @@ -844,14 +843,14 @@ lemma decodeCNodeInvocation_ccorres: apply (simp add: conj_comms valid_tcb_state'_def) apply (wp injection_wp_E[OF refl]) apply (rule hoare_post_imp_R) - apply (rule_tac Q'="\rv. valid_pspace' and valid_queues + apply (rule_tac Q'="\rv. valid_pspace' and valid_cap' rv and valid_objs' and tcb_at' thread and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_vcg_R_conj) apply (rule deriveCap_Null_helper [OF deriveCap_derived]) apply wp apply (clarsimp simp: cte_wp_at_ctes_of) - apply (simp add: is_derived'_def badge_derived'_def) + apply (fastforce simp: is_derived'_def badge_derived'_def) apply (simp add: Collect_const_mem all_ex_eq_helper) apply (vcg exspec=deriveCap_modifies) apply (simp add: Collect_const_mem) @@ -959,12 +958,14 @@ lemma decodeCNodeInvocation_ccorres: apply (rule_tac Q'="\a b. cte_wp_at' (\x. True) a b \ invs' b \ tcb_at' thread b \ sch_act_wf (ksSchedulerAction b) b \ valid_tcb_state' Restart b \ Q2 b" for Q2 in hoare_post_imp_R) - prefer 2 - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (drule ctes_of_valid') - apply (erule invs_valid_objs') - apply (clarsimp simp:valid_updateCapDataI invs_queues invs_valid_objs' invs_valid_pspace') - apply (assumption) + prefer 2 + apply (clarsimp simp:cte_wp_at_ctes_of) + apply (drule ctes_of_valid') + apply (erule invs_valid_objs') + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (clarsimp simp:valid_updateCapDataI invs_valid_objs' invs_valid_pspace') + apply assumption apply (wp hoare_vcg_all_lift_R injection_wp_E[OF refl] lsfco_cte_at' hoare_vcg_const_imp_lift_R )+ @@ -1359,7 +1360,7 @@ lemma decodeCNodeInvocation_ccorres: apply simp apply (vcg exspec=getSyscallArg_modifies) apply (clarsimp simp: valid_tcb_state'_def invs_valid_objs' invs_valid_pspace' - ct_in_state'_def pred_tcb_at' invs_queues + ct_in_state'_def pred_tcb_at' cur_tcb'_def word_sle_def word_sless_def unat_lt2p[where 'a=32, folded word_bits_def]) apply (rule conjI) @@ -1391,9 +1392,6 @@ end context begin interpretation Arch . (*FIXME: arch_split*) -crunch valid_queues[wp]: insertNewCap "valid_queues" - (wp: crunch_wps) - lemmas setCTE_def3 = setCTE_def2[THEN eq_reflection] lemma setCTE_sch_act_wf[wp]: @@ -3310,8 +3308,7 @@ lemma decodeUntypedInvocation_ccorres_helper: | Some n \ args ! 4 + args ! 5 - 1 < 2 ^ n) and sch_act_simple and ct_active'" in hoare_post_imp_R) prefer 2 - apply (clarsimp simp: invs_valid_objs' invs_mdb' - invs_queues ct_in_state'_def pred_tcb_at') + apply (clarsimp simp: invs_valid_objs' invs_mdb' ct_in_state'_def pred_tcb_at') apply (subgoal_tac "ksCurThread s \ ksIdleThread sa") prefer 2 apply clarsimp diff --git a/proof/crefine/ARM_HYP/IpcCancel_C.thy b/proof/crefine/ARM_HYP/IpcCancel_C.thy index c9b6048513..78d4b3fe8b 100644 --- a/proof/crefine/ARM_HYP/IpcCancel_C.thy +++ b/proof/crefine/ARM_HYP/IpcCancel_C.thy @@ -15,12 +15,12 @@ begin declare ctcb_size_bits_ge_4[simp] lemma cready_queues_index_to_C_in_range': - assumes prems: "qdom \ ucast maxDom" "prio \ ucast maxPrio" + assumes prems: "qdom \ maxDomain" "prio \ maxPriority" shows "cready_queues_index_to_C qdom prio < num_tcb_queues" proof - have P: "unat prio < numPriorities" using prems - by (simp add: numPriorities_def seL4_MaxPrio_def Suc_le_lessD unat_le_helper) + by (simp add: numPriorities_def Suc_le_lessD unat_le_helper maxDomain_def maxPriority_def) have Q: "unat qdom < numDomains" using prems by (simp add: maxDom_to_H le_maxDomain_eq_less_numDomains word_le_nat_alt) @@ -34,56 +34,18 @@ lemmas cready_queues_index_to_C_in_range = lemma cready_queues_index_to_C_inj: "\ cready_queues_index_to_C qdom prio = cready_queues_index_to_C qdom' prio'; - prio \ ucast maxPrio; prio' \ ucast maxPrio \ \ prio = prio' \ qdom = qdom'" + prio \ maxPriority; prio' \ maxPriority \ \ prio = prio' \ qdom = qdom'" apply (rule context_conjI) - apply (auto simp: cready_queues_index_to_C_def numPriorities_def + apply (auto simp: cready_queues_index_to_C_def numPriorities_def maxPriority_def seL4_MaxPrio_def word_le_nat_alt dest: arg_cong[where f="\x. x mod 256"]) done lemma cready_queues_index_to_C_distinct: - "\ qdom = qdom' \ prio \ prio'; prio \ ucast maxPrio; prio' \ ucast maxPrio \ + "\ qdom = qdom' \ prio \ prio'; prio \ maxPriority; prio' \ maxPriority \ \ cready_queues_index_to_C qdom prio \ cready_queues_index_to_C qdom' prio'" apply (auto simp: cready_queues_index_to_C_inj) done -lemma cstate_relation_ksReadyQueues_update: - "\ cstate_relation hs cs; arr = ksReadyQueues_' cs; - sched_queue_relation' (clift (t_hrs_' cs)) v (head_C v') (end_C v'); - qdom \ ucast maxDom; prio \ ucast maxPrio \ - \ cstate_relation (ksReadyQueues_update (\qs. qs ((qdom, prio) := v)) hs) - (ksReadyQueues_'_update (\_. Arrays.update arr - (cready_queues_index_to_C qdom prio) v') cs)" - apply (clarsimp simp: cstate_relation_def Let_def - cmachine_state_relation_def - carch_state_relation_def carch_globals_def - cready_queues_relation_def seL4_MinPrio_def minDom_def) - apply (frule cready_queues_index_to_C_in_range, assumption) - apply clarsimp - apply (frule_tac qdom=qdoma and prio=prioa in cready_queues_index_to_C_in_range, assumption) - apply (frule cready_queues_index_to_C_distinct, assumption+) - apply clarsimp - done - -lemma cmap_relation_drop_fun_upd: - "\ cm x = Some v; \v''. rel v'' v = rel v'' v' \ - \ cmap_relation am (cm (x \ v')) f rel - = cmap_relation am cm f rel" - apply (simp add: cmap_relation_def) - apply (rule conj_cong[OF refl]) - apply (rule ball_cong[OF refl]) - apply (auto split: if_split) - done - -lemma valid_queuesD': - "\ obj_at' (inQ d p) t s; valid_queues' s \ - \ t \ set (ksReadyQueues s (d, p))" - by (simp add: valid_queues'_def) - -lemma invs_valid_queues'[elim!]: - "invs' s \ valid_queues' s" - by (simp add: invs'_def valid_state'_def) - - lemma ntfn_ptr_get_queue_spec: "\s. \ \ {\. s = \ \ \ \\<^sub>c \<^bsup>\\<^esup>ntfnPtr} \ret__struct_tcb_queue_C :== PROC ntfn_ptr_get_queue(\ntfnPtr) \head_C \ret__struct_tcb_queue_C = Ptr (ntfnQueue_head_CL (notification_lift (the (cslift s \<^bsup>s\<^esup>ntfnPtr)))) \ @@ -229,22 +191,19 @@ lemma cancelSignal_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) apply simp - apply (erule (1) map_to_ko_atI') - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) - apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def) - apply (simp add: carch_state_relation_def carch_globals_def) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (erule (1) map_to_ko_atI') + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) + apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def) + apply (simp add: carch_state_relation_def carch_globals_def) apply (simp add: carch_state_relation_def carch_globals_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) @@ -267,30 +226,27 @@ lemma cancelSignal_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_ntfn_queue) - apply fastforce - apply assumption+ - apply simp - apply (erule (1) map_to_ko_atI') - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) - apply (simp add: cnotification_relation_def Let_def isWaitingNtfn_def - split: ntfn.splits split del: if_split) - apply (erule iffD1 [OF tcb_queue_relation'_cong [OF refl _ _ refl], rotated -1]) - apply (clarsimp simp add: Ptr_ptr_val h_t_valid_clift_Some_iff) - apply (simp add: tcb_queue_relation'_next_mask) - apply (clarsimp simp add: Ptr_ptr_val h_t_valid_clift_Some_iff) - apply (simp add: tcb_queue_relation'_prev_mask) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cendpoint_relation_ntfn_queue) + apply fastforce + apply assumption+ apply simp - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (erule (1) map_to_ko_atI') + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) + apply (simp add: cnotification_relation_def Let_def isWaitingNtfn_def + split: ntfn.splits split del: if_split) + apply (erule iffD1 [OF tcb_queue_relation'_cong [OF refl _ _ refl], rotated -1]) + apply (clarsimp simp add: Ptr_ptr_val h_t_valid_clift_Some_iff) + apply (simp add: tcb_queue_relation'_next_mask) + apply (clarsimp simp add: Ptr_ptr_val h_t_valid_clift_Some_iff) + apply (simp add: tcb_queue_relation'_prev_mask) + apply simp apply (simp add: carch_state_relation_def carch_globals_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) @@ -458,68 +414,6 @@ lemma isRunnable_ccorres [corres]: apply (simp add: ThreadState_defs)+ done - - -lemma tcb_queue_relation_update_head: - fixes getNext_update :: "(tcb_C ptr \ tcb_C ptr) \ tcb_C \ tcb_C" and - getPrev_update :: "(tcb_C ptr \ tcb_C ptr) \ tcb_C \ tcb_C" - assumes qr: "tcb_queue_relation getNext getPrev mp queue NULL qhead" - and qh': "qhead' \ tcb_ptr_to_ctcb_ptr ` set queue" - and cs_tcb: "mp qhead' = Some tcb" - and valid_ep: "\t\set queue. tcb_at' t s" "distinct queue" - and qhN: "qhead' \ NULL" - and fgN: "fg_cons getNext (getNext_update \ (\x _. x))" - and fgP: "fg_cons getPrev (getPrev_update \ (\x _. x))" - and npu: "\f t. getNext (getPrev_update f t) = getNext t" - and pnu: "\f t. getPrev (getNext_update f t) = getPrev t" - shows "tcb_queue_relation getNext getPrev - (upd_unless_null qhead (getPrev_update (\_. qhead') (the (mp qhead))) - (mp(qhead' := Some (getPrev_update (\_. NULL) (getNext_update (\_. qhead) tcb))))) - (ctcb_ptr_to_tcb_ptr qhead' # queue) NULL qhead'" - using qr qh' cs_tcb valid_ep qhN - apply (subgoal_tac "qhead \ qhead'") - apply (clarsimp simp: pnu upd_unless_null_def fg_consD1 [OF fgN] fg_consD1 [OF fgP] pnu npu) - apply (cases queue) - apply simp - apply (frule (2) tcb_queue_relation_next_not_NULL) - apply simp - apply (clarsimp simp: fg_consD1 [OF fgN] fg_consD1 [OF fgP] pnu npu) - apply (subst tcb_queue_relation_cong [OF refl refl refl, where mp' = mp]) - apply (clarsimp simp: inj_eq) - apply (intro impI conjI) - apply (frule_tac x = x in imageI [where f = tcb_ptr_to_ctcb_ptr]) - apply simp - apply simp - apply simp - apply clarsimp - apply (cases queue) - apply simp - apply simp - done - -lemma tcbSchedEnqueue_update: - assumes sr: "sched_queue_relation' mp queue qhead qend" - and qh': "qhead' \ tcb_ptr_to_ctcb_ptr ` set queue" - and cs_tcb: "mp qhead' = Some tcb" - and valid_ep: "\t\set queue. tcb_at' t s" "distinct queue" - and qhN: "qhead' \ NULL" - shows - "sched_queue_relation' - (upd_unless_null qhead (tcbSchedPrev_C_update (\_. qhead') (the (mp qhead))) - (mp(qhead' \ tcb\tcbSchedNext_C := qhead, tcbSchedPrev_C := NULL\))) - (ctcb_ptr_to_tcb_ptr qhead' # queue) qhead' (if qend = NULL then qhead' else qend)" - using sr qh' cs_tcb valid_ep qhN - apply - - apply (erule tcb_queue_relationE') - apply (rule tcb_queue_relationI') - apply (erule (5) tcb_queue_relation_update_head - [where getNext_update = tcbSchedNext_C_update and getPrev_update = tcbSchedPrev_C_update], simp_all)[1] - apply simp - apply (intro impI) - apply (erule (1) tcb_queue_relation_not_NULL') - apply simp - done - lemma tcb_ptr_to_ctcb_ptr_imageD: "x \ tcb_ptr_to_ctcb_ptr ` S \ ctcb_ptr_to_tcb_ptr x \ S" apply (erule imageE) @@ -532,94 +426,8 @@ lemma ctcb_ptr_to_tcb_ptr_imageI: apply simp done -lemma tcb_queue'_head_end_NULL: - assumes qr: "tcb_queue_relation' getNext getPrev mp queue qhead qend" - and tat: "\t\set queue. tcb_at' t s" - shows "(qend = NULL) = (qhead = NULL)" - using qr tat - apply - - apply (erule tcb_queue_relationE') - apply (simp add: tcb_queue_head_empty_iff) - apply (rule impI) - apply (rule tcb_at_not_NULL) - apply (erule bspec) - apply simp - done - -lemma tcb_queue_relation_qhead_mem: - "\ tcb_queue_relation getNext getPrev mp queue NULL qhead; - (\tcb\set queue. tcb_at' tcb t) \ - \ qhead \ NULL \ ctcb_ptr_to_tcb_ptr qhead \ set queue" - by (clarsimp simp: tcb_queue_head_empty_iff tcb_queue_relation_head_hd) - -lemma tcb_queue_relation_qhead_valid: - "\ tcb_queue_relation getNext getPrev (cslift s') queue NULL qhead; - (s, s') \ rf_sr; (\tcb\set queue. tcb_at' tcb s) \ - \ qhead \ NULL \ s' \\<^sub>c qhead" - apply (frule (1) tcb_queue_relation_qhead_mem) - apply clarsimp - apply(drule (3) tcb_queue_memberD) - apply (simp add: h_t_valid_clift_Some_iff) - done - -lemmas tcb_queue_relation_qhead_mem' = tcb_queue_relation_qhead_mem [OF tcb_queue_relation'_queue_rel] -lemmas tcb_queue_relation_qhead_valid' = tcb_queue_relation_qhead_valid [OF tcb_queue_relation'_queue_rel] - - -lemma valid_queues_valid_q: - "valid_queues s \ (\tcb\set (ksReadyQueues s (qdom, prio)). tcb_at' tcb s) \ distinct (ksReadyQueues s (qdom, prio))" - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def) - apply (drule spec [where x = qdom]) - apply (drule spec [where x = prio]) - apply clarsimp - apply (drule (1) bspec, erule obj_at'_weakenE) - apply simp - done - -lemma invs_valid_q: - "invs' s \ (\tcb\set (ksReadyQueues s (qdom, prio)). tcb_at' tcb s) \ distinct (ksReadyQueues s (qdom, prio))" - apply (rule valid_queues_valid_q) - apply (clarsimp simp: invs'_def valid_state'_def) - done - -lemma tcbQueued_not_in_queues: - assumes vq: "valid_queues s" - and objat: "obj_at' (Not \ tcbQueued) thread s" - shows "thread \ set (ksReadyQueues s (d, p))" - using vq objat - apply - - apply clarsimp - apply (drule (1) valid_queues_obj_at'D) - apply (erule obj_atE')+ - apply (clarsimp simp: inQ_def) - done - declare unat_ucast_8_32[simp] -lemma rf_sr_sched_queue_relation: - "\ (s, s') \ rf_sr; d \ ucast maxDom; p \ ucast maxPrio \ - \ sched_queue_relation' (cslift s') (ksReadyQueues s (d, p)) - (head_C (index (ksReadyQueues_' (globals s')) - (cready_queues_index_to_C d p))) - (end_C (index (ksReadyQueues_' (globals s')) - (cready_queues_index_to_C d p)))" - unfolding rf_sr_def cstate_relation_def cready_queues_relation_def - apply (clarsimp simp: Let_def seL4_MinPrio_def minDom_def) - done - -lemma ready_queue_not_in: - assumes vq: "valid_queues s" - and inq: "t \ set (ksReadyQueues s (d, p))" - and neq: "d \ d' \ p \ p'" - shows "t \ set (ksReadyQueues s (d', p'))" -proof - assume "t \ set (ksReadyQueues s (d', p'))" - hence "obj_at' (inQ d' p') t s" using vq by (rule valid_queues_obj_at'D) - moreover have "obj_at' (inQ d p) t s" using inq vq by (rule valid_queues_obj_at'D) - ultimately show False using neq - by (clarsimp elim!: obj_atE' simp: inQ_def) -qed - lemma ctcb_relation_unat_prio_eq: "ctcb_relation tcb tcb' \ unat (tcbPriority tcb) = unat (tcbPriority_C tcb')" apply (clarsimp simp: ctcb_relation_def) @@ -653,139 +461,6 @@ lemma threadSet_queued_ccorres [corres]: apply (clarsimp simp: typ_heap_simps) done -lemma ccorres_pre_getQueue: - assumes cc: "\queue. ccorres r xf (P queue) (P' queue) hs (f queue) c" - shows "ccorres r xf (\s. P (ksReadyQueues s (d, p)) s \ d \ maxDomain \ p \ maxPriority) - {s'. \queue. (let cqueue = index (ksReadyQueues_' (globals s')) - (cready_queues_index_to_C d p) in - sched_queue_relation' (cslift s') queue (head_C cqueue) (end_C cqueue)) \ s' \ P' queue} - hs (getQueue d p >>= (\queue. f queue)) c" - apply (rule ccorres_guard_imp2) - apply (rule ccorres_symb_exec_l2) - defer - defer - apply (rule gq_sp) - defer - apply (rule ccorres_guard_imp) - apply (rule cc) - apply clarsimp - apply assumption - apply assumption - apply (clarsimp simp: getQueue_def gets_exs_valid) - apply clarsimp - apply (drule spec, erule mp) - apply (simp add: Let_def) - apply (erule rf_sr_sched_queue_relation) - apply (simp add: maxDom_to_H maxPrio_to_H)+ - done - -lemma state_relation_queue_update_helper': - "\ (s, s') \ rf_sr; - (\d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct (ksReadyQueues s (d, p))); - globals t = ksReadyQueues_'_update - (\_. Arrays.update (ksReadyQueues_' (globals s')) prio' q') - (t_hrs_'_update f (globals s')); - sched_queue_relation' (cslift t) q (head_C q') (end_C q'); - cslift t |` ( - tcb_ptr_to_ctcb_ptr ` S ) - = cslift s' |` ( - tcb_ptr_to_ctcb_ptr ` S ); - option_map tcb_null_sched_ptrs \ cslift t - = option_map tcb_null_sched_ptrs \ cslift s'; - cslift_all_but_tcb_C t s'; - zero_ranges_are_zero (gsUntypedZeroRanges s) (f (t_hrs_' (globals s'))) - = zero_ranges_are_zero (gsUntypedZeroRanges s) (t_hrs_' (globals s')); - hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s')); - prio' = cready_queues_index_to_C qdom prio; - \x \ S. obj_at' (inQ qdom prio) x s - \ (obj_at' (\tcb. tcbPriority tcb = prio) x s - \ obj_at' (\tcb. tcbDomain tcb = qdom) x s) - \ (tcb_at' x s \ (\d' p'. (d' \ qdom \ p' \ prio) - \ x \ set (ksReadyQueues s (d', p')))); - S \ {}; qdom \ ucast maxDom; prio \ ucast maxPrio \ - \ (s \ksReadyQueues := (ksReadyQueues s)((qdom, prio) := q)\, t) \ rf_sr" - apply (subst(asm) disj_imp_rhs) - apply (subst obj_at'_and[symmetric]) - apply (rule disjI1, erule obj_at'_weakenE, simp add: inQ_def) - apply (subst(asm) disj_imp_rhs) - apply (subst(asm) obj_at'_and[symmetric]) - apply (rule conjI, erule obj_at'_weakenE, simp) - apply (rule allI, rule allI) - apply (drule_tac x=d' in spec) - apply (drule_tac x=p' in spec) - apply clarsimp - apply (drule(1) bspec) - apply (clarsimp simp: inQ_def obj_at'_def) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def) - apply (intro conjI) - \ \cpspace_relation\ - apply (erule nonemptyE, drule(1) bspec) - apply (clarsimp simp: cpspace_relation_def) - apply (drule obj_at_ko_at', clarsimp) - apply (rule cmap_relationE1, assumption, - erule ko_at_projectKO_opt) - apply (frule null_sched_queue) - apply (frule null_sched_epD) - apply (intro conjI) - \ \tcb relation\ - apply (drule ctcb_relation_null_queue_ptrs, - simp_all)[1] - \ \endpoint relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (erule cendpoint_relation_upd_tcb_no_queues, simp+) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (erule cnotification_relation_upd_tcb_no_queues, simp+) - \ \ready queues\ - apply (simp add: cready_queues_relation_def Let_def cready_queues_index_to_C_in_range - seL4_MinPrio_def minDom_def) - apply clarsimp - apply (frule cready_queues_index_to_C_distinct, assumption+) - apply (clarsimp simp: cready_queues_index_to_C_in_range all_conj_distrib) - apply (rule iffD1 [OF tcb_queue_relation'_cong[OF refl], rotated -1], - drule spec, drule spec, erule mp, simp+) - apply clarsimp - apply (drule_tac x="tcb_ptr_to_ctcb_ptr x" in fun_cong)+ - apply (clarsimp simp: restrict_map_def - split: if_split_asm) - apply (simp_all add: carch_state_relation_def cmachine_state_relation_def - h_t_valid_clift_Some_iff) - done - -lemma state_relation_queue_update_helper: - "\ (s, s') \ rf_sr; valid_queues s; - globals t = ksReadyQueues_'_update - (\_. Arrays.update (ksReadyQueues_' (globals s')) prio' q') - (t_hrs_'_update f (globals s')); - sched_queue_relation' (cslift t) q (head_C q') (end_C q'); - cslift t |` ( - tcb_ptr_to_ctcb_ptr ` S ) - = cslift s' |` ( - tcb_ptr_to_ctcb_ptr ` S ); - option_map tcb_null_sched_ptrs \ cslift t - = option_map tcb_null_sched_ptrs \ cslift s'; - cslift_all_but_tcb_C t s'; - zero_ranges_are_zero (gsUntypedZeroRanges s) (f (t_hrs_' (globals s'))) - = zero_ranges_are_zero (gsUntypedZeroRanges s) (t_hrs_' (globals s')); - hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s')); - prio' = cready_queues_index_to_C qdom prio; - \x \ S. obj_at' (inQ qdom prio) x s - \ (obj_at' (\tcb. tcbPriority tcb = prio) x s - \ obj_at' (\tcb. tcbDomain tcb = qdom) x s) - \ (tcb_at' x s \ (\d' p'. (d' \ qdom \ p' \ prio) - \ x \ set (ksReadyQueues s (d', p')))); - S \ {}; qdom \ ucast maxDom; prio \ ucast maxPrio \ - \ (s \ksReadyQueues := (ksReadyQueues s)((qdom, prio) := q)\, t) \ rf_sr" - apply (subgoal_tac "\d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct(ksReadyQueues s (d, p))") - apply (erule(5) state_relation_queue_update_helper', simp_all) - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE, clarsimp) - done - (* FIXME: move *) lemma cmap_relation_no_upd: "\ cmap_relation a c f rel; a p = Some ko; rel ko v; inj f \ \ cmap_relation a (c(f p \ v)) f rel" @@ -827,8 +502,8 @@ lemma cready_queues_index_to_C_def2: lemma ready_queues_index_spec: "\s. \ \ {s'. s' = s \ (Kernel_Config.numDomains \ 1 \ dom_' s' = 0)} Call ready_queues_index_'proc - \\ret__unsigned_long = (dom_' s) * 0x100 + (prio_' s)\" - by vcg (simp add: numDomains_sge_1_simp) + \\ret__unsigned_long = (dom_' s) * word_of_nat numPriorities + (prio_' s)\" + by vcg (simp add: numDomains_sge_1_simp numPriorities_def) lemma prio_to_l1index_spec: "\s. \ \ {s} Call prio_to_l1index_'proc @@ -964,15 +639,6 @@ lemma cmachine_state_relation_enqueue_simp: unfolding cmachine_state_relation_def by clarsimp -lemma tcb_queue_relation'_empty_ksReadyQueues: - "\ sched_queue_relation' (cslift x) (q s) NULL NULL ; \t\ set (q s). tcb_at' t s \ \ q s = []" - apply (clarsimp simp add: tcb_queue_relation'_def) - apply (subst (asm) eq_commute) - apply (cases "q s" rule: rev_cases, simp) - apply (clarsimp simp: tcb_at_not_NULL) - done - - lemma invert_prioToL1Index_c_simp: "p \ maxPriority \ @@ -986,13 +652,247 @@ lemma c_invert_assist: "7 - (ucast (p :: priority) >> 5 :: machine_word) < 8" using prio_ucast_shiftr_wordRadix_helper'[simplified wordRadix_def] by - (rule word_less_imp_diff_less, simp_all) +lemma addToBitmap_ccorres: + "ccorres dc xfdc + (K (tdom \ maxDomain \ prio \ maxPriority)) (\\dom = ucast tdom\ \ \\prio = ucast prio\) hs + (addToBitmap tdom prio) (Call addToBitmap_'proc)" + supply prio_and_dom_limit_helpers[simp] invert_prioToL1Index_c_simp[simp] + apply (rule ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (frule maxDomain_le_unat_ucast_explicit) + apply (clarsimp simp: getQueue_def gets_def get_def setQueue_def modify_def + put_def bind_def return_def bitmap_fun_defs) + apply (intro conjI impI allI) + apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def + carch_state_relation_def cmachine_state_relation_def) + apply (rule conjI) + apply (clarsimp intro!: cbitmap_L1_relation_bit_set) + apply (fastforce dest!: cbitmap_L2_relation_bit_set simp: wordRadix_def mask_def) + done + +lemma rf_sr_tcb_update_twice: + "h_t_valid (hrs_htd (hrs2 (globals s') (t_hrs_' (gs2 (globals s'))))) c_guard + (ptr (t_hrs_' (gs2 (globals s'))) (globals s')) + \ ((s, globals_update (\gs. t_hrs_'_update (\ths. + hrs_mem_update (heap_update (ptr ths gs :: tcb_C ptr) (v ths gs)) + (hrs_mem_update (heap_update (ptr ths gs) (v' ths gs)) (hrs2 gs ths))) (gs2 gs)) s') \ rf_sr) + = ((s, globals_update (\gs. t_hrs_'_update (\ths. + hrs_mem_update (heap_update (ptr ths gs) (v ths gs)) (hrs2 gs ths)) (gs2 gs)) s') \ rf_sr)" + by (simp add: rf_sr_def cstate_relation_def Let_def + cpspace_relation_def typ_heap_simps' + carch_state_relation_def cmachine_state_relation_def + packed_heap_update_collapse_hrs) + +lemmas rf_sr_tcb_update_no_queue_gen2 = + rf_sr_obj_update_helper[OF rf_sr_tcb_update_no_queue_gen, simplified] + +lemma tcb_queue_prepend_ccorres: + "ccorres ctcb_queue_relation ret__struct_tcb_queue_C_' + (\s. tcb_at' tcbPtr s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None) + \ (\head. tcbQueueHead queue = Some head \ tcb_at' head s)) + (\ctcb_queue_relation queue \queue\ \ \\tcb = tcb_ptr_to_ctcb_ptr tcbPtr\) hs + (tcbQueuePrepend queue tcbPtr) (Call tcb_queue_prepend_'proc)" + (is "ccorres _ _ ?abs _ _ _ _") + supply if_split[split del] + apply (cinit lift: tcb_') + \ \cinit is not able to lift queue_' because queue_' is later modified in the C program\ + apply (rule_tac xf'=queue_' in ccorres_abstract, ceqv, rename_tac cqueue) + apply (rule_tac P="ctcb_queue_relation queue cqueue" in ccorres_gen_asm2) + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue)" + and R="?abs" + and R'="\\queue = cqueue\" + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + apply ceqv + apply (rule_tac r'=ctcb_queue_relation and xf'=queue_' in ccorres_split_nothrow) + apply (rule_tac Q="?abs" + and Q'="\s'. queue_' s' = cqueue" + in ccorres_cond_both') + apply fastforce + apply clarsimp + apply (rule ccorres_return[where R=\]) + apply (rule conseqPre, vcg) + apply (fastforce simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (rule ccorres_seq_skip'[THEN iffD1]) + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_Guard) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s + \ head_C cqueue = option_to_ctcb_ptr (tcbQueueHead queue)}" + and R="\head_C cqueue = option_to_ctcb_ptr (tcbQueueHead queue)\" + in threadSet_ccorres_lemma4[where P=\ and P'=\]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce intro!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' tcb_cte_cases_def cteSizeBits_def + ctcb_relation_def option_to_ctcb_ptr_def) + apply (clarsimp simp: ctcb_relation_def option_to_ctcb_ptr_def split: if_splits) + apply ceqv + apply simp + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_Guard) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr + \ ko_at' tcb (the (tcbQueueHead queue)) s + \ head_C cqueue = option_to_ctcb_ptr (tcbQueueHead queue)}" + and R="\head_C cqueue = option_to_ctcb_ptr (tcbQueueHead queue)\" + in threadSet_ccorres_lemma4[where P=\ and P'=\]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce intro!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' tcb_cte_cases_def cteSizeBits_def + ctcb_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + apply fastforce + apply ceqv + apply (rule ccorres_return_Skip') + apply wpsimp + apply vcg + apply wpsimp + apply vcg + apply ceqv + apply csymbr + apply (fastforce intro: ccorres_return_C') + apply wpsimp + apply vcg + apply clarsimp + apply (vcg exspec=tcb_queue_empty_modifies) + apply clarsimp + apply (frule (1) tcb_at_h_t_valid) + by (force dest: tcb_at_h_t_valid + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + +lemma tcb_queue_append_ccorres: + "ccorres ctcb_queue_relation ret__struct_tcb_queue_C_' + (\s. tcb_at' tcbPtr s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None) + \ (\head. tcbQueueHead queue = Some head \ tcb_at' head s) + \ (\end. tcbQueueEnd queue = Some end \ tcb_at' end s)) + (\ctcb_queue_relation queue \queue\ \ \\tcb = tcb_ptr_to_ctcb_ptr tcbPtr\) hs + (tcbQueueAppend queue tcbPtr) (Call tcb_queue_append_'proc)" + (is "ccorres _ _ ?abs _ _ _ _") + supply if_split[split del] + apply (cinit lift: tcb_') + \ \cinit is not able to lift queue_' because queue_' is later modified in the C program\ + apply (rule_tac xf'=queue_' in ccorres_abstract, ceqv, rename_tac cqueue) + apply (rule_tac P="ctcb_queue_relation queue cqueue + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None)" + in ccorres_gen_asm2) + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue)" + and R="?abs" + and R'="\\queue = cqueue\" + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + apply ceqv + apply (rule_tac r'=ctcb_queue_relation and xf'=queue_' in ccorres_split_nothrow) + apply (rule_tac Q="?abs" + and Q'="\s'. queue_' s' = cqueue" + in ccorres_cond_both') + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply clarsimp + apply (rule ccorres_return[where R=\]) + apply (rule conseqPre, vcg) + apply (fastforce simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (rule ccorres_seq_skip'[THEN iffD1]) + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_Guard) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s + \ end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd queue)}" + and R="\end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd queue)\" + in threadSet_ccorres_lemma4[where P=\ and P'=\]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce intro!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' tcb_cte_cases_def cteSizeBits_def + ctcb_relation_def option_to_ctcb_ptr_def) + apply (clarsimp simp: ctcb_relation_def option_to_ctcb_ptr_def split: if_splits) + apply ceqv + apply simp + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_Guard) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr + \ ko_at' tcb (the (tcbQueueEnd queue)) s + \ end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd queue)}" + and R="\end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd queue)\" + in threadSet_ccorres_lemma4[where P=\ and P'=\]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce intro!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' tcb_cte_cases_def cteSizeBits_def + ctcb_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + apply fastforce + apply ceqv + apply (rule ccorres_return_Skip') + apply wpsimp + apply vcg + apply wpsimp + apply vcg + apply ceqv + apply csymbr + apply (fastforce intro: ccorres_return_C') + apply wpsimp + apply vcg + apply (vcg exspec=tcb_queue_empty_modifies) + apply clarsimp + apply (frule (1) tcb_at_h_t_valid) + by (force dest: tcb_at_h_t_valid + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + +lemma getQueue_ccorres: + "ccorres ctcb_queue_relation queue_' + (K (tdom \ maxDomain \ prio \ maxPriority)) + \\idx___unsigned_long = word_of_nat (cready_queues_index_to_C tdom prio)\ hs + (getQueue tdom prio) (\queue :== \ksReadyQueues.[unat \idx___unsigned_long])" + apply (rule ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply (clarsimp simp: getQueue_def gets_def get_def bind_def return_def) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def) + apply (frule (1) cready_queues_index_to_C_in_range) + apply (clarsimp simp: unat_of_nat_eq cready_queues_relation_def) + done + +lemma setQueue_ccorres: + "ctcb_queue_relation queue cqueue \ + ccorres dc xfdc + (K (tdom \ maxDomain \ prio \ maxPriority)) + \\idx___unsigned_long = word_of_nat (cready_queues_index_to_C tdom prio)\ hs + (setQueue tdom prio queue) + (Basic (\s. globals_update + (ksReadyQueues_'_update + (\_. Arrays.update (ksReadyQueues_' (globals s)) (unat (idx___unsigned_long_' s)) cqueue)) s))" + apply (rule ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply (clarsimp simp: setQueue_def get_def modify_def put_def bind_def) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def + carch_state_relation_def cmachine_state_relation_def) + apply (frule (1) cready_queues_index_to_C_in_range) + apply (clarsimp simp: unat_of_nat_eq cready_queues_relation_def) + apply (frule cready_queues_index_to_C_distinct, assumption+) + apply (frule_tac qdom=d and prio=p in cready_queues_index_to_C_in_range) + apply fastforce + apply clarsimp + done + +crunch (empty_fail) empty_fail[wp]: isRunnable + lemma tcbSchedEnqueue_ccorres: "ccorres dc xfdc - (valid_queues and tcb_at' t and valid_objs') - (UNIV \ \\tcb = tcb_ptr_to_ctcb_ptr t\) - hs - (tcbSchedEnqueue t) - (Call tcbSchedEnqueue_'proc)" + (tcb_at' t and valid_objs' and pspace_aligned' and pspace_distinct') + \\tcb = tcb_ptr_to_ctcb_ptr t\ hs + (tcbSchedEnqueue t) (Call tcbSchedEnqueue_'proc)" proof - note prio_and_dom_limit_helpers[simp] word_sle_def[simp] maxDom_to_H[simp] maxPrio_to_H[simp] note invert_prioToL1Index_c_simp[simp] @@ -1002,35 +902,13 @@ proof - note word_less_1[simp del] show ?thesis - apply (cinit lift: tcb_') - apply (rule_tac r'="\rv rv'. rv = to_bool rv'" - and xf'="ret__unsigned_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (simp add: when_def unless_def del: Collect_const split del: if_split) - apply (rule ccorres_cond[where R=\]) - apply (simp add: to_bool_def) - apply (rule ccorres_rhs_assoc)+ - apply csymbr - apply csymbr - apply csymbr - apply csymbr - apply (rule_tac r'="\rv rv'. rv' = ucast rv" - and xf'="dom_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (rule_tac r'="\rv rv'. rv' = ucast rv" - and xf'="prio_'" in ccorres_split_nothrow) + apply (cinit lift: tcb_') + apply (rule ccorres_stateAssert)+ + apply (rule ccorres_symb_exec_l) + apply (rule ccorres_assert) + apply (thin_tac runnable) + apply (rule_tac r'="\rv rv'. rv = to_bool rv'" and xf'="ret__unsigned_'" + in ccorres_split_nothrow) apply (rule threadGet_vcg_corres) apply (rule allI, rule conseqPre, vcg) apply clarsimp @@ -1038,237 +916,246 @@ proof - apply (drule spec, drule(1) mp, clarsimp) apply (clarsimp simp: typ_heap_simps ctcb_relation_def) apply ceqv - apply (rule ccorres_rhs_assoc2)+ - apply (simp only: bind_assoc[symmetric]) - apply (rule ccorres_split_nothrow_novcg_dc) - prefer 2 - apply (rule ccorres_move_c_guard_tcb) - apply ctac - prefer 2 - apply (wp, clarsimp, wp+) - apply (rule_tac P="\s. valid_queues s \ (\p. t \ set (ksReadyQueues s p)) - \ (\tcb. ko_at' tcb t s \ tcbDomain tcb =rva - \ tcbPriority tcb = rvb \ valid_tcb' tcb s)" - and P'=UNIV in ccorres_from_vcg) - apply (rule allI, rule conseqPre, vcg) - apply (clarsimp simp: getQueue_def gets_def get_def setQueue_def modify_def - put_def bind_def return_def bitmap_fun_defs null_def) - apply (clarsimp simp: queue_in_range valid_tcb'_def) - apply (rule conjI; clarsimp simp: queue_in_range) - (* queue is empty, set t to be new queue *) - apply (drule (1) obj_at_cslift_tcb) - apply clarsimp - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply (subgoal_tac - "head_C (ksReadyQueues_' - (globals x).[cready_queues_index_to_C (tcbDomain tcb) (tcbPriority tcb)]) = NULL") - prefer 2 - apply (frule_tac s=\ in tcb_queue'_head_end_NULL; simp add: valid_queues_valid_q) - apply (subgoal_tac - "end_C (ksReadyQueues_' - (globals x).[cready_queues_index_to_C (tcbDomain tcb) (tcbPriority tcb)]) = NULL") - prefer 2 - apply (frule_tac s=\ in tcb_queue'_head_end_NULL[symmetric]; simp add: valid_queues_valid_q) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (frule maxDomain_le_unat_ucast_explicit) - apply (clarsimp simp: cready_queues_index_to_C_def numPriorities_def) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (simp add: t_hrs_ksReadyQueues_upd_absorb) - apply (rule conjI) - apply (clarsimp simp: l2BitmapSize_def' wordRadix_def c_invert_assist) - - apply (subst rf_sr_drop_bitmaps_enqueue_helper, assumption) - apply (fastforce intro: cbitmap_L1_relation_bit_set) - apply (fastforce intro: cbitmap_L2_relation_bit_set simp: wordRadix_def mask_def) - - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (drule_tac qhead'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedEnqueue_update, - simp_all add: valid_queues_valid_q)[1] - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - - apply (erule(1) state_relation_queue_update_helper[where S="{t}"], - (simp | rule globals.equality)+, - simp_all add: cready_queues_index_to_C_def2 numPriorities_def - t_hrs_ksReadyQueues_upd_absorb upd_unless_null_def - typ_heap_simps)[1] - apply (fastforce simp: tcb_null_sched_ptrs_def typ_heap_simps c_guard_clift - elim: obj_at'_weaken)+ - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply clarsimp - apply (rule conjI; clarsimp simp: queue_in_range) - (* invalid, disagreement between C and Haskell on emptiness of queue *) - apply (drule (1) obj_at_cslift_tcb) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (clarsimp simp: cready_queues_index_to_C_def numPriorities_def) - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply clarsimp - apply (drule tcb_queue_relation'_empty_ksReadyQueues; simp add: valid_queues_valid_q) - (* queue was not empty, add t to queue and leave bitmaps alone *) - apply (drule (1) obj_at_cslift_tcb) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (clarsimp simp: cready_queues_index_to_C_def numPriorities_def) - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply clarsimp - apply (frule_tac t=\ in tcb_queue_relation_qhead_mem') - apply (simp add: valid_queues_valid_q) - apply (frule(1) tcb_queue_relation_qhead_valid') - apply (simp add: valid_queues_valid_q) - apply (clarsimp simp: typ_heap_simps h_t_valid_clift_Some_iff numPriorities_def - cready_queues_index_to_C_def2) - apply (drule_tac qhead'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedEnqueue_update, - simp_all add: valid_queues_valid_q)[1] - apply clarsimp - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - apply (frule(2) obj_at_cslift_tcb[OF valid_queues_obj_at'D]) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (erule_tac S="{t, v}" for v in state_relation_queue_update_helper, - (simp | rule globals.equality)+, - simp_all add: typ_heap_simps if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 upd_unless_null_def - cong: if_cong split del: if_split - del: fun_upd_restrict_conv)[1] - apply simp - apply (rule conjI) + apply (simp add: when_def unless_def del: Collect_const split del: if_split) + apply (rule ccorres_cond[where R=\]) + apply (simp add: to_bool_def) + apply (rule ccorres_rhs_assoc)+ + apply csymbr + apply csymbr + apply csymbr + apply csymbr + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="dom_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) apply clarsimp - apply (drule_tac s="tcb_ptr_to_ctcb_ptr t" in sym, simp) - apply (clarsimp simp add: fun_upd_twist) - prefer 4 - apply (simp add: obj_at'_weakenE[OF _ TrueI]) - apply (rule disjI1, erule valid_queues_obj_at'D) - apply simp+ - apply (fastforce simp: tcb_null_sched_ptrs_def) - apply (simp add: typ_heap_simps c_guard_clift) - apply (simp add: guard_is_UNIV_def) - apply simp - apply (wp threadGet_wp) - apply vcg - apply simp - apply (wp threadGet_wp) - apply vcg - apply (rule ccorres_return_Skip) - apply simp - apply (wp threadGet_wp) - apply vcg - apply (fastforce simp: valid_objs'_def obj_at'_def ran_def projectKOs typ_at'_def - valid_obj'_def inQ_def - dest!: valid_queues_obj_at'D) - done + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="prio_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule ccorres_rhs_assoc2)+ + apply (simp only: bind_assoc[symmetric]) + apply (rule ccorres_split_nothrow_novcg_dc) + prefer 2 + apply (rule ccorres_move_c_guard_tcb) + apply (simp only: dc_def[symmetric]) + apply ctac + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_symb_exec_r) + apply (rule ccorres_Guard_Seq) + apply (simp add: bind_assoc) + apply (ctac add: getQueue_ccorres) + apply (rename_tac queue cqueue) + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue)" + and R="\s. \ tcbQueueEmpty queue \ tcb_at' (the (tcbQueueHead queue)) s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None)" + and R'="{s'. queue_' s' = cqueue}" + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def + tcbQueueEmpty_def) + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_cond[where R=\]) + apply fastforce + apply (ctac add: addToBitmap_ccorres) + apply (rule ccorres_return_Skip) + apply ceqv + apply (ctac add: tcb_queue_prepend_ccorres) + apply (rule ccorres_Guard) + apply (rule setQueue_ccorres) + apply fastforce + apply wpsimp + apply (vcg exspec=tcb_queue_prepend_modifies) + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift') + apply (vcg exspec=addToBitmap_modifies) + apply vcg + apply wpsimp + apply vcg + apply clarsimp + apply vcg + apply (rule conseqPre, vcg) + apply clarsimp + apply wpsimp + apply (clarsimp simp: guard_is_UNIV_def) + apply (wpsimp wp: threadGet_wp) + apply vcg + apply clarsimp + apply (wpsimp wp: threadGet_wp) + apply vcg + apply (rule ccorres_return_Skip) + apply (wpsimp wp: threadGet_wp) + apply (vcg expsec=thread_state_get_tcbQueued_modifies) + apply wpsimp + apply (wpsimp wp: isRunnable_wp) + apply wpsimp + apply normalise_obj_at' + apply (rename_tac tcb) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (clarsimp simp: valid_tcb'_def) + apply (frule (1) obj_at_cslift_tcb) + apply (rule conjI) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (force dest!: tcbQueueHead_iff_tcbQueueEnd simp: tcbQueueEmpty_def obj_at'_def) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply (rule conjI) + apply (clarsimp simp: maxDomain_def) + apply (cut_tac qdom="tcbDomain tcb" and prio="tcbPriority tcb" + in cready_queues_index_to_C_in_range) + apply fastforce + apply fastforce + apply (clarsimp simp: word_less_nat_alt cready_queues_index_to_C_def2) + done qed -lemmas tcbSchedDequeue_update - = tcbDequeue_update[where tn=tcbSchedNext_C and tn_update=tcbSchedNext_C_update - and tp=tcbSchedPrev_C and tp_update=tcbSchedPrev_C_update, - simplified] - -lemma tcb_queue_relation_prev_next: - "\ tcb_queue_relation tn tp mp queue qprev qhead; - tcbp \ set queue; distinct (ctcb_ptr_to_tcb_ptr qprev # queue); - \t \ set queue. tcb_at' t s; qprev \ tcb_Ptr 0 \ mp qprev \ None; - mp (tcb_ptr_to_ctcb_ptr tcbp) = Some tcb \ - \ (tn tcb \ tcb_Ptr 0 \ tn tcb \ tcb_ptr_to_ctcb_ptr ` set queue - \ mp (tn tcb) \ None \ tn tcb \ tcb_ptr_to_ctcb_ptr tcbp) - \ (tp tcb \ tcb_Ptr 0 \ (tp tcb \ tcb_ptr_to_ctcb_ptr ` set queue - \ tp tcb = qprev) - \ mp (tp tcb) \ None \ tp tcb \ tcb_ptr_to_ctcb_ptr tcbp) - \ (tn tcb \ tcb_Ptr 0 \ tn tcb \ tp tcb)" - apply (induct queue arbitrary: qprev qhead) - apply simp - apply simp - apply (erule disjE) - apply clarsimp - apply (case_tac "queue") - apply clarsimp - apply clarsimp - apply (rule conjI) - apply clarsimp - apply clarsimp - apply (drule_tac f=ctcb_ptr_to_tcb_ptr in arg_cong[where y="tp tcb"], simp) - apply clarsimp - apply fastforce - done - -lemma tcb_queue_relation_prev_next': - "\ tcb_queue_relation' tn tp mp queue qhead qend; tcbp \ set queue; distinct queue; - \t \ set queue. tcb_at' t s; mp (tcb_ptr_to_ctcb_ptr tcbp) = Some tcb \ - \ (tn tcb \ tcb_Ptr 0 \ tn tcb \ tcb_ptr_to_ctcb_ptr ` set queue - \ mp (tn tcb) \ None \ tn tcb \ tcb_ptr_to_ctcb_ptr tcbp) - \ (tp tcb \ tcb_Ptr 0 \ tp tcb \ tcb_ptr_to_ctcb_ptr ` set queue - \ mp (tp tcb) \ None \ tp tcb \ tcb_ptr_to_ctcb_ptr tcbp) - \ (tn tcb \ tcb_Ptr 0 \ tn tcb \ tp tcb)" - apply (clarsimp simp: tcb_queue_relation'_def split: if_split_asm) - apply (drule(1) tcb_queue_relation_prev_next, simp_all) - apply (fastforce dest: tcb_at_not_NULL) - apply clarsimp - done +lemma tcbSchedAppend_ccorres: + "ccorres dc xfdc + (tcb_at' t and valid_objs' and pspace_aligned' and pspace_distinct') + \\tcb = tcb_ptr_to_ctcb_ptr t\ hs + (tcbSchedAppend t) (Call tcbSchedAppend_'proc)" +proof - + note prio_and_dom_limit_helpers[simp] word_sle_def[simp] maxDom_to_H[simp] maxPrio_to_H[simp] + note invert_prioToL1Index_c_simp[simp] -(* L1 bitmap only updated if L2 entry bits end up all zero *) -lemma rf_sr_drop_bitmaps_dequeue_helper_L2: - "\ (\,\') \ rf_sr ; - cbitmap_L2_relation ksqL2upd' ksqL2upd \ - \ -((\\ksReadyQueues := ksqupd, - ksReadyQueuesL2Bitmap := ksqL2upd\, - \'\idx___unsigned_long_' := i', - queue_' := queue_upd', - globals := globals \' - \ksReadyQueuesL2Bitmap_' := ksqL2upd', - ksReadyQueues_' := ksqupd'\\) - \ rf_sr) - = -((\\ksReadyQueues := ksqupd\, - \'\idx___unsigned_long_' := i', - queue_' := queue_upd', - globals := globals \' - \ksReadyQueues_' := ksqupd'\\) \ rf_sr) -" - unfolding rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def - by (clarsimp simp: rf_sr_cbitmap_L1_relation rf_sr_cbitmap_L2_relation) + (* when numDomains = 1, array bounds checks would become _ = 0 rather than _ < 1, changing the + shape of the proof compared to when numDomains > 1 *) + note word_less_1[simp del] -lemma rf_sr_drop_bitmaps_dequeue_helper: - "\ (\,\') \ rf_sr ; - cbitmap_L1_relation ksqL1upd' ksqL1upd ; cbitmap_L2_relation ksqL2upd' ksqL2upd \ - \ -((\\ksReadyQueues := ksqupd, - ksReadyQueuesL2Bitmap := ksqL2upd, - ksReadyQueuesL1Bitmap := ksqL1upd\, - \'\idx___unsigned_long_' := i', - queue_' := queue_upd', - globals := globals \' - \ksReadyQueuesL2Bitmap_' := ksqL2upd', - ksReadyQueuesL1Bitmap_' := ksqL1upd', - ksReadyQueues_' := ksqupd'\\) - \ rf_sr) - = -((\\ksReadyQueues := ksqupd\, - \'\idx___unsigned_long_' := i', - queue_' := queue_upd', - globals := globals \' - \ksReadyQueues_' := ksqupd'\\) \ rf_sr) -" - unfolding rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def - by (clarsimp simp: rf_sr_cbitmap_L1_relation rf_sr_cbitmap_L2_relation) + show ?thesis + apply (cinit lift: tcb_') + apply (rule ccorres_stateAssert)+ + apply (rule ccorres_symb_exec_l) + apply (rule ccorres_assert) + apply (thin_tac "runnable") + apply (rule_tac r'="\rv rv'. rv = to_bool rv'" and xf'="ret__unsigned_'" + in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (simp add: when_def unless_def del: Collect_const split del: if_split) + apply (rule ccorres_cond[where R=\]) + apply (simp add: to_bool_def) + apply (rule ccorres_rhs_assoc)+ + apply csymbr + apply csymbr + apply csymbr + apply csymbr + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="dom_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="prio_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule ccorres_rhs_assoc2)+ + apply (simp only: bind_assoc[symmetric]) + apply (rule ccorres_split_nothrow_novcg_dc) + prefer 2 + apply (rule ccorres_move_c_guard_tcb) + apply (simp only: dc_def[symmetric]) + apply ctac + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_symb_exec_r) + apply (rule ccorres_Guard_Seq) + apply (simp add: bind_assoc) + apply (ctac add: getQueue_ccorres) + apply (rename_tac queue cqueue) + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue)" + and R="\s. \ tcbQueueEmpty queue \ tcb_at' (the (tcbQueueHead queue)) s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None)" + and R'="{s'. queue_' s' = cqueue}" + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def + tcbQueueEmpty_def) + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_cond[where R=\]) + apply (fastforce dest!: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (ctac add: addToBitmap_ccorres) + apply (rule ccorres_return_Skip) + apply ceqv + apply (ctac add: tcb_queue_append_ccorres) + apply (rule ccorres_Guard) + apply (rule setQueue_ccorres) + apply fastforce + apply wpsimp + apply (vcg exspec=tcb_queue_prepend_modifies) + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift') + apply (vcg exspec=addToBitmap_modifies) + apply vcg + apply wpsimp + apply vcg + apply clarsimp + apply vcg + apply (rule conseqPre, vcg) + apply clarsimp + apply wpsimp + apply (clarsimp simp: guard_is_UNIV_def) + apply (wpsimp wp: threadGet_wp) + apply vcg + apply clarsimp + apply (wpsimp wp: threadGet_wp) + apply clarsimp + apply vcg + apply (rule ccorres_return_Skip) + apply (wpsimp wp: threadGet_wp) + apply (vcg expsec=thread_state_get_tcbQueued_modifies) + apply wpsimp + apply (wpsimp wp: isRunnable_wp) + apply wpsimp + apply normalise_obj_at' + apply (rename_tac tcb) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (clarsimp simp: valid_tcb'_def) + apply (frule (1) obj_at_cslift_tcb) + apply (rule conjI) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (frule (3) obj_at'_tcbQueueEnd_ksReadyQueues) + apply (force dest!: tcbQueueHead_iff_tcbQueueEnd simp: tcbQueueEmpty_def obj_at'_def) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply (rule conjI) + apply (clarsimp simp: maxDomain_def) + apply (cut_tac qdom="tcbDomain tcb" and prio="tcbPriority tcb" + in cready_queues_index_to_C_in_range) + apply fastforce + apply fastforce + apply (clarsimp simp: word_less_nat_alt cready_queues_index_to_C_def2 tcbQueueEmpty_def) + done +qed (* FIXME same proofs as bit_set, maybe can generalise? *) lemma cbitmap_L1_relation_bit_clear: @@ -1285,27 +1172,6 @@ lemma cbitmap_L1_relation_bit_clear: invertL1Index_def l2BitmapSize_def' le_maxDomain_eq_less_numDomains word_le_nat_alt num_domains_index_updates) -lemma cready_queues_relation_empty_queue_helper: - "\ tcbDomain ko \ maxDomain ; tcbPriority ko \ maxPriority ; - cready_queues_relation (cslift \') (ksReadyQueues_' (globals \')) (ksReadyQueues \)\ - \ - cready_queues_relation (cslift \') - (Arrays.update (ksReadyQueues_' (globals \')) (unat (tcbDomain ko) * 256 + unat (tcbPriority ko)) - (tcb_queue_C.end_C_update (\_. NULL) - (head_C_update (\_. NULL) - (ksReadyQueues_' (globals \').[unat (tcbDomain ko) * 256 + unat (tcbPriority ko)])))) - ((ksReadyQueues \)((tcbDomain ko, tcbPriority ko) := []))" - unfolding cready_queues_relation_def Let_def - using maxPrio_to_H[simp] maxDom_to_H[simp] - apply clarsimp - apply (frule (1) cready_queues_index_to_C_in_range[simplified maxDom_to_H maxPrio_to_H]) - apply (fold cready_queues_index_to_C_def[simplified numPriorities_def]) - apply (case_tac "qdom = tcbDomain ko", - simp_all add: prio_and_dom_limit_helpers seL4_MinPrio_def - minDom_def) - apply (fastforce simp: cready_queues_index_to_C_in_range simp: cready_queues_index_to_C_distinct)+ - done - lemma cbitmap_L2_relationD: "\ cbitmap_L2_relation cbitmap2 abitmap2 ; d \ maxDomain ; i < l2BitmapSize \ \ cbitmap2.[unat d].[i] = abitmap2 (d, i)" @@ -1335,64 +1201,301 @@ lemma cbitmap_L2_relation_bit_clear: apply (case_tac "da = d" ; clarsimp simp: num_domains_index_updates) done -lemma tcbSchedDequeue_ccorres': +lemma removeFromBitmap_ccorres: "ccorres dc xfdc - ((\s. \d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct (ksReadyQueues s (d, p))) - and valid_queues' and tcb_at' t and valid_objs') - (UNIV \ \\tcb = tcb_ptr_to_ctcb_ptr t\) - [] - (tcbSchedDequeue t) - (Call tcbSchedDequeue_'proc)" + (K (tdom \ maxDomain \ prio \ maxPriority)) (\\dom = ucast tdom\ \ \\prio = ucast prio\) hs + (removeFromBitmap tdom prio) (Call removeFromBitmap_'proc)" proof - - note prio_and_dom_limit_helpers[simp] word_sle_def[simp] (* when numDomains = 1, array bounds checks would become _ = 0 rather than _ < 1, changing the shape of the proof compared to when numDomains > 1 *) include no_less_1_simps - have ksQ_tcb_at': "\s ko d p. - \d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct (ksReadyQueues s (d, p)) \ - \t\set (ksReadyQueues s (d, p)). tcb_at' t s" - by (fastforce dest: spec elim: obj_at'_weakenE) - - have invert_l1_index_limit: "\p. invertL1Index (prioToL1Index p) < 8" + have invert_l1_index_limit: "\p. invertL1Index (prioToL1Index p) < l2BitmapSize" unfolding invertL1Index_def l2BitmapSize_def' prioToL1Index_def by simp show ?thesis - apply (cinit lift: tcb_') - apply (rule_tac r'="\rv rv'. rv = to_bool rv'" - and xf'="ret__unsigned_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (simp add: when_def - del: Collect_const split del: if_split) - apply (rule ccorres_cond[where R=\]) - apply (simp add: to_bool_def) - apply (rule ccorres_rhs_assoc)+ - apply csymbr - apply csymbr - apply csymbr - apply csymbr - apply (rule_tac r'="\rv rv'. rv' = ucast rv" - and xf'="dom_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) + supply if_split[split del] + (* pull out static assms *) + apply simp + apply (rule ccorres_grab_asm[where P=\, simplified]) + apply (cinit lift: dom_' prio_') + apply clarsimp + apply csymbr + apply csymbr + (* we can clear up all C guards now *) + apply (clarsimp simp: maxDomain_le_unat_ucast_explicit word_and_less') + apply (simp add: invert_prioToL1Index_c_simp word_less_nat_alt) + apply (simp add: invert_l1_index_limit[simplified l2BitmapSize_def']) + apply ccorres_rewrite + (* handle L2 update *) + apply (rule_tac ccorres_split_nothrow_novcg_dc) + apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply (clarsimp simp: simpler_gets_def get_def modify_def + put_def bind_def return_def bitmap_fun_defs) + apply (frule rf_sr_cbitmap_L2_relation) + apply (erule cbitmap_L2_relation_update) + apply (erule (1) cbitmap_L2_relation_bit_clear) + (* the check on the C side is identical to checking the L2 entry, rewrite the condition *) + apply (simp add: getReadyQueuesL2Bitmap_def) + apply (rule ccorres_symb_exec_l3, rename_tac l2) + apply (rule_tac C'="{s. l2 = 0}" + and Q="\s. l2 = ksReadyQueuesL2Bitmap s (tdom, invertL1Index (prioToL1Index prio))" + in ccorres_rewrite_cond_sr[where Q'=UNIV]) + apply clarsimp + apply (frule rf_sr_cbitmap_L2_relation) + apply (clarsimp simp: cbitmap_L2_relationD invert_l1_index_limit split: if_split) + (* unset L1 bit when L2 entry is empty *) + apply (rule ccorres_from_vcg[where P=\ and P'=UNIV]) apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (rule_tac r'="\rv rv'. rv' = ucast rv" - and xf'="prio_'" in ccorres_split_nothrow) + apply (clarsimp simp: simpler_gets_def get_def modify_def + put_def bind_def return_def bitmap_fun_defs) + apply (frule rf_sr_cbitmap_L1_relation) + apply (erule cbitmap_L1_relation_update) + apply (erule (1) cbitmap_L1_relation_bit_clear) + apply wpsimp+ + apply (fastforce simp: guard_is_UNIV_def) + apply clarsimp + done +qed + +lemma ctcb_ptr_to_tcb_ptr_option_to_ctcb_ptr[simp]: + "ctcb_ptr_to_tcb_ptr (option_to_ctcb_ptr (Some ptr)) = ptr" + by (clarsimp simp: option_to_ctcb_ptr_def) + +lemma tcb_queue_remove_ccorres: + "ccorres ctcb_queue_relation ret__struct_tcb_queue_C_' + (\s. tcb_at' tcbPtr s \ valid_objs' s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None)) + (\ctcb_queue_relation queue \queue\ \ \\tcb = tcb_ptr_to_ctcb_ptr tcbPtr\) hs + (tcbQueueRemove queue tcbPtr) (Call tcb_queue_remove_'proc)" + (is "ccorres _ _ ?abs _ _ _ _") + supply if_split[split del] + apply (cinit' lift: tcb_') + apply (rename_tac tcb') + apply (simp only: tcbQueueRemove_def) + \ \cinit is not able to lift queue_' because queue_' is later modified in the C program\ + apply (rule_tac xf'=queue_' in ccorres_abstract, ceqv, rename_tac cqueue) + apply (rule_tac P="ctcb_queue_relation queue cqueue" in ccorres_gen_asm2) + apply (rule ccorres_pre_getObject_tcb, rename_tac tcb) + apply (rule ccorres_symb_exec_l, rename_tac beforePtrOpt) + apply (rule ccorres_symb_exec_l, rename_tac afterPtrOpt) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac xf'="before___ptr_to_struct_tcb_C_'" + and val="option_to_ctcb_ptr beforePtrOpt" + and R="ko_at' tcb tcbPtr and K (tcbSchedPrev tcb = beforePtrOpt)" + and R'=UNIV + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: obj_at_cslift_tcb simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac xf'="after___ptr_to_struct_tcb_C_'" + and val="option_to_ctcb_ptr afterPtrOpt" + and R="ko_at' tcb tcbPtr and K (tcbSchedNext tcb = afterPtrOpt)" + in ccorres_symb_exec_r_known_rv[where R'=UNIV]) + apply (rule conseqPre, vcg) + apply (fastforce dest: obj_at_cslift_tcb simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule ccorres_cond_seq) + apply (rule ccorres_cond[where R="?abs"]) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (rule ccorres_rhs_assoc)+ + apply csymbr + apply csymbr + apply (fastforce intro: ccorres_return_C') + apply (rule ccorres_cond_seq) + apply (rule_tac Q="?abs" and Q'=\ in ccorres_cond_both') + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def split: if_splits) + apply clarsimp + apply (rule ccorres_assert2) + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb)+ + apply (rule_tac P=\ and P'="tcb_at' tcbPtr" + and Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb (the afterPtrOpt) s}" + in threadSet_ccorres_lemma3) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply fastforce + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb[where thread=tcbPtr]) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule ccorres_symb_exec_r) + apply (fastforce intro: ccorres_return_C') + apply vcg + apply (rule conseqPre, vcg) + apply clarsimp + apply wpsimp + apply vcg + apply wpsimp + apply vcg + apply (rule ccorres_cond_seq) + apply (rule_tac Q="?abs" and Q'=\ in ccorres_cond_both') + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def split: if_splits) + apply clarsimp + apply (rule ccorres_assert2) + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb)+ + apply (rule_tac P=\ and P'="tcb_at' tcbPtr" + and Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb (the beforePtrOpt) s}" + in threadSet_ccorres_lemma3) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply fastforce + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb[where thread=tcbPtr]) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule ccorres_symb_exec_r) + apply (fastforce intro: ccorres_return_C') + apply vcg + apply (rule conseqPre, vcg) + apply clarsimp + apply wpsimp + apply vcg + apply wpsimp + apply vcg + apply clarsimp + apply (rule ccorres_assert2)+ + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb)+ + apply (rule_tac Q="\s tcb'. {s'. (s, s') \ rf_sr \ ko_at' tcb' (the beforePtrOpt) s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb)+ + apply (rule_tac P=\ and P'="tcb_at' tcbPtr" + and Q="\s tcb'. {s'. (s, s') \ rf_sr \ ko_at' tcb' (the afterPtrOpt) s}" + in threadSet_ccorres_lemma3) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb[where thread=tcbPtr]) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb[where thread=tcbPtr]) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply fastforce + apply ceqv + apply (fastforce intro: ccorres_return_C') + apply (wpsimp | vcg)+ + apply (clarsimp split: if_splits) + apply normalise_obj_at' + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + by (intro conjI impI; + clarsimp simp: ctcb_queue_relation_def typ_heap_simps option_to_ctcb_ptr_def + valid_tcb'_def valid_bound_tcb'_def) + +lemma tcbQueueRemove_tcb_at'_head: + "\\s. valid_objs' s \ (\head. tcbQueueHead queue = Some head \ tcb_at' head s)\ + tcbQueueRemove queue t + \\rv s. \ tcbQueueEmpty rv \ tcb_at' (the (tcbQueueHead rv)) s\" + unfolding tcbQueueRemove_def + apply (wpsimp wp: getTCB_wp haskell_assert_wp hoare_vcg_imp_lift') + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (fastforce simp: valid_tcb'_def valid_bound_tcb'_def tcbQueueEmpty_def obj_at'_def) + done + +lemma tcbSchedDequeue_ccorres: + "ccorres dc xfdc + (tcb_at' t and valid_objs' and pspace_aligned' and pspace_distinct') + \\tcb = tcb_ptr_to_ctcb_ptr t\ hs + (tcbSchedDequeue t) (Call tcbSchedDequeue_'proc)" +proof - + note prio_and_dom_limit_helpers[simp] word_sle_def[simp] maxDom_to_H[simp] maxPrio_to_H[simp] + note invert_prioToL1Index_c_simp[simp] + + (* when numDomains = 1, array bounds checks would become _ = 0 rather than _ < 1, changing the + shape of the proof compared to when numDomains > 1 *) + note word_less_1[simp del] + + show ?thesis + apply (cinit lift: tcb_') + apply (rule ccorres_stateAssert)+ + apply (rule_tac r'="\rv rv'. rv = to_bool rv'" and xf'="ret__unsigned_'" + in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (simp add: when_def del: Collect_const split del: if_split) + apply (rule ccorres_cond[where R=\]) + apply (simp add: to_bool_def) + apply (rule ccorres_rhs_assoc)+ + apply csymbr + apply csymbr + apply csymbr + apply csymbr + apply csymbr + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="dom_'" in ccorres_split_nothrow) apply (rule threadGet_vcg_corres) apply (rule allI, rule conseqPre, vcg) apply clarsimp @@ -1400,308 +1503,80 @@ proof - apply (drule spec, drule(1) mp, clarsimp) apply (clarsimp simp: typ_heap_simps ctcb_relation_def) apply ceqv - apply (rule ccorres_rhs_assoc2)+ - apply (simp only: bind_assoc[symmetric]) - apply (rule ccorres_split_nothrow_novcg_dc) - prefer 2 - apply (rule ccorres_move_c_guard_tcb) - apply ctac - prefer 2 - apply (wp, clarsimp, wp+) - apply (rule_tac P="(\s. \d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct(ksReadyQueues s (d, p))) - and valid_queues' and obj_at' (inQ rva rvb) t - and (\s. rva \ maxDomain \ rvb \ maxPriority)" - and P'=UNIV in ccorres_from_vcg) - apply (rule allI, rule conseqPre, vcg) - apply (clarsimp simp: getQueue_def gets_def get_def setQueue_def modify_def - put_def bind_def return_def bitmap_fun_defs when_def - null_def) - - apply (rule conjI; clarsimp simp: queue_in_range[simplified maxDom_to_H maxPrio_to_H]) - apply (rule conjI; clarsimp simp: queue_in_range[simplified maxDom_to_H maxPrio_to_H]) - apply (frule(1) valid_queuesD') - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) - apply (fastforce simp: maxDom_to_H maxPrio_to_H)+ - apply (frule_tac s=\ in tcb_queue_relation_prev_next'; (fastforce simp: ksQ_tcb_at')?) - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (intro conjI ; - clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift)+ - apply (drule(2) filter_empty_unfiltered_contr, simp)+ - apply (rule conjI; clarsimp) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (rule conjI; clarsimp) - apply (subst rf_sr_drop_bitmaps_dequeue_helper, assumption) - apply (fastforce intro: cbitmap_L1_relation_bit_clear) - apply (simp add: invert_prioToL1Index_c_simp) - apply (frule rf_sr_cbitmap_L2_relation) - apply (clarsimp simp: cbitmap_L2_relation_def - word_size prioToL1Index_def wordRadix_def mask_def - word_le_nat_alt - numPriorities_def wordBits_def l2BitmapSize_def' - invertL1Index_def numDomains_less_numeric_explicit) - apply (case_tac "d = tcbDomain ko" - ; fastforce simp: le_maxDomain_eq_less_numDomains - numDomains_less_numeric_explicit) - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: maxDom_to_H maxPrio_to_H)+ - - apply (frule_tac s=\ in tcb_queue_relation_prev_next', assumption) - prefer 3 - apply fastforce - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by ((fastforce simp: ksQ_tcb_at')+) - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - (* trivial case, setting queue to empty *) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def carch_state_relation_def - cmachine_state_relation_def) - apply (erule (2) cready_queues_relation_empty_queue_helper) - (* impossible case, C L2 update disagrees with Haskell update *) - apply (simp add: invert_prioToL1Index_c_simp) - apply (subst (asm) num_domains_index_updates) - subgoal by (simp add: le_maxDomain_eq_less_numDomains word_le_nat_alt) - apply (subst (asm) Arrays.index_update) - apply (simp add: invert_l1_index_limit) - - apply (frule rf_sr_cbitmap_L2_relation) - apply (drule_tac i="invertL1Index (prioToL1Index (tcbPriority ko))" - in cbitmap_L2_relationD, assumption) - apply (fastforce simp: l2BitmapSize_def' invert_l1_index_limit) - apply (fastforce simp: prioToL1Index_def invertL1Index_def mask_def wordRadix_def) - (* impossible case *) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (drule(2) filter_empty_unfiltered_contr, fastforce) - - apply (frule (1) valid_queuesD') - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) - apply fold_subgoals[2] - apply (fastforce simp: maxDom_to_H maxPrio_to_H)+ - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (frule_tac s=\ in tcb_queue_relation_prev_next', assumption) - prefer 3 - apply fastforce - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: ksQ_tcb_at')+ - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - apply (clarsimp simp: filter_noteq_op upd_unless_null_def) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI, clarsimp) - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (rule conjI; clarsimp) - apply (simp add: typ_heap_simps) - apply (clarsimp simp: h_t_valid_c_guard [OF h_t_valid_field, OF h_t_valid_clift] - h_t_valid_field[OF h_t_valid_clift] h_t_valid_clift) - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 typ_heap_simps - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - apply (fold_subgoals (prefix))[3] - subgoal premises prems using prems by (fastforce simp: tcb_null_sched_ptrs_def typ_heap_simps c_guard_clift)+ - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split, - simp_all add: typ_heap_simps')[1] - subgoal by (fastforce simp: tcb_null_sched_ptrs_def) - subgoal by fastforce - + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="prio_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule ccorres_symb_exec_r) + apply (rule ccorres_Guard_Seq) + apply (simp add: bind_assoc) + apply (ctac add: getQueue_ccorres) + apply (rule_tac r'=ctcb_queue_relation and xf'=new_queue_' in ccorres_split_nothrow) + apply (ctac add: tcb_queue_remove_ccorres) + apply ceqv + apply (rename_tac queue' newqueue) + apply (rule ccorres_Guard_Seq) + apply (ctac add: setQueue_ccorres) + apply (rule ccorres_split_nothrow_novcg_dc) + apply ctac + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue')" + and R="\s. \ tcbQueueEmpty queue' \ tcb_at' (the (tcbQueueHead queue')) s" + in ccorres_symb_exec_r_known_rv[where R'=UNIV]) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def + tcbQueueEmpty_def split: option.splits) + apply ceqv + apply (rule ccorres_cond[where R=\]) + apply fastforce + apply (ctac add: removeFromBitmap_ccorres) + apply (rule ccorres_return_Skip) + apply vcg + apply (wpsimp wp: hoare_vcg_imp_lift') + apply (clarsimp simp: guard_is_UNIV_def) + apply (wpsimp wp: hoare_vcg_imp_lift') + apply vcg + apply ((wpsimp wp: tcbQueueRemove_tcb_at'_head | wp (once) hoare_drop_imps)+)[1] + apply (vcg exspec=tcb_queue_remove_modifies) + apply wpsimp + apply vcg + apply vcg + apply (rule conseqPre, vcg) apply clarsimp - apply (rule conjI; clarsimp) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (rule conjI; clarsimp) - (* invalid, missing bitmap updates on haskell side *) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems - by (fastforce dest!: tcb_queue_relation'_empty_ksReadyQueues - elim: obj_at'_weaken)+ - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - apply (fold_subgoals (prefix))[4] - subgoal premises prems using prems - by (fastforce simp: typ_heap_simps c_guard_clift tcb_null_sched_ptrs_def)+ - apply (rule conjI; clarsimp simp: queue_in_range[simplified maxDom_to_H maxPrio_to_H]) - apply (frule (1) valid_queuesD') - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: maxDom_to_H maxPrio_to_H)+ - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (frule_tac s=\ in tcb_queue_relation_prev_next') - apply fastforce - prefer 3 - apply fastforce - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: ksQ_tcb_at')+ - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - apply (clarsimp simp: filter_noteq_op upd_unless_null_def) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI; clarsimp) - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (clarsimp simp: typ_heap_simps) - apply (rule conjI; clarsimp simp: typ_heap_simps) - apply (drule(2) filter_empty_unfiltered_contr[simplified filter_noteq_op], simp) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (rule conjI; clarsimp) - (* impossible case, C L2 update disagrees with Haskell update *) - apply (subst (asm) num_domains_index_updates) - apply (simp add: le_maxDomain_eq_less_numDomains word_le_nat_alt) - apply (subst (asm) Arrays.index_update) - subgoal using invert_l1_index_limit - by (fastforce simp add: invert_prioToL1Index_c_simp intro: nat_Suc_less_le_imp) - apply (frule rf_sr_cbitmap_L2_relation) - apply (simp add: invert_prioToL1Index_c_simp) - apply (drule_tac i="invertL1Index (prioToL1Index (tcbPriority ko))" - in cbitmap_L2_relationD, assumption) - subgoal by (simp add: invert_l1_index_limit l2BitmapSize_def') - apply (fastforce simp: prioToL1Index_def invertL1Index_def mask_def wordRadix_def) - - apply (simp add: invert_prioToL1Index_c_simp) - apply (subst rf_sr_drop_bitmaps_dequeue_helper_L2, assumption) - subgoal by (fastforce dest: rf_sr_cbitmap_L2_relation elim!: cbitmap_L2_relation_bit_clear) - - (* trivial case, setting queue to empty *) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def carch_state_relation_def - cmachine_state_relation_def) - apply (erule (2) cready_queues_relation_empty_queue_helper) - - apply (frule (1) valid_queuesD') - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: maxDom_to_H maxPrio_to_H)+ - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (simp add: invert_prioToL1Index_c_simp) - apply (frule_tac s=\ in tcb_queue_relation_prev_next') - apply (fastforce simp add: ksQ_tcb_at')+ - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - apply (clarsimp simp: filter_noteq_op upd_unless_null_def) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI, clarsimp) - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (clarsimp simp: typ_heap_simps) - apply (rule conjI; clarsimp simp: typ_heap_simps) - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - apply (fastforce simp: tcb_null_sched_ptrs_def) - apply (clarsimp simp: typ_heap_simps) - apply (fastforce simp: typ_heap_simps c_guard_clift) - apply (fastforce simp: typ_heap_simps) - apply (fastforce simp: tcb_null_sched_ptrs_def) - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - apply (fold_subgoals (prefix))[4] - subgoal premises prems using prems - by (fastforce simp: typ_heap_simps c_guard_clift tcb_null_sched_ptrs_def)+ - apply (clarsimp) - apply (rule conjI; clarsimp simp: typ_heap_simps) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (rule conjI; clarsimp) - (* invalid, missing bitmap updates on haskell side *) - apply (drule tcb_queue_relation'_empty_ksReadyQueues) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce elim: obj_at'_weaken)+ - (* invalid, missing bitmap updates on haskell side *) - apply (drule tcb_queue_relation'_empty_ksReadyQueues) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce elim: obj_at'_weaken)+ - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 typ_heap_simps - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - apply (fold_subgoals (prefix))[3] - subgoal premises prems using prems - by (fastforce simp: typ_heap_simps c_guard_clift tcb_null_sched_ptrs_def)+ - apply (simp add: guard_is_UNIV_def) - apply simp - apply (wp threadGet_wp) + apply (wpsimp wp: threadGet_wp) + apply vcg + apply clarsimp + apply (wpsimp wp: threadGet_wp) apply vcg - apply simp - apply (wp threadGet_wp) - apply vcg - apply (rule ccorres_return_Skip) - apply simp - apply (wp threadGet_wp) - apply vcg - by (fastforce simp: valid_objs'_def obj_at'_def ran_def projectKOs typ_at'_def - valid_obj'_def valid_tcb'_def inQ_def) + apply (rule ccorres_return_Skip) + apply (wpsimp wp: threadGet_wp) + apply (vcg expsec=thread_state_get_tcbQueued_modifies) + apply normalise_obj_at' + apply (rename_tac tcb) + apply (frule (1) obj_at_cslift_tcb) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (clarsimp simp: valid_tcb'_def) + apply (cut_tac qdom="tcbDomain tcb" and prio="tcbPriority tcb" + in cready_queues_index_to_C_in_range) + apply fastforce + apply fastforce + apply (rule conjI) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (force dest!: tcbQueueHead_iff_tcbQueueEnd simp: tcbQueueEmpty_def obj_at'_def) + by (fastforce simp: word_less_nat_alt + cready_queues_index_to_C_def2 ctcb_relation_def + typ_heap_simps le_maxDomain_eq_less_numDomains(2) unat_trans_ucast_helper) qed -lemma tcbSchedDequeue_ccorres: - "ccorres dc xfdc - (valid_queues and valid_queues' and tcb_at' t and valid_objs') - (UNIV \ \\tcb = tcb_ptr_to_ctcb_ptr t\) - [] - (tcbSchedDequeue t) - (Call tcbSchedDequeue_'proc)" - apply (rule ccorres_guard_imp [OF tcbSchedDequeue_ccorres']) - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE) - apply (clarsimp)+ - done - lemma tcb_queue_relation_append: "\ tcb_queue_relation tn tp mp queue qprev qhead; queue \ []; qend' \ tcb_ptr_to_ctcb_ptr ` set queue; mp qend' = Some tcb; @@ -1720,211 +1595,6 @@ lemma tcb_queue_relation_append: apply clarsimp done -lemma tcbSchedAppend_update: - assumes sr: "sched_queue_relation' mp queue qhead qend" - and qh': "qend' \ tcb_ptr_to_ctcb_ptr ` set queue" - and cs_tcb: "mp qend' = Some tcb" - and valid_ep: "\t\set queue. tcb_at' t s" "distinct queue" - and qhN: "qend' \ NULL" - shows - "sched_queue_relation' - (upd_unless_null qend (tcbSchedNext_C_update (\_. qend') (the (mp qend))) - (mp(qend' \ tcb\tcbSchedNext_C := NULL, tcbSchedPrev_C := qend\))) - (queue @ [ctcb_ptr_to_tcb_ptr qend']) (if queue = [] then qend' else qhead) qend'" - using sr qh' valid_ep cs_tcb qhN - apply - - apply (rule rev_cases[where xs=queue]) - apply (simp add: tcb_queue_relation'_def upd_unless_null_def) - apply (clarsimp simp: tcb_queue_relation'_def upd_unless_null_def tcb_at_not_NULL) - apply (drule_tac qend'=qend' and tn_update=tcbSchedNext_C_update - and tp_update=tcbSchedPrev_C_update and qend="tcb_ptr_to_ctcb_ptr y" - in tcb_queue_relation_append, simp_all) - apply (fastforce simp add: tcb_at_not_NULL) - apply (simp add: fun_upd_twist) - done - -lemma tcb_queue_relation_qend_mems: - "\ tcb_queue_relation' getNext getPrev mp queue qhead qend; - \x \ set queue. tcb_at' x s \ - \ (qend = NULL \ queue = []) - \ (qend \ NULL \ ctcb_ptr_to_tcb_ptr qend \ set queue)" - apply (clarsimp simp: tcb_queue_relation'_def) - apply (drule bspec, erule last_in_set) - apply (simp add: tcb_at_not_NULL) - done - -lemma tcbSchedAppend_ccorres: - "ccorres dc xfdc - (valid_queues and tcb_at' t and valid_objs') - (UNIV \ \\tcb = tcb_ptr_to_ctcb_ptr t\) - [] - (tcbSchedAppend t) - (Call tcbSchedAppend_'proc)" -proof - - note prio_and_dom_limit_helpers[simp] word_sle_def[simp] maxDom_to_H[simp] maxPrio_to_H[simp] - - (* when numDomains = 1, array bounds checks would become _ = 0 rather than _ < 1, changing the - shape of the proof compared to when numDomains > 1 *) - include no_less_1_simps - - show ?thesis - apply (cinit lift: tcb_') - apply (rule_tac r'="\rv rv'. rv = to_bool rv'" - and xf'="ret__unsigned_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (simp add: when_def unless_def del: Collect_const split del: if_split) - apply (rule ccorres_cond[where R=\]) - apply (simp add: to_bool_def) - apply (rule ccorres_rhs_assoc)+ - apply csymbr - apply csymbr - apply csymbr - apply csymbr - apply (rule_tac r'="\rv rv'. rv' = ucast rv" - and xf'="dom_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (rule_tac r'="\rv rv'. rv' = ucast rv" - and xf'="prio_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (rule ccorres_rhs_assoc2)+ - apply (simp only: bind_assoc[symmetric]) - apply (rule ccorres_split_nothrow_novcg_dc) - prefer 2 - apply (rule ccorres_move_c_guard_tcb) - apply ctac - prefer 2 - apply (wp, clarsimp, wp+) - apply (rule_tac P="\s. valid_queues s \ (\p. t \ set (ksReadyQueues s p)) - \ (\tcb. ko_at' tcb t s \ tcbDomain tcb =rva - \ tcbPriority tcb = rvb \ valid_tcb' tcb s)" - and P'=UNIV in ccorres_from_vcg) - apply (rule allI, rule conseqPre, vcg) - apply (clarsimp simp: getQueue_def gets_def get_def setQueue_def modify_def - put_def bind_def return_def bitmap_fun_defs null_def) - apply (clarsimp simp: queue_in_range valid_tcb'_def) - apply (rule conjI; clarsimp simp: queue_in_range) - apply (drule (1) obj_at_cslift_tcb) - apply clarsimp - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply (frule_tac s=\ in tcb_queue_relation_qend_mems, simp add: valid_queues_valid_q) - apply (drule_tac qend'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedAppend_update, - simp_all add: valid_queues_valid_q)[1] - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (simp add: invert_prioToL1Index_c_simp) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI; clarsimp) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (simp add: t_hrs_ksReadyQueues_upd_absorb) - apply (subst rf_sr_drop_bitmaps_enqueue_helper, assumption) - apply (fastforce intro: cbitmap_L1_relation_bit_set) - subgoal by (fastforce intro: cbitmap_L2_relation_bit_set simp: wordRadix_def mask_def) - apply (erule(1) state_relation_queue_update_helper[where S="{t}"], - (simp | rule globals.equality)+, - simp_all add: cready_queues_index_to_C_def2 numPriorities_def - t_hrs_ksReadyQueues_upd_absorb upd_unless_null_def - typ_heap_simps)[1] - apply (fastforce simp: tcb_null_sched_ptrs_def elim: obj_at'_weaken) - apply (fastforce simp: typ_heap_simps c_guard_clift) - apply (fastforce simp: tcb_null_sched_ptrs_def elim: obj_at'_weaken) - apply (clarsimp simp: upd_unless_null_def cready_queues_index_to_C_def numPriorities_def) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI; clarsimp simp: queue_in_range) - apply (drule (1) obj_at_cslift_tcb) - apply clarsimp - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply (frule_tac s=\ in tcb_queue_relation_qend_mems, - simp add: valid_queues_valid_q) - apply (drule_tac qend'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedAppend_update, - simp_all add: valid_queues_valid_q)[1] - apply clarsimp - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (clarsimp simp: upd_unless_null_def cready_queues_index_to_C_def numPriorities_def) - apply (drule (1) obj_at_cslift_tcb) - apply clarsimp - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply (frule_tac s=\ in tcb_queue_relation_qend_mems, - simp add: valid_queues_valid_q) - apply (drule_tac qend'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedAppend_update, - simp_all add: valid_queues_valid_q)[1] - apply clarsimp - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - apply (clarsimp simp: cready_queues_index_to_C_def2 numPriorities_def) - apply (frule(2) obj_at_cslift_tcb[OF valid_queues_obj_at'D]) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (erule_tac S="{t, v}" for v in state_relation_queue_update_helper, - (simp | rule globals.equality)+, - simp_all add: typ_heap_simps if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 upd_unless_null_def - cong: if_cong split del: if_split - del: fun_upd_restrict_conv)[1] - apply simp - apply (rule conjI) - apply clarsimp - apply (drule_tac s="tcb_ptr_to_ctcb_ptr t" in sym, simp) - apply (clarsimp simp add: fun_upd_twist) - prefer 4 - apply (simp add: obj_at'_weakenE[OF _ TrueI]) - apply (rule disjI1, erule valid_queues_obj_at'D) - subgoal by simp - subgoal by simp - subgoal by (fastforce simp: tcb_null_sched_ptrs_def) - subgoal by (fastforce simp: typ_heap_simps c_guard_clift) - apply (simp add: guard_is_UNIV_def) - apply simp - apply (wp threadGet_wp) - apply vcg - apply simp - apply (wp threadGet_wp) - apply vcg - apply (rule ccorres_return_Skip) - apply simp - apply (wp threadGet_wp) - apply vcg - by (fastforce simp: valid_objs'_def obj_at'_def ran_def projectKOs typ_at'_def - valid_obj'_def inQ_def - dest!: valid_queues_obj_at'D) -qed - lemma isStopped_spec: "\s. \ \ ({s} \ {s. cslift s (thread_' s) \ None}) Call isStopped_'proc {s'. ret__unsigned_long_' s' = from_bool (tsType_CL (thread_state_lift (tcbState_C (the (cslift s (thread_' s))))) \ @@ -1970,8 +1640,11 @@ lemma tcb_at_1: done lemma rescheduleRequired_ccorres: - "ccorres dc xfdc (valid_queues and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_objs') - UNIV [] rescheduleRequired (Call rescheduleRequired_'proc)" + "ccorres dc xfdc + ((\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_objs' + and pspace_aligned' and pspace_distinct') + UNIV [] + rescheduleRequired (Call rescheduleRequired_'proc)" apply cinit apply (rule ccorres_symb_exec_l) apply (rule ccorres_split_nothrow_novcg[where r'=dc and xf'=xfdc]) @@ -2081,43 +1754,18 @@ lemma cguard_UNIV: by fastforce lemma lookupBitmapPriority_le_maxPriority: - "\ ksReadyQueuesL1Bitmap s d \ 0 ; valid_queues s \ + "\ ksReadyQueuesL1Bitmap s d \ 0 ; + \d p. d > maxDomain \ p > maxPriority \ tcbQueueEmpty (ksReadyQueues s (d, p)); + valid_bitmaps s \ \ lookupBitmapPriority d s \ maxPriority" - unfolding valid_queues_def valid_queues_no_bitmap_def - by (fastforce dest!: bitmapQ_from_bitmap_lookup bitmapQ_ksReadyQueuesI intro: ccontr) - -lemma rf_sr_ksReadyQueuesL1Bitmap_not_zero: - "\ (\, s') \ rf_sr ; d \ maxDomain ; ksReadyQueuesL1Bitmap_' (globals s').[unat d] \ 0 \ - \ ksReadyQueuesL1Bitmap \ d \ 0" - apply (drule rf_sr_cbitmap_L1_relation) - apply (simp add: cbitmap_L1_relation_def) - done + apply (clarsimp simp: valid_bitmaps_def) + by (fastforce dest!: bitmapQ_from_bitmap_lookup bitmapQ_ksReadyQueuesI intro: ccontr) lemma ksReadyQueuesL1Bitmap_word_log2_max: - "\valid_queues s; ksReadyQueuesL1Bitmap s d \ 0\ - \ word_log2 (ksReadyQueuesL1Bitmap s d) < l2BitmapSize" - unfolding valid_queues_def - by (fastforce dest: word_log2_nth_same bitmapQ_no_L1_orphansD) - - -lemma rf_sr_ksReadyQueuesL2Bitmap_simp: - "\ (\, s') \ rf_sr ; d \ maxDomain ; valid_queues \ ; ksReadyQueuesL1Bitmap \ d \ 0 \ - \ ksReadyQueuesL2Bitmap_' (globals s').[unat d].[word_log2 (ksReadyQueuesL1Bitmap \ d)] = - ksReadyQueuesL2Bitmap \ (d, word_log2 (ksReadyQueuesL1Bitmap \ d))" - apply (frule rf_sr_cbitmap_L2_relation) - apply (frule (1) ksReadyQueuesL1Bitmap_word_log2_max) - apply (drule (3) cbitmap_L2_relationD) - done - -lemma ksReadyQueuesL2Bitmap_nonzeroI: - "\ d \ maxDomain ; valid_queues s ; ksReadyQueuesL1Bitmap s d \ 0 \ - \ ksReadyQueuesL2Bitmap s (d, invertL1Index (word_log2 (ksReadyQueuesL1Bitmap s d))) \ 0" - unfolding valid_queues_def - apply clarsimp - apply (frule bitmapQ_no_L1_orphansD) - apply (erule word_log2_nth_same) - apply clarsimp - done + "\valid_bitmaps s; ksReadyQueuesL1Bitmap s d \ 0\ + \ word_log2 (ksReadyQueuesL1Bitmap s d) < l2BitmapSize" + unfolding valid_bitmaps_def + by (fastforce dest: word_log2_nth_same bitmapQ_no_L1_orphansD) lemma clzl_spec: "\s. \ \ {\. s = \ \ x___unsigned_long_' s \ 0} Call clzl_'proc @@ -2313,9 +1961,9 @@ lemma threadGet_get_obj_at'_has_domain: lemma possibleSwitchTo_ccorres: shows "ccorres dc xfdc - (valid_queues and (\s. weak_sch_act_wf (ksSchedulerAction s) s) + ((\s. weak_sch_act_wf (ksSchedulerAction s) s) and st_tcb_at' runnable' t and (\s. ksCurDomain s \ maxDomain) - and valid_objs') + and valid_objs' and pspace_aligned' and pspace_distinct') ({s. target_' s = tcb_ptr_to_ctcb_ptr t} \ UNIV) [] (possibleSwitchTo t ) @@ -2363,8 +2011,8 @@ lemma possibleSwitchTo_ccorres: lemma scheduleTCB_ccorres': "ccorres dc xfdc - (tcb_at' thread and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_queues - and valid_objs') + (tcb_at' thread and (\s. weak_sch_act_wf (ksSchedulerAction s) s) + and valid_objs' and pspace_aligned' and pspace_distinct') (UNIV \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) [] (do (runnable, curThread, action) \ do @@ -2414,24 +2062,26 @@ lemma scheduleTCB_ccorres': apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def cscheduler_action_relation_def) apply wp+ - apply (simp add: isRunnable_def isStopped_def) - apply wp + apply (simp add: isRunnable_def isStopped_def) apply (simp add: guard_is_UNIV_def) apply clarsimp apply (clarsimp simp: st_tcb_at'_def obj_at'_def weak_sch_act_wf_def) done lemma scheduleTCB_ccorres_valid_queues'_pre: - "ccorresG rf_sr \ dc xfdc (tcb_at' thread and st_tcb_at' (not runnable') thread and valid_queues' and valid_queues and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_objs') - (UNIV \ \\tptr = tcb_ptr_to_ctcb_ptr thread\) [] - (do (runnable, curThread, action) \ do - runnable \ isRunnable thread; - curThread \ getCurThread; - action \ getSchedulerAction; - return (runnable, curThread, action) od; - when (\ runnable \ curThread = thread \ action = ResumeCurrentThread) rescheduleRequired - od) - (Call scheduleTCB_'proc)" + "ccorresG rf_sr \ dc xfdc + (tcb_at' thread and st_tcb_at' (not runnable') thread + and (\s. weak_sch_act_wf (ksSchedulerAction s) s) + and valid_objs' and pspace_aligned' and pspace_distinct') + \\tptr = tcb_ptr_to_ctcb_ptr thread\ [] + (do (runnable, curThread, action) \ do runnable \ isRunnable thread; + curThread \ getCurThread; + action \ getSchedulerAction; + return (runnable, curThread, action) + od; + when (\ runnable \ curThread = thread \ action = ResumeCurrentThread) rescheduleRequired + od) + (Call scheduleTCB_'proc)" supply empty_fail_cond[simp] apply (cinit' lift: tptr_' simp del: word_neq_0_conv) apply (rule ccorres_rhs_assoc2)+ @@ -2472,17 +2122,17 @@ lemma scheduleTCB_ccorres_valid_queues'_pre: split: scheduler_action.split_asm) apply wp+ apply (simp add: isRunnable_def isStopped_def) - apply wp apply (simp add: guard_is_UNIV_def) apply (clarsimp simp: st_tcb_at'_def obj_at'_def) done - lemmas scheduleTCB_ccorres_valid_queues' = scheduleTCB_ccorres_valid_queues'_pre[unfolded bind_assoc return_bind split_conv] lemma rescheduleRequired_ccorres_valid_queues'_simple: - "ccorresG rf_sr \ dc xfdc (valid_queues' and sch_act_simple) UNIV [] rescheduleRequired (Call rescheduleRequired_'proc)" + "ccorresG rf_sr \ dc xfdc + sch_act_simple UNIV [] + rescheduleRequired (Call rescheduleRequired_'proc)" apply cinit apply (rule ccorres_symb_exec_l) apply (rule ccorres_split_nothrow_novcg[where r'=dc and xf'=xfdc]) @@ -2515,16 +2165,17 @@ lemma rescheduleRequired_ccorres_valid_queues'_simple: split: scheduler_action.split_asm) lemma scheduleTCB_ccorres_valid_queues'_pre_simple: - "ccorresG rf_sr \ dc xfdc (tcb_at' thread and st_tcb_at' (not runnable') thread and valid_queues' and sch_act_simple) - (UNIV \ \\tptr = tcb_ptr_to_ctcb_ptr thread\) [] - (do (runnable, curThread, action) \ do - runnable \ isRunnable thread; - curThread \ getCurThread; - action \ getSchedulerAction; - return (runnable, curThread, action) od; - when (\ runnable \ curThread = thread \ action = ResumeCurrentThread) rescheduleRequired - od) - (Call scheduleTCB_'proc)" + "ccorresG rf_sr \ dc xfdc + (tcb_at' thread and st_tcb_at' (not runnable') thread and valid_queues' and sch_act_simple) + \\tptr = tcb_ptr_to_ctcb_ptr thread\ [] + (do (runnable, curThread, action) \ do runnable \ isRunnable thread; + curThread \ getCurThread; + action \ getSchedulerAction; + return (runnable, curThread, action) + od; + when (\ runnable \ curThread = thread \ action = ResumeCurrentThread) rescheduleRequired + od) + (Call scheduleTCB_'proc)" supply empty_fail_cond[simp] apply (cinit' lift: tptr_' simp del: word_neq_0_conv) apply (rule ccorres_rhs_assoc2)+ @@ -2563,11 +2214,10 @@ lemma scheduleTCB_ccorres_valid_queues'_pre_simple: apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def cscheduler_action_relation_def) apply wp+ - apply (simp add: isRunnable_def isStopped_def) - apply wp + apply (simp add: isRunnable_def isStopped_def) apply (simp add: guard_is_UNIV_def) apply clarsimp - apply (clarsimp simp: st_tcb_at'_def obj_at'_def valid_queues'_def) + apply (clarsimp simp: st_tcb_at'_def obj_at'_def) done lemmas scheduleTCB_ccorres_valid_queues'_simple @@ -2587,48 +2237,35 @@ lemma threadSet_weak_sch_act_wf_runnable': apply (clarsimp) done -lemma threadSet_valid_queues_and_runnable': "\\s. valid_queues s \ (\p. thread \ set (ksReadyQueues s p) \ runnable' st)\ - threadSet (tcbState_update (\_. st)) thread - \\rv s. valid_queues s\" - apply (wp threadSet_valid_queues) - apply (clarsimp simp: inQ_def) -done - lemma setThreadState_ccorres[corres]: "ccorres dc xfdc - (\s. tcb_at' thread s \ valid_queues s \ valid_objs' s \ valid_tcb_state' st s \ - (ksSchedulerAction s = SwitchToThread thread \ runnable' st) \ - (\p. thread \ set (ksReadyQueues s p) \ runnable' st) \ - sch_act_wf (ksSchedulerAction s) s) - ({s'. (\cl fl. cthread_state_relation_lifted st (cl\tsType_CL := ts_' s' && mask 4\, fl))} + (\s. tcb_at' thread s \ valid_objs' s \ valid_tcb_state' st s + \ (ksSchedulerAction s = SwitchToThread thread \ runnable' st) + \ sch_act_wf (ksSchedulerAction s) s \ pspace_aligned' s \ pspace_distinct' s) + ({s'. (\cl fl. cthread_state_relation_lifted st (cl\tsType_CL := ts_' s' && mask 4\, fl))} \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) hs - (setThreadState st thread) (Call setThreadState_'proc)" + (setThreadState st thread) (Call setThreadState_'proc)" apply (cinit lift: tptr_' cong add: call_ignore_cong) apply (ctac (no_vcg) add: threadSet_tcbState_simple_corres) apply (ctac add: scheduleTCB_ccorres) - apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_queues_and_runnable' - threadSet_valid_objs') - by (clarsimp simp: weak_sch_act_wf_def valid_queues_def valid_tcb'_tcbState_update) - -lemma threadSet_valid_queues'_and_not_runnable': "\tcb_at' thread and valid_queues' and (\s. (\ runnable' st))\ - threadSet (tcbState_update (\_. st)) thread - \\rv. tcb_at' thread and st_tcb_at' (not runnable') thread and valid_queues' \" - - apply (wp threadSet_valid_queues' threadSet_tcbState_st_tcb_at') - apply (clarsimp simp: pred_neg_def valid_queues'_def inQ_def)+ -done + apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_objs') + apply (clarsimp simp: weak_sch_act_wf_def valid_tcb'_tcbState_update) + done lemma setThreadState_ccorres_valid_queues': - "ccorres dc xfdc - (\s. tcb_at' thread s \ valid_queues' s \ \ runnable' st \ weak_sch_act_wf (ksSchedulerAction s) s \ Invariants_H.valid_queues s \ (\p. thread \ set (ksReadyQueues s p)) \ sch_act_not thread s \ valid_objs' s \ valid_tcb_state' st s) + "ccorres dc xfdc + (\s. tcb_at' thread s \ \ runnable' st \ weak_sch_act_wf (ksSchedulerAction s) s + \ sch_act_not thread s \ valid_objs' s \ valid_tcb_state' st s + \ pspace_aligned' s \ pspace_distinct' s) ({s'. (\cl fl. cthread_state_relation_lifted st (cl\tsType_CL := ts_' s' && mask 4\, fl))} - \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) [] - (setThreadState st thread) (Call setThreadState_'proc)" + \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) [] + (setThreadState st thread) (Call setThreadState_'proc)" apply (cinit lift: tptr_' cong add: call_ignore_cong) apply (ctac (no_vcg) add: threadSet_tcbState_simple_corres) apply (ctac add: scheduleTCB_ccorres_valid_queues') - apply (wp threadSet_valid_queues'_and_not_runnable' threadSet_weak_sch_act_wf_runnable' threadSet_valid_queues_and_runnable' threadSet_valid_objs') - by (clarsimp simp: valid_tcb'_def tcb_cte_cases_def) + apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_objs' + threadSet_tcbState_st_tcb_at') + by (clarsimp simp: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) lemma simp_list_case_return: "(case x of [] \ return e | y # ys \ return f) = return (if x = [] then e else f)" @@ -2649,24 +2286,23 @@ lemma cancelSignal_ccorres [corres]: apply (rule ccorres_rhs_assoc2) apply (ctac (no_vcg) add: cancelSignal_ccorres_helper) apply (ctac add: setThreadState_ccorres_valid_queues') - apply ((wp setNotification_ksQ hoare_vcg_all_lift set_ntfn_valid_objs' | simp add: valid_tcb_state'_def split del: if_split)+)[1] + apply ((wp hoare_vcg_all_lift set_ntfn_valid_objs' | simp add: valid_tcb_state'_def split del: if_split)+)[1] apply (simp add: ThreadState_defs) apply (rule conjI, clarsimp, rule conjI, clarsimp) apply (frule (1) ko_at_valid_ntfn'[OF _ invs_valid_objs']) - subgoal by ((auto simp: obj_at'_def projectKOs st_tcb_at'_def invs'_def valid_state'_def + subgoal + by ((auto simp: obj_at'_def projectKOs st_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of cthread_state_relation_def sch_act_wf_weak valid_ntfn'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] | - clarsimp simp: eq_commute)+) + | clarsimp simp: eq_commute)+) apply (clarsimp) apply (frule (1) ko_at_valid_ntfn'[OF _ invs_valid_objs']) apply (frule (2) ntfn_blocked_in_queueD) by (auto simp: obj_at'_def projectKOs st_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of valid_ntfn'_def cthread_state_relation_def sch_act_wf_weak isWaitingNtfn_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] - split: ntfn.splits option.splits - | clarsimp simp: eq_commute + split: ntfn.splits option.splits + | clarsimp simp: eq_commute | drule_tac x=thread in bspec)+ lemma cmap_relation_ep: @@ -2969,23 +2605,20 @@ lemma cancelIPC_ccorres_helper: cpspace_relation_def update_ep_map_tos typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - subgoal by (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - subgoal by (simp add: cendpoint_relation_def Let_def EPState_Idle_def) - subgoal by simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - subgoal by simp - apply (erule (1) map_to_ko_atI') - apply (simp add: heap_to_user_data_def Let_def) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - subgoal by (clarsimp simp: comp_def) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + subgoal by (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + subgoal by (simp add: cendpoint_relation_def Let_def EPState_Idle_def) + subgoal by simp + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + subgoal by simp + apply (erule (1) map_to_ko_atI') + apply (simp add: heap_to_user_data_def Let_def) subgoal by (simp add: carch_state_relation_def carch_globals_def typ_heap_simps') subgoal by (simp add: cmachine_state_relation_def) @@ -3006,38 +2639,36 @@ lemma cancelIPC_ccorres_helper: cpspace_relation_def update_ep_map_tos typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - subgoal by (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (simp add: cendpoint_relation_def Let_def isSendEP_def isRecvEP_def split: endpoint.splits split del: if_split) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + subgoal by (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (simp add: cendpoint_relation_def Let_def isSendEP_def isRecvEP_def + split: endpoint.splits split del: if_split) \ \recv case\ - apply (clarsimp simp add: Ptr_ptr_val h_t_valid_clift_Some_iff - tcb_queue_relation'_next_mask tcb_queue_relation'_prev_mask cong: tcb_queue_relation'_cong) - subgoal by (intro impI conjI; simp) - \ \send case\ - apply (clarsimp simp add: Ptr_ptr_val h_t_valid_clift_Some_iff - tcb_queue_relation'_next_mask tcb_queue_relation'_prev_mask cong: tcb_queue_relation'_cong) + apply (clarsimp simp: Ptr_ptr_val h_t_valid_clift_Some_iff + tcb_queue_relation'_next_mask tcb_queue_relation'_prev_mask + cong: tcb_queue_relation'_cong) + subgoal by (intro impI conjI; simp) + \ \send case\ + apply (clarsimp simp: Ptr_ptr_val h_t_valid_clift_Some_iff + tcb_queue_relation'_next_mask tcb_queue_relation'_prev_mask cong: tcb_queue_relation'_cong) subgoal by (intro impI conjI; simp) subgoal by simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - apply simp - apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - subgoal by (clarsimp simp: comp_def) - subgoal by (simp add: carch_state_relation_def carch_globals_def - typ_heap_simps') + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp + apply (erule (1) map_to_ko_atI') + subgoal by (simp add: carch_state_relation_def carch_globals_def typ_heap_simps') subgoal by (simp add: cmachine_state_relation_def) subgoal by (simp add: h_t_valid_clift_Some_iff) subgoal by (simp add: objBits_simps') subgoal by (simp add: objBits_simps) apply assumption - done + done declare empty_fail_get[iff] @@ -3244,37 +2875,35 @@ lemma cancelIPC_ccorres1: subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits) + split: thread_state.splits) apply clarsimp apply (frule (2) ep_blocked_in_queueD_recv) apply (frule (1) ko_at_valid_ep'[OF _ invs_valid_objs']) subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of isRecvEP_def cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits endpoint.splits) + split: thread_state.splits endpoint.splits) apply (rule conjI) apply (clarsimp simp: inQ_def) - apply (rule conjI) - apply clarsimp apply clarsimp apply (rule conjI) subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits) + split: thread_state.splits) apply clarsimp apply (rule conjI) subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits) + split: thread_state.splits) apply clarsimp apply (frule (2) ep_blocked_in_queueD_send) apply (frule (1) ko_at_valid_ep'[OF _ invs_valid_objs']) subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of isSendEP_def cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits endpoint.splits)[1] + split: thread_state.splits endpoint.splits)[1] apply (auto simp: isTS_defs cthread_state_relation_def typ_heap_simps weak_sch_act_wf_def) apply (case_tac ts, auto simp: isTS_defs cthread_state_relation_def typ_heap_simps) diff --git a/proof/crefine/ARM_HYP/Ipc_C.thy b/proof/crefine/ARM_HYP/Ipc_C.thy index 9d661c04c5..65b4af48ca 100644 --- a/proof/crefine/ARM_HYP/Ipc_C.thy +++ b/proof/crefine/ARM_HYP/Ipc_C.thy @@ -27,10 +27,6 @@ lemma replyFromKernel_success_empty: unfolding replyFromKernel_def replyFromKernel_success_empty_def by (simp add: setMRs_Nil submonad_asUser.fn_stateAssert) -crunch valid_queues[wp]: handleFaultReply valid_queues - -crunch valid_queues'[wp]: handleFaultReply valid_queues' - crunch sch_act_wf: handleFaultReply "\s. sch_act_wf (ksSchedulerAction s) s" crunch valid_ipc_buffer_ptr' [wp]: copyMRs "valid_ipc_buffer_ptr' p" @@ -1434,8 +1430,7 @@ lemma getRestartPC_ccorres [corres]: done lemma asUser_tcbFault_obj_at: - "\obj_at' (\tcb. P (tcbFault tcb)) t\ asUser t' m - \\rv. obj_at' (\tcb. P (tcbFault tcb)) t\" + "asUser t' m \obj_at' (\tcb. P (tcbFault tcb)) t\" supply if_cong[cong] apply (simp add: asUser_def split_def) apply (wp threadGet_wp) @@ -4461,10 +4456,6 @@ lemma doReplyTransfer_ccorres [corres]: \ \\grant = from_bool grant\) hs (doReplyTransfer sender receiver slot grant) (Call doReplyTransfer_'proc)" -proof - - have invs_valid_queues_strg: "\s. invs' s \ valid_queues s" - by clarsimp - show ?thesis apply (cinit lift: sender_' receiver_' slot_' grant_') apply (rule getThreadState_ccorres_foo) apply (rule ccorres_assert2) @@ -4496,7 +4487,7 @@ proof - apply (ctac(no_vcg) add: cteDeleteOne_ccorres[where w="scast cap_reply_cap"]) apply (ctac(no_vcg) add: setThreadState_ccorres) apply (ctac(no_vcg) add: possibleSwitchTo_ccorres) - apply (wpsimp wp: sts_running_valid_queues setThreadState_st_tcb)+ + apply (wpsimp wp: sts_valid_objs' setThreadState_st_tcb)+ apply (wp cteDeleteOne_sch_act_wf) apply vcg apply (rule conseqPre, vcg) @@ -4505,8 +4496,7 @@ proof - apply wp apply (simp add: cap_get_tag_isCap) apply (strengthen invs_weak_sch_act_wf_strg - cte_wp_at_imp_consequent'[where P="\ct. Ex (ccap_relation (cteCap ct))" for ct] - invs_valid_queues_strg) + cte_wp_at_imp_consequent'[where P="\ct. Ex (ccap_relation (cteCap ct))" for ct]) apply (simp add: cap_reply_cap_def) apply (wp doIPCTransfer_reply_or_replyslot) apply (clarsimp simp: seL4_Fault_NullFault_def ccorres_cond_iffs @@ -4541,19 +4531,20 @@ proof - apply (ctac (no_vcg)) apply (simp only: K_bind_def) apply (ctac add: possibleSwitchTo_ccorres) - apply (wp sts_running_valid_queues setThreadState_st_tcb | simp)+ - apply (ctac add: setThreadState_ccorres_valid_queues'_simple) + apply (wp sts_valid_objs' setThreadState_st_tcb | simp)+ + apply (ctac add: setThreadState_ccorres_simple) apply wp - apply ((wp threadSet_valid_queues threadSet_sch_act threadSet_valid_queues' hoare_weak_lift_imp + apply ((wp threadSet_sch_act hoare_weak_lift_imp threadSet_valid_objs' threadSet_weak_sch_act_wf | simp add: valid_tcb_state'_def)+)[1] apply (clarsimp simp: guard_is_UNIV_def ThreadState_defs mask_def option_to_ctcb_ptr_def) - apply (rule_tac Q="\rv. valid_queues and tcb_at' receiver and valid_queues' and + apply (rule_tac Q="\rv. tcb_at' receiver and valid_objs' and sch_act_simple and (\s. ksCurDomain s \ maxDomain) and - (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) + (\s. sch_act_wf (ksSchedulerAction s) s) and + pspace_aligned' and pspace_distinct'" in hoare_post_imp) apply (clarsimp simp: inQ_def weak_sch_act_wf_def) - apply (wp threadSet_valid_queues threadSet_sch_act handleFaultReply_sch_act_wf) + apply (wp threadSet_sch_act handleFaultReply_sch_act_wf) apply (clarsimp simp: guard_is_UNIV_def) apply assumption apply clarsimp @@ -4562,7 +4553,7 @@ proof - apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_tcb]) apply (clarsimp simp: ctcb_relation_def typ_heap_simps) apply wp - apply (strengthen vp_invs_strg' invs_valid_queues') + apply (strengthen vp_invs_strg') apply (wp cteDeleteOne_tcbFault cteDeleteOne_sch_act_wf) apply vcg apply (rule conseqPre, vcg) @@ -4578,7 +4569,6 @@ proof - cap_get_tag_isCap) apply fastforce done -qed lemma ccorres_getCTE_cte_at: "ccorresG rf_sr \ r xf P P' hs (getCTE p >>= f) c @@ -4598,7 +4588,7 @@ lemma ccorres_getCTE_cte_at: done lemma setupCallerCap_ccorres [corres]: - "ccorres dc xfdc (valid_queues and valid_pspace' and (\s. \d p. sender \ set (ksReadyQueues s (d, p))) + "ccorres dc xfdc (valid_pspace' and (\s. sch_act_wf (ksSchedulerAction s) s) and sch_act_not sender and tcb_at' sender and tcb_at' receiver and tcb_at' sender and tcb_at' receiver) @@ -4728,23 +4718,20 @@ lemma sendIPC_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def - tcb_queue_relation'_def) - apply simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def + tcb_queue_relation'_def) apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - apply simp - apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp + apply (erule (1) map_to_ko_atI') apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -4768,30 +4755,27 @@ lemma sendIPC_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - isRecvEP_def isSendEP_def - tcb_queue_relation'_def valid_ep'_def - split: endpoint.splits list.splits - split del: if_split) - apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") - apply (clarsimp dest!: is_aligned_tcb_ptr_to_ctcb_ptr - split del: if_split) - apply (clarsimp split: if_split) - apply simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + isRecvEP_def isSendEP_def + tcb_queue_relation'_def valid_ep'_def + split: endpoint.splits list.splits + split del: if_split) + apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") + apply (clarsimp dest!: is_aligned_tcb_ptr_to_ctcb_ptr + split del: if_split) + apply (clarsimp split: if_split) apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - apply simp - apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp + apply (erule (1) map_to_ko_atI') apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -4814,10 +4798,9 @@ lemma rf_sr_tcb_update_twice: cmachine_state_relation_def) lemma sendIPC_block_ccorres_helper: - "ccorres dc xfdc (tcb_at' thread and valid_queues and valid_objs' and + "ccorres dc xfdc (tcb_at' thread and valid_objs' and pspace_aligned' and pspace_distinct' and sch_act_not thread and ep_at' epptr and - (\s. sch_act_wf (ksSchedulerAction s) s \ - (\d p. thread \ set (ksReadyQueues s (d, p)))) and + (\s. sch_act_wf (ksSchedulerAction s) s) and K (bos = ThreadState_BlockedOnSend \ epptr' = epptr \ badge' = badge \ cg = from_bool canGrant \ cgr = from_bool canGrantReply @@ -4873,7 +4856,7 @@ lemma sendIPC_block_ccorres_helper: apply ceqv apply clarsimp apply ctac - apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_queues + apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_objs') apply (clarsimp simp: guard_is_UNIV_def) apply (clarsimp simp: sch_act_wf_weak valid_tcb'_def valid_tcb_state'_def @@ -4977,6 +4960,19 @@ lemma tcb_queue_relation_qend_valid': apply (simp add: h_t_valid_clift_Some_iff) done +lemma tcb_queue'_head_end_NULL: + assumes qr: "tcb_queue_relation' getNext getPrev mp queue qhead qend" + and tat: "\t\set queue. tcb_at' t s" + shows "(qend = NULL) = (qhead = NULL)" + using qr tat + apply - + apply (erule tcb_queue_relationE') + apply (simp add: tcb_queue_head_empty_iff split: if_splits) + apply (rule tcb_at_not_NULL) + apply (erule bspec) + apply simp + done + lemma tcbEPAppend_spec: "\s queue. \ \ \s. \t. (t, s) \ rf_sr \ (\tcb\set queue. tcb_at' tcb t) \ distinct queue @@ -5097,29 +5093,26 @@ lemma sendIPC_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep', assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - mask_def [where n=2] EPState_Send_def) - apply (clarsimp simp: tcb_queue_relation'_def) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep', assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + mask_def [where n=2] EPState_Send_def) + apply (clarsimp simp: tcb_queue_relation'_def) + apply (simp add: isSendEP_def isRecvEP_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue, assumption+) apply (simp add: isSendEP_def isRecvEP_def) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_ep_queue, assumption+) - apply (simp add: isSendEP_def isRecvEP_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (simp only:projectKOs injectKO_ep objBits_simps) - apply clarsimp - apply (clarsimp simp: obj_at'_def projectKOs) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (simp only:projectKOs injectKO_ep objBits_simps) + apply clarsimp + apply (clarsimp simp: obj_at'_def projectKOs) apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: typ_heap_simps') @@ -5136,31 +5129,28 @@ lemma sendIPC_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep', assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - mask_def [where n=2] EPState_Send_def - split: if_split) - apply (fastforce simp: tcb_queue_relation'_def - valid_ep'_def - dest: tcb_queue_relation_next_not_NULL) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep', assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + mask_def [where n=2] EPState_Send_def + split: if_split) + apply (fastforce simp: tcb_queue_relation'_def + valid_ep'_def + dest: tcb_queue_relation_next_not_NULL) + apply (simp add: isSendEP_def isRecvEP_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue, assumption+) apply (simp add: isSendEP_def isRecvEP_def) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_ep_queue, assumption+) - apply (simp add: isSendEP_def isRecvEP_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def projectKOs) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def projectKOs) apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -5180,8 +5170,7 @@ lemma ctcb_relation_blockingIPCCanGrantD: lemma sendIPC_ccorres [corres]: "ccorres dc xfdc (invs' and st_tcb_at' simple' thread - and sch_act_not thread and ep_at' epptr and - (\s. \d p. thread \ set (ksReadyQueues s (d, p)))) + and sch_act_not thread and ep_at' epptr) (UNIV \ \\blocking = from_bool blocking\ \ \\do_call = from_bool do_call\ \ \\badge = badge\ @@ -5212,8 +5201,7 @@ lemma sendIPC_ccorres [corres]: apply ceqv apply (rule_tac A="invs' and st_tcb_at' simple' thread and sch_act_not thread and ko_at' ep epptr - and ep_at' epptr - and (\s. \d p. thread \ set (ksReadyQueues s (d, p)))" + and ep_at' epptr" in ccorres_guard_imp2 [where A'=UNIV]) apply wpc \ \RecvEP case\ @@ -5261,12 +5249,11 @@ lemma sendIPC_ccorres [corres]: apply (ctac add: setThreadState_ccorres) apply (rule ccorres_return_Skip) apply (wpsimp wp: hoare_drop_imps hoare_vcg_all_lift possibleSwitchTo_sch_act_not - possibleSwitchTo_sch_act_not sts_st_tcb' - possibleSwitchTo_ksQ' sts_valid_queues sts_ksQ' + possibleSwitchTo_sch_act_not sts_st_tcb' sts_valid_objs' simp: valid_tcb_state'_def)+ apply vcg - apply (wpsimp wp: doIPCTransfer_sch_act setEndpoint_ksQ hoare_vcg_all_lift - set_ep_valid_objs' setEndpoint_valid_mdb' + apply (wpsimp wp: doIPCTransfer_sch_act hoare_vcg_all_lift + set_ep_valid_objs' setEndpoint_valid_mdb' | wp (once) hoare_drop_imp | strengthen sch_act_wf_weak)+ apply (fastforce simp: guard_is_UNIV_def ThreadState_defs Collect_const_mem mask_def @@ -5342,7 +5329,7 @@ lemma sendIPC_ccorres [corres]: st_tcb_at'_def valid_tcb_state'_def ko_wp_at'_def isBlockedOnSend_def projectKO_opt_tcb split: if_split_asm if_split) - apply (rule conjI, simp, rule impI, clarsimp simp: valid_pspace_valid_objs') + apply (rule conjI, simp, rule impI, clarsimp simp: valid_pspace'_def) apply (erule delta_sym_refs) apply (clarsimp split: if_split_asm dest!: symreftype_inverse')+ @@ -5385,10 +5372,9 @@ lemma ctcb_relation_blockingIPCCanGrantReplyD: done lemma receiveIPC_block_ccorres_helper: - "ccorres dc xfdc (tcb_at' thread and valid_queues and valid_objs' and + "ccorres dc xfdc (tcb_at' thread and valid_objs' and pspace_aligned' and pspace_distinct' and sch_act_not thread and ep_at' epptr and - (\s. sch_act_wf (ksSchedulerAction s) s \ - (\d p. thread \ set (ksReadyQueues s (d, p)))) and + (\s. sch_act_wf (ksSchedulerAction s) s) and K (epptr = epptr && ~~ mask 4) and K (isEndpointCap cap \ ccap_relation cap cap')) UNIV hs @@ -5426,7 +5412,7 @@ lemma receiveIPC_block_ccorres_helper: apply ceqv apply clarsimp apply ctac - apply (wp threadSet_valid_queues hoare_vcg_all_lift threadSet_valid_objs' + apply (wp hoare_vcg_all_lift threadSet_valid_objs' threadSet_weak_sch_act_wf_runnable') apply (clarsimp simp: guard_is_UNIV_def) apply (clarsimp simp: sch_act_wf_weak valid_tcb'_def valid_tcb_state'_def @@ -5491,31 +5477,28 @@ lemma receiveIPC_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep', assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - mask_def [where n=2] EPState_Recv_def - split: if_split) - apply (fastforce simp: tcb_queue_relation'_def - valid_ep'_def - dest: tcb_queue_relation_next_not_NULL) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep', assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + mask_def [where n=2] EPState_Recv_def + split: if_split) + apply (fastforce simp: tcb_queue_relation'_def + valid_ep'_def + dest: tcb_queue_relation_next_not_NULL) + apply (simp add: isSendEP_def isRecvEP_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue, assumption+) apply (simp add: isSendEP_def isRecvEP_def) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_ep_queue, assumption+) - apply (simp add: isSendEP_def isRecvEP_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def projectKOs) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def projectKOs) apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -5532,28 +5515,25 @@ lemma receiveIPC_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep', assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - mask_def [where n=2] EPState_Recv_def) - apply (clarsimp simp: tcb_queue_relation'_def) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep', assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + mask_def [where n=2] EPState_Recv_def) + apply (clarsimp simp: tcb_queue_relation'_def) + apply (simp add: isSendEP_def isRecvEP_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue, assumption+) apply (simp add: isSendEP_def isRecvEP_def) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_ep_queue, assumption+) - apply (simp add: isSendEP_def isRecvEP_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def projectKOs) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def projectKOs) apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: typ_heap_simps') @@ -5621,23 +5601,20 @@ lemma receiveIPC_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def - tcb_queue_relation'_def) - apply simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def + tcb_queue_relation'_def) apply simp + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: typ_heap_simps') @@ -5661,30 +5638,27 @@ lemma receiveIPC_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - isRecvEP_def isSendEP_def - tcb_queue_relation'_def valid_ep'_def - split: endpoint.splits list.splits - split del: if_split) - apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") - apply (clarsimp dest!: is_aligned_tcb_ptr_to_ctcb_ptr - split del: if_split) - apply (clarsimp split: if_split) - apply simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + isRecvEP_def isSendEP_def + tcb_queue_relation'_def valid_ep'_def + split: endpoint.splits list.splits + split del: if_split) + apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") + apply (clarsimp dest!: is_aligned_tcb_ptr_to_ctcb_ptr + split del: if_split) + apply (clarsimp split: if_split) apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - apply simp - apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp + apply (erule (1) map_to_ko_atI') apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: typ_heap_simps') @@ -5801,7 +5775,6 @@ lemma receiveIPC_ccorres [corres]: notes option.case_cong_weak [cong] shows "ccorres dc xfdc (invs' and st_tcb_at' simple' thread and sch_act_not thread - and (\s. \d p. thread \ set (ksReadyQueues s (d, p))) and valid_cap' cap and K (isEndpointCap cap)) (UNIV \ \\thread = tcb_ptr_to_ctcb_ptr thread\ \ \ccap_relation cap \cap\ @@ -5877,7 +5850,6 @@ lemma receiveIPC_ccorres [corres]: apply ceqv apply (rule_tac A="invs' and st_tcb_at' simple' thread and sch_act_not thread - and (\s. \d p. thread \ set (ksReadyQueues s (d, p))) and ko_at' ep (capEPPtr cap)" in ccorres_guard_imp2 [where A'=UNIV]) apply wpc @@ -6017,28 +5989,26 @@ lemma receiveIPC_ccorres [corres]: apply ccorres_rewrite apply ctac apply (ctac add: possibleSwitchTo_ccorres) - apply (wpsimp wp: sts_st_tcb' sts_valid_queues) + apply (wpsimp wp: sts_st_tcb' sts_valid_objs') apply (vcg exspec=setThreadState_modifies) apply (fastforce simp: guard_is_UNIV_def ThreadState_defs mask_def cap_get_tag_isCap ccap_relation_ep_helpers) apply (clarsimp simp: valid_tcb_state'_def) - apply (rule_tac Q="\_. valid_pspace' and valid_queues + apply (rule_tac Q="\_. valid_pspace' and st_tcb_at' ((=) sendState) sender and tcb_at' thread and (\s. sch_act_wf (ksSchedulerAction s) s) - and (\s. (\a b. sender \ set (ksReadyQueues s (a, b)))) and sch_act_not sender and K (thread \ sender) and (\s. ksCurDomain s \ maxDomain)" in hoare_post_imp) - apply (clarsimp simp: valid_pspace_valid_objs' pred_tcb_at'_def sch_act_wf_weak - obj_at'_def) + apply (fastforce simp: valid_pspace_valid_objs' pred_tcb_at'_def sch_act_wf_weak + obj_at'_def) apply (wpsimp simp: guard_is_UNIV_def option_to_ptr_def option_to_0_def conj_ac)+ - apply (rule_tac Q="\rv. valid_queues and valid_pspace' - and cur_tcb' and tcb_at' sender and tcb_at' thread - and sch_act_not sender and K (thread \ sender) - and ep_at' (capEPPtr cap) - and (\s. ksCurDomain s \ maxDomain) - and (\s. sch_act_wf (ksSchedulerAction s) s \ - (\d p. sender \ set (ksReadyQueues s (d, p))))" - in hoare_post_imp) + apply (rule_tac Q="\rv. valid_pspace' + and cur_tcb' and tcb_at' sender and tcb_at' thread + and sch_act_not sender and K (thread \ sender) + and ep_at' (capEPPtr cap) + and (\s. ksCurDomain s \ maxDomain) + and (\s. sch_act_wf (ksSchedulerAction s) s)" + in hoare_post_imp) subgoal by (auto, auto simp: st_tcb_at'_def obj_at'_def) apply (wp hoare_vcg_all_lift set_ep_valid_objs') apply (clarsimp simp: guard_is_UNIV_def) @@ -6072,13 +6042,11 @@ lemma receiveIPC_ccorres [corres]: split: if_split_asm bool.splits) (*very long *) apply (clarsimp simp: obj_at'_def state_refs_of'_def projectKOs) apply (frule(1) sym_refs_ko_atD' [OF _ invs_sym']) - apply (frule invs_queues) apply clarsimp apply (rename_tac list x xa) apply (rule_tac P="x\set list" in case_split) apply (clarsimp simp:st_tcb_at_refs_of_rev') apply (erule_tac x=x and P="\x. st_tcb_at' P x s" for P in ballE) - apply (drule_tac t=x in valid_queues_not_runnable'_not_ksQ) apply (clarsimp simp: st_tcb_at'_def obj_at'_def) apply (subgoal_tac "sch_act_not x s") prefer 2 @@ -6157,23 +6125,20 @@ lemma sendSignal_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) - apply simp+ - apply (erule (1) map_to_ko_atI') - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) - apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def - tcb_queue_relation'_def) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) + apply simp+ + apply (erule (1) map_to_ko_atI') + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) + apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def + tcb_queue_relation'_def) + apply simp apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -6199,30 +6164,27 @@ lemma sendSignal_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) - apply simp+ - apply (erule (1) map_to_ko_atI') - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) - apply (clarsimp simp: cnotification_relation_def Let_def - isWaitingNtfn_def - tcb_queue_relation'_def valid_ntfn'_def - split: Structures_H.notification.splits list.splits - split del: if_split) - apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") - apply (clarsimp dest!: is_aligned_tcb_ptr_to_ctcb_ptr - split del: if_split) - apply (clarsimp split: if_split) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) + apply simp+ + apply (erule (1) map_to_ko_atI') + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) + apply (clarsimp simp: cnotification_relation_def Let_def + isWaitingNtfn_def + tcb_queue_relation'_def valid_ntfn'_def + split: Structures_H.notification.splits list.splits + split del: if_split) + apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") + apply (clarsimp dest!: is_aligned_tcb_ptr_to_ctcb_ptr + split del: if_split) + apply (clarsimp split: if_split) + apply simp apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -6328,7 +6290,7 @@ lemma sendSignal_ccorres [corres]: apply (ctac(no_vcg) add: setThreadState_ccorres) apply (ctac(no_vcg) add: setRegister_ccorres) apply (ctac add: possibleSwitchTo_ccorres) - apply (wp sts_running_valid_queues sts_st_tcb_at'_cases + apply (wp sts_valid_objs' sts_st_tcb_at'_cases | simp add: option_to_ctcb_ptr_def split del: if_split)+ apply (rule_tac Q="\_. tcb_at' (the (ntfnBoundTCB ntfn)) and invs'" in hoare_post_imp) @@ -6394,10 +6356,8 @@ lemma sendSignal_ccorres [corres]: apply (ctac (no_vcg)) apply (ctac add: possibleSwitchTo_ccorres) apply (simp) - apply (wp weak_sch_act_wf_lift_linear - setThreadState_oa_queued - sts_valid_queues tcb_in_cur_domain'_lift)[1] - apply (wp sts_valid_queues sts_runnable) + apply (wp weak_sch_act_wf_lift_linear tcb_in_cur_domain'_lift)[1] + apply (wp sts_valid_objs' sts_runnable) apply (wp setThreadState_st_tcb set_ntfn_valid_objs' | clarsimp)+ apply (clarsimp simp: guard_is_UNIV_def ThreadState_defs mask_def badgeRegister_def Kernel_C.badgeRegister_def @@ -6422,10 +6382,9 @@ lemma sendSignal_ccorres [corres]: done lemma receiveSignal_block_ccorres_helper: - "ccorres dc xfdc (tcb_at' thread and valid_queues and sch_act_not thread and - valid_objs' and ntfn_at' ntfnptr and - (\s. sch_act_wf (ksSchedulerAction s) s \ - (\d p. thread \ set (ksReadyQueues s (d, p)))) and + "ccorres dc xfdc (tcb_at' thread and sch_act_not thread and + valid_objs' and ntfn_at' ntfnptr and pspace_aligned' and pspace_distinct' and + (\s. sch_act_wf (ksSchedulerAction s) s) and K (ntfnptr = ntfnptr && ~~ mask 4)) UNIV hs (setThreadState (Structures_H.thread_state.BlockedOnNotification @@ -6458,7 +6417,7 @@ lemma receiveSignal_block_ccorres_helper: apply ceqv apply clarsimp apply ctac - apply (wp threadSet_valid_queues hoare_vcg_all_lift threadSet_valid_objs' + apply (wp hoare_vcg_all_lift threadSet_valid_objs' threadSet_weak_sch_act_wf_runnable') apply (clarsimp simp: guard_is_UNIV_def) apply (auto simp: weak_sch_act_wf_def valid_tcb'_def tcb_cte_cases_def @@ -6580,31 +6539,28 @@ lemma receiveSignal_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cendpoint_relation_ntfn_queue, assumption+) + apply (simp add: isWaitingNtfn_def) apply simp - apply (rule cendpoint_relation_ntfn_queue, assumption+) - apply (simp add: isWaitingNtfn_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def projectKOs) - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn', assumption+) - apply (case_tac "ntfn", simp_all)[1] - apply (clarsimp simp: cnotification_relation_def Let_def - mask_def [where n=2] NtfnState_Waiting_def) - subgoal by (fastforce simp: tcb_queue_relation'_def is_aligned_neg_mask_weaken - valid_ntfn'_def - dest: tcb_queue_relation_next_not_NULL) - apply (simp add: isWaitingNtfn_def) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - subgoal by (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def projectKOs) + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn', assumption+) + apply (case_tac "ntfn", simp_all)[1] + apply (clarsimp simp: cnotification_relation_def Let_def + mask_def [where n=2] NtfnState_Waiting_def) + subgoal by (fastforce simp: tcb_queue_relation'_def is_aligned_neg_mask_weaken + valid_ntfn'_def + dest: tcb_queue_relation_next_not_NULL) + apply (simp add: isWaitingNtfn_def) apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -6621,30 +6577,27 @@ lemma receiveSignal_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cendpoint_relation_ntfn_queue, assumption+) + apply (simp add: isWaitingNtfn_def) apply simp - apply (rule cendpoint_relation_ntfn_queue, assumption+) - apply (simp add: isWaitingNtfn_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def projectKOs) - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn', assumption+) - apply (case_tac "ntfn", simp_all)[1] - apply (clarsimp simp: cnotification_relation_def Let_def - mask_def [where n=2] NtfnState_Waiting_def - split: if_split) - apply (fastforce simp: tcb_queue_relation'_def is_aligned_neg_mask_weaken) - apply (simp add: isWaitingNtfn_def) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def projectKOs) + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn', assumption+) + apply (case_tac "ntfn", simp_all)[1] + apply (clarsimp simp: cnotification_relation_def Let_def + mask_def [where n=2] NtfnState_Waiting_def + split: if_split) + apply (fastforce simp: tcb_queue_relation'_def is_aligned_neg_mask_weaken) + apply (simp add: isWaitingNtfn_def) apply (simp add: carch_state_relation_def typ_heap_simps') apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -6656,7 +6609,6 @@ lemma receiveSignal_enqueue_ccorres_helper: lemma receiveSignal_ccorres [corres]: "ccorres dc xfdc (invs' and valid_cap' cap and st_tcb_at' simple' thread and sch_act_not thread - and (\s. \d p. thread \ set (ksReadyQueues s (d, p))) and K (isNotificationCap cap)) (UNIV \ \\thread = tcb_ptr_to_ctcb_ptr thread\ \ \ccap_relation cap \cap\ diff --git a/proof/crefine/ARM_HYP/IsolatedThreadAction.thy b/proof/crefine/ARM_HYP/IsolatedThreadAction.thy index fdf7abf47c..9defe6fa56 100644 --- a/proof/crefine/ARM_HYP/IsolatedThreadAction.thy +++ b/proof/crefine/ARM_HYP/IsolatedThreadAction.thy @@ -1152,9 +1152,11 @@ lemma oblivious_switchToThread_schact: threadSet_def tcbSchedEnqueue_def unless_when asUser_def getQueue_def setQueue_def storeWordUser_def setRegister_def pointerInUserData_def isRunnable_def isStopped_def - getThreadState_def tcbSchedDequeue_def bitmap_fun_defs) + getThreadState_def tcbSchedDequeue_def tcbQueueRemove_def bitmap_fun_defs + ksReadyQueues_asrt_def) apply (safe intro!: oblivious_bind - | simp_all add: oblivious_setVMRoot_schact oblivious_vcpuSwitch_schact)+ + | simp_all add: ready_qs_runnable_def idleThreadNotQueued_def oblivious_setVMRoot_schact + oblivious_vcpuSwitch_schact)+ done (* FIXME move *) @@ -1195,9 +1197,8 @@ lemma tcbSchedEnqueue_tcbPriority[wp]: done crunch obj_at_prio[wp]: cteDeleteOne "obj_at' (\tcb. P (tcbPriority tcb)) t" - (wp: crunch_wps setEndpoint_obj_at_tcb' - setThreadState_obj_at_unchanged setNotification_tcb setBoundNotification_obj_at_unchanged - simp: crunch_simps unless_def) + (wp: crunch_wps setEndpoint_obj_at'_tcb setNotification_tcb + simp: crunch_simps unless_def setBoundNotification_def) lemma setThreadState_no_sch_change: "\\s. P (ksSchedulerAction s) \ (runnable' st \ t \ ksCurThread s)\ @@ -1315,8 +1316,6 @@ lemma setCTE_assert_modify: apply (rule word_and_le2) apply (simp add: objBits_simps mask_def field_simps) apply (simp add: simpler_modify_def cong: option.case_cong if_cong) - apply (rule kernel_state.fold_congs[OF refl refl]) - apply (clarsimp simp: projectKO_opt_tcb cong: if_cong) apply (clarsimp simp: lookupAround2_char1 word_and_le2) apply (rule ccontr, clarsimp) apply (erule(2) ps_clearD) @@ -1455,11 +1454,14 @@ lemma thread_actions_isolatableD: lemma tcbSchedDequeue_rewrite: "monadic_rewrite True True (obj_at' (Not \ tcbQueued) t) (tcbSchedDequeue t) (return ())" apply (simp add: tcbSchedDequeue_def) - apply (wp_pre, monadic_rewrite_symb_exec_l_known False, simp) - apply (rule monadic_rewrite_refl) - apply (wpsimp wp: threadGet_const)+ + apply wp_pre + apply monadic_rewrite_symb_exec_l + apply (monadic_rewrite_symb_exec_l_known False, simp) + apply (rule monadic_rewrite_refl) + apply (wpsimp wp: threadGet_const)+ done +(* FIXME: improve automation here *) lemma switchToThread_rewrite: "monadic_rewrite True True (ct_in_state' (Not \ runnable') and cur_tcb' and obj_at' (Not \ tcbQueued) t) @@ -1467,7 +1469,9 @@ lemma switchToThread_rewrite: (do Arch.switchToThread t; setCurThread t od)" apply (simp add: switchToThread_def Thread_H.switchToThread_def) apply (monadic_rewrite_l tcbSchedDequeue_rewrite, simp) - apply (rule monadic_rewrite_refl) + (* strip LHS of getters and asserts until LHS and RHS are the same *) + apply (repeat_unless \rule monadic_rewrite_refl\ monadic_rewrite_symb_exec_l) + apply wpsimp+ apply (clarsimp simp: comp_def) done @@ -1509,9 +1513,33 @@ lemma switchToThread_isolatable: split: tcb_state_regs.split)+ done +lemma tcbQueued_put_tcb_state_regs_tcb: + "tcbQueued (put_tcb_state_regs_tcb tsr tcb) = tcbQueued tcb" + apply (clarsimp simp: put_tcb_state_regs_tcb_def) + by (cases tsr; clarsimp) + +lemma idleThreadNotQueued_isolatable: + "thread_actions_isolatable idx (stateAssert idleThreadNotQueued [])" + apply (simp add: stateAssert_def2 stateAssert_def) + apply (intro thread_actions_isolatable_bind[OF _ _ hoare_pre(1)] + gets_isolatable + thread_actions_isolatable_if + thread_actions_isolatable_returns + thread_actions_isolatable_fail) + unfolding idleThreadNotQueued_def + apply (clarsimp simp: obj_at_partial_overwrite_If) + apply (clarsimp simp: obj_at'_def tcbQueued_put_tcb_state_regs_tcb) + apply wpsimp+ + done + lemma setCurThread_isolatable: "thread_actions_isolatable idx (setCurThread t)" - by (simp add: setCurThread_def modify_isolatable) + unfolding setCurThread_def + apply (rule thread_actions_isolatable_bind) + apply (rule idleThreadNotQueued_isolatable) + apply (fastforce intro: modify_isolatable) + apply wpsimp + done lemma isolate_thread_actions_tcbs_at: assumes f: "\x. \tcb_at' (idx x)\ f \\rv. tcb_at' (idx x)\" shows diff --git a/proof/crefine/ARM_HYP/Recycle_C.thy b/proof/crefine/ARM_HYP/Recycle_C.thy index 2c5622949b..14ea1378ab 100644 --- a/proof/crefine/ARM_HYP/Recycle_C.thy +++ b/proof/crefine/ARM_HYP/Recycle_C.thy @@ -889,16 +889,6 @@ lemma cnotification_relation_q_cong: apply (auto intro: iffD1[OF tcb_queue_relation'_cong[OF refl refl refl]]) done -lemma tcbSchedEnqueue_ep_at: - "\obj_at' (P :: endpoint \ bool) ep\ - tcbSchedEnqueue t - \\rv. obj_at' P ep\" - including no_pre - apply (simp add: tcbSchedEnqueue_def unless_def null_def) - apply (wp threadGet_wp, clarsimp, wp+) - apply (clarsimp split: if_split, wp) - done - lemma ccorres_duplicate_guard: "ccorres r xf (P and P) Q hs f f' \ ccorres r xf P Q hs f f'" by (erule ccorres_guard_imp, auto) @@ -918,10 +908,11 @@ lemma cancelBadgedSends_ccorres: (UNIV \ {s. epptr_' s = Ptr ptr} \ {s. badge_' s = bdg}) [] (cancelBadgedSends ptr bdg) (Call cancelBadgedSends_'proc)" apply (cinit lift: epptr_' badge_' simp: whileAnno_def) + apply (rule ccorres_stateAssert) apply (simp add: list_case_return cong: list.case_cong Structures_H.endpoint.case_cong call_ignore_cong del: Collect_const) - apply (rule ccorres_pre_getEndpoint) + apply (rule ccorres_pre_getEndpoint, rename_tac ep) apply (rule_tac R="ko_at' ep ptr" and xf'="ret__unsigned_'" and val="case ep of RecvEP q \ scast EPState_Recv | IdleEP \ scast EPState_Idle | SendEP q \ scast EPState_Send" @@ -973,8 +964,9 @@ lemma cancelBadgedSends_ccorres: st_tcb_at' (\st. isBlockedOnSend st \ blockingObject st = ptr) x s) \ distinct (xs @ list) \ ko_at' IdleEP ptr s \ (\p. \x \ set (xs @ list). \rf. (x, rf) \ {r \ state_refs_of' s p. snd r \ NTFNBound}) - \ valid_queues s \ pspace_aligned' s \ pspace_distinct' s - \ sch_act_wf (ksSchedulerAction s) s \ valid_objs' s" + \ pspace_aligned' s \ pspace_distinct' s + \ sch_act_wf (ksSchedulerAction s) s \ valid_objs' s + \ ksReadyQueues_head_end s \ ksReadyQueues_head_end_tcb_at' s" and P'="\xs. {s. ep_queue_relation' (cslift s) (xs @ list) (head_C (queue_' s)) (end_C (queue_' s))} \ {s. thread_' s = (case list of [] \ tcb_Ptr 0 @@ -1070,8 +1062,9 @@ lemma cancelBadgedSends_ccorres: apply (rule_tac rrel=dc and xf=xfdc and P="\s. (\t \ set (x @ a # lista). tcb_at' t s) \ (\p. \t \ set (x @ a # lista). \rf. (t, rf) \ {r \ state_refs_of' s p. snd r \ NTFNBound}) - \ valid_queues s \ distinct (x @ a # lista) - \ pspace_aligned' s \ pspace_distinct' s" + \ distinct (x @ a # lista) + \ pspace_aligned' s \ pspace_distinct' s + \ ksReadyQueues_head_end s \ ksReadyQueues_head_end_tcb_at' s" and P'="{s. ep_queue_relation' (cslift s) (x @ a # lista) (head_C (queue_' s)) (end_C (queue_' s))}" in ccorres_from_vcg) @@ -1087,8 +1080,7 @@ lemma cancelBadgedSends_ccorres: apply (clarsimp simp: return_def rf_sr_def cstate_relation_def Let_def) apply (rule conjI) apply (clarsimp simp: cpspace_relation_def) - apply (rule conjI, erule ctcb_relation_null_queue_ptrs) - apply (rule null_ep_queue) + apply (rule conjI, erule ctcb_relation_null_ep_ptrs) subgoal by (simp add: o_def) apply (rule conjI) apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) @@ -1111,9 +1103,6 @@ lemma cancelBadgedSends_ccorres: apply (clarsimp simp: image_iff) apply (drule_tac x=p in spec) subgoal by fastforce - apply (rule conjI) - apply (erule cready_queues_relation_not_queue_ptrs; - fastforce dest: null_ep_schedD[unfolded o_def] simp: o_def) apply (simp add: carch_state_relation_def cmachine_state_relation_def h_t_valid_clift_Some_iff) @@ -1124,12 +1113,11 @@ lemma cancelBadgedSends_ccorres: apply wp apply simp apply vcg - apply (wp hoare_vcg_const_Ball_lift tcbSchedEnqueue_ep_at - sch_act_wf_lift) + apply (wp hoare_vcg_const_Ball_lift sch_act_wf_lift) apply simp apply (vcg exspec=tcbSchedEnqueue_cslift_spec) apply (wp hoare_vcg_const_Ball_lift sts_st_tcb_at'_cases - sts_sch_act sts_valid_queues setThreadState_oa_queued) + sts_sch_act sts_valid_objs') apply (vcg exspec=setThreadState_cslift_spec) apply (simp add: ccorres_cond_iffs) apply (rule ccorres_symb_exec_r2) @@ -1153,14 +1141,11 @@ lemma cancelBadgedSends_ccorres: apply (clarsimp simp: cscheduler_action_relation_def st_tcb_at'_def split: scheduler_action.split_asm) apply (rename_tac word) - apply (frule_tac x=word in tcbSchedEnqueue_cslift_precond_discharge) - apply simp - subgoal by clarsimp - subgoal by clarsimp + apply (frule_tac x=word in tcbSchedEnqueue_cslift_precond_discharge; simp?) subgoal by clarsimp apply clarsimp apply (rule conjI) - apply (frule(3) tcbSchedEnqueue_cslift_precond_discharge) + apply (frule tcbSchedEnqueue_cslift_precond_discharge; simp?) subgoal by clarsimp apply clarsimp apply (rule context_conjI) @@ -1200,9 +1185,19 @@ lemma cancelBadgedSends_ccorres: apply (clarsimp split: if_split) apply (drule sym_refsD, clarsimp) apply (drule(1) bspec)+ - by (auto simp: obj_at'_def projectKOs state_refs_of'_def pred_tcb_at'_def tcb_bound_refs'_def - dest!: symreftype_inverse') - + apply (frule ksReadyQueues_asrt_ksReadyQueues_head_end) + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (frule (2) ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at') + apply (fastforce simp: obj_at'_def projectKOs state_refs_of'_def pred_tcb_at'_def + tcb_bound_refs'_def + dest!: symreftype_inverse') + apply (frule ksReadyQueues_asrt_ksReadyQueues_head_end) + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (frule (2) ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at') + apply fastforce + done lemma tcb_ptr_to_ctcb_ptr_force_fold: "x + 2 ^ ctcb_size_bits = ptr_val (tcb_ptr_to_ctcb_ptr x)" diff --git a/proof/crefine/ARM_HYP/Refine_C.thy b/proof/crefine/ARM_HYP/Refine_C.thy index 2d20a22fa7..90daae6955 100644 --- a/proof/crefine/ARM_HYP/Refine_C.thy +++ b/proof/crefine/ARM_HYP/Refine_C.thy @@ -60,7 +60,7 @@ proof - apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply simp apply vcg apply vcg @@ -74,14 +74,13 @@ proof - apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply simp apply (rule_tac Q="\rv s. invs' s \ (\x. rv = Some x \ x \ ARM_HYP.maxIRQ) \ rv \ Some 0x3FF \ - sch_act_not (ksCurThread s) s \ - (\p. ksCurThread s \ set (ksReadyQueues s p))" in hoare_post_imp) + sch_act_not (ksCurThread s) s" + in hoare_post_imp) apply (clarsimp simp: Kernel_C.maxIRQ_def ARM_HYP.maxIRQ_def) apply (wp getActiveIRQ_le_maxIRQ getActiveIRQ_neq_Some0xFF | simp)+ - apply (clarsimp simp: ct_not_ksQ) apply (clarsimp simp: invs'_def valid_state'_def) done qed @@ -107,14 +106,12 @@ lemma handleUnknownSyscall_ccorres: apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (clarsimp, vcg) apply (clarsimp, rule conseqPre, vcg, clarsimp) apply clarsimp apply (intro impI conjI allI) - apply fastforce - apply (clarsimp simp: ct_not_ksQ) - apply (clarsimp simp add: sch_act_simple_def split: scheduler_action.split) + apply fastforce apply (rule active_ex_cap') apply (erule active_from_running') apply (erule invs_iflive') @@ -167,13 +164,13 @@ lemma handleVMFaultEvent_ccorres: apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (case_tac x, clarsimp, wp) apply (clarsimp, wp, simp) apply wp apply (simp add: guard_is_UNIV_def) apply (clarsimp simp: simple_sane_strg[unfolded sch_act_sane_not]) - by (auto simp: ct_in_state'_def cfault_rel_def is_cap_fault_def ct_not_ksQ + by (auto simp: ct_in_state'_def cfault_rel_def is_cap_fault_def elim: pred_tcb'_weakenE st_tcb_ex_cap'' dest: st_tcb_at_idle_thread' rf_sr_ksCurThread) @@ -199,16 +196,14 @@ lemma handleUserLevelFault_ccorres: apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (clarsimp, vcg) apply (clarsimp, rule conseqPre, vcg, clarsimp) apply clarsimp apply (intro impI conjI allI) - apply (simp add: ct_in_state'_def) - apply (erule pred_tcb'_weakenE) - apply simp - apply (clarsimp simp: ct_not_ksQ) - apply (clarsimp simp add: sch_act_simple_def split: scheduler_action.split) + apply (simp add: ct_in_state'_def) + apply (erule pred_tcb'_weakenE) + apply simp apply (rule active_ex_cap') apply (erule active_from_running') apply (erule invs_iflive') @@ -388,11 +383,10 @@ lemma handleSyscall_ccorres: apply wp[1] apply clarsimp apply wp - apply (rule_tac Q="\rv s. ct_in_state' simple' s \ sch_act_sane s \ - (\p. ksCurThread s \ set (ksReadyQueues s p))" + apply (rule_tac Q="\rv s. ct_in_state' simple' s \ sch_act_sane s" in hoare_post_imp) apply (simp add: ct_in_state'_def) - apply (wp handleReply_sane handleReply_ct_not_ksQ) + apply (wp handleReply_sane) \ \SysYield\ apply (clarsimp simp: syscall_from_H_def syscall_defs) apply (rule ccorres_cond_empty |rule ccorres_cond_univ)+ @@ -418,14 +412,14 @@ lemma handleSyscall_ccorres: apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg_throws) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) - apply (wp schedule_invs' schedule_sch_act_wf | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + apply (wp schedule_invs' schedule_sch_act_wf + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (wpsimp wp: hoare_vcg_if_lift3) apply (strengthen non_kernel_IRQs_strg[where Q=True, simplified]) apply (wpsimp wp: hoare_drop_imps) apply (simp | wpc | wp hoare_drop_imp handleReply_sane handleReply_nonz_cap_to_ct schedule_invs' - handleReply_ct_not_ksQ[simplified] | strengthen ct_active_not_idle'_strengthen invs_valid_objs_strengthen)+ apply (rule_tac Q="\rv. invs' and ct_active'" in hoare_post_imp, simp) apply (wp hy_invs') @@ -443,7 +437,7 @@ lemma handleSyscall_ccorres: apply (frule active_ex_cap') apply (clarsimp simp: invs'_def valid_state'_def) apply (clarsimp simp: simple_sane_strg ct_in_state'_def st_tcb_at'_def obj_at'_def - isReply_def ct_not_ksQ) + isReply_def) apply (rule conjI, fastforce) prefer 2 apply (cut_tac 'b=32 and x=a and n=10 and 'a=10 in ucast_leq_mask) @@ -535,14 +529,15 @@ lemma handleVCPUFault_ccorres: apply (ctac (no_vcg) add: activateThread_ccorres) apply (clarsimp, assumption) apply assumption - apply (wp schedule_sch_act_wf schedule_invs'|strengthen invs_queues invs_valid_objs')+ + apply (wp schedule_sch_act_wf schedule_invs' + | strengthen invs_valid_objs' invs_pspace_aligned' invs_pspace_distinct')+ apply vcg apply (clarsimp, rule conseqPre, vcg) apply clarsimp apply vcg apply (clarsimp, rule conseqPre, vcg) apply clarsimp - apply (clarsimp simp: ct_not_ksQ ct_running_imp_simple' fastpathKernelAssertions_def) + apply (clarsimp simp: ct_running_imp_simple' fastpathKernelAssertions_def) apply (rule conjI, rule active_ex_cap', erule active_from_running', fastforce) apply (clarsimp simp: cfault_rel_def seL4_Fault_VCPUFault_lift is_cap_fault_def) done @@ -662,6 +657,7 @@ lemma callKernel_withFastpath_corres_C: apply (clarsimp simp: typ_heap_simps' ct_in_state'_def "StrictC'_register_defs" word_sle_def word_sless_def st_tcb_at'_opeq_simp) + apply (frule ready_qs_runnable_cross, (fastforce simp: valid_sched_def)+) apply (rule conjI, fastforce simp: st_tcb_at'_def) apply (auto elim!: pred_tcb'_weakenE cnode_caps_gsCNodes_from_sr[rotated]) done @@ -678,10 +674,13 @@ lemma threadSet_all_invs_triv': apply (rule hoare_pre) apply (rule wp_from_corres_unit) apply (rule threadset_corresT [where f="tcb_arch_update (arch_tcb_context_set f)"]) - apply (simp add: tcb_relation_def arch_tcb_context_set_def - atcbContextSet_def arch_tcb_relation_def) - apply (simp add: tcb_cap_cases_def) - apply (simp add: tcb_cte_cases_def) + apply (simp add: tcb_relation_def arch_tcb_context_set_def + atcbContextSet_def arch_tcb_relation_def) + apply (simp add: tcb_cap_cases_def) + apply (simp add: tcb_cte_cases_def) + apply fastforce + apply fastforce + apply fastforce apply (simp add: exst_same_def) apply (wp thread_set_invs_trivial thread_set_ct_running thread_set_not_state_valid_sched threadSet_invs_trivial threadSet_ct_running' hoare_weak_lift_imp @@ -691,7 +690,7 @@ lemma threadSet_all_invs_triv': | wp (once) hoare_vcg_disj_lift)+ apply clarsimp apply (rule exI, rule conjI, assumption) - apply (clarsimp simp: invs_def invs'_def cur_tcb_def cur_tcb'_def) + apply (clarsimp simp: invs_def valid_state_def valid_pspace_def invs'_def cur_tcb_def) apply (simp add: state_relation_def) done @@ -903,17 +902,22 @@ lemma dmo_domain_user_mem'[wp]: done lemma do_user_op_corres_C: - "corres_underlying rf_sr False False (=) (invs' and ex_abs einvs) \ - (doUserOp f tc) (doUserOp_C f tc)" + "corres_underlying rf_sr False False (=) + (invs' and ksReadyQueues_asrt and ex_abs einvs) \ + (doUserOp f tc) (doUserOp_C f tc)" apply (simp only: doUserOp_C_def doUserOp_def split_def) apply (rule corres_guard_imp) apply (rule_tac P=\ and P'=\ and r'="(=)" in corres_split) apply (clarsimp simp: simpler_gets_def getCurThread_def corres_underlying_def rf_sr_def cstate_relation_def Let_def) - apply (rule_tac P=valid_state' and P'=\ and r'="(=)" in corres_split) + apply (rule_tac P="valid_state' and ksReadyQueues_asrt" + and P'=\ and r'="(=)" + in corres_split) apply (clarsimp simp: cstate_to_A_def absKState_def rf_sr_def cstate_to_H_correct ptable_lift_def) - apply (rule_tac P=valid_state' and P'=\ and r'="(=)" in corres_split) + apply (rule_tac P="valid_state' and ksReadyQueues_asrt" + and P'=\ and r'="(=)" + in corres_split) apply (clarsimp simp: cstate_to_A_def absKState_def rf_sr_def cstate_to_H_correct ptable_rights_def) apply (rule_tac P=pspace_distinct' and P'=\ and r'="(=)" @@ -1010,6 +1014,9 @@ lemma refinement2_both: apply (subst cstate_to_H_correct) apply (fastforce simp: full_invs'_def invs'_def) apply (clarsimp simp: rf_sr_def) + apply (clarsimp simp: lift_state_relation_def full_invs_def) + apply (rule ksReadyQueues_asrt_cross) + apply (erule state_relation_ready_queues_relation) apply (simp add:absKState_def observable_memory_def absExst_def) apply (rule MachineTypes.machine_state.equality,simp_all)[1] apply (rule ext) @@ -1036,13 +1043,35 @@ lemma refinement2_both: apply (clarsimp simp add: do_user_op_C_def do_user_op_H_def monad_to_transition_def) apply (rule rev_mp, rule_tac f="uop" and tc=af in do_user_op_corres_C) apply (clarsimp simp: corres_underlying_def invs_def ex_abs_def) - apply (fastforce simp: full_invs'_def ex_abs_def) + apply (drule bspec) + apply fastforce + apply clarsimp + apply (elim impE) + apply (clarsimp simp: full_invs'_def ex_abs_def) + apply (intro conjI) + apply (rule ksReadyQueues_asrt_cross) + apply (erule state_relation_ready_queues_relation) + apply (clarsimp simp: lift_state_relation_def full_invs_def) + apply (frule state_relation_ready_queues_relation) + apply (fastforce simp: ready_queues_relation_def Let_def tcbQueueEmpty_def) + apply fastforce apply (erule_tac P="a \ b \ c \ (\x. e x)" for a b c d e in disjE) apply (clarsimp simp add: do_user_op_C_def do_user_op_H_def monad_to_transition_def) apply (rule rev_mp, rule_tac f="uop" and tc=af in do_user_op_corres_C) apply (clarsimp simp: corres_underlying_def invs_def ex_abs_def) - apply (fastforce simp: full_invs'_def ex_abs_def) + apply (drule bspec) + apply fastforce + apply clarsimp + apply (elim impE) + apply (clarsimp simp: full_invs'_def ex_abs_def) + apply (intro conjI) + apply (rule ksReadyQueues_asrt_cross) + apply (erule state_relation_ready_queues_relation) + apply (clarsimp simp: lift_state_relation_def full_invs_def) + apply (frule state_relation_ready_queues_relation) + apply (fastforce simp: ready_queues_relation_def Let_def tcbQueueEmpty_def) + apply fastforce apply (clarsimp simp: check_active_irq_C_def check_active_irq_H_def) apply (rule rev_mp, rule check_active_irq_corres_C) diff --git a/proof/crefine/ARM_HYP/Retype_C.thy b/proof/crefine/ARM_HYP/Retype_C.thy index 1b2921f73d..8f91f1589a 100644 --- a/proof/crefine/ARM_HYP/Retype_C.thy +++ b/proof/crefine/ARM_HYP/Retype_C.thy @@ -3054,7 +3054,6 @@ lemma cnc_tcb_helper: and al: "is_aligned (ctcb_ptr_to_tcb_ptr p) (objBitsKO kotcb)" and ptr0: "ctcb_ptr_to_tcb_ptr p \ 0" and ptrlb: "2^ctcb_size_bits \ ptr_val p" - and vq: "valid_queues \" and pal: "pspace_aligned' (\\ksPSpace := ks\)" and pno: "pspace_no_overlap' (ctcb_ptr_to_tcb_ptr p) (objBitsKO kotcb) (\\ksPSpace := ks\)" and pds: "pspace_distinct' (\\ksPSpace := ks\)" @@ -3431,9 +3430,10 @@ proof - apply (simp add: thread_state_lift_def eval_nat_numeral atcbContextGet_def)+ apply (simp add: Kernel_Config.timeSlice_def) apply (simp add: cfault_rel_def seL4_Fault_lift_def seL4_Fault_get_tag_def Let_def - lookup_fault_lift_def lookup_fault_get_tag_def lookup_fault_invalid_root_def - eval_nat_numeral seL4_Fault_NullFault_def option_to_ptr_def option_to_0_def - split: if_split)+ + lookup_fault_lift_def lookup_fault_get_tag_def lookup_fault_invalid_root_def + eval_nat_numeral seL4_Fault_NullFault_def option_to_ptr_def option_to_0_def + option_to_ctcb_ptr_def + split: if_split)+ done have pks: "ks (ctcb_ptr_to_tcb_ptr p) = None" @@ -3484,15 +3484,6 @@ proof - apply (fastforce simp: dom_def) done - hence kstcb: "\qdom prio. ctcb_ptr_to_tcb_ptr p \ set (ksReadyQueues \ (qdom, prio))" using vq - apply (clarsimp simp add: valid_queues_def valid_queues_no_bitmap_def) - apply (drule_tac x = qdom in spec) - apply (drule_tac x = prio in spec) - apply clarsimp - apply (drule (1) bspec) - apply (simp add: obj_at'_def) - done - have ball_subsetE: "\P S R. \ \x \ S. P x; R \ S \ \ \x \ R. P x" by blast @@ -3606,7 +3597,7 @@ proof - apply (simp add: cl_cte [simplified] cl_tcb [simplified] cl_rest [simplified] tag_disj_via_td_name) apply (clarsimp simp add: cready_queues_relation_def Let_def htd_safe[simplified] kernel_data_refs_domain_eq_rotate) - apply (simp add: kstcb tcb_queue_update_other' hrs_htd_update + apply (simp add: tcb_queue_update_other' hrs_htd_update ptr_retyp_to_array[simplified] irq[simplified]) done qed @@ -4555,7 +4546,7 @@ declare replicate_numeral [simp del] lemma ccorres_placeNewObject_tcb: "ccorresG rf_sr \ dc xfdc (pspace_aligned' and pspace_distinct' and pspace_no_overlap' regionBase tcbBlockSizeBits - and valid_queues and (\s. sym_refs (state_refs_of' s)) + and (\s. sym_refs (state_refs_of' s)) and (\s. 2 ^ tcbBlockSizeBits \ gsMaxObjectSize s) and ret_zero regionBase (2 ^ tcbBlockSizeBits) and K (regionBase \ 0 \ range_cover regionBase tcbBlockSizeBits tcbBlockSizeBits 1 @@ -4892,7 +4883,7 @@ qed lemma placeNewObject_user_data: "ccorresG rf_sr \ dc xfdc (pspace_aligned' and pspace_distinct' and pspace_no_overlap' regionBase (pageBits+us) - and valid_queues and valid_machine_state' + and valid_machine_state' and ret_zero regionBase (2 ^ (pageBits+us)) and (\s. sym_refs (state_refs_of' s)) and (\s. 2^(pageBits + us) \ gsMaxObjectSize s) @@ -5033,7 +5024,7 @@ lemma placeNewObject_user_data_device: "ccorresG rf_sr \ dc xfdc (pspace_aligned' and pspace_distinct' and ret_zero regionBase (2 ^ (pageBits + us)) - and pspace_no_overlap' regionBase (pageBits+us) and valid_queues + and pspace_no_overlap' regionBase (pageBits+us) and (\s. sym_refs (state_refs_of' s)) and (\s. 2^(pageBits + us) \ gsMaxObjectSize s) and K (regionBase \ 0 \ range_cover regionBase (pageBits + us) (pageBits+us) (Suc 0) @@ -5843,7 +5834,7 @@ proof - apply clarify apply (intro conjI) apply (clarsimp simp: invs_pspace_aligned' invs_pspace_distinct' invs_valid_global' - APIType_capBits_def invs_queues invs_valid_objs' + APIType_capBits_def invs_valid_objs' invs_urz) apply clarsimp apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def @@ -5999,11 +5990,6 @@ lemma threadSet_domain_ccorres [corres]: apply (simp add: map_to_ctes_upd_tcb_no_ctes map_to_tcbs_upd tcb_cte_cases_def) apply (simp add: cep_relations_drop_fun_upd cvariable_relation_upd_const ko_at_projectKO_opt) - apply (rule conjI) - defer - apply (erule cready_queues_relation_not_queue_ptrs) - apply (rule ext, simp split: if_split) - apply (rule ext, simp split: if_split) apply (drule ko_at_projectKO_opt) apply (erule (2) cmap_relation_upd_relI) subgoal by (simp add: ctcb_relation_def) @@ -6127,7 +6113,6 @@ proof - createObject_c_preconds_def) apply (frule invs_pspace_aligned') apply (frule invs_pspace_distinct') - apply (frule invs_queues) apply (frule invs_sym') apply (simp add: getObjectSize_def objBits_simps word_bits_conv ARM_HYP_H.getObjectSize_def apiGetObjectSize_def @@ -6181,7 +6166,6 @@ proof - apply (clarsimp simp: createObject_hs_preconds_def isFrameType_def) apply (frule invs_pspace_aligned') apply (frule invs_pspace_distinct') - apply (frule invs_queues) apply (frule invs_sym') apply (auto simp: getObjectSize_def objBits_simps ARM_HYP_H.getObjectSize_def apiGetObjectSize_def @@ -6222,7 +6206,6 @@ proof - apply (clarsimp simp: createObject_hs_preconds_def isFrameType_def) apply (frule invs_pspace_aligned') apply (frule invs_pspace_distinct') - apply (frule invs_queues) apply (frule invs_sym') apply (auto simp: getObjectSize_def objBits_simps ARM_HYP_H.getObjectSize_def apiGetObjectSize_def @@ -6265,7 +6248,6 @@ proof - apply (clarsimp simp: createObject_hs_preconds_def isFrameType_def) apply (frule invs_pspace_aligned') apply (frule invs_pspace_distinct') - apply (frule invs_queues) apply (frule invs_sym') apply (frule(1) ghost_assertion_size_logic_no_unat) apply (clarsimp simp: objBits_simps ARM_HYP_H.getObjectSize_def apiGetObjectSize_def diff --git a/proof/crefine/ARM_HYP/SR_lemmas_C.thy b/proof/crefine/ARM_HYP/SR_lemmas_C.thy index 3de04ec5ea..1fd9818801 100644 --- a/proof/crefine/ARM_HYP/SR_lemmas_C.thy +++ b/proof/crefine/ARM_HYP/SR_lemmas_C.thy @@ -310,11 +310,15 @@ lemma cmdbnode_relation_mdb_node_to_H [simp]: unfolding cmdbnode_relation_def mdb_node_to_H_def mdb_node_lift_def cte_lift_def by (fastforce split: option.splits) -definition - tcb_no_ctes_proj :: "tcb \ Structures_H.thread_state \ word32 \ word32 \ arch_tcb \ bool \ word8 \ word8 \ word8 \ nat \ fault option \ word32 option" +definition tcb_no_ctes_proj :: + "tcb \ Structures_H.thread_state \ machine_word \ machine_word \ arch_tcb \ bool \ word8 + \ word8 \ word8 \ nat \ fault option \ machine_word option + \ machine_word option \ machine_word option" where - "tcb_no_ctes_proj t \ (tcbState t, tcbFaultHandler t, tcbIPCBuffer t, tcbArch t, tcbQueued t, - tcbMCP t, tcbPriority t, tcbDomain t, tcbTimeSlice t, tcbFault t, tcbBoundNotification t)" + "tcb_no_ctes_proj t \ + (tcbState t, tcbFaultHandler t, tcbIPCBuffer t, tcbArch t, tcbQueued t, + tcbMCP t, tcbPriority t, tcbDomain t, tcbTimeSlice t, tcbFault t, tcbBoundNotification t, + tcbSchedNext t, tcbSchedPrev t)" lemma tcb_cte_cases_proj_eq [simp]: "tcb_cte_cases p = Some (getF, setF) \ @@ -1488,9 +1492,9 @@ lemma cmap_relation_cong: apply (erule imageI) done -lemma ctcb_relation_null_queue_ptrs: +lemma ctcb_relation_null_ep_ptrs: assumes rel: "cmap_relation mp mp' tcb_ptr_to_ctcb_ptr ctcb_relation" - and same: "map_option tcb_null_queue_ptrs \ mp'' = map_option tcb_null_queue_ptrs \ mp'" + and same: "map_option tcb_null_ep_ptrs \ mp'' = map_option tcb_null_ep_ptrs \ mp'" shows "cmap_relation mp mp'' tcb_ptr_to_ctcb_ptr ctcb_relation" using rel apply (rule iffD1 [OF cmap_relation_cong, OF _ map_option_eq_dom_eq, rotated -1]) @@ -1498,7 +1502,7 @@ lemma ctcb_relation_null_queue_ptrs: apply (rule same [symmetric]) apply (drule compD [OF same]) apply (case_tac b, case_tac b') - apply (simp add: ctcb_relation_def tcb_null_queue_ptrs_def) + apply (simp add: ctcb_relation_def tcb_null_ep_ptrs_def) done (* Levity: added (20090419 09:44:27) *) @@ -2406,6 +2410,14 @@ lemma update_vcpu_map_to_vcpu: = (map_to_vcpus (ksPSpace s))(p \ vcpu)" by (rule ext, clarsimp simp: projectKOs map_comp_def split: if_split) +lemma rf_sr_ctcb_queue_relation: + "\ (s, s') \ rf_sr; d \ maxDomain; p \ maxPriority \ + \ ctcb_queue_relation (ksReadyQueues s (d, p)) + (index (ksReadyQueues_' (globals s')) (cready_queues_index_to_C d p))" + unfolding rf_sr_def cstate_relation_def cready_queues_relation_def + apply (clarsimp simp: Let_def seL4_MinPrio_def minDom_def maxDom_to_H maxPrio_to_H) + done + lemma rf_sr_sched_action_relation: "(s, s') \ rf_sr \ cscheduler_action_relation (ksSchedulerAction s) (ksSchedulerAction_' (globals s'))" @@ -2444,5 +2456,11 @@ lemma physBase_spec: apply (simp add: Kernel_Config.physBase_def) done +lemma rf_sr_obj_update_helper: + "(s, s'\ globals := globals s' \ t_hrs_' := t_hrs_' (globals (undefined + \ globals := (undefined \ t_hrs_' := f (globals s') (t_hrs_' (globals s')) \)\))\\) \ rf_sr + \ (s, globals_update (\v. t_hrs_'_update (f v) v) s') \ rf_sr" + by (simp cong: StateSpace.state.fold_congs globals.fold_congs) + end end diff --git a/proof/crefine/ARM_HYP/Schedule_C.thy b/proof/crefine/ARM_HYP/Schedule_C.thy index 8e632b4fb6..4c0ca2714c 100644 --- a/proof/crefine/ARM_HYP/Schedule_C.thy +++ b/proof/crefine/ARM_HYP/Schedule_C.thy @@ -6,25 +6,11 @@ *) theory Schedule_C -imports Tcb_C +imports Tcb_C Detype_C begin instance tcb :: no_vcpu by intro_classes auto -context begin interpretation Arch . (*FIXME: arch_split*) - -(* FIXME: Move to Refine *) -crunches Arch.switchToThread - for valid_queues'[wp]: valid_queues' - (ignore: clearExMonitor wp: crunch_wps) -crunches switchToIdleThread - for ksCurDomain[wp]: "\s. P (ksCurDomain s)" -crunches switchToIdleThread, switchToThread - for valid_pspace'[wp]: valid_pspace' - (simp: whenE_def) - -end - (*FIXME: arch_split: move up?*) context Arch begin context begin global_naming global @@ -51,16 +37,17 @@ lemma switchToIdleThread_ccorres: "ccorres dc xfdc invs_no_cicd' UNIV hs switchToIdleThread (Call switchToIdleThread_'proc)" apply (cinit) + apply (rule ccorres_stateAssert) apply (rule ccorres_symb_exec_l) apply (ctac (no_vcg) add: Arch_switchToIdleThread_ccorres) apply (simp add: setCurThread_def) + apply (rule ccorres_stateAssert) apply (rule_tac P="\s. thread = ksIdleThread s" and P'=UNIV in ccorres_from_vcg) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: simpler_modify_def) apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def carch_state_relation_def cmachine_state_relation_def) - apply (wpsimp simp: ARM_HYP_H.switchToIdleThread_def - wp: vcpuSwitch_it')+ + apply (wpsimp simp: ARM_HYP_H.switchToIdleThread_def wp: hoare_drop_imps)+ done lemma Arch_switchToThread_ccorres: @@ -94,6 +81,13 @@ lemma Arch_switchToThread_ccorres: apply (clarsimp simp: typ_heap_simps ctcb_relation_def carch_tcb_relation_def) done +lemma invs_no_cicd'_pspace_aligned': + "all_invs_but_ct_idle_or_in_cur_domain' s \ pspace_aligned' s" + by (simp add: all_invs_but_ct_idle_or_in_cur_domain'_def valid_pspace'_def) + +lemma invs_no_cicd'_pspace_distinct': + "all_invs_but_ct_idle_or_in_cur_domain' s \ pspace_distinct' s" + by (simp add: all_invs_but_ct_idle_or_in_cur_domain'_def valid_pspace'_def) (* FIXME: move *) lemma switchToThread_ccorres: @@ -103,23 +97,28 @@ lemma switchToThread_ccorres: hs (switchToThread t) (Call switchToThread_'proc)" - apply (cinit lift: thread_') + apply (clarsimp simp: switchToThread_def) + apply (rule ccorres_symb_exec_l'[OF _ _ isRunnable_sp]; (solves wpsimp)?) + apply (rule ccorres_symb_exec_l'[OF _ _ assert_sp]; (solves wpsimp)?) + apply (rule ccorres_stateAssert_fwd)+ + apply (cinit' lift: thread_') apply (ctac (no_vcg) add: Arch_switchToThread_ccorres) apply (ctac (no_vcg) add: tcbSchedDequeue_ccorres) + apply (simp add: setCurThread_def) + apply (rule ccorres_stateAssert) apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg) apply clarsimp apply (rule conseqPre, vcg) - apply (clarsimp simp: setCurThread_def simpler_modify_def) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def) - apply wp+ - apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def) + apply (clarsimp simp: setCurThread_def simpler_modify_def rf_sr_def cstate_relation_def + Let_def carch_state_relation_def cmachine_state_relation_def) + apply (wpsimp wp: Arch_switchToThread_invs_no_cicd' hoare_drop_imps + | strengthen invs_no_cicd'_pspace_aligned' invs_no_cicd'_pspace_distinct')+ done lemma activateThread_ccorres: "ccorres dc xfdc (ct_in_state' activatable' and (\s. sch_act_wf (ksSchedulerAction s) s) - and valid_queues and valid_objs') + and valid_objs' and pspace_aligned' and pspace_distinct') UNIV [] activateThread (Call activateThread_'proc)" @@ -209,12 +208,36 @@ lemma switchToThread_ccorres': apply auto done +lemma ccorres_pre_getQueue: + assumes cc: "\queue. ccorres r xf (P queue) (P' queue) hs (f queue) c" + shows "ccorres r xf (\s. P (ksReadyQueues s (d, p)) s \ d \ maxDomain \ p \ maxPriority) + {s'. \queue. (let cqueue = index (ksReadyQueues_' (globals s')) + (cready_queues_index_to_C d p) in + ctcb_queue_relation queue cqueue) \ s' \ P' queue} + hs (getQueue d p >>= (\queue. f queue)) c" + apply (rule ccorres_guard_imp2) + apply (rule ccorres_symb_exec_l2) + defer + defer + apply (rule gq_sp) + defer + apply (rule ccorres_guard_imp) + apply (rule cc) + apply clarsimp + apply assumption + apply assumption + apply (clarsimp simp: getQueue_def gets_exs_valid) + apply clarsimp + apply (drule spec, erule mp) + apply (erule rf_sr_ctcb_queue_relation) + apply (simp add: maxDom_to_H maxPrio_to_H)+ + done + lemma chooseThread_ccorres: "ccorres dc xfdc all_invs_but_ct_idle_or_in_cur_domain' UNIV [] chooseThread (Call chooseThread_'proc)" proof - note prio_and_dom_limit_helpers [simp] - note ksReadyQueuesL2Bitmap_nonzeroI [simp] note Collect_const_mem [simp] (* when numDomains = 1, array bounds checks would become _ = 0 rather than _ < 1, changing the shape of the proof compared to when numDomains > 1 *) @@ -224,9 +247,22 @@ proof - "\s. invs_no_cicd' s \ ksCurDomain s \ maxDomain" by (simp add: invs_no_cicd'_def) + have invs_no_cicd'_valid_bitmaps: + "\s. invs_no_cicd' s \ valid_bitmaps s" + by (simp add: invs_no_cicd'_def) + + have invs_no_cicd'_pspace_aligned': + "\s. invs_no_cicd' s \ pspace_aligned' s" + by (simp add: invs_no_cicd'_def valid_pspace'_def) + + have invs_no_cicd'_pspace_distinct': + "\s. invs_no_cicd' s \ pspace_distinct' s" + by (simp add: invs_no_cicd'_def valid_pspace'_def) + show ?thesis supply if_split[split del] apply (cinit) + apply (rule ccorres_stateAssert)+ apply (simp add: numDomains_sge_1_simp) apply (rule_tac xf'=dom_' and r'="\rv rv'. rv' = ucast rv" in ccorres_split_nothrow_novcg) apply (rule ccorres_from_vcg[where P=\ and P'=UNIV]) @@ -259,7 +295,7 @@ proof - apply (rule_tac P="curdom \ maxDomain" in ccorres_cross_over_guard_no_st) apply (rule_tac P="prio \ maxPriority" in ccorres_cross_over_guard_no_st) apply (rule ccorres_pre_getQueue) - apply (rule_tac P="queue \ []" in ccorres_cross_over_guard_no_st) + apply (rule_tac P="\ tcbQueueEmpty queue" in ccorres_cross_over_guard_no_st) apply (rule ccorres_symb_exec_l) apply (rule ccorres_assert) apply (rule ccorres_symb_exec_r) @@ -274,37 +310,40 @@ proof - apply (rule conseqPre, vcg) apply (rule Collect_mono) apply clarsimp - apply (strengthen queue_in_range) apply assumption apply clarsimp apply (rule conseqPre, vcg) apply clarsimp apply (wp isRunnable_wp)+ apply (clarsimp simp: Let_def guard_is_UNIV_def) - apply (drule invs_no_cicd'_queues) - apply (case_tac queue, simp) - apply (clarsimp simp: tcb_queue_relation'_def cready_queues_index_to_C_def numPriorities_def) - apply (clarsimp simp add: maxDom_to_H maxPrio_to_H - queue_in_range[where qdom=0, simplified, simplified maxPrio_to_H]) - apply (clarsimp simp: le_maxDomain_eq_less_numDomains unat_trans_ucast_helper ) + apply (rule conjI) + apply (clarsimp simp: le_maxDomain_eq_less_numDomains unat_trans_ucast_helper) + apply (intro conjI impI) + apply (clarsimp simp: cready_queues_index_to_C_def numPriorities_def ctcb_queue_relation_def + tcbQueueEmpty_def option_to_ctcb_ptr_def) + apply (frule_tac qdom=curdom and prio=rv in cready_queues_index_to_C_in_range') + apply fastforce + apply (clarsimp simp: num_tcb_queues_val word_less_nat_alt cready_queues_index_to_C_def2) apply wpsimp apply (clarsimp simp: guard_is_UNIV_def le_maxDomain_eq_less_numDomains word_less_nat_alt numDomains_less_numeric_explicit) - apply (frule invs_no_cicd'_queues) + apply clarsimp apply (frule invs_no_cicd'_max_CurDomain) - apply (frule invs_no_cicd'_queues) - apply (clarsimp simp: valid_queues_def lookupBitmapPriority_le_maxPriority) + apply (frule invs_no_cicd'_pspace_aligned') + apply (frule invs_no_cicd'_pspace_distinct') + apply (frule invs_no_cicd'_valid_bitmaps) + apply (frule valid_bitmaps_bitmapQ_no_L1_orphans) + apply (frule valid_bitmaps_valid_bitmapQ) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def cong: conj_cong) apply (intro conjI impI) - apply (fastforce dest: bitmapQ_from_bitmap_lookup simp: valid_bitmapQ_bitmapQ_simp) - apply (fastforce dest: lookupBitmapPriority_obj_at' - simp: pred_conj_def obj_at'_def st_tcb_at'_def) - apply (fastforce dest: bitmapQ_from_bitmap_lookup simp: valid_bitmapQ_bitmapQ_simp) - apply (clarsimp simp: pred_conj_def obj_at'_def st_tcb_at'_def) - apply (clarsimp simp: not_less le_maxDomain_eq_less_numDomains) - apply (prop_tac "ksCurDomain s = 0") - using unsigned_eq_0_iff apply force - apply (cut_tac s=s in lookupBitmapPriority_obj_at'; simp?) - apply (clarsimp simp: pred_conj_def obj_at'_def st_tcb_at'_def) + apply (fastforce intro: lookupBitmapPriority_le_maxPriority) + apply (fastforce dest!: bitmapQ_from_bitmap_lookup valid_bitmapQ_bitmapQ_simp) + apply (fastforce dest!: lookupBitmapPriority_obj_at' + simp: ready_queue_relation_def ksReadyQueues_asrt_def st_tcb_at'_def obj_at'_def) + apply (fastforce dest: lookupBitmapPriority_le_maxPriority) + apply (fastforce dest!: bitmapQ_from_bitmap_lookup valid_bitmapQ_bitmapQ_simp) + apply (fastforce dest!: lookupBitmapPriority_obj_at' + simp: ready_queue_relation_def ksReadyQueues_asrt_def st_tcb_at'_def obj_at'_def) done qed @@ -628,7 +667,7 @@ lemma schedule_ccorres: apply (wp (once) hoare_drop_imps) apply wp apply (strengthen strenghten_False_imp[where P="a = ResumeCurrentThread" for a]) - apply (clarsimp simp: conj_ac invs_queues invs_valid_objs' cong: conj_cong) + apply (clarsimp simp: conj_ac invs_valid_objs' cong: conj_cong) apply wp apply (clarsimp, vcg exspec=tcbSchedEnqueue_modifies) apply (clarsimp, vcg exspec=tcbSchedEnqueue_modifies) @@ -648,9 +687,11 @@ lemma schedule_ccorres: apply wp apply vcg - apply (clarsimp simp: tcb_at_invs' rf_sr_ksCurThread if_apply_def2 invs_queues invs_valid_objs') + apply (clarsimp simp: tcb_at_invs' rf_sr_ksCurThread if_apply_def2 invs_valid_objs') apply (frule invs_sch_act_wf') apply (frule tcb_at_invs') + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') apply (rule conjI) apply (clarsimp dest!: rf_sr_cscheduler_relation simp: cscheduler_action_relation_def) apply (rule conjI; clarsimp) @@ -699,11 +740,7 @@ lemma threadSet_timeSlice_ccorres [corres]: map_to_tcbs_upd) apply (simp add: cep_relations_drop_fun_upd cvariable_relation_upd_const ko_at_projectKO_opt) - apply (rule conjI) defer - apply (erule cready_queues_relation_not_queue_ptrs) - apply (rule ext, simp split: if_split) - apply (rule ext, simp split: if_split) apply (drule ko_at_projectKO_opt) apply (erule (2) cmap_relation_upd_relI) apply (simp add: ctcb_relation_def) @@ -747,7 +784,7 @@ lemma timerTick_ccorres: apply simp apply (ctac (no_vcg) add: tcbSchedAppend_ccorres) apply (ctac add: rescheduleRequired_ccorres) - apply (wp weak_sch_act_wf_lift_linear threadSet_valid_queues + apply (wp weak_sch_act_wf_lift_linear threadSet_pred_tcb_at_state tcbSchedAppend_valid_objs' threadSet_valid_objs' threadSet_tcbDomain_triv | clarsimp simp: st_tcb_at'_def o_def split: if_splits)+ apply (vcg exspec=tcbSchedDequeue_modifies) diff --git a/proof/crefine/ARM_HYP/StateRelation_C.thy b/proof/crefine/ARM_HYP/StateRelation_C.thy index 085931cff3..6ede377ef7 100644 --- a/proof/crefine/ARM_HYP/StateRelation_C.thy +++ b/proof/crefine/ARM_HYP/StateRelation_C.thy @@ -16,8 +16,7 @@ definition definition "array_relation r n a c \ \i \ n. r (a i) (index c (unat i))" -(* used for bound ntfn/tcb *) -definition +definition option_to_ctcb_ptr :: "machine_word option \ tcb_C ptr" where "option_to_ctcb_ptr x \ case x of None \ NULL | Some t \ tcb_ptr_to_ctcb_ptr t" @@ -371,7 +370,9 @@ where \ tcbTimeSlice atcb = unat (tcbTimeSlice_C ctcb) \ cfault_rel (tcbFault atcb) (seL4_Fault_lift (tcbFault_C ctcb)) (lookup_fault_lift (tcbLookupFailure_C ctcb)) - \ option_to_ptr (tcbBoundNotification atcb) = tcbBoundNotification_C ctcb" + \ option_to_ptr (tcbBoundNotification atcb) = tcbBoundNotification_C ctcb + \ option_to_ctcb_ptr (tcbSchedPrev atcb) = tcbSchedPrev_C ctcb + \ option_to_ctcb_ptr (tcbSchedNext atcb) = tcbSchedNext_C ctcb" abbreviation "ep_queue_relation' \ tcb_queue_relation' tcbEPNext_C tcbEPPrev_C" @@ -600,17 +601,17 @@ definition where "cready_queues_index_to_C qdom prio \ (unat qdom) * numPriorities + (unat prio)" -definition cready_queues_relation :: - "tcb_C typ_heap \ (tcb_queue_C[num_tcb_queues]) \ (domain \ priority \ ready_queue) \ bool" -where - "cready_queues_relation h_tcb queues aqueues \ - \qdom prio. ((qdom \ ucast minDom \ qdom \ ucast maxDom \ - prio \ ucast minPrio \ prio \ ucast maxPrio) \ - (let cqueue = index queues (cready_queues_index_to_C qdom prio) in - sched_queue_relation' h_tcb (aqueues (qdom, prio)) (head_C cqueue) (end_C cqueue))) - \ (\ (qdom \ ucast minDom \ qdom \ ucast maxDom \ - prio \ ucast minPrio \ prio \ ucast maxPrio) \ aqueues (qdom, prio) = [])" +definition ctcb_queue_relation :: "tcb_queue \ tcb_queue_C \ bool" where + "ctcb_queue_relation aqueue cqueue \ + head_C cqueue = option_to_ctcb_ptr (tcbQueueHead aqueue) + \ end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd aqueue)" +definition cready_queues_relation :: + "(domain \ priority \ ready_queue) \ (tcb_queue_C[num_tcb_queues]) \ bool" + where + "cready_queues_relation aqueues cqueues \ + \d p. d \ maxDomain \ p \ maxPriority + \ ctcb_queue_relation (aqueues (d, p)) (index cqueues (cready_queues_index_to_C d p))" abbreviation "cte_array_relation astate cstate @@ -748,9 +749,7 @@ where "cstate_relation astate cstate \ let cheap = t_hrs_' cstate in cpspace_relation (ksPSpace astate) (underlying_memory (ksMachineState astate)) cheap \ - cready_queues_relation (clift cheap) - (ksReadyQueues_' cstate) - (ksReadyQueues astate) \ + cready_queues_relation (ksReadyQueues astate) (ksReadyQueues_' cstate) \ zero_ranges_are_zero (gsUntypedZeroRanges astate) cheap \ cbitmap_L1_relation (ksReadyQueuesL1Bitmap_' cstate) (ksReadyQueuesL1Bitmap astate) \ cbitmap_L2_relation (ksReadyQueuesL2Bitmap_' cstate) (ksReadyQueuesL2Bitmap astate) \ diff --git a/proof/crefine/ARM_HYP/SyscallArgs_C.thy b/proof/crefine/ARM_HYP/SyscallArgs_C.thy index 9a6af32f0c..8ad4b332e5 100644 --- a/proof/crefine/ARM_HYP/SyscallArgs_C.thy +++ b/proof/crefine/ARM_HYP/SyscallArgs_C.thy @@ -48,9 +48,7 @@ lemma replyOnRestart_invs'[wp]: including no_pre apply (simp add: replyOnRestart_def) apply (wp setThreadState_nonqueued_state_update rfk_invs' hoare_weak_lift_imp) - apply (rule hoare_vcg_all_lift) - apply (wp setThreadState_nonqueued_state_update rfk_invs' hoare_vcg_all_lift rfk_ksQ) - apply (rule hoare_strengthen_post, rule gts_sp') + apply (rule hoare_strengthen_post, rule gts_sp') apply (clarsimp simp: pred_tcb_at') apply (auto elim!: pred_tcb'_weakenE st_tcb_ex_cap'' dest: st_tcb_at_idle_thread') diff --git a/proof/crefine/ARM_HYP/Syscall_C.thy b/proof/crefine/ARM_HYP/Syscall_C.thy index 4fe21b768b..8608bfab4f 100644 --- a/proof/crefine/ARM_HYP/Syscall_C.thy +++ b/proof/crefine/ARM_HYP/Syscall_C.thy @@ -49,8 +49,7 @@ lemma cap_cases_one_on_true_sum: lemma performInvocation_Endpoint_ccorres: "ccorres (K (K \) \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (invs' and st_tcb_at' simple' thread and ep_at' epptr - and sch_act_sane and (\s. thread = ksCurThread s - \ (\p. ksCurThread s \ set (ksReadyQueues s p)))) + and sch_act_sane and (\s. thread = ksCurThread s)) (UNIV \ {s. block_' s = from_bool blocking} \ {s. call_' s = from_bool do_call} \ {s. badge_' s = badge} @@ -123,7 +122,6 @@ lemma decodeInvocation_ccorres: and (\s. \v \ set extraCaps. ex_cte_cap_wp_to' isCNodeCap (snd v) s) and (\s. \v \ set extraCaps. s \' fst v \ cte_at' (snd v) s) and (\s. \v \ set extraCaps. \y \ zobj_refs' (fst v). ex_nonz_cap_to' y s) - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p)) and sysargs_rel args buffer) (UNIV \ {s. call_' s = from_bool isCall} \ {s. block_' s = from_bool isBlocking} @@ -200,7 +198,7 @@ lemma decodeInvocation_ccorres: apply simp apply (rule hoare_use_eq[where f=ksCurThread]) apply (wp sts_invs_minor' sts_st_tcb_at'_cases - setThreadState_ct' hoare_vcg_all_lift sts_ksQ')+ + setThreadState_ct' hoare_vcg_all_lift)+ apply simp apply (vcg exspec=setThreadState_modifies) apply vcg @@ -522,7 +520,7 @@ lemma wordFromMessageInfo_spec: lemma handleDoubleFault_ccorres: "ccorres dc xfdc (invs' and tcb_at' tptr and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and - sch_act_not tptr and (\s. \p. tptr \ set (ksReadyQueues s p))) + sch_act_not tptr) (UNIV \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr tptr}) [] (handleDoubleFault tptr ex1 ex2) (Call handleDoubleFault_'proc)" @@ -600,8 +598,7 @@ lemma hrs_mem_update_use_hrs_mem: lemma sendFaultIPC_ccorres: "ccorres (cfault_rel2 \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') - (invs' and st_tcb_at' simple' tptr and sch_act_not tptr and - (\s. \p. tptr \ set (ksReadyQueues s p))) + (invs' and st_tcb_at' simple' tptr and sch_act_not tptr) (UNIV \ {s. (cfault_rel (Some fault) (seL4_Fault_lift(current_fault_' (globals s))) (lookup_fault_lift(current_lookup_fault_' (globals s))))} \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr tptr}) @@ -679,8 +676,8 @@ lemma sendFaultIPC_ccorres: apply (ctac (no_vcg) add: sendIPC_ccorres) apply (ctac (no_vcg) add: ccorres_return_CE [unfolded returnOk_def comp_def]) apply wp - apply (wp threadSet_pred_tcb_no_state threadSet_invs_trivial threadSet_typ_at_lifts - | simp)+ + apply (wpsimp wp: threadSet_invs_trivial) + apply (wpsimp wp: threadSet_pred_tcb_no_state threadSet_typ_at_lifts) apply (clarsimp simp: guard_is_UNIV_def) apply (subgoal_tac "capEPBadge epcap && mask 28 = capEPBadge epcap") @@ -715,8 +712,7 @@ lemma sendFaultIPC_ccorres: apply vcg apply (clarsimp simp: inQ_def) apply (rule_tac Q="\a b. invs' b \ st_tcb_at' simple' tptr b - \ sch_act_not tptr b \ valid_cap' a b - \ (\p. tptr \ set (ksReadyQueues b p))" + \ sch_act_not tptr b \ valid_cap' a b" and E="\ _. \" in hoare_post_impErr) apply (wp) @@ -737,8 +733,7 @@ lemma sendFaultIPC_ccorres: done lemma handleFault_ccorres: - "ccorres dc xfdc (invs' and st_tcb_at' simple' t and - sch_act_not t and (\s. \p. t \ set (ksReadyQueues s p))) + "ccorres dc xfdc (invs' and st_tcb_at' simple' t and sch_act_not t) (UNIV \ {s. (cfault_rel (Some flt) (seL4_Fault_lift(current_fault_' (globals s))) (lookup_fault_lift(current_lookup_fault_' (globals s))) )} \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr t}) @@ -825,8 +820,7 @@ lemma getMessageInfo_msgLength': lemma handleInvocation_ccorres: "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (invs' and (\s. vs_valid_duplicates' (ksPSpace s)) and - ct_active' and sch_act_simple and - (\s. \x. ksCurThread s \ set (ksReadyQueues s x))) + ct_active' and sch_act_simple) (UNIV \ {s. isCall_' s = from_bool isCall} \ {s. isBlocking_' s = from_bool isBlocking}) [] (handleInvocation isCall isBlocking) (Call handleInvocation_'proc)" @@ -955,7 +949,7 @@ lemma handleInvocation_ccorres: apply (wp hoare_split_bind_case_sumE hoare_drop_imps setThreadState_nonqueued_state_update ct_in_state'_set setThreadState_st_tcb - hoare_vcg_all_lift sts_ksQ' + hoare_vcg_all_lift | wpc | wps)+ apply auto[1] apply clarsimp @@ -1217,9 +1211,6 @@ lemma ccorres_trim_redundant_throw_break: lemma invs_valid_objs_strengthen: "invs' s \ valid_objs' s" by fastforce -lemma ct_not_ksQ_strengthen: - "thread = ksCurThread s \ ksCurThread s \ set (ksReadyQueues s p) \ thread \ set (ksReadyQueues s p)" by fastforce - lemma option_to_ctcb_ptr_valid_ntfn: "valid_ntfn' ntfn s ==> (option_to_ctcb_ptr (ntfnBoundTCB ntfn) = NULL) = (ntfnBoundTCB ntfn = None)" apply (cases "ntfnBoundTCB ntfn", simp_all add: option_to_ctcb_ptr_def) @@ -1253,8 +1244,7 @@ lemma handleRecv_ccorres: notes rf_sr_upd_safe[simp del] if_cong[cong] shows "ccorres dc xfdc - (\s. invs' s \ st_tcb_at' simple' (ksCurThread s) s - \ sch_act_sane s \ (\p. ksCurThread s \ set (ksReadyQueues s p))) + (\s. invs' s \ st_tcb_at' simple' (ksCurThread s) s \ sch_act_sane s) {s. isBlocking_' s = from_bool isBlocking} [] (handleRecv isBlocking) @@ -1317,7 +1307,7 @@ lemma handleRecv_ccorres: apply (rule_tac P="\s. ksCurThread s = thread" in ccorres_cross_over_guard) apply (ctac add: receiveIPC_ccorres) - apply (wp deleteCallerCap_ksQ_ct' hoare_vcg_all_lift) + apply (wp hoare_vcg_all_lift) apply (rule conseqPost[where Q'=UNIV and A'="{}"], vcg exspec=deleteCallerCap_modifies) apply (clarsimp dest!: rf_sr_ksCurThread) apply simp @@ -1440,13 +1430,11 @@ lemma handleRecv_ccorres: apply clarsimp apply (rename_tac thread epCPtr) apply (rule_tac Q'="(\rv s. invs' s \ st_tcb_at' simple' thread s - \ sch_act_sane s \ (\p. thread \ set (ksReadyQueues s p)) \ thread = ksCurThread s + \ sch_act_sane s \ thread = ksCurThread s \ valid_cap' rv s)" in hoare_post_imp_R[rotated]) - apply (clarsimp simp: sch_act_sane_def) - apply (auto dest!: obj_at_valid_objs'[OF _ invs_valid_objs'] - simp: projectKOs valid_obj'_def, - auto simp: pred_tcb_at'_def obj_at'_def objBits_simps projectKOs ct_in_state'_def)[1] - apply wp + apply (intro conjI impI allI; clarsimp simp: sch_act_sane_def) + apply (fastforce dest: obj_at_valid_objs'[OF _ invs_valid_objs'] ko_at_valid_ntfn') + apply wp apply clarsimp apply (vcg exspec=isStopped_modifies exspec=lookupCap_modifies) @@ -1495,7 +1483,7 @@ lemma handleYield_ccorres: apply (ctac add: rescheduleRequired_ccorres) apply (wp weak_sch_act_wf_lift_linear tcbSchedAppend_valid_objs') apply (vcg exspec= tcbSchedAppend_modifies) - apply (wp weak_sch_act_wf_lift_linear tcbSchedDequeue_valid_queues) + apply (wp weak_sch_act_wf_lift_linear) apply (vcg exspec= tcbSchedDequeue_modifies) apply (clarsimp simp: tcb_at_invs' invs_valid_objs' valid_objs'_maxPriority valid_objs'_maxDomain) @@ -1800,8 +1788,7 @@ lemma ccorres_vgicMaintenance: notes virq_virq_pending_set_virqEOIIRQEN_spec = virq_virq_pending_set_virqEOIIRQEN_spec' shows "ccorres dc xfdc - (\s. invs' s \ sch_act_not (ksCurThread s) s - \ (\p. ksCurThread s \ set (ksReadyQueues s p))) + (\s. invs' s \ sch_act_not (ksCurThread s) s) UNIV hs vgicMaintenance (Call VGICMaintenance_'proc)" (is "ccorres _ _ ?PRE _ _ _ _") @@ -2136,7 +2123,6 @@ lemma ccorres_VPPIEvent: shows "ccorres dc xfdc (\s. invs' s \ sch_act_not (ksCurThread s) s - \ (\p. ksCurThread s \ set (ksReadyQueues s p)) \ irqVPPIEventIndex irq \ None) \\irq = ucast irq\ hs (vppiEvent irq) (Call VPPIEvent_'proc)" @@ -2218,8 +2204,7 @@ qed lemma ccorres_handleReservedIRQ: "ccorres dc xfdc - (invs' and (\s. irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s \ - (\p. ksCurThread s \ set (ksReadyQueues s p)))) + (invs' and (\s. irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s)) (UNIV \ {s. irq_' s = ucast irq}) hs (handleReservedIRQ irq) (Call handleReservedIRQ_'proc)" supply Collect_const[simp del] @@ -2257,10 +2242,8 @@ lemma ccorres_handleReservedIRQ: lemma handleInterrupt_ccorres: "ccorres dc xfdc - (invs' and (\s. irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s \ - (\p. ksCurThread s \ set (ksReadyQueues s p)))) - (UNIV \ \\irq = ucast irq\) - hs + (invs' and (\s. irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s)) + \\irq = ucast irq\ hs (handleInterrupt irq) (Call handleInterrupt_'proc)" apply (cinit lift: irq_' cong: call_ignore_cong) diff --git a/proof/crefine/ARM_HYP/TcbQueue_C.thy b/proof/crefine/ARM_HYP/TcbQueue_C.thy index 5b6dba4499..c83f759d51 100644 --- a/proof/crefine/ARM_HYP/TcbQueue_C.thy +++ b/proof/crefine/ARM_HYP/TcbQueue_C.thy @@ -891,49 +891,6 @@ lemma tcb_queue_relation'_prev_mask: shows "ptr_val (getPrev tcb) && ~~ mask bits = ptr_val (getPrev tcb)" by (rule tcb_queue_relation_prev_mask [OF tcb_queue_relation'_queue_rel], fact+) - -lemma cready_queues_relation_null_queue_ptrs: - assumes rel: "cready_queues_relation mp cq aq" - and same: "option_map tcb_null_ep_ptrs \ mp' = option_map tcb_null_ep_ptrs \ mp" - shows "cready_queues_relation mp' cq aq" - using rel - apply (clarsimp simp: cready_queues_relation_def Let_def all_conj_distrib) - apply (drule spec, drule spec, drule mp, (erule conjI)+, assumption) - apply (clarsimp simp: tcb_queue_relation'_def) - apply (erule iffD2 [OF tcb_queue_relation_only_next_prev, rotated -1]) - apply (rule ext) - apply (case_tac "mp' x") - apply (frule compD [OF same]) - apply simp - apply (frule compD [OF same]) - apply (clarsimp simp: tcb_null_ep_ptrs_def) - apply (case_tac z, case_tac a) - apply simp - \ \clag\ - apply (rule ext) - apply (case_tac "mp' x") - apply (frule compD [OF same]) - apply simp - apply (frule compD [OF same]) - apply (clarsimp simp: tcb_null_ep_ptrs_def) - apply (case_tac z, case_tac a) - apply simp - done - -lemma cready_queues_relation_not_queue_ptrs: - assumes rel: "cready_queues_relation mp cq aq" - and same: "option_map tcbSchedNext_C \ mp' = option_map tcbSchedNext_C \ mp" - "option_map tcbSchedPrev_C \ mp' = option_map tcbSchedPrev_C \ mp" - shows "cready_queues_relation mp' cq aq" - using rel - apply (clarsimp simp: cready_queues_relation_def tcb_queue_relation'_def Let_def all_conj_distrib) - apply (drule spec, drule spec, drule mp, (erule conjI)+, assumption) - apply clarsimp - apply (erule iffD2 [OF tcb_queue_relation_only_next_prev, rotated -1]) - apply (rule same) - apply (rule same) - done - lemma ntfn_ep_disjoint: assumes srs: "sym_refs (state_refs_of' s)" and epat: "ko_at' ep epptr s" @@ -1101,8 +1058,6 @@ lemma rf_sr_tcb_update_no_queue: (tcb_ptr_to_ctcb_ptr thread) ctcb) (t_hrs_' (globals s')); tcbEPNext_C ctcb = tcbEPNext_C (the (cslift s' (tcb_ptr_to_ctcb_ptr thread))); tcbEPPrev_C ctcb = tcbEPPrev_C (the (cslift s' (tcb_ptr_to_ctcb_ptr thread))); - tcbSchedNext_C ctcb = tcbSchedNext_C (the (cslift s' (tcb_ptr_to_ctcb_ptr thread))); - tcbSchedPrev_C ctcb = tcbSchedPrev_C (the (cslift s' (tcb_ptr_to_ctcb_ptr thread))); (\x\ran tcb_cte_cases. (\(getF, setF). getF tcb' = getF tcb) x); ctcb_relation tcb' ctcb \ @@ -1116,31 +1071,22 @@ lemma rf_sr_tcb_update_no_queue: apply (clarsimp simp: map_comp_update projectKO_opt_tcb cvariable_relation_upd_const typ_heap_simps') apply (intro conjI) - subgoal by (clarsimp simp: cmap_relation_def map_comp_update projectKO_opts_defs inj_eq) - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_upd_tcb_no_queues, assumption+) - subgoal by (clarsimp intro!: ext) - subgoal by (clarsimp intro!: ext) + subgoal by (clarsimp simp: cmap_relation_def map_comp_update projectKO_opts_defs inj_eq) apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_upd_tcb_no_queues, assumption+) + apply (rule cendpoint_relation_upd_tcb_no_queues, assumption+) subgoal by (clarsimp intro!: ext) subgoal by (clarsimp intro!: ext) - apply (erule cready_queues_relation_not_queue_ptrs) + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_upd_tcb_no_queues, assumption+) subgoal by (clarsimp intro!: ext) subgoal by (clarsimp intro!: ext) subgoal by (simp add: carch_state_relation_def typ_heap_simps') by (simp add: cmachine_state_relation_def) -lemma rf_sr_tcb_update_no_queue_helper: - "(s, s'\ globals := globals s' \ t_hrs_' := t_hrs_' (globals (undefined - \ globals := (undefined \ t_hrs_' := f (globals s') (t_hrs_' (globals s')) \)\))\\) \ rf_sr - \ (s, globals_update (\v. t_hrs_'_update (f v) v) s') \ rf_sr" - by (simp cong: StateSpace.state.fold_congs globals.fold_congs) - -lemmas rf_sr_tcb_update_no_queue2 - = rf_sr_tcb_update_no_queue_helper [OF rf_sr_tcb_update_no_queue, simplified] +lemmas rf_sr_tcb_update_no_queue2 = + rf_sr_obj_update_helper[OF rf_sr_tcb_update_no_queue, simplified] lemma tcb_queue_relation_not_in_q: "ctcb_ptr_to_tcb_ptr x \ set xs \ @@ -1170,31 +1116,24 @@ lemma rf_sr_tcb_update_not_in_queue: apply clarsimp apply (auto simp: obj_at'_def ko_wp_at'_def)[1] apply (intro conjI) - subgoal by (clarsimp simp: cmap_relation_def map_comp_update projectKO_opts_defs inj_eq) - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply clarsimp - apply (subgoal_tac "thread \ (fst ` ep_q_refs_of' a)") - apply (clarsimp simp: cendpoint_relation_def Let_def split: Structures_H.endpoint.split) - subgoal by (intro conjI impI allI, simp_all add: image_def tcb_queue_relation_not_in_q)[1] - apply (drule(1) map_to_ko_atI') - apply (drule sym_refs_ko_atD', clarsimp+) - subgoal by blast + subgoal by (clarsimp simp: cmap_relation_def map_comp_update projectKO_opts_defs inj_eq) apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply clarsimp - apply (subgoal_tac "thread \ (fst ` ntfn_q_refs_of' (ntfnObj a))") - apply (clarsimp simp: cnotification_relation_def Let_def - split: ntfn.splits) - subgoal by (simp add: image_def tcb_queue_relation_not_in_q)[1] + apply (subgoal_tac "thread \ (fst ` ep_q_refs_of' a)") + apply (clarsimp simp: cendpoint_relation_def Let_def split: Structures_H.endpoint.split) + subgoal by (intro conjI impI allI, simp_all add: image_def tcb_queue_relation_not_in_q)[1] apply (drule(1) map_to_ko_atI') apply (drule sym_refs_ko_atD', clarsimp+) subgoal by blast - apply (simp add: cready_queues_relation_def, erule allEI) - apply (clarsimp simp: Let_def) - apply (subst tcb_queue_relation_not_in_q) - apply clarsimp - apply (drule valid_queues_obj_at'D, clarsimp) - apply (clarsimp simp: obj_at'_def projectKOs inQ_def) - subgoal by simp + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply clarsimp + apply (subgoal_tac "thread \ (fst ` ntfn_q_refs_of' (ntfnObj a))") + apply (clarsimp simp: cnotification_relation_def Let_def + split: ntfn.splits) + subgoal by (simp add: image_def tcb_queue_relation_not_in_q)[1] + apply (drule(1) map_to_ko_atI') + apply (drule sym_refs_ko_atD', clarsimp+) + subgoal by blast subgoal by (simp add: carch_state_relation_def carch_globals_def typ_heap_simps') by (simp add: cmachine_state_relation_def) diff --git a/proof/crefine/ARM_HYP/Tcb_C.thy b/proof/crefine/ARM_HYP/Tcb_C.thy index 661b7aa95d..980cc69829 100644 --- a/proof/crefine/ARM_HYP/Tcb_C.thy +++ b/proof/crefine/ARM_HYP/Tcb_C.thy @@ -59,8 +59,6 @@ lemma doMachineOp_sched: done context begin interpretation Arch . (*FIXME: arch_split*) -crunch queues[wp]: setupReplyMaster "valid_queues" - (simp: crunch_simps wp: crunch_wps) crunch curThread [wp]: restart "\s. P (ksCurThread s)" (wp: crunch_wps simp: crunch_simps) @@ -391,9 +389,10 @@ lemma hrs_mem_update_cong: lemma setPriority_ccorres: "ccorres dc xfdc - (\s. tcb_at' t s \ Invariants_H.valid_queues s \ ksCurDomain s \ maxDomain \ - valid_queues' s \ valid_objs' s \ weak_sch_act_wf (ksSchedulerAction s) s \ (priority \ maxPriority)) - (UNIV \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr t} \ {s. prio_' s = ucast priority}) + (\s. tcb_at' t s \ ksCurDomain s \ maxDomain \ + valid_objs' s \ weak_sch_act_wf (ksSchedulerAction s) s \ (priority \ maxPriority) \ + pspace_aligned' s \ pspace_distinct' s) + ({s. tptr_' s = tcb_ptr_to_ctcb_ptr t} \ {s. prio_' s = ucast priority}) [] (setPriority t priority) (Call setPriority_'proc)" apply (cinit lift: tptr_' prio_') apply (ctac(no_vcg) add: tcbSchedDequeue_ccorres) @@ -416,7 +415,7 @@ lemma setPriority_ccorres: apply (ctac add: possibleSwitchTo_ccorres) apply (rule ccorres_return_Skip') apply (wp isRunnable_wp) - apply (wpsimp wp: hoare_drop_imps threadSet_valid_queues threadSet_valid_objs' + apply (wpsimp wp: hoare_drop_imps threadSet_valid_objs' weak_sch_act_wf_lift_linear threadSet_pred_tcb_at_state threadSet_tcbDomain_triv simp: st_tcb_at'_def o_def split: if_splits) @@ -425,18 +424,13 @@ lemma setPriority_ccorres: where Q="\rv s. obj_at' (\_. True) t s \ priority \ maxPriority \ - Invariants_H.valid_queues s \ ksCurDomain s \ maxDomain \ valid_objs' s \ - valid_queues' s \ weak_sch_act_wf (ksSchedulerAction s) s \ - (\d p. \ t \ set (ksReadyQueues s (d, p)))"]) - apply (wp weak_sch_act_wf_lift_linear tcbSchedDequeue_valid_queues tcbSchedDequeue_nonq) + pspace_aligned' s \ pspace_distinct' s"]) + apply (wp weak_sch_act_wf_lift_linear valid_tcb'_def) apply (clarsimp simp: valid_tcb'_tcbPriority_update) apply clarsimp - apply (frule (1) valid_objs'_maxDomain[where t=t]) - apply (frule (1) valid_objs'_maxPriority[where t=t]) - apply simp done lemma setMCPriority_ccorres: @@ -674,12 +668,12 @@ lemma invokeTCB_ThreadControl_ccorres: apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem) apply (rule hoare_strengthen_post [ where Q= "\rv s. - Invariants_H.valid_queues s \ valid_objs' s \ weak_sch_act_wf (ksSchedulerAction s) s \ ((\a b. priority = Some (a, b)) \ tcb_at' target s \ ksCurDomain s \ maxDomain \ - valid_queues' s \ fst (the priority) \ maxPriority)"]) + fst (the priority) \ maxPriority) \ + pspace_aligned' s \ pspace_distinct' s"]) apply (strengthen sch_act_wf_weak) apply (wp hoare_weak_lift_imp) apply (clarsimp split: if_splits) @@ -764,12 +758,12 @@ lemma invokeTCB_ThreadControl_ccorres: apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem) apply (simp cong: conj_cong) apply (rule hoare_strengthen_post[ - where Q="\a b. (Invariants_H.valid_queues b \ - valid_objs' b \ + where Q="\a b. (valid_objs' b \ sch_act_wf (ksSchedulerAction b) b \ + pspace_aligned' b \ pspace_distinct' b \ ((\a b. priority = Some (a, b)) \ tcb_at' target b \ - ksCurDomain b \ maxDomain \ valid_queues' b \ + ksCurDomain b \ maxDomain \ fst (the priority) \ maxPriority)) \ ((case snd (the buf) of None \ 0 @@ -792,15 +786,15 @@ lemma invokeTCB_ThreadControl_ccorres: prefer 2 apply fastforce apply (strengthen cte_is_derived_capMasterCap_strg - invs_queues invs_weak_sch_act_wf invs_sch_act_wf' + invs_weak_sch_act_wf invs_sch_act_wf' invs_valid_objs' invs_mdb' invs_pspace_aligned', simp add: o_def) apply (rule_tac P="is_aligned (fst (the buf)) msg_align_bits" in hoare_gen_asm) apply (wp threadSet_ipcbuffer_trivial hoare_weak_lift_imp | simp - | strengthen invs_sch_act_wf' invs_valid_objs' invs_weak_sch_act_wf invs_queues - invs_valid_queues' | wp hoare_drop_imps)+ + | strengthen invs_sch_act_wf' invs_valid_objs' invs_weak_sch_act_wf + | wp hoare_drop_imps)+ (* \ P *) apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem option_to_0_def @@ -810,7 +804,7 @@ lemma invokeTCB_ThreadControl_ccorres: apply (rule ccorres_return_C_errorE, simp+)[1] apply vcg apply (simp add: conj_comms cong: conj_cong) - apply (strengthen invs_ksCurDomain_maxDomain') + apply (strengthen invs_ksCurDomain_maxDomain' invs_pspace_distinct') apply (wp hoare_vcg_const_imp_lift_R cteDelete_invs') apply simp apply (rule ccorres_split_nothrow_novcg_dc) @@ -827,8 +821,7 @@ lemma invokeTCB_ThreadControl_ccorres: apply (rule conjI) apply (clarsimp simp: case_option_If2 if_n_0_0 objBits_simps' valid_cap'_def capAligned_def word_bits_conv obj_at'_def projectKOs) - apply (clarsimp simp: invs_valid_objs' invs_valid_queues' - Invariants_H.invs_queues invs_ksCurDomain_maxDomain') + apply (fastforce simp: invs_valid_objs' invs_ksCurDomain_maxDomain') apply (rule ccorres_Cond_rhs_Seq) apply (rule ccorres_rhs_assoc)+ apply csymbr @@ -1058,7 +1051,7 @@ lemma restart_ccorres: apply (ctac(no_vcg) add: tcbSchedEnqueue_ccorres) apply (ctac add: possibleSwitchTo_ccorres) apply (wp weak_sch_act_wf_lift)[1] - apply (wp sts_valid_queues setThreadState_st_tcb)[1] + apply (wp sts_valid_objs' setThreadState_st_tcb)[1] apply (simp add: valid_tcb_state'_def) apply wp apply (wp (once) sch_act_wf_lift, (wp tcb_in_cur_domain'_lift)+) @@ -1668,7 +1661,7 @@ lemma invokeTCB_WriteRegisters_ccorres[where S=UNIV]: apply (clarsimp simp: frame_gp_registers_convs word_less_nat_alt sysargs_rel_def n_frameRegisters_def n_msgRegisters_def split: if_split_asm) - apply (simp add: invs_weak_sch_act_wf invs_valid_objs' invs_queues) + apply (simp add: invs_weak_sch_act_wf invs_valid_objs') apply (fastforce dest!: global'_no_ex_cap simp: invs'_def valid_state'_def) done @@ -3193,7 +3186,8 @@ lemma decodeTCBConfigure_ccorres: apply (rule conjI, fastforce) apply (drule interpret_excaps_eq) apply (clarsimp simp: cte_wp_at_ctes_of valid_tcb_state'_def numeral_eqs le_ucast_ucast_le - tcb_at_invs' invs_valid_objs' invs_queues invs_sch_act_wf' + tcb_at_invs' invs_valid_objs' invs_sch_act_wf' + invs_pspace_aligned' invs_pspace_distinct' ct_in_state'_def pred_tcb_at'_def obj_at'_def tcb_st_refs_of'_def) apply (erule disjE; simp add: objBits_defs mask_def) apply (clarsimp simp: idButNot_def interpret_excaps_test_null @@ -4450,9 +4444,9 @@ lemma invokeTCB_SetTLSBase_ccorres: apply (rule ccorres_return_CE, simp+)[1] apply (wpsimp wp: hoare_drop_imp simp: guard_is_UNIV_def)+ apply vcg - apply (clarsimp simp: tlsBaseRegister_def ARM_HYP.tlsBaseRegister_def - invs_weak_sch_act_wf invs_queues TLS_BASE_def TPIDRURW_def - split: if_split) + apply (fastforce simp: tlsBaseRegister_def ARM_HYP.tlsBaseRegister_def + invs_weak_sch_act_wf TLS_BASE_def TPIDRURW_def + split: if_split) done lemma decodeSetTLSBase_ccorres: diff --git a/proof/crefine/ARM_HYP/Wellformed_C.thy b/proof/crefine/ARM_HYP/Wellformed_C.thy index d42a1b71e0..eba1590e20 100644 --- a/proof/crefine/ARM_HYP/Wellformed_C.thy +++ b/proof/crefine/ARM_HYP/Wellformed_C.thy @@ -170,10 +170,6 @@ where abbreviation "ep_queue_relation \ tcb_queue_relation tcbEPNext_C tcbEPPrev_C" -abbreviation - "sched_queue_relation \ tcb_queue_relation tcbSchedNext_C tcbSchedPrev_C" - - definition wordSizeCase :: "'a \ 'a \ 'a" where "wordSizeCase a b \ (if bitSize (undefined::word32) = 32 diff --git a/proof/crefine/Move_C.thy b/proof/crefine/Move_C.thy index e0e8dae8cc..bef3026fc2 100644 --- a/proof/crefine/Move_C.thy +++ b/proof/crefine/Move_C.thy @@ -625,9 +625,7 @@ lemma tcbFault_submonad_args: lemma threadGet_stateAssert_gets: "threadGet ext t = do stateAssert (tcb_at' t) []; gets (thread_fetch ext t) od" apply (rule is_stateAssert_gets [OF _ _ empty_fail_threadGet no_fail_threadGet]) - apply (clarsimp intro!: obj_at_ko_at'[where P="\tcb :: tcb. True", simplified] - | wp threadGet_wp)+ - apply (clarsimp simp: obj_at'_def thread_fetch_def projectKOs) + apply (wp threadGet_wp | clarsimp simp: obj_at'_def thread_fetch_def projectKOs)+ done lemma threadGet_tcbFault_submonad_fn: @@ -915,14 +913,6 @@ lemma ex_st_tcb_at'_simp[simp]: "(\ts. st_tcb_at' ((=) ts) dest s) = tcb_at' dest s" by (auto simp add: pred_tcb_at'_def obj_at'_def) -lemma threadGet_wp: - "\\s. \tcb. ko_at' tcb thread s \ P (f tcb) s\ threadGet f thread \P\" - apply (rule hoare_post_imp [OF _ tg_sp']) - apply clarsimp - apply (frule obj_at_ko_at') - apply (clarsimp elim: obj_atE') - done - lemma threadGet_wp'': "\\s. \v. obj_at' (\tcb. f tcb = v) thread s \ P v s\ threadGet f thread \P\" apply (rule hoare_pre) @@ -1029,10 +1019,6 @@ lemma st_tcb_at'_opeq_simp: = st_tcb_at' (\st. st = Structures_H.thread_state.Running) (ksCurThread s) s" by (fastforce simp add: st_tcb_at'_def obj_at'_def) -lemma invs_queues_imp: - "invs' s \ valid_queues s" - by clarsimp - lemma invs'_pspace_domain_valid: "invs' s \ pspace_domain_valid s" by (simp add: invs'_def valid_state'_def) @@ -1042,45 +1028,6 @@ lemma and_eq_0_is_nth: shows "y = 1 << n \ ((x && y) = 0) = (\ (x !! n))" by (metis (poly_guards_query) and_eq_0_is_nth) -lemma tcbSchedEnqueue_obj_at_unchangedT: - assumes y: "\f. \tcb. P (tcbQueued_update f tcb) = P tcb" - shows "\obj_at' P t\ tcbSchedEnqueue t' \\rv. obj_at' P t\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wp | simp add: y)+ - done - -lemma rescheduleRequired_obj_at_unchangedT: - assumes y: "\f. \tcb. P (tcbQueued_update f tcb) = P tcb" - shows "\obj_at' P t\ rescheduleRequired \\rv. obj_at' P t\" - apply (simp add: rescheduleRequired_def) - apply (wp tcbSchedEnqueue_obj_at_unchangedT[OF y] | wpc)+ - apply simp - done - -lemma setThreadState_obj_at_unchangedT: - assumes x: "\f. \tcb. P (tcbState_update f tcb) = P tcb" - assumes y: "\f. \tcb. P (tcbQueued_update f tcb) = P tcb" - shows "\obj_at' P t\ setThreadState t' ts \\rv. obj_at' P t\" - apply (simp add: setThreadState_def) - apply (wp rescheduleRequired_obj_at_unchangedT[OF y], simp) - apply (wp threadSet_obj_at'_strongish) - apply (clarsimp simp: obj_at'_def projectKOs x cong: if_cong) - done - -lemma setBoundNotification_obj_at_unchangedT: - assumes x: "\f. \tcb. P (tcbBoundNotification_update f tcb) = P tcb" - shows "\obj_at' P t\ setBoundNotification t' ts \\rv. obj_at' P t\" - apply (simp add: setBoundNotification_def) - apply (wp threadSet_obj_at'_strongish) - apply (clarsimp simp: obj_at'_def projectKOs x cong: if_cong) - done - -lemmas setThreadState_obj_at_unchanged - = setThreadState_obj_at_unchangedT[OF all_tcbI all_tcbI] - -lemmas setBoundNotification_obj_at_unchanged - = setBoundNotification_obj_at_unchangedT[OF all_tcbI] - lemma magnitudeCheck_assert2: "\ is_aligned x n; (1 :: machine_word) < 2 ^ n; ksPSpace s x = Some v \ \ magnitudeCheck x (snd (lookupAround2 x (ksPSpace (s :: kernel_state)))) n @@ -1299,13 +1246,6 @@ lemma ksPSpace_update_eq_ExD: \ \ps. s = t \ ksPSpace := ps \" by (erule exI) -lemma tcbSchedEnqueue_queued_queues_inv: - "\\s. obj_at' tcbQueued t s \ P (ksReadyQueues s) \ tcbSchedEnqueue t \\_ s. P (ksReadyQueues s)\" - unfolding tcbSchedEnqueue_def unless_def - apply (wpsimp simp: if_apply_def2 wp: threadGet_wp) - apply normalise_obj_at' - done - (* FIXME BV: generalise *) lemma word_clz_1[simp]: "word_clz (1::32 word) = 31" diff --git a/proof/crefine/RISCV64/ADT_C.thy b/proof/crefine/RISCV64/ADT_C.thy index 7b4ddd4efe..e4961e7853 100644 --- a/proof/crefine/RISCV64/ADT_C.thy +++ b/proof/crefine/RISCV64/ADT_C.thy @@ -77,8 +77,8 @@ lemma Basic_sem_eq: lemma setTCBContext_C_corres: "\ ccontext_relation tc tc'; t' = tcb_ptr_to_ctcb_ptr t \ \ - corres_underlying rf_sr nf nf' dc (pspace_domain_valid and tcb_at' t) \ - (threadSet (\tcb. tcb \ tcbArch := atcbContextSet tc (tcbArch tcb)\) t) (setTCBContext_C tc' t')" + corres_underlying rf_sr nf nf' dc (pspace_domain_valid and tcb_at' t) \ + (threadSet (\tcb. tcb \ tcbArch := atcbContextSet tc (tcbArch tcb)\) t) (setTCBContext_C tc' t')" apply (simp add: setTCBContext_C_def exec_C_def Basic_sem_eq corres_underlying_def) apply clarsimp apply (simp add: threadSet_def bind_assoc split_def exec_gets) @@ -107,8 +107,6 @@ lemma setTCBContext_C_corres: apply (simp add: map_to_ctes_upd_tcb_no_ctes map_to_tcbs_upd tcb_cte_cases_def cvariable_relation_upd_const ko_at_projectKO_opt cteSizeBits_def) apply (simp add: cep_relations_drop_fun_upd) - apply (apply_conjunct \match conclusion in \cready_queues_relation _ _ _\ \ - \erule cready_queues_relation_not_queue_ptrs; rule ext; simp split: if_split\\) apply (drule ko_at_projectKO_opt) apply (erule (2) cmap_relation_upd_relI) apply (simp add: ctcb_relation_def carch_tcb_relation_def) @@ -591,25 +589,51 @@ lemma tcb_queue_rel'_unique: apply (erule(2) tcb_queue_rel_unique) done -definition - cready_queues_to_H - :: "(tcb_C ptr \ tcb_C) \ (tcb_queue_C[num_tcb_queues]) \ word8 \ word8 \ machine_word list" + +definition tcb_queue_C_to_tcb_queue :: "tcb_queue_C \ tcb_queue" where + "tcb_queue_C_to_tcb_queue q \ + TcbQueue (if head_C q = NULL then None else Some (ctcb_ptr_to_tcb_ptr (head_C q))) + (if end_C q = NULL then None else Some (ctcb_ptr_to_tcb_ptr (end_C q)))" + +definition cready_queues_to_H :: + "tcb_queue_C[num_tcb_queues] \ (domain \ priority \ ready_queue)" where - "cready_queues_to_H h_tcb cs \ \(qdom, prio). if ucast minDom \ qdom \ qdom \ ucast maxDom - \ ucast seL4_MinPrio \ prio \ prio \ ucast seL4_MaxPrio - then THE aq. let cqueue = index cs (cready_queues_index_to_C qdom prio) - in sched_queue_relation' h_tcb aq (head_C cqueue) (StateRelation_C.end_C cqueue) - else []" + "cready_queues_to_H cs \ + \(qdom, prio). + if qdom \ maxDomain \ prio \ maxPriority + then let cqueue = index cs (cready_queues_index_to_C qdom prio) + in tcb_queue_C_to_tcb_queue cqueue + else TcbQueue None None" lemma cready_queues_to_H_correct: - "cready_queues_relation (clift s) cs as \ - cready_queues_to_H (clift s) cs = as" - apply (clarsimp simp: cready_queues_to_H_def cready_queues_relation_def - fun_eq_iff) - apply (rule the_equality) - apply simp - apply (clarsimp simp: Let_def) - apply (rule_tac hp="clift s" in tcb_queue_rel'_unique, simp_all add: lift_t_NULL) + "\cready_queues_relation (ksReadyQueues s) (ksReadyQueues_' ch); + no_0_obj' s; ksReadyQueues_asrt s; pspace_aligned' s; pspace_distinct' s\ + \ cready_queues_to_H (ksReadyQueues_' ch) = ksReadyQueues s" + apply (clarsimp simp: cready_queues_to_H_def cready_queues_relation_def Let_def) + apply (clarsimp simp: fun_eq_iff) + apply (rename_tac d p) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (frule (3) obj_at'_tcbQueueEnd_ksReadyQueues) + apply (frule tcbQueueHead_iff_tcbQueueEnd) + apply (rule conjI) + apply (clarsimp simp: tcb_queue_C_to_tcb_queue_def ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (case_tac "tcbQueueHead (ksReadyQueues s (d, p)) = None") + apply (clarsimp simp: tcb_queue.expand) + apply clarsimp + apply (rename_tac queue_head queue_end) + apply (prop_tac "tcb_at' queue_head s", fastforce simp: tcbQueueEmpty_def obj_at'_def) + apply (prop_tac "tcb_at' queue_end s", fastforce simp: tcbQueueEmpty_def obj_at'_def) + apply (drule kernel.tcb_at_not_NULL)+ + apply (fastforce simp: tcb_queue.expand kernel.ctcb_ptr_to_ctcb_ptr) + apply (clarsimp simp: tcbQueueEmpty_def ctcb_queue_relation_def option_to_ctcb_ptr_def + split: option.splits; + metis tcb_queue.exhaust_sel word_not_le) done (* showing that cpspace_relation is actually unique >>>*) @@ -753,12 +777,15 @@ lemma cthread_state_rel_imp_eq: apply (cases y, simp_all add: ThreadState_defs)+ done -lemma ksPSpace_valid_objs_tcbBoundNotification_nonzero: - "\s. ksPSpace s = ah \ no_0_obj' s \ valid_objs' s - \ map_to_tcbs ah p = Some tcb \ tcbBoundNotification tcb \ Some 0" +lemma map_to_tcbs_Some_refs_nonzero: + "\map_to_tcbs (ksPSpace s) p = Some tcb; no_0_obj' s; valid_objs' s\ + \ tcbBoundNotification tcb \ Some 0 + \ tcbSchedPrev tcb \ Some 0 + \ tcbSchedNext tcb \ Some 0" + supply word_neq_0_conv[simp del] apply (clarsimp simp: map_comp_def split: option.splits) - apply (erule(1) valid_objsE') - apply (clarsimp simp: projectKOs valid_obj'_def valid_tcb'_def) + apply (erule (1) valid_objsE') + apply (fastforce simp: projectKOs valid_obj'_def valid_tcb'_def) done lemma atcbContextGet_inj[simp]: @@ -769,34 +796,75 @@ lemma ccontext_relation_imp_eq2: "\ccontext_relation (atcbContextGet t) x; ccontext_relation (atcbContextGet t') x\ \ t = t'" by (auto dest: ccontext_relation_imp_eq) +lemma tcb_ptr_to_ctcb_ptr_inj: + "tcb_ptr_to_ctcb_ptr x = tcb_ptr_to_ctcb_ptr y \ x = y" + by (auto simp: tcb_ptr_to_ctcb_ptr_def ctcb_offset_def) + +lemma + assumes "pspace_aligned' as" "pspace_distinct' as" "valid_tcb' atcb as" + shows tcb_at'_tcbBoundNotification: + "bound (tcbBoundNotification atcb) \ ntfn_at' (the (tcbBoundNotification atcb)) as" + and tcb_at'_tcbSchedPrev: + "tcbSchedPrev atcb \ None \ tcb_at' (the (tcbSchedPrev atcb)) as" + and tcb_at'_tcbSchedNext: + "tcbSchedNext atcb \ None \ tcb_at' (the (tcbSchedNext atcb)) as" + using assms + by (clarsimp simp: valid_tcb'_def obj_at'_def)+ + lemma cpspace_tcb_relation_unique: - assumes tcbs: "cpspace_tcb_relation ah ch" "cpspace_tcb_relation ah' ch" - and vs: "\s. ksPSpace s = ah \ no_0_obj' s \ valid_objs' s" - and vs': "\s. ksPSpace s = ah' \ no_0_obj' s \ valid_objs' s" - assumes ctes: " \tcb tcb'. (\p. map_to_tcbs ah p = Some tcb \ - map_to_tcbs ah' p = Some tcb') \ - (\x\ran tcb_cte_cases. fst x tcb' = fst x tcb)" - shows "map_to_tcbs ah' = map_to_tcbs ah" + assumes tcbs: "cpspace_tcb_relation (ksPSpace as) ch" "cpspace_tcb_relation (ksPSpace as') ch" + assumes vs: "no_0_obj' as" "valid_objs' as" + assumes vs': "no_0_obj' as'" "valid_objs' as'" + assumes ad: "pspace_aligned' as" "pspace_distinct' as" + assumes ad': "pspace_aligned' as'" "pspace_distinct' as'" + assumes ctes: "\tcb tcb'. (\p. map_to_tcbs (ksPSpace as) p = Some tcb \ + map_to_tcbs (ksPSpace as') p = Some tcb') \ + (\x\ran tcb_cte_cases. fst x tcb' = fst x tcb)" + shows "map_to_tcbs (ksPSpace as') = map_to_tcbs (ksPSpace as)" using tcbs(2) tcbs(1) apply (clarsimp simp add: cmap_relation_def) apply (drule inj_image_inv[OF inj_tcb_ptr_to_ctcb_ptr])+ apply (simp add: tcb_ptr_to_ctcb_ptr_def[abs_def] ctcb_offset_def) apply (rule ext) - apply (case_tac "x:dom (map_to_tcbs ah)") + apply (case_tac "x \ dom (map_to_tcbs (ksPSpace as))") apply (drule bspec, assumption)+ apply (simp add: dom_def Collect_eq, drule_tac x=x in spec) apply clarsimp apply (rename_tac p x y) apply (cut_tac ctes) apply (drule_tac x=x in spec, drule_tac x=y in spec, erule impE, fastforce) - apply (frule ksPSpace_valid_objs_tcbBoundNotification_nonzero[OF vs]) - apply (frule ksPSpace_valid_objs_tcbBoundNotification_nonzero[OF vs']) + apply (frule map_to_tcbs_Some_refs_nonzero[OF _ vs]) + apply (frule map_to_tcbs_Some_refs_nonzero[OF _ vs']) + apply (rename_tac atcb atcb') + apply (prop_tac "valid_tcb' atcb as") + apply (fastforce intro: vs ad map_to_ko_atI tcb_ko_at_valid_objs_valid_tcb') + apply (prop_tac "valid_tcb' atcb' as'") + apply (fastforce intro: vs' ad' map_to_ko_atI tcb_ko_at_valid_objs_valid_tcb') + apply (frule tcb_at'_tcbSchedPrev[OF ad]) + apply (frule tcb_at'_tcbSchedPrev[OF ad']) + apply (frule tcb_at'_tcbSchedNext[OF ad]) + apply (frule tcb_at'_tcbSchedNext[OF ad']) apply (thin_tac "map_to_tcbs x y = Some z" for x y z)+ - apply (case_tac x, case_tac y, case_tac "the (clift ch (tcb_Ptr (p+0x200)))") + apply (case_tac "the (clift ch (tcb_Ptr (p + 2 ^ ctcb_size_bits)))") apply (clarsimp simp: ctcb_relation_def ran_tcb_cte_cases) - apply (clarsimp simp: option_to_ptr_def option_to_0_def split: option.splits) - apply (auto simp: cfault_rel_imp_eq cthread_state_rel_imp_eq carch_tcb_relation_def - ccontext_relation_imp_eq2 up_ucast_inj_eq ctcb_size_bits_def) + apply (clarsimp simp: option_to_ctcb_ptr_def option_to_ptr_def option_to_0_def) + apply (rule tcb.expand) + apply clarsimp + apply (intro conjI) + apply (simp add: cthread_state_rel_imp_eq) + apply (simp add: cfault_rel_imp_eq) + apply (case_tac "tcbBoundNotification atcb'", case_tac "tcbBoundNotification atcb"; clarsimp) + apply (clarsimp split: option.splits) + apply (case_tac "tcbSchedPrev atcb'"; case_tac "tcbSchedPrev atcb"; clarsimp) + apply (force dest!: kernel.tcb_at_not_NULL) + apply (force dest!: kernel.tcb_at_not_NULL) + apply (force simp: tcb_ptr_to_ctcb_ptr_inj) + apply (case_tac "tcbSchedNext atcb'"; case_tac "tcbSchedNext atcb"; clarsimp) + apply (force dest!: kernel.tcb_at_not_NULL) + apply (force dest!: kernel.tcb_at_not_NULL) + apply (force simp: tcb_ptr_to_ctcb_ptr_inj) + apply (force simp: carch_tcb_relation_def ccontext_relation_imp_eq2) + apply auto done lemma tcb_queue_rel_clift_unique: @@ -827,10 +895,6 @@ lemma ksPSpace_valid_pspace_ntfnBoundTCB_nonzero: apply (clarsimp simp: projectKOs valid_obj'_def valid_ntfn'_def) done -lemma tcb_ptr_to_ctcb_ptr_inj: - "tcb_ptr_to_ctcb_ptr x = tcb_ptr_to_ctcb_ptr y \ x = y" - by (auto simp: tcb_ptr_to_ctcb_ptr_def ctcb_offset_def) - lemma cpspace_ntfn_relation_unique: assumes ntfns: "cpspace_ntfn_relation ah ch" "cpspace_ntfn_relation ah' ch" and vs: "\s. ksPSpace s = ah \ valid_pspace' s" @@ -1078,8 +1142,8 @@ proof - apply (drule (1) cpspace_pte_relation_unique) apply (drule (1) cpspace_asidpool_relation_unique) apply (drule (1) cpspace_tcb_relation_unique) - apply (fastforce intro: no_0_objs no_0_objs' valid_objs valid_objs') - apply (fastforce intro: no_0_objs no_0_objs' valid_objs valid_objs') + apply (fastforce intro: no_0_objs no_0_objs' valid_objs valid_objs')+ + apply (fastforce intro: aligned distinct aligned' distinct')+ apply (intro allI impI,elim exE conjE) apply (rule_tac p=p in map_to_ctes_tcb_ctes, assumption) apply (frule (1) map_to_ko_atI[OF _ aligned distinct]) @@ -1132,7 +1196,7 @@ lemma ksPSpace_eq_imp_valid_tcb'_eq: by (auto simp: ksPSpace_eq_imp_obj_at'_eq[OF ksPSpace] ksPSpace_eq_imp_valid_cap'_eq[OF ksPSpace] ksPSpace_eq_imp_typ_at'_eq[OF ksPSpace] - valid_tcb'_def valid_tcb_state'_def valid_bound_ntfn'_def + valid_tcb'_def valid_tcb_state'_def valid_bound_ntfn'_def valid_bound_tcb'_def split: thread_state.splits option.splits) lemma ksPSpace_eq_imp_valid_objs'_eq: @@ -1287,7 +1351,7 @@ where ksDomSchedule = cDomSchedule_to_H kernel_all_global_addresses.ksDomSchedule, ksCurDomain = ucast (ksCurDomain_' s), ksDomainTime = ksDomainTime_' s, - ksReadyQueues = cready_queues_to_H (clift (t_hrs_' s)) (ksReadyQueues_' s), + ksReadyQueues = cready_queues_to_H (ksReadyQueues_' s), ksReadyQueuesL1Bitmap = cbitmap_L1_to_H (ksReadyQueuesL1Bitmap_' s), ksReadyQueuesL2Bitmap = cbitmap_L2_to_H (ksReadyQueuesL2Bitmap_' s), ksCurThread = ctcb_ptr_to_tcb_ptr (ksCurThread_' s), @@ -1309,16 +1373,16 @@ lemma trivial_eq_conj: "B = C \ (A \ B) = (A \ C)" lemma cstate_to_H_correct: assumes valid: "valid_state' as" assumes cstate_rel: "cstate_relation as cs" + assumes rdyqs: "ksReadyQueues_asrt as" shows "cstate_to_H cs = as \ksMachineState:= observable_memory (ksMachineState as) (user_mem' as)\" apply (subgoal_tac "cstate_to_machine_H cs = observable_memory (ksMachineState as) (user_mem' as)") apply (rule kernel_state.equality, simp_all add: cstate_to_H_def) - apply (rule cstate_to_pspace_H_correct) + apply (rule cstate_to_pspace_H_correct) using valid apply (simp add: valid_state'_def) using cstate_rel valid apply (clarsimp simp: cstate_relation_def cpspace_relation_def Let_def - observable_memory_def valid_state'_def - valid_pspace'_def) + observable_memory_def valid_state'_def valid_pspace'_def) using cstate_rel apply (clarsimp simp: cstate_relation_def cpspace_relation_def Let_def prod_eq_iff) using cstate_rel @@ -1326,10 +1390,10 @@ lemma cstate_to_H_correct: using valid cstate_rel apply (rule mk_gsUntypedZeroRanges_correct) subgoal - using cstate_rel - by (fastforce simp: cstate_relation_def cpspace_relation_def - Let_def ghost_size_rel_def unat_eq_0 - split: if_split) + using cstate_rel + by (fastforce simp: cstate_relation_def cpspace_relation_def + Let_def ghost_size_rel_def unat_eq_0 + split: if_split) using valid cstate_rel apply (rule cDomScheduleIdx_to_H_correct) using cstate_rel @@ -1343,8 +1407,13 @@ lemma cstate_to_H_correct: using cstate_rel apply (clarsimp simp: cstate_relation_def Let_def) apply (rule cready_queues_to_H_correct) - using cstate_rel - apply (clarsimp simp: cstate_relation_def Let_def) + using cstate_rel rdyqs + apply (fastforce intro!: cready_queues_to_H_correct + simp: cstate_relation_def Let_def) + using valid apply (fastforce simp: valid_state'_def) + using rdyqs apply fastforce + using valid apply (fastforce simp: valid_state'_def) + using valid apply (fastforce simp: valid_state'_def) using cstate_rel apply (clarsimp simp: cstate_relation_def Let_def) using cstate_rel diff --git a/proof/crefine/RISCV64/ArchMove_C.thy b/proof/crefine/RISCV64/ArchMove_C.thy index a73eae0e85..ddbf18b54d 100644 --- a/proof/crefine/RISCV64/ArchMove_C.thy +++ b/proof/crefine/RISCV64/ArchMove_C.thy @@ -297,14 +297,8 @@ lemma obj_at_kernel_mappings': \ p \ kernel_mappings" by (clarsimp simp: pspace_in_kernel_mappings'_def obj_at'_def dom_def) -crunches Arch.switchToThread - for valid_queues'[wp]: valid_queues' - (simp: crunch_simps wp: hoare_drop_imps) crunches switchToIdleThread for ksCurDomain[wp]: "\s. P (ksCurDomain s)" -crunches switchToIdleThread, switchToThread - for valid_pspace'[wp]: valid_pspace' - (simp: whenE_def crunch_simps wp: hoare_drop_imps) lemma getMessageInfo_less_4: "\\\ getMessageInfo t \\rv s. msgExtraCaps rv < 4\" diff --git a/proof/crefine/RISCV64/Arch_C.thy b/proof/crefine/RISCV64/Arch_C.thy index 49083a7bd3..5750c9fbca 100644 --- a/proof/crefine/RISCV64/Arch_C.thy +++ b/proof/crefine/RISCV64/Arch_C.thy @@ -1391,7 +1391,7 @@ lemma performPageGetAddress_ccorres: apply clarsimp apply (rule conseqPre, vcg) apply clarsimp - apply (clarsimp simp: invs_no_0_obj' tcb_at_invs' invs_queues invs_valid_objs' invs_sch_act_wf' + apply (clarsimp simp: invs_no_0_obj' tcb_at_invs' invs_valid_objs' invs_sch_act_wf' rf_sr_ksCurThread msgRegisters_unfold seL4_MessageInfo_lift_def message_info_to_H_def mask_def) apply (cases isCall) @@ -2833,13 +2833,14 @@ lemma decodeRISCVMMUInvocation_ccorres: apply (rule conjI; clarsimp) apply (frule invs_arch_state') apply (rule conjI, clarsimp simp: valid_arch_state'_def valid_asid_table'_def) - apply (clarsimp simp: neq_Nil_conv excaps_map_def valid_tcb_state'_def invs_queues - invs_sch_act_wf' + apply (clarsimp simp: neq_Nil_conv excaps_map_def valid_tcb_state'_def invs_sch_act_wf' unat_lt2p[where 'a=machine_word_len, folded word_bits_def]) apply (frule interpret_excaps_eq[rule_format, where n=1], simp) apply (rule conjI; clarsimp)+ apply (rule conjI, erule ctes_of_valid', clarsimp) apply (intro conjI) + apply fastforce + apply fastforce apply fastforce apply (fastforce elim!: pred_tcb'_weakenE) apply (clarsimp simp: st_tcb_at'_def obj_at'_def) @@ -2856,9 +2857,11 @@ lemma decodeRISCVMMUInvocation_ccorres: apply (clarsimp simp: le_mask_asid_bits_helper) apply (simp add: is_aligned_shiftl_self) (* RISCVASIDPoolAssign *) - apply (clarsimp simp: isCap_simps valid_tcb_state'_def invs_queues invs_sch_act_wf') + apply (clarsimp simp: isCap_simps valid_tcb_state'_def invs_sch_act_wf') apply (frule invs_arch_state', clarsimp) apply (intro conjI) + apply fastforce + apply fastforce apply fastforce apply (fastforce simp: ct_in_state'_def elim!: pred_tcb'_weakenE) apply (fastforce simp: ct_in_state'_def elim!: pred_tcb'_weakenE) diff --git a/proof/crefine/RISCV64/Detype_C.thy b/proof/crefine/RISCV64/Detype_C.thy index d53327927c..7e2c7a19ee 100644 --- a/proof/crefine/RISCV64/Detype_C.thy +++ b/proof/crefine/RISCV64/Detype_C.thy @@ -1680,35 +1680,11 @@ proof - done moreover - from invs have "valid_queues s" .. - hence "\p. \t \ set (ksReadyQueues s p). tcb_at' t s \ ko_wp_at' live' t s" - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def) - apply (drule spec, drule spec) - apply clarsimp - apply (drule (1) bspec) - apply (rule conjI) - apply (erule obj_at'_weakenE) - apply simp - apply (simp add: obj_at'_real_def) - apply (erule ko_wp_at'_weakenE) - apply (clarsimp simp: inQ_def) - done - hence tat: "\p. \t \ set (ksReadyQueues s p). tcb_at' t s" - and tlive: "\p. \t \ set (ksReadyQueues s p). ko_wp_at' live' t s" - by auto from sr have - "cready_queues_relation (clift ?th_s) - (ksReadyQueues_' (globals s')) (ksReadyQueues s)" + "cready_queues_relation (ksReadyQueues s) (ksReadyQueues_' (globals s'))" unfolding cready_queues_relation_def rf_sr_def cstate_relation_def cpspace_relation_def apply (clarsimp simp: Let_def all_conj_distrib) - apply (drule spec, drule spec, drule mp) - apply fastforce - apply ((subst lift_t_typ_region_bytes, rule cm_disj_tcb, assumption+, - simp_all add: objBits_simps pageBits_def)[1])+ - \ \waiting ...\ - apply (simp add: tcb_queue_relation_live_restrict - [OF D.valid_untyped tat tlive rl]) done moreover diff --git a/proof/crefine/RISCV64/Finalise_C.thy b/proof/crefine/RISCV64/Finalise_C.thy index 6a51ca38f4..7eacd462ab 100644 --- a/proof/crefine/RISCV64/Finalise_C.thy +++ b/proof/crefine/RISCV64/Finalise_C.thy @@ -35,6 +35,108 @@ declare if_split [split del] definition "option_map2 f m = option_map f \ m" +definition ksReadyQueues_head_end_2 :: "(domain \ priority \ ready_queue) \ bool" where + "ksReadyQueues_head_end_2 qs \ + \d p. tcbQueueHead (qs (d, p)) \ None \ tcbQueueEnd (qs (d, p)) \ None" + +abbreviation "ksReadyQueues_head_end s \ ksReadyQueues_head_end_2 (ksReadyQueues s)" + +lemmas ksReadyQueues_head_end_def = ksReadyQueues_head_end_2_def + +lemma ksReadyQueues_asrt_ksReadyQueues_head_end: + "ksReadyQueues_asrt s \ ksReadyQueues_head_end s" + by (fastforce dest: tcbQueueHead_iff_tcbQueueEnd + simp: ready_queue_relation_def ksReadyQueues_asrt_def ksReadyQueues_head_end_def) + +lemma tcbSchedEnqueue_ksReadyQueues_head_end[wp]: + "tcbSchedEnqueue tcbPtr \ksReadyQueues_head_end\" + unfolding tcbSchedEnqueue_def tcbQueuePrepend_def setQueue_def + apply (wpsimp wp: threadSet_wp threadGet_wp simp: bitmap_fun_defs) + apply (clarsimp simp: tcbQueueEmpty_def obj_at'_def ksReadyQueues_head_end_def split: if_splits) + done + +lemma ksReadyQueues_head_end_ksSchedulerAction_update[simp]: + "ksReadyQueues_head_end (s\ksSchedulerAction := ChooseNewThread\) = ksReadyQueues_head_end s" + by (simp add: ksReadyQueues_head_end_def) + +crunches rescheduleRequired + for ksReadyQueues_head_end[wp]: ksReadyQueues_head_end + +lemma setThreadState_ksReadyQueues_head_end[wp]: + "setThreadState ts tcbPtr \ksReadyQueues_head_end\" + unfolding setThreadState_def + by (wpsimp wp: threadSet_wp threadGet_wp simp: bitmap_fun_defs) + +definition ksReadyQueues_head_end_tcb_at'_2 :: + "(domain \ priority \ ready_queue) \ (obj_ref \ tcb) \ bool" where + "ksReadyQueues_head_end_tcb_at'_2 qs tcbs \ + \d p. (\head. tcbQueueHead (qs (d, p)) = Some head \ tcbs head \ None) + \ (\end. tcbQueueEnd (qs (d, p)) = Some end \ tcbs end \ None)" + +abbreviation "ksReadyQueues_head_end_tcb_at' s \ + ksReadyQueues_head_end_tcb_at'_2 (ksReadyQueues s) (tcbs_of' s)" + +lemmas ksReadyQueues_head_end_tcb_at'_def = ksReadyQueues_head_end_tcb_at'_2_def + +lemma ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at': + "\ksReadyQueues_asrt s; pspace_aligned' s; pspace_distinct' s\ + \ ksReadyQueues_head_end_tcb_at' s" + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def + ksReadyQueues_head_end_tcb_at'_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: list_queue_relation_def) + apply (intro conjI impI allI) + apply (case_tac "ts = []", clarsimp) + apply (fastforce dest!: heap_path_head hd_in_set + simp: opt_pred_def tcbQueueEmpty_def split: option.splits) + apply (fastforce simp: queue_end_valid_def opt_pred_def tcbQueueEmpty_def + split: option.splits) + done + +lemma tcbSchedEnqueue_ksReadyQueues_head_end_tcb_at'[wp]: + "tcbSchedEnqueue tcbPtr \ksReadyQueues_head_end_tcb_at'\" + unfolding tcbSchedEnqueue_def tcbQueuePrepend_def setQueue_def + apply (wpsimp wp: threadSet_wp threadGet_wp simp: bitmap_fun_defs) + apply (clarsimp simp: ksReadyQueues_head_end_tcb_at'_def split: if_splits) + done + +lemma ksReadyQueues_head_end_tcb_at'_ksSchedulerAction_update[simp]: + "ksReadyQueues_head_end_tcb_at' (s\ksSchedulerAction := ChooseNewThread\) + = ksReadyQueues_head_end_tcb_at' s" + by (simp add: ksReadyQueues_head_end_tcb_at'_def) + +crunches rescheduleRequired + for ksReadyQueues_head_end_tcb_at'[wp]: ksReadyQueues_head_end_tcb_at' + +lemma setThreadState_ksReadyQueues_head_end_tcb_at'[wp]: + "setThreadState ts tcbPtr \ksReadyQueues_head_end_tcb_at'\" + unfolding setThreadState_def + apply (wpsimp wp: threadSet_wp) + apply (fastforce simp: ksReadyQueues_head_end_tcb_at'_def split: if_splits) + done + +lemma head_end_ksReadyQueues_': + "\ (s, s') \ rf_sr; ksReadyQueues_head_end s; ksReadyQueues_head_end_tcb_at' s; + pspace_aligned' s; pspace_distinct' s; + d \ maxDomain; p \ maxPriority \ + \ head_C (index (ksReadyQueues_' (globals s')) (cready_queues_index_to_C d p)) = NULL + \ end_C (index (ksReadyQueues_' (globals s')) (cready_queues_index_to_C d p)) = NULL" + apply (frule (2) rf_sr_ctcb_queue_relation[where d=d and p=p]) + apply (clarsimp simp: ksReadyQueues_head_end_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: ksReadyQueues_head_end_tcb_at'_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: ctcb_queue_relation_def option_to_ctcb_ptr_def split: option.splits) + apply (rename_tac "end" head end_tcb head_tcb) + apply (prop_tac "tcb_at' head s \ tcb_at' end s") + apply (fastforce intro!: aligned'_distinct'_ko_wp_at'I + simp: obj_at'_real_def opt_map_def split: option.splits) + apply (fastforce dest: tcb_at_not_NULL) + done + lemma tcbSchedEnqueue_cslift_spec: "\s. \\\<^bsub>/UNIV\<^esub> \s. \d v. option_map2 tcbPriority_C (cslift s) \tcb = Some v \ unat v \ numPriorities @@ -46,7 +148,9 @@ lemma tcbSchedEnqueue_cslift_spec: \ None \ option_map2 tcbDomain_C (cslift s) (head_C (index \ksReadyQueues (unat (d*0x100 + v)))) - \ None)\ + \ None) + \ (head_C (index \ksReadyQueues (unat (d * 0x100 + v))) \ NULL + \ end_C (index \ksReadyQueues (unat (d * 0x100 + v))) \ NULL)\ Call tcbSchedEnqueue_'proc {s'. option_map2 tcbEPNext_C (cslift s') = option_map2 tcbEPNext_C (cslift s) \ option_map2 tcbEPPrev_C (cslift s') = option_map2 tcbEPPrev_C (cslift s) @@ -63,8 +167,8 @@ lemma tcbSchedEnqueue_cslift_spec: apply (rule conjI) apply (clarsimp simp: typ_heap_simps cong: if_cong) apply (simp split: if_split) - apply (clarsimp simp: typ_heap_simps if_Some_helper cong: if_cong) - by (simp split: if_split) + by (auto simp: typ_heap_simps' if_Some_helper numPriorities_def + cong: if_cong split: if_splits) lemma setThreadState_cslift_spec: "\s. \\\<^bsub>/UNIV\<^esub> \s. s \\<^sub>c \tptr \ (\x. ksSchedulerAction_' (globals s) = tcb_Ptr x @@ -160,8 +264,9 @@ lemma ctcb_relation_tcbPriority_maxPriority_numPriorities: done lemma tcbSchedEnqueue_cslift_precond_discharge: - "\ (s, s') \ rf_sr; obj_at' (P :: tcb \ bool) x s; - valid_queues s; valid_objs' s \ \ + "\ (s, s') \ rf_sr; obj_at' (P :: tcb \ bool) x s; valid_objs' s ; + ksReadyQueues_head_end s; ksReadyQueues_head_end_tcb_at' s; + pspace_aligned' s; pspace_distinct' s\ \ (\d v. option_map2 tcbPriority_C (cslift s') (tcb_ptr_to_ctcb_ptr x) = Some v \ unat v < numPriorities \ option_map2 tcbDomain_C (cslift s') (tcb_ptr_to_ctcb_ptr x) = Some d @@ -172,31 +277,49 @@ lemma tcbSchedEnqueue_cslift_precond_discharge: \ None \ option_map2 tcbDomain_C (cslift s') (head_C (index (ksReadyQueues_' (globals s')) (unat (d*0x100 + v)))) - \ None))" + \ None) + \ (head_C (index (ksReadyQueues_' (globals s')) (unat (d * 0x100 + v))) \ NULL + \ end_C (index (ksReadyQueues_' (globals s')) (unat (d * 0x100 + v))) \ NULL))" apply (drule(1) obj_at_cslift_tcb) apply (clarsimp simp: typ_heap_simps' option_map2_def) + apply (rename_tac tcb tcb') apply (frule_tac t=x in valid_objs'_maxPriority, fastforce simp: obj_at'_def) apply (frule_tac t=x in valid_objs'_maxDomain, fastforce simp: obj_at'_def) apply (drule_tac P="\tcb. tcbPriority tcb \ maxPriority" in obj_at_ko_at2', simp) apply (drule_tac P="\tcb. tcbDomain tcb \ maxDomain" in obj_at_ko_at2', simp) apply (simp add: ctcb_relation_tcbDomain_maxDomain_numDomains ctcb_relation_tcbPriority_maxPriority_numPriorities) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) + apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" in rf_sr_ctcb_queue_relation) apply (simp add: maxDom_to_H maxPrio_to_H)+ + apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" in head_end_ksReadyQueues_', fastforce+) apply (simp add: cready_queues_index_to_C_def2 numPriorities_def le_maxDomain_eq_less_numDomains) apply (clarsimp simp: ctcb_relation_def) apply (frule arg_cong[where f=unat], subst(asm) unat_ucast_up_simp, simp) - apply (frule tcb_queue'_head_end_NULL) - apply (erule conjunct1[OF valid_queues_valid_q]) - apply (frule(1) tcb_queue_relation_qhead_valid') - apply (simp add: valid_queues_valid_q) - apply (clarsimp simp: h_t_valid_clift_Some_iff) + apply (frule (3) head_end_ksReadyQueues_', fastforce+) + apply (clarsimp simp: ksReadyQueues_head_end_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (prop_tac "\ tcbQueueEmpty ((ksReadyQueues s (tcbDomain tcb, tcbPriority tcb)))") + apply (clarsimp simp: tcbQueueEmpty_def ctcb_queue_relation_def option_to_ctcb_ptr_def + split: option.splits) + apply (clarsimp simp: ksReadyQueues_head_end_tcb_at'_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (clarsimp simp: tcbQueueEmpty_def) + apply (rename_tac head "end" head_tcb end_tcb) + apply (prop_tac "tcb_at' head s") + apply (fastforce intro: aligned'_distinct'_ko_wp_at'I + simp: obj_at'_real_def opt_map_def split: option.splits) + apply (frule_tac thread=head in obj_at_cslift_tcb) + apply fastforce + apply (clarsimp dest: obj_at_cslift_tcb simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) done lemma cancel_all_ccorres_helper: "ccorres dc xfdc - (\s. valid_objs' s \ valid_queues s + (\s. valid_objs' s \ pspace_aligned' s \ pspace_distinct' s + \ ksReadyQueues_head_end s \ ksReadyQueues_head_end_tcb_at' s \ (\t\set ts. tcb_at' t s \ t \ 0) \ sch_act_wf (ksSchedulerAction s) s) {s'. \p. ep_queue_relation (cslift s') ts @@ -251,11 +374,11 @@ next apply (erule cmap_relationE1 [OF cmap_relation_tcb]) apply (erule ko_at_projectKO_opt) apply (fastforce intro: typ_heap_simps) - apply (wp sts_running_valid_queues | simp)+ + apply (wp sts_valid_objs' | simp)+ apply (rule ceqv_refl) apply (rule "Cons.hyps") apply (wp sts_valid_objs' sts_sch_act sch_act_wf_lift hoare_vcg_const_Ball_lift - sts_running_valid_queues sts_st_tcb' setThreadState_oa_queued | simp)+ + sts_st_tcb' | simp)+ apply (vcg exspec=setThreadState_cslift_spec exspec=tcbSchedEnqueue_cslift_spec) apply (clarsimp simp: tcb_at_not_NULL Collect_const_mem valid_tcb_state'_def @@ -269,16 +392,13 @@ next st_tcb_at'_def split: scheduler_action.split_asm) apply (rename_tac word) - apply (frule_tac x=word in tcbSchedEnqueue_cslift_precond_discharge) - apply simp - apply clarsimp - apply clarsimp - apply clarsimp + apply (frule_tac x=word in tcbSchedEnqueue_cslift_precond_discharge; clarsimp?) + apply simp apply clarsimp apply (rule conjI) apply (frule(3) tcbSchedEnqueue_cslift_precond_discharge) apply clarsimp - apply clarsimp + apply clarsimp+ apply (subst ep_queue_relation_shift, fastforce) apply (drule_tac x="tcb_ptr_to_ctcb_ptr thread" in fun_cong)+ @@ -287,11 +407,17 @@ next done qed +crunches setEndpoint, setNotification + for ksReadyQueues_head_end[wp]: ksReadyQueues_head_end + and ksReadyQueues_head_end_tcb_at'[wp]: ksReadyQueues_head_end_tcb_at' + (simp: updateObject_default_def) + lemma cancelAllIPC_ccorres: "ccorres dc xfdc - (invs') (UNIV \ {s. epptr_' s = Ptr epptr}) [] + invs' (UNIV \ {s. epptr_' s = Ptr epptr}) [] (cancelAllIPC epptr) (Call cancelAllIPC_'proc)" apply (cinit lift: epptr_') + apply (rule ccorres_stateAssert) apply (rule ccorres_symb_exec_l [OF _ getEndpoint_inv _ empty_fail_getEndpoint]) apply (rule_tac xf'=ret__unsigned_longlong_' and val="case ep of IdleEP \ scast EPState_Idle @@ -306,7 +432,7 @@ lemma cancelAllIPC_ccorres: apply (simp add: cendpoint_relation_def Let_def split: endpoint.split_asm) apply ceqv - apply (rule_tac A="invs' and ko_at' ep epptr" + apply (rule_tac A="invs' and ksReadyQueues_asrt and ko_at' ep epptr" in ccorres_guard_imp2[where A'=UNIV]) apply wpc apply (rename_tac list) @@ -347,12 +473,11 @@ lemma cancelAllIPC_ccorres: apply ceqv apply (ctac add: rescheduleRequired_ccorres) apply (wp weak_sch_act_wf_lift_linear - cancelAllIPC_mapM_x_valid_queues | simp)+ apply (rule mapM_x_wp', wp)+ apply (wp sts_st_tcb') apply (clarsimp split: if_split) - apply (rule mapM_x_wp', wp)+ + apply (rule mapM_x_wp', wp sts_valid_objs')+ apply (clarsimp simp: valid_tcb_state'_def) apply (simp add: guard_is_UNIV_def) apply (wp set_ep_valid_objs' hoare_vcg_const_Ball_lift @@ -395,18 +520,21 @@ lemma cancelAllIPC_ccorres: apply (rule cancel_all_ccorres_helper) apply ceqv apply (ctac add: rescheduleRequired_ccorres) - apply (wp cancelAllIPC_mapM_x_valid_queues) - apply (wp mapM_x_wp' weak_sch_act_wf_lift_linear + apply (wp mapM_x_wp' weak_sch_act_wf_lift_linear sts_valid_objs' sts_st_tcb' | clarsimp simp: valid_tcb_state'_def split: if_split)+ apply (simp add: guard_is_UNIV_def) apply (wp set_ep_valid_objs' hoare_vcg_const_Ball_lift weak_sch_act_wf_lift_linear) apply vcg - apply (clarsimp simp: valid_ep'_def invs_valid_objs' invs_queues) + apply (clarsimp simp: valid_ep'_def invs_valid_objs') apply (rule cmap_relationE1[OF cmap_relation_ep], assumption) apply (erule ko_at_projectKO_opt) apply (frule obj_at_valid_objs', clarsimp+) apply (clarsimp simp: valid_obj'_def valid_ep'_def) + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (frule ksReadyQueues_asrt_ksReadyQueues_head_end) + apply (frule (2) ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at') subgoal by (auto simp: typ_heap_simps cendpoint_relation_def Let_def tcb_queue_relation'_def invs_valid_objs' valid_objs'_maxDomain valid_objs'_maxPriority @@ -418,9 +546,10 @@ lemma cancelAllIPC_ccorres: lemma cancelAllSignals_ccorres: "ccorres dc xfdc - (invs') (UNIV \ {s. ntfnPtr_' s = Ptr ntfnptr}) [] + invs' (UNIV \ {s. ntfnPtr_' s = Ptr ntfnptr}) [] (cancelAllSignals ntfnptr) (Call cancelAllSignals_'proc)" apply (cinit lift: ntfnPtr_') + apply (rule ccorres_stateAssert) apply (rule ccorres_symb_exec_l [OF _ get_ntfn_inv' _ empty_fail_getNotification]) apply (rule_tac xf'=ret__unsigned_longlong_' and val="case ntfnObj ntfn of IdleNtfn \ scast NtfnState_Idle @@ -435,7 +564,7 @@ lemma cancelAllSignals_ccorres: apply (simp add: cnotification_relation_def Let_def split: ntfn.split_asm) apply ceqv - apply (rule_tac A="invs' and ko_at' ntfn ntfnptr" + apply (rule_tac A="invs' and ksReadyQueues_asrt and ko_at' ntfn ntfnptr" in ccorres_guard_imp2[where A'=UNIV]) apply wpc apply (simp add: notification_state_defs ccorres_cond_iffs) @@ -475,8 +604,7 @@ lemma cancelAllSignals_ccorres: apply (rule cancel_all_ccorres_helper) apply ceqv apply (ctac add: rescheduleRequired_ccorres) - apply (wp cancelAllIPC_mapM_x_valid_queues) - apply (wp mapM_x_wp' weak_sch_act_wf_lift_linear + apply (wp mapM_x_wp' weak_sch_act_wf_lift_linear sts_valid_objs' sts_st_tcb' | clarsimp simp: valid_tcb_state'_def split: if_split)+ apply (simp add: guard_is_UNIV_def) apply (wp set_ntfn_valid_objs' hoare_vcg_const_Ball_lift @@ -487,6 +615,10 @@ lemma cancelAllSignals_ccorres: apply (erule ko_at_projectKO_opt) apply (frule obj_at_valid_objs', clarsimp+) apply (clarsimp simp add: valid_obj'_def valid_ntfn'_def) + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (frule ksReadyQueues_asrt_ksReadyQueues_head_end) + apply (frule (2) ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at') subgoal by (auto simp: typ_heap_simps cnotification_relation_def Let_def tcb_queue_relation'_def invs_valid_objs' valid_objs'_maxDomain valid_objs'_maxPriority @@ -571,16 +703,16 @@ lemma tcb_queue_relation2_cong: context kernel_m begin -lemma setThreadState_ccorres_valid_queues'_simple: - "ccorres dc xfdc (\s. tcb_at' thread s \ valid_queues' s \ \ runnable' st \ sch_act_simple s) +lemma setThreadState_ccorres_simple: + "ccorres dc xfdc (\s. tcb_at' thread s \ \ runnable' st \ sch_act_simple s) ({s'. (\cl fl. cthread_state_relation_lifted st (cl\tsType_CL := ts_' s' && mask 4\, fl))} \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) [] (setThreadState st thread) (Call setThreadState_'proc)" apply (cinit lift: tptr_' cong add: call_ignore_cong) apply (ctac (no_vcg) add: threadSet_tcbState_simple_corres) apply (ctac add: scheduleTCB_ccorres_valid_queues'_simple) - apply (wp threadSet_valid_queues'_and_not_runnable') - apply (clarsimp simp: weak_sch_act_wf_def valid_queues'_def) + apply (wp threadSet_tcbState_st_tcb_at') + apply (fastforce simp: weak_sch_act_wf_def) done lemma updateRestartPC_ccorres: @@ -596,9 +728,7 @@ lemma updateRestartPC_ccorres: done crunches updateRestartPC - for valid_queues'[wp]: valid_queues' - and sch_act_simple[wp]: sch_act_simple - and valid_queues[wp]: Invariants_H.valid_queues + for sch_act_simple[wp]: sch_act_simple and valid_objs'[wp]: valid_objs' and tcb_at'[wp]: "tcb_at' p" @@ -642,21 +772,12 @@ lemma suspend_ccorres: apply (ctac (no_vcg) add: updateRestartPC_ccorres) apply (rule ccorres_return_Skip) apply ceqv - apply (ctac(no_vcg) add: setThreadState_ccorres_valid_queues'_simple) - apply (ctac add: tcbSchedDequeue_ccorres') - apply (rule_tac Q="\_. - (\s. \t' d p. (t' \ set (ksReadyQueues s (d, p)) \ - obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d - \ tcbPriority tcb = p) t' s \ - (t' \ thread \ st_tcb_at' runnable' t' s)) \ - distinct (ksReadyQueues s (d, p))) and valid_queues' and valid_objs' and tcb_at' thread" - in hoare_post_imp) + apply (ctac(no_vcg) add: setThreadState_ccorres_simple) + apply (ctac add: tcbSchedDequeue_ccorres) + apply (rule_tac Q="\_. valid_objs' and tcb_at' thread and pspace_aligned' and pspace_distinct'" + in hoare_post_imp) apply clarsimp - apply (drule_tac x="t" in spec) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp elim!: obj_at'_weakenE simp: inQ_def) - apply (wp sts_valid_queues_partial)[1] + apply (wp sts_valid_objs')[1] apply clarsimp apply (wpsimp simp: valid_tcb_state'_def) apply clarsimp @@ -671,8 +792,7 @@ lemma suspend_ccorres: apply (rule cancelIPC_sch_act_simple) apply (rule cancelIPC_tcb_at'[where t=thread]) apply (rule delete_one_conc_fr.cancelIPC_invs) - apply (fastforce simp: invs_valid_queues' invs_queues invs_valid_objs' - valid_tcb_state'_def) + apply (fastforce simp: invs_valid_objs' valid_tcb_state'_def) apply (auto simp: ThreadState_defs) done @@ -857,8 +977,8 @@ lemma unbindMaybeNotification_ccorres: apply (clarsimp ) apply (frule (1) ko_at_valid_ntfn'[OF _ invs_valid_objs']) by (auto simp: valid_ntfn'_def valid_bound_tcb'_def obj_at'_def - objBitsKO_def is_aligned_def option_to_ctcb_ptr_def tcb_at_not_NULL - split: ntfn.splits) + objBitsKO_def is_aligned_def option_to_ctcb_ptr_def tcb_at_not_NULL + split: ntfn.splits) (* TODO: move *) definition @@ -1677,20 +1797,6 @@ lemma ep_queue_relation_shift2: apply (clarsimp split: option.split_asm) done -lemma sched_queue_relation_shift: - "(option_map2 tcbSchedNext_C (f (cslift s)) - = option_map2 tcbSchedNext_C (cslift s) - \ option_map2 tcbSchedPrev_C (f (cslift s)) - = option_map2 tcbSchedPrev_C (cslift s)) - \ sched_queue_relation (f (cslift s)) ts qPrev qHead - = sched_queue_relation (cslift s) ts qPrev qHead" - apply (induct ts arbitrary: qPrev qHead; clarsimp) - apply (simp add: option_map2_def fun_eq_iff - map_option_case) - apply (drule_tac x=qHead in spec)+ - apply (clarsimp split: option.split_asm) - done - lemma cendpoint_relation_udpate_arch: "\ cslift x p = Some tcb ; cendpoint_relation (cslift x) v v' \ \ cendpoint_relation ((cslift x)(p \ tcbArch_C_update f tcb)) v v'" diff --git a/proof/crefine/RISCV64/Interrupt_C.thy b/proof/crefine/RISCV64/Interrupt_C.thy index c23fb74d58..706f2d40ec 100644 --- a/proof/crefine/RISCV64/Interrupt_C.thy +++ b/proof/crefine/RISCV64/Interrupt_C.thy @@ -257,7 +257,7 @@ lemma decodeIRQHandlerInvocation_ccorres: apply (simp add: syscall_error_to_H_cases) apply simp apply (clarsimp simp: Collect_const_mem tcb_at_invs') - apply (clarsimp simp: invs_queues invs_valid_objs' + apply (clarsimp simp: invs_valid_objs' ct_in_state'_def ccap_rights_relation_def mask_def[where n=4] ThreadState_defs) @@ -273,7 +273,7 @@ lemma decodeIRQHandlerInvocation_ccorres: excaps_map_def excaps_in_mem_def word_less_nat_alt hd_conv_nth slotcap_in_mem_def valid_tcb_state'_def dest!: interpret_excaps_eq split: bool.splits)+ - apply (auto dest: st_tcb_at_idle_thread' ctes_of_valid')[4] + apply (auto dest: st_tcb_at_idle_thread' ctes_of_valid')[6] apply (drule ctes_of_valid') apply fastforce apply (clarsimp simp add:valid_cap_simps' RISCV64.maxIRQ_def) diff --git a/proof/crefine/RISCV64/Invoke_C.thy b/proof/crefine/RISCV64/Invoke_C.thy index f650ef4f20..5da6ad0739 100644 --- a/proof/crefine/RISCV64/Invoke_C.thy +++ b/proof/crefine/RISCV64/Invoke_C.thy @@ -80,15 +80,14 @@ lemma setDomain_ccorres: and (\s. curThread = ksCurThread s)" in hoare_strengthen_post) apply (wp threadSet_all_invs_but_sch_extra) - apply (clarsimp simp: valid_pspace_valid_objs' st_tcb_at_def[symmetric] - sch_act_simple_def st_tcb_at'_def weak_sch_act_wf_def - split: if_splits) + apply (fastforce simp: valid_pspace_valid_objs' st_tcb_at_def[symmetric] + sch_act_simple_def st_tcb_at'_def weak_sch_act_wf_def + split: if_splits) apply (simp add: guard_is_UNIV_def) - apply (rule_tac Q="\_. invs' and tcb_at' t and sch_act_simple - and (\s. curThread = ksCurThread s \ (\p. t \ set (ksReadyQueues s p)))" + apply (rule_tac Q="\_. invs' and tcb_at' t and sch_act_simple and (\s. curThread = ksCurThread s)" in hoare_strengthen_post) apply (wp weak_sch_act_wf_lift_linear tcbSchedDequeue_not_queued - tcbSchedDequeue_not_in_queue hoare_vcg_imp_lift hoare_vcg_all_lift) + hoare_vcg_imp_lift hoare_vcg_all_lift) apply (clarsimp simp: invs'_def valid_pspace'_def valid_state'_def) apply (fastforce simp: valid_tcb'_def tcb_cte_cases_def invs'_def valid_state'_def valid_pspace'_def) @@ -196,8 +195,8 @@ lemma decodeDomainInvocation_ccorres: apply clarsimp apply (vcg exspec=getSyscallArg_modifies) - apply (clarsimp simp: valid_tcb_state'_def invs_valid_queues' invs_valid_objs' - invs_queues invs_sch_act_wf' ct_in_state'_def pred_tcb_at' + apply (clarsimp simp: valid_tcb_state'_def invs_valid_objs' + invs_sch_act_wf' ct_in_state'_def pred_tcb_at' rf_sr_ksCurThread word_sle_def word_sless_def sysargs_rel_to_n mask_eq_iff_w2p mask_eq_iff_w2p word_size ThreadState_defs) apply (rule conjI) @@ -207,7 +206,7 @@ lemma decodeDomainInvocation_ccorres: apply (drule_tac x="extraCaps ! 0" and P="\v. valid_cap' (fst v) s" in bspec) apply (clarsimp simp: nth_mem interpret_excaps_test_null excaps_map_def) apply (clarsimp simp: valid_cap_simps' pred_tcb'_weakenE active_runnable') - apply (rule conjI) + apply (intro conjI; fastforce?) apply (fastforce simp: tcb_st_refs_of'_def elim:pred_tcb'_weakenE) apply (simp add: word_le_nat_alt unat_ucast unat_numDomains_to_H le_maxDomain_eq_less_numDomains) apply (clarsimp simp: ccap_relation_def cap_to_H_simps cap_thread_cap_lift) @@ -760,15 +759,15 @@ lemma decodeCNodeInvocation_ccorres: apply simp apply (wp injection_wp_E[OF refl]) apply (rule hoare_post_imp_R) - apply (rule_tac Q'="\rv. valid_pspace' and valid_queues + apply (rule_tac Q'="\rv. valid_pspace' and valid_cap' rv and valid_objs' and tcb_at' thread and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_vcg_R_conj) apply (rule deriveCap_Null_helper[OF deriveCap_derived]) apply wp apply (clarsimp simp: cte_wp_at_ctes_of) - apply (simp add: is_derived'_def badge_derived'_def - valid_tcb_state'_def) + apply (fastforce simp: is_derived'_def badge_derived'_def + valid_tcb_state'_def) apply (simp add: Collect_const_mem all_ex_eq_helper) apply (vcg exspec=deriveCap_modifies) apply wp @@ -836,14 +835,14 @@ lemma decodeCNodeInvocation_ccorres: apply (simp add: conj_comms valid_tcb_state'_def) apply (wp injection_wp_E[OF refl]) apply (rule hoare_post_imp_R) - apply (rule_tac Q'="\rv. valid_pspace' and valid_queues + apply (rule_tac Q'="\rv. valid_pspace' and valid_cap' rv and valid_objs' and tcb_at' thread and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_vcg_R_conj) apply (rule deriveCap_Null_helper [OF deriveCap_derived]) apply wp apply (clarsimp simp: cte_wp_at_ctes_of) - apply (simp add: is_derived'_def badge_derived'_def) + apply (fastforce simp: is_derived'_def badge_derived'_def) apply (simp add: Collect_const_mem all_ex_eq_helper) apply (vcg exspec=deriveCap_modifies) apply (simp add: Collect_const_mem) @@ -951,12 +950,14 @@ lemma decodeCNodeInvocation_ccorres: apply (rule_tac Q'="\a b. cte_wp_at' (\x. True) a b \ invs' b \ tcb_at' thread b \ sch_act_wf (ksSchedulerAction b) b \ valid_tcb_state' Restart b \ Q2 b" for Q2 in hoare_post_imp_R) - prefer 2 - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (drule ctes_of_valid') - apply (erule invs_valid_objs') - apply (clarsimp simp:valid_updateCapDataI invs_queues invs_valid_objs' invs_valid_pspace') - apply (assumption) + prefer 2 + apply (clarsimp simp:cte_wp_at_ctes_of) + apply (drule ctes_of_valid') + apply (erule invs_valid_objs') + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (clarsimp simp:valid_updateCapDataI invs_valid_objs' invs_valid_pspace') + apply assumption apply (wp hoare_vcg_all_lift_R injection_wp_E[OF refl] lsfco_cte_at' hoare_vcg_const_imp_lift_R )+ @@ -1351,7 +1352,7 @@ lemma decodeCNodeInvocation_ccorres: apply simp apply (vcg exspec=getSyscallArg_modifies) apply (clarsimp simp: valid_tcb_state'_def invs_valid_objs' invs_valid_pspace' - ct_in_state'_def pred_tcb_at' invs_queues + ct_in_state'_def pred_tcb_at' cur_tcb'_def word_sle_def word_sless_def unat_lt2p[where 'a=machine_word_len, folded word_bits_def]) apply (rule conjI) @@ -1383,9 +1384,6 @@ end context begin interpretation Arch . (*FIXME: arch_split*) -crunch valid_queues[wp]: insertNewCap "valid_queues" - (wp: crunch_wps) - lemmas setCTE_def3 = setCTE_def2[THEN eq_reflection] lemma setCTE_sch_act_wf[wp]: @@ -3273,7 +3271,7 @@ lemma decodeUntypedInvocation_ccorres_helper: and sch_act_simple and ct_active'" in hoare_post_imp_R) prefer 2 apply (clarsimp simp: invs_valid_objs' invs_mdb' - invs_queues ct_in_state'_def pred_tcb_at') + ct_in_state'_def pred_tcb_at') apply (subgoal_tac "ksCurThread s \ ksIdleThread sa") prefer 2 apply clarsimp diff --git a/proof/crefine/RISCV64/IpcCancel_C.thy b/proof/crefine/RISCV64/IpcCancel_C.thy index 716f11e51f..b11da5071d 100644 --- a/proof/crefine/RISCV64/IpcCancel_C.thy +++ b/proof/crefine/RISCV64/IpcCancel_C.thy @@ -14,12 +14,12 @@ context kernel_m begin lemma cready_queues_index_to_C_in_range': - assumes prems: "qdom \ ucast maxDom" "prio \ ucast maxPrio" + assumes prems: "qdom \ maxDomain" "prio \ maxPriority" shows "cready_queues_index_to_C qdom prio < num_tcb_queues" proof - have P: "unat prio < numPriorities" using prems - by (simp add: numPriorities_def seL4_MaxPrio_def Suc_le_lessD unat_le_helper) + by (simp add: numPriorities_def Suc_le_lessD unat_le_helper maxDomain_def maxPriority_def) have Q: "unat qdom < numDomains" using prems by (simp add: maxDom_to_H le_maxDomain_eq_less_numDomains word_le_nat_alt) @@ -33,36 +33,18 @@ lemmas cready_queues_index_to_C_in_range = lemma cready_queues_index_to_C_inj: "\ cready_queues_index_to_C qdom prio = cready_queues_index_to_C qdom' prio'; - prio \ ucast maxPrio; prio' \ ucast maxPrio \ \ prio = prio' \ qdom = qdom'" + prio \ maxPriority; prio' \ maxPriority \ \ prio = prio' \ qdom = qdom'" apply (rule context_conjI) - apply (auto simp: cready_queues_index_to_C_def numPriorities_def + apply (auto simp: cready_queues_index_to_C_def numPriorities_def maxPriority_def seL4_MaxPrio_def word_le_nat_alt dest: arg_cong[where f="\x. x mod 256"]) done lemma cready_queues_index_to_C_distinct: - "\ qdom = qdom' \ prio \ prio'; prio \ ucast maxPrio; prio' \ ucast maxPrio \ + "\ qdom = qdom' \ prio \ prio'; prio \ maxPriority; prio' \ maxPriority \ \ cready_queues_index_to_C qdom prio \ cready_queues_index_to_C qdom' prio'" apply (auto simp: cready_queues_index_to_C_inj) done -lemma cstate_relation_ksReadyQueues_update: - "\ cstate_relation hs cs; arr = ksReadyQueues_' cs; - sched_queue_relation' (clift (t_hrs_' cs)) v (head_C v') (end_C v'); - qdom \ ucast maxDom; prio \ ucast maxPrio \ - \ cstate_relation (ksReadyQueues_update (\qs. qs ((qdom, prio) := v)) hs) - (ksReadyQueues_'_update (\_. Arrays.update arr - (cready_queues_index_to_C qdom prio) v') cs)" - apply (clarsimp simp: cstate_relation_def Let_def - cmachine_state_relation_def - carch_state_relation_def carch_globals_def - cready_queues_relation_def seL4_MinPrio_def minDom_def) - apply (frule cready_queues_index_to_C_in_range, assumption) - apply clarsimp - apply (frule_tac qdom=qdoma and prio=prioa in cready_queues_index_to_C_in_range, assumption) - apply (frule cready_queues_index_to_C_distinct, assumption+) - apply clarsimp - done - lemma cmap_relation_drop_fun_upd: "\ cm x = Some v; \v''. rel v'' v = rel v'' v' \ \ cmap_relation am (cm (x \ v')) f rel @@ -73,16 +55,6 @@ lemma cmap_relation_drop_fun_upd: apply (auto split: if_split) done -lemma valid_queuesD': - "\ obj_at' (inQ d p) t s; valid_queues' s \ - \ t \ set (ksReadyQueues s (d, p))" - by (simp add: valid_queues'_def) - -lemma invs_valid_queues'[elim!]: - "invs' s \ valid_queues' s" - by (simp add: invs'_def valid_state'_def) - - lemma ntfn_ptr_get_queue_spec: "\s. \ \ {\. s = \ \ \ \\<^sub>c \<^bsup>\\<^esup>ntfnPtr} \ret__struct_tcb_queue_C :== PROC ntfn_ptr_get_queue(\ntfnPtr) \head_C \ret__struct_tcb_queue_C = Ptr (ntfnQueue_head_CL (notification_lift (the (cslift s \<^bsup>s\<^esup>ntfnPtr)))) \ @@ -227,22 +199,19 @@ lemma cancelSignal_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) - apply simp - apply (erule (1) map_to_ko_atI') - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) - apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def) - apply (simp add: carch_state_relation_def carch_globals_def) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) + apply simp + apply (erule (1) map_to_ko_atI') + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) + apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def) + apply (simp add: carch_state_relation_def carch_globals_def) apply (clarsimp simp: carch_state_relation_def carch_globals_def typ_heap_simps' packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) @@ -263,34 +232,31 @@ lemma cancelSignal_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_ntfn_queue) - apply fastforce - apply assumption+ - apply simp - apply (erule (1) map_to_ko_atI') - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) - apply (simp add: cnotification_relation_def Let_def isWaitingNtfn_def - split: ntfn.splits split del: if_split) - apply (erule iffD1 [OF tcb_queue_relation'_cong [OF refl _ _ refl], rotated -1]) - apply (clarsimp simp add: h_t_valid_clift_Some_iff) - apply (subst tcb_queue_relation'_next_sign; assumption?) - apply fastforce - apply (simp add: notification_lift_def sign_extend_sign_extend_eq canonical_bit_def) - apply (clarsimp simp: h_t_valid_clift_Some_iff notification_lift_def sign_extend_sign_extend_eq) - apply (subst tcb_queue_relation'_prev_sign; assumption?) - apply fastforce - apply (simp add: canonical_bit_def) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (rule cendpoint_relation_ntfn_queue) + apply fastforce + apply assumption+ + apply simp + apply (erule (1) map_to_ko_atI') + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) + apply (simp add: cnotification_relation_def Let_def isWaitingNtfn_def + split: ntfn.splits split del: if_split) + apply (erule iffD1 [OF tcb_queue_relation'_cong [OF refl _ _ refl], rotated -1]) + apply (clarsimp simp add: h_t_valid_clift_Some_iff) + apply (subst tcb_queue_relation'_next_sign; assumption?) + apply fastforce + apply (simp add: notification_lift_def sign_extend_sign_extend_eq canonical_bit_def) + apply (clarsimp simp: h_t_valid_clift_Some_iff notification_lift_def sign_extend_sign_extend_eq) + apply (subst tcb_queue_relation'_prev_sign; assumption?) + apply fastforce + apply (simp add: canonical_bit_def) + apply simp subgoal by (clarsimp simp: carch_state_relation_def carch_globals_def) subgoal by (simp add: cmachine_state_relation_def) subgoal by (simp add: h_t_valid_clift_Some_iff) @@ -456,68 +422,6 @@ lemma isRunnable_ccorres [corres]: apply (simp add: ThreadState_defs)+ done - - -lemma tcb_queue_relation_update_head: - fixes getNext_update :: "(tcb_C ptr \ tcb_C ptr) \ tcb_C \ tcb_C" and - getPrev_update :: "(tcb_C ptr \ tcb_C ptr) \ tcb_C \ tcb_C" - assumes qr: "tcb_queue_relation getNext getPrev mp queue NULL qhead" - and qh': "qhead' \ tcb_ptr_to_ctcb_ptr ` set queue" - and cs_tcb: "mp qhead' = Some tcb" - and valid_ep: "\t\set queue. tcb_at' t s" "distinct queue" - and qhN: "qhead' \ NULL" - and fgN: "fg_cons getNext (getNext_update \ (\x _. x))" - and fgP: "fg_cons getPrev (getPrev_update \ (\x _. x))" - and npu: "\f t. getNext (getPrev_update f t) = getNext t" - and pnu: "\f t. getPrev (getNext_update f t) = getPrev t" - shows "tcb_queue_relation getNext getPrev - (upd_unless_null qhead (getPrev_update (\_. qhead') (the (mp qhead))) - (mp(qhead' := Some (getPrev_update (\_. NULL) (getNext_update (\_. qhead) tcb))))) - (ctcb_ptr_to_tcb_ptr qhead' # queue) NULL qhead'" - using qr qh' cs_tcb valid_ep qhN - apply (subgoal_tac "qhead \ qhead'") - apply (clarsimp simp: pnu upd_unless_null_def fg_consD1 [OF fgN] fg_consD1 [OF fgP] npu) - apply (cases queue) - apply simp - apply (frule (2) tcb_queue_relation_next_not_NULL) - apply simp - apply (clarsimp simp: fg_consD1 [OF fgN] fg_consD1 [OF fgP] pnu npu) - apply (subst tcb_queue_relation_cong [OF refl refl refl, where mp' = mp]) - apply (clarsimp simp: inj_eq) - apply (intro impI conjI) - apply (frule_tac x = x in imageI [where f = tcb_ptr_to_ctcb_ptr]) - apply simp - apply simp - apply simp - apply clarsimp - apply (cases queue) - apply simp - apply simp - done - -lemma tcbSchedEnqueue_update: - assumes sr: "sched_queue_relation' mp queue qhead qend" - and qh': "qhead' \ tcb_ptr_to_ctcb_ptr ` set queue" - and cs_tcb: "mp qhead' = Some tcb" - and valid_ep: "\t\set queue. tcb_at' t s" "distinct queue" - and qhN: "qhead' \ NULL" - shows - "sched_queue_relation' - (upd_unless_null qhead (tcbSchedPrev_C_update (\_. qhead') (the (mp qhead))) - (mp(qhead' \ tcb\tcbSchedNext_C := qhead, tcbSchedPrev_C := NULL\))) - (ctcb_ptr_to_tcb_ptr qhead' # queue) qhead' (if qend = NULL then qhead' else qend)" - using sr qh' cs_tcb valid_ep qhN - apply - - apply (erule tcb_queue_relationE') - apply (rule tcb_queue_relationI') - apply (erule (5) tcb_queue_relation_update_head - [where getNext_update = tcbSchedNext_C_update and getPrev_update = tcbSchedPrev_C_update], simp_all)[1] - apply simp - apply (intro impI) - apply (erule (1) tcb_queue_relation_not_NULL') - apply simp - done - lemma tcb_ptr_to_ctcb_ptr_imageD: "x \ tcb_ptr_to_ctcb_ptr ` S \ ctcb_ptr_to_tcb_ptr x \ S" apply (erule imageE) @@ -530,93 +434,6 @@ lemma ctcb_ptr_to_tcb_ptr_imageI: apply simp done -lemma tcb_queue'_head_end_NULL: - assumes qr: "tcb_queue_relation' getNext getPrev mp queue qhead qend" - and tat: "\t\set queue. tcb_at' t s" - shows "(qend = NULL) = (qhead = NULL)" - using qr tat - apply - - apply (erule tcb_queue_relationE') - apply (simp add: tcb_queue_head_empty_iff) - apply (rule impI) - apply (rule tcb_at_not_NULL) - apply (erule bspec) - apply simp - done - -lemma tcb_queue_relation_qhead_mem: - "\ tcb_queue_relation getNext getPrev mp queue NULL qhead; - (\tcb\set queue. tcb_at' tcb t) \ - \ qhead \ NULL \ ctcb_ptr_to_tcb_ptr qhead \ set queue" - by (clarsimp simp: tcb_queue_head_empty_iff tcb_queue_relation_head_hd) - -lemma tcb_queue_relation_qhead_valid: - "\ tcb_queue_relation getNext getPrev (cslift s') queue NULL qhead; - (s, s') \ rf_sr; (\tcb\set queue. tcb_at' tcb s) \ - \ qhead \ NULL \ s' \\<^sub>c qhead" - apply (frule (1) tcb_queue_relation_qhead_mem) - apply clarsimp - apply(drule (3) tcb_queue_memberD) - apply (simp add: h_t_valid_clift_Some_iff) - done - -lemmas tcb_queue_relation_qhead_mem' = tcb_queue_relation_qhead_mem [OF tcb_queue_relation'_queue_rel] -lemmas tcb_queue_relation_qhead_valid' = tcb_queue_relation_qhead_valid [OF tcb_queue_relation'_queue_rel] - - -lemma valid_queues_valid_q: - "valid_queues s \ (\tcb\set (ksReadyQueues s (qdom, prio)). tcb_at' tcb s) \ distinct (ksReadyQueues s (qdom, prio))" - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def) - apply (drule spec [where x = qdom]) - apply (drule spec [where x = prio]) - apply clarsimp - apply (drule (1) bspec, erule obj_at'_weakenE) - apply simp - done - -lemma invs_valid_q: - "invs' s \ (\tcb\set (ksReadyQueues s (qdom, prio)). tcb_at' tcb s) \ distinct (ksReadyQueues s (qdom, prio))" - apply (rule valid_queues_valid_q) - apply (clarsimp simp: invs'_def valid_state'_def) - done - -lemma tcbQueued_not_in_queues: - assumes vq: "valid_queues s" - and objat: "obj_at' (Not \ tcbQueued) thread s" - shows "thread \ set (ksReadyQueues s (d, p))" - using vq objat - apply - - apply clarsimp - apply (drule (1) valid_queues_obj_at'D) - apply (erule obj_atE')+ - apply (clarsimp simp: inQ_def) - done - - -lemma rf_sr_sched_queue_relation: - "\ (s, s') \ rf_sr; d \ ucast maxDom; p \ ucast maxPrio \ - \ sched_queue_relation' (cslift s') (ksReadyQueues s (d, p)) - (head_C (index (ksReadyQueues_' (globals s')) - (cready_queues_index_to_C d p))) - (end_C (index (ksReadyQueues_' (globals s')) - (cready_queues_index_to_C d p)))" - unfolding rf_sr_def cstate_relation_def cready_queues_relation_def - apply (clarsimp simp: Let_def seL4_MinPrio_def minDom_def) - done - -lemma ready_queue_not_in: - assumes vq: "valid_queues s" - and inq: "t \ set (ksReadyQueues s (d, p))" - and neq: "d \ d' \ p \ p'" - shows "t \ set (ksReadyQueues s (d', p'))" -proof - assume "t \ set (ksReadyQueues s (d', p'))" - hence "obj_at' (inQ d' p') t s" using vq by (rule valid_queues_obj_at'D) - moreover have "obj_at' (inQ d p) t s" using inq vq by (rule valid_queues_obj_at'D) - ultimately show False using neq - by (clarsimp elim!: obj_atE' simp: inQ_def) -qed - lemma ctcb_relation_unat_prio_eq: "ctcb_relation tcb tcb' \ unat (tcbPriority tcb) = unat (tcbPriority_C tcb')" apply (clarsimp simp: ctcb_relation_def) @@ -650,137 +467,6 @@ lemma threadSet_queued_ccorres [corres]: apply (clarsimp simp: typ_heap_simps) done -lemma ccorres_pre_getQueue: - assumes cc: "\queue. ccorres r xf (P queue) (P' queue) hs (f queue) c" - shows "ccorres r xf (\s. P (ksReadyQueues s (d, p)) s \ d \ maxDomain \ p \ maxPriority) - {s'. \queue. (let cqueue = index (ksReadyQueues_' (globals s')) - (cready_queues_index_to_C d p) in - sched_queue_relation' (cslift s') queue (head_C cqueue) (end_C cqueue)) \ s' \ P' queue} - hs (getQueue d p >>= (\queue. f queue)) c" - apply (rule ccorres_guard_imp2) - apply (rule ccorres_symb_exec_l2) - defer - defer - apply (rule gq_sp) - defer - apply (rule ccorres_guard_imp) - apply (rule cc) - apply clarsimp - apply assumption - apply assumption - apply (clarsimp simp: getQueue_def gets_exs_valid) - apply clarsimp - apply (drule spec, erule mp) - apply (simp add: Let_def) - apply (erule rf_sr_sched_queue_relation) - apply (simp add: maxDom_to_H maxPrio_to_H)+ - done - -lemma state_relation_queue_update_helper': - "\ (s, s') \ rf_sr; - (\d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct (ksReadyQueues s (d, p))); - globals t = ksReadyQueues_'_update - (\_. Arrays.update (ksReadyQueues_' (globals s')) prio' q') - (t_hrs_'_update f (globals s')); - sched_queue_relation' (cslift t) q (head_C q') (end_C q'); - cslift t |` ( - tcb_ptr_to_ctcb_ptr ` S ) - = cslift s' |` ( - tcb_ptr_to_ctcb_ptr ` S ); - option_map tcb_null_sched_ptrs \ cslift t - = option_map tcb_null_sched_ptrs \ cslift s'; - cslift_all_but_tcb_C t s'; - zero_ranges_are_zero (gsUntypedZeroRanges s) (f (t_hrs_' (globals s'))) - = zero_ranges_are_zero (gsUntypedZeroRanges s) (t_hrs_' (globals s')); - hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s')); - prio' = cready_queues_index_to_C qdom prio; - \x \ S. obj_at' (inQ qdom prio) x s - \ (obj_at' (\tcb. tcbPriority tcb = prio) x s - \ obj_at' (\tcb. tcbDomain tcb = qdom) x s) - \ (tcb_at' x s \ (\d' p'. (d' \ qdom \ p' \ prio) - \ x \ set (ksReadyQueues s (d', p')))); - S \ {}; qdom \ ucast maxDom; prio \ ucast maxPrio \ - \ (s \ksReadyQueues := (ksReadyQueues s)((qdom, prio) := q)\, t) \ rf_sr" - apply (subst(asm) disj_imp_rhs) - apply (subst obj_at'_and[symmetric]) - apply (rule disjI1, erule obj_at'_weakenE, simp add: inQ_def) - apply (subst(asm) disj_imp_rhs) - apply (subst(asm) obj_at'_and[symmetric]) - apply (rule conjI, erule obj_at'_weakenE, simp) - apply (rule allI, rule allI) - apply (drule_tac x=d' in spec) - apply (drule_tac x=p' in spec) - apply clarsimp - apply (drule(1) bspec) - apply (clarsimp simp: inQ_def obj_at'_def) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def) - apply (intro conjI) - \ \cpspace_relation\ - apply (erule nonemptyE, drule(1) bspec) - apply (clarsimp simp: cpspace_relation_def) - apply (drule obj_at_ko_at', clarsimp) - apply (rule cmap_relationE1, assumption, - erule ko_at_projectKO_opt) - apply (frule null_sched_queue) - apply (frule null_sched_epD) - apply (intro conjI) - \ \tcb relation\ - apply (drule ctcb_relation_null_queue_ptrs, - simp_all)[1] - \ \endpoint relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (erule cendpoint_relation_upd_tcb_no_queues, simp+) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (erule cnotification_relation_upd_tcb_no_queues, simp+) - \ \ready queues\ - apply (simp add: cready_queues_relation_def Let_def cready_queues_index_to_C_in_range - seL4_MinPrio_def minDom_def) - apply clarsimp - apply (frule cready_queues_index_to_C_distinct, assumption+) - apply (clarsimp simp: cready_queues_index_to_C_in_range all_conj_distrib) - apply (rule iffD1 [OF tcb_queue_relation'_cong[OF refl], rotated -1], - drule spec, drule spec, erule mp, simp+) - apply clarsimp - apply (drule_tac x="tcb_ptr_to_ctcb_ptr x" in fun_cong)+ - apply (clarsimp simp: restrict_map_def - split: if_split_asm) - by (auto simp: carch_state_relation_def cmachine_state_relation_def) - -lemma state_relation_queue_update_helper: - "\ (s, s') \ rf_sr; valid_queues s; - globals t = ksReadyQueues_'_update - (\_. Arrays.update (ksReadyQueues_' (globals s')) prio' q') - (t_hrs_'_update f (globals s')); - sched_queue_relation' (cslift t) q (head_C q') (end_C q'); - cslift t |` ( - tcb_ptr_to_ctcb_ptr ` S ) - = cslift s' |` ( - tcb_ptr_to_ctcb_ptr ` S ); - option_map tcb_null_sched_ptrs \ cslift t - = option_map tcb_null_sched_ptrs \ cslift s'; - cslift_all_but_tcb_C t s'; - zero_ranges_are_zero (gsUntypedZeroRanges s) (f (t_hrs_' (globals s'))) - = zero_ranges_are_zero (gsUntypedZeroRanges s) (t_hrs_' (globals s')); - hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s')); - prio' = cready_queues_index_to_C qdom prio; - \x \ S. obj_at' (inQ qdom prio) x s - \ (obj_at' (\tcb. tcbPriority tcb = prio) x s - \ obj_at' (\tcb. tcbDomain tcb = qdom) x s) - \ (tcb_at' x s \ (\d' p'. (d' \ qdom \ p' \ prio) - \ x \ set (ksReadyQueues s (d', p')))); - S \ {}; qdom \ ucast maxDom; prio \ ucast maxPrio \ - \ (s \ksReadyQueues := (ksReadyQueues s)((qdom, prio) := q)\, t) \ rf_sr" - apply (subgoal_tac "\d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct(ksReadyQueues s (d, p))") - apply (erule(5) state_relation_queue_update_helper', simp_all) - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE, clarsimp) - done - (* FIXME: move *) lemma cmap_relation_no_upd: "\ cmap_relation a c f rel; a p = Some ko; rel ko v; inj f \ \ cmap_relation a (c(f p \ v)) f rel" @@ -825,8 +511,8 @@ lemma cready_queues_index_to_C_def2: lemma ready_queues_index_spec: "\s. \ \ {s'. s' = s \ (Kernel_Config.numDomains \ 1 \ dom_' s' = 0)} Call ready_queues_index_'proc - \\ret__unsigned_long = (dom_' s) * 0x100 + (prio_' s)\" - by vcg (simp add: numDomains_sge_1_simp) + \\ret__unsigned_long = (dom_' s) * word_of_nat numPriorities + (prio_' s)\" + by vcg (simp add: numDomains_sge_1_simp numPriorities_def) lemma prio_to_l1index_spec: "\s. \ \ {s} Call prio_to_l1index_'proc @@ -921,56 +607,6 @@ lemma cbitmap_L2_relation_bit_set: apply (case_tac "da = d" ; clarsimp simp: num_domains_index_updates) done -lemma carch_state_relation_enqueue_simp: - "carch_state_relation (ksArchState \) - (t_hrs_'_update f - (globals \' \ksReadyQueuesL1Bitmap_' := l1upd, ksReadyQueuesL2Bitmap_' := l2upd \) - \ksReadyQueues_' := rqupd \) = - carch_state_relation (ksArchState \) (t_hrs_'_update f (globals \'))" - unfolding carch_state_relation_def - by clarsimp - -lemma t_hrs_ksReadyQueues_upd_absorb: - "t_hrs_'_update f (g s) \ksReadyQueues_' := rqupd \ = - t_hrs_'_update f (g s \ksReadyQueues_' := rqupd\)" - by simp - -lemma rf_sr_drop_bitmaps_enqueue_helper: - "\ (\,\') \ rf_sr ; - cbitmap_L1_relation ksqL1upd' ksqL1upd ; cbitmap_L2_relation ksqL2upd' ksqL2upd \ - \ - ((\\ksReadyQueues := ksqupd, ksReadyQueuesL1Bitmap := ksqL1upd, ksReadyQueuesL2Bitmap := ksqL2upd\, - \'\idx_' := i', queue_' := queue_upd', - globals := t_hrs_'_update f - (globals \' - \ksReadyQueuesL1Bitmap_' := ksqL1upd', - ksReadyQueuesL2Bitmap_' := ksqL2upd', - ksReadyQueues_' := ksqupd'\)\) \ rf_sr) = - ((\\ksReadyQueues := ksqupd\, - \'\idx_' := i', queue_' := queue_upd', - globals := t_hrs_'_update f - (globals \' \ksReadyQueues_' := ksqupd'\)\) \ rf_sr)" - unfolding rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def - by (clarsimp simp: rf_sr_cbitmap_L1_relation rf_sr_cbitmap_L2_relation) - -lemma cmachine_state_relation_enqueue_simp: - "cmachine_state_relation (ksMachineState \) - (t_hrs_'_update f - (globals \' \ksReadyQueuesL1Bitmap_' := l1upd, ksReadyQueuesL2Bitmap_' := l2upd \) - \ksReadyQueues_' := rqupd \) = - cmachine_state_relation (ksMachineState \) (t_hrs_'_update f (globals \'))" - unfolding cmachine_state_relation_def - by clarsimp - -lemma tcb_queue_relation'_empty_ksReadyQueues: - "\ sched_queue_relation' (cslift x) (q s) NULL NULL ; \t\ set (q s). tcb_at' t s \ \ q s = []" - apply (clarsimp simp add: tcb_queue_relation'_def) - apply (subst (asm) eq_commute) - apply (cases "q s" rule: rev_cases, simp) - apply (clarsimp simp: tcb_at_not_NULL) - done - lemma invert_prioToL1Index_c_simp: "p \ maxPriority \ @@ -984,13 +620,247 @@ lemma c_invert_assist: "3 - (ucast (p :: priority) >> 6 :: machine_word) < 4" using prio_ucast_shiftr_wordRadix_helper'[simplified wordRadix_def] by - (rule word_less_imp_diff_less, simp_all) +lemma addToBitmap_ccorres: + "ccorres dc xfdc + (K (tdom \ maxDomain \ prio \ maxPriority)) (\\dom = ucast tdom\ \ \\prio = ucast prio\) hs + (addToBitmap tdom prio) (Call addToBitmap_'proc)" + supply prio_and_dom_limit_helpers[simp] invert_prioToL1Index_c_simp[simp] + apply (rule ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (frule maxDomain_le_unat_ucast_explicit) + apply (clarsimp simp: getQueue_def gets_def get_def setQueue_def modify_def + put_def bind_def return_def bitmap_fun_defs) + apply (intro conjI impI allI) + apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def + carch_state_relation_def cmachine_state_relation_def) + apply (rule conjI) + apply (clarsimp intro!: cbitmap_L1_relation_bit_set) + apply (fastforce dest!: cbitmap_L2_relation_bit_set simp: wordRadix_def mask_def) + done + +lemma rf_sr_tcb_update_twice: + "h_t_valid (hrs_htd (hrs2 (globals s') (t_hrs_' (gs2 (globals s'))))) c_guard + (ptr (t_hrs_' (gs2 (globals s'))) (globals s')) + \ ((s, globals_update (\gs. t_hrs_'_update (\ths. + hrs_mem_update (heap_update (ptr ths gs :: tcb_C ptr) (v ths gs)) + (hrs_mem_update (heap_update (ptr ths gs) (v' ths gs)) (hrs2 gs ths))) (gs2 gs)) s') \ rf_sr) + = ((s, globals_update (\gs. t_hrs_'_update (\ths. + hrs_mem_update (heap_update (ptr ths gs) (v ths gs)) (hrs2 gs ths)) (gs2 gs)) s') \ rf_sr)" + by (simp add: rf_sr_def cstate_relation_def Let_def + cpspace_relation_def typ_heap_simps' + carch_state_relation_def cmachine_state_relation_def + packed_heap_update_collapse_hrs) + +lemmas rf_sr_tcb_update_no_queue_gen2 = + rf_sr_obj_update_helper[OF rf_sr_tcb_update_no_queue_gen, simplified] + +lemma tcb_queue_prepend_ccorres: + "ccorres ctcb_queue_relation ret__struct_tcb_queue_C_' + (\s. tcb_at' tcbPtr s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None) + \ (\head. tcbQueueHead queue = Some head \ tcb_at' head s)) + (\ctcb_queue_relation queue \queue\ \ \\tcb = tcb_ptr_to_ctcb_ptr tcbPtr\) hs + (tcbQueuePrepend queue tcbPtr) (Call tcb_queue_prepend_'proc)" + (is "ccorres _ _ ?abs _ _ _ _") + supply if_split[split del] + apply (cinit lift: tcb_') + \ \cinit is not able to lift queue_' because queue_' is later modified in the C program\ + apply (rule_tac xf'=queue_' in ccorres_abstract, ceqv, rename_tac cqueue) + apply (rule_tac P="ctcb_queue_relation queue cqueue" in ccorres_gen_asm2) + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue)" + and R="?abs" + and R'="\\queue = cqueue\" + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + apply ceqv + apply (rule_tac r'=ctcb_queue_relation and xf'=queue_' in ccorres_split_nothrow) + apply (rule_tac Q="?abs" + and Q'="\s'. queue_' s' = cqueue" + in ccorres_cond_both') + apply fastforce + apply clarsimp + apply (rule ccorres_return[where R=\]) + apply (rule conseqPre, vcg) + apply (fastforce simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (rule ccorres_seq_skip'[THEN iffD1]) + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_Guard) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s + \ head_C cqueue = option_to_ctcb_ptr (tcbQueueHead queue)}" + and R="\head_C cqueue = option_to_ctcb_ptr (tcbQueueHead queue)\" + in threadSet_ccorres_lemma4[where P=\ and P'=\]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce intro!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' tcb_cte_cases_def cteSizeBits_def + ctcb_relation_def option_to_ctcb_ptr_def) + apply (clarsimp simp: ctcb_relation_def option_to_ctcb_ptr_def split: if_splits) + apply ceqv + apply simp + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_Guard) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr + \ ko_at' tcb (the (tcbQueueHead queue)) s + \ head_C cqueue = option_to_ctcb_ptr (tcbQueueHead queue)}" + and R="\head_C cqueue = option_to_ctcb_ptr (tcbQueueHead queue)\" + in threadSet_ccorres_lemma4[where P=\ and P'=\]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce intro!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' tcb_cte_cases_def cteSizeBits_def + ctcb_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + apply fastforce + apply ceqv + apply (rule ccorres_return_Skip') + apply wpsimp + apply vcg + apply wpsimp + apply vcg + apply ceqv + apply csymbr + apply (fastforce intro: ccorres_return_C') + apply wpsimp + apply vcg + apply clarsimp + apply (vcg exspec=tcb_queue_empty_modifies) + apply clarsimp + apply (frule (1) tcb_at_h_t_valid) + by (force dest: tcb_at_h_t_valid + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + +lemma tcb_queue_append_ccorres: + "ccorres ctcb_queue_relation ret__struct_tcb_queue_C_' + (\s. tcb_at' tcbPtr s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None) + \ (\head. tcbQueueHead queue = Some head \ tcb_at' head s) + \ (\end. tcbQueueEnd queue = Some end \ tcb_at' end s)) + (\ctcb_queue_relation queue \queue\ \ \\tcb = tcb_ptr_to_ctcb_ptr tcbPtr\) hs + (tcbQueueAppend queue tcbPtr) (Call tcb_queue_append_'proc)" + (is "ccorres _ _ ?abs _ _ _ _") + supply if_split[split del] + apply (cinit lift: tcb_') + \ \cinit is not able to lift queue_' because queue_' is later modified in the C program\ + apply (rule_tac xf'=queue_' in ccorres_abstract, ceqv, rename_tac cqueue) + apply (rule_tac P="ctcb_queue_relation queue cqueue + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None)" + in ccorres_gen_asm2) + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue)" + and R="?abs" + and R'="\\queue = cqueue\" + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + apply ceqv + apply (rule_tac r'=ctcb_queue_relation and xf'=queue_' in ccorres_split_nothrow) + apply (rule_tac Q="?abs" + and Q'="\s'. queue_' s' = cqueue" + in ccorres_cond_both') + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply clarsimp + apply (rule ccorres_return[where R=\]) + apply (rule conseqPre, vcg) + apply (fastforce simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (rule ccorres_seq_skip'[THEN iffD1]) + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_Guard) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s + \ end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd queue)}" + and R="\end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd queue)\" + in threadSet_ccorres_lemma4[where P=\ and P'=\]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce intro!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' tcb_cte_cases_def cteSizeBits_def + ctcb_relation_def option_to_ctcb_ptr_def) + apply (clarsimp simp: ctcb_relation_def option_to_ctcb_ptr_def split: if_splits) + apply ceqv + apply simp + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_Guard) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr + \ ko_at' tcb (the (tcbQueueEnd queue)) s + \ end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd queue)}" + and R="\end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd queue)\" + in threadSet_ccorres_lemma4[where P=\ and P'=\]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce intro!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' tcb_cte_cases_def cteSizeBits_def + ctcb_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + apply fastforce + apply ceqv + apply (rule ccorres_return_Skip') + apply wpsimp + apply vcg + apply wpsimp + apply vcg + apply ceqv + apply csymbr + apply (fastforce intro: ccorres_return_C') + apply wpsimp + apply vcg + apply (vcg exspec=tcb_queue_empty_modifies) + apply clarsimp + apply (frule (1) tcb_at_h_t_valid) + by (force dest: tcb_at_h_t_valid + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + +lemma getQueue_ccorres: + "ccorres ctcb_queue_relation queue_' + (K (tdom \ maxDomain \ prio \ maxPriority)) + \\idx = word_of_nat (cready_queues_index_to_C tdom prio)\ hs + (getQueue tdom prio) (\queue :== \ksReadyQueues.[unat \idx])" + apply (rule ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply (clarsimp simp: getQueue_def gets_def get_def bind_def return_def) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def) + apply (frule (1) cready_queues_index_to_C_in_range) + apply (clarsimp simp: unat_of_nat_eq cready_queues_relation_def) + done + +lemma setQueue_ccorres: + "ctcb_queue_relation queue cqueue \ + ccorres dc xfdc + (K (tdom \ maxDomain \ prio \ maxPriority)) + \\idx = word_of_nat (cready_queues_index_to_C tdom prio)\ hs + (setQueue tdom prio queue) + (Basic (\s. globals_update + (ksReadyQueues_'_update + (\_. Arrays.update (ksReadyQueues_' (globals s)) (unat (idx_' s)) cqueue)) s))" + apply (rule ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply (clarsimp simp: setQueue_def get_def modify_def put_def bind_def) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def + carch_state_relation_def cmachine_state_relation_def) + apply (frule (1) cready_queues_index_to_C_in_range) + apply (clarsimp simp: unat_of_nat_eq cready_queues_relation_def) + apply (frule cready_queues_index_to_C_distinct, assumption+) + apply (frule_tac qdom=d and prio=p in cready_queues_index_to_C_in_range) + apply fastforce + apply clarsimp + done + +crunch (empty_fail) empty_fail[wp]: isRunnable + lemma tcbSchedEnqueue_ccorres: "ccorres dc xfdc - (valid_queues and tcb_at' t and valid_objs') - (UNIV \ \\tcb = tcb_ptr_to_ctcb_ptr t\) - hs - (tcbSchedEnqueue t) - (Call tcbSchedEnqueue_'proc)" + (tcb_at' t and valid_objs' and pspace_aligned' and pspace_distinct') + \\tcb = tcb_ptr_to_ctcb_ptr t\ hs + (tcbSchedEnqueue t) (Call tcbSchedEnqueue_'proc)" proof - note prio_and_dom_limit_helpers[simp] word_sle_def[simp] maxDom_to_H[simp] maxPrio_to_H[simp] note invert_prioToL1Index_c_simp[simp] @@ -1001,24 +871,12 @@ proof - show ?thesis apply (cinit lift: tcb_') - apply (rule_tac r'="\rv rv'. rv = to_bool rv'" and xf'="ret__unsigned_longlong_'" - in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (simp add: when_def unless_def del: Collect_const split del: if_split) - apply (rule ccorres_cond[where R=\]) - apply (simp add: to_bool_def) - apply (rule ccorres_rhs_assoc)+ - apply csymbr - apply csymbr - apply csymbr - apply csymbr - apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="dom_'" in ccorres_split_nothrow) + apply (rule ccorres_stateAssert)+ + apply (rule ccorres_symb_exec_l) + apply (rule ccorres_assert) + apply (thin_tac runnable) + apply (rule_tac r'="\rv rv'. rv = to_bool rv'" and xf'="ret__unsigned_longlong_'" + in ccorres_split_nothrow) apply (rule threadGet_vcg_corres) apply (rule allI, rule conseqPre, vcg) apply clarsimp @@ -1026,244 +884,246 @@ proof - apply (drule spec, drule(1) mp, clarsimp) apply (clarsimp simp: typ_heap_simps ctcb_relation_def) apply ceqv - apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="prio_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (rule ccorres_rhs_assoc2)+ - apply (simp only: bind_assoc[symmetric]) - apply (rule ccorres_split_nothrow_novcg_dc) - prefer 2 - apply (rule ccorres_move_c_guard_tcb) - apply simp - apply ctac - prefer 2 - apply (wp, clarsimp, wp+) - apply (rule_tac P="\s. valid_queues s \ (\p. t \ set (ksReadyQueues s p)) - \ (\tcb. ko_at' tcb t s \ tcbDomain tcb =rva - \ tcbPriority tcb = rvb \ valid_tcb' tcb s)" - and P'=UNIV in ccorres_from_vcg) - apply (rule allI, rule conseqPre, vcg) - apply (clarsimp simp: getQueue_def gets_def get_def setQueue_def modify_def - put_def bind_def return_def bitmap_fun_defs null_def) - apply (clarsimp simp: queue_in_range valid_tcb'_def) - apply (rule conjI; clarsimp simp: queue_in_range) - (* queue is empty, set t to be new queue *) - apply (drule (1) obj_at_cslift_tcb) - apply clarsimp - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply (subgoal_tac - "head_C (ksReadyQueues_' (globals x) - .[cready_queues_index_to_C (tcbDomain tcb) (tcbPriority tcb)]) = NULL") - prefer 2 - apply (frule_tac s=\ in tcb_queue'_head_end_NULL; simp add: valid_queues_valid_q) - apply (subgoal_tac - "end_C (ksReadyQueues_' (globals x) - .[cready_queues_index_to_C (tcbDomain tcb) (tcbPriority tcb)]) = NULL") - prefer 2 - apply (frule_tac s=\ in tcb_queue'_head_end_NULL[symmetric]; simp add: valid_queues_valid_q) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (frule maxDomain_le_unat_ucast_explicit) - apply (clarsimp simp: cready_queues_index_to_C_def numPriorities_def) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (simp add: t_hrs_ksReadyQueues_upd_absorb) - - apply (rule conjI) - apply (clarsimp simp: l2BitmapSize_def' wordRadix_def c_invert_assist) - apply (subst rf_sr_drop_bitmaps_enqueue_helper, assumption) - apply (fastforce intro: cbitmap_L1_relation_bit_set) - apply (fastforce intro: cbitmap_L2_relation_bit_set simp: wordRadix_def mask_def) - - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (drule_tac qhead'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedEnqueue_update, - simp_all add: valid_queues_valid_q)[1] - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - apply (erule(1) state_relation_queue_update_helper[where S="{t}"], - (simp | rule globals.equality)+, - simp_all add: cready_queues_index_to_C_def2 numPriorities_def - t_hrs_ksReadyQueues_upd_absorb upd_unless_null_def - typ_heap_simps)[1] - apply (fastforce simp: tcb_null_sched_ptrs_def typ_heap_simps c_guard_clift - elim: obj_at'_weaken)+ - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply clarsimp - apply (rule conjI; clarsimp simp: queue_in_range) - (* invalid, disagreement between C and Haskell on emptiness of queue *) - apply (drule (1) obj_at_cslift_tcb) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (clarsimp simp: cready_queues_index_to_C_def numPriorities_def) - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply clarsimp - apply (drule tcb_queue_relation'_empty_ksReadyQueues; simp add: valid_queues_valid_q) - (* queue was not empty, add t to queue and leave bitmaps alone *) - apply (drule (1) obj_at_cslift_tcb) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (clarsimp simp: cready_queues_index_to_C_def numPriorities_def) - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply clarsimp - apply (frule_tac t=\ in tcb_queue_relation_qhead_mem') - apply (simp add: valid_queues_valid_q) - apply (frule(1) tcb_queue_relation_qhead_valid') - apply (simp add: valid_queues_valid_q) - apply (clarsimp simp: typ_heap_simps h_t_valid_clift_Some_iff numPriorities_def - cready_queues_index_to_C_def2) - apply (drule_tac qhead'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedEnqueue_update, - simp_all add: valid_queues_valid_q)[1] + apply (simp add: when_def unless_def del: Collect_const split del: if_split) + apply (rule ccorres_cond[where R=\]) + apply (simp add: to_bool_def) + apply (rule ccorres_rhs_assoc)+ + apply csymbr + apply csymbr + apply csymbr + apply csymbr + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="dom_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) apply clarsimp - - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - apply (frule(2) obj_at_cslift_tcb[OF valid_queues_obj_at'D]) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (erule_tac S="{t, v}" for v in state_relation_queue_update_helper, - (simp | rule globals.equality)+, - simp_all add: typ_heap_simps if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 upd_unless_null_def - del: fun_upd_restrict_conv - cong: if_cong - split del: if_split)[1] - apply simp - apply (rule conjI) + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="prio_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) apply clarsimp - apply (drule_tac s="tcb_ptr_to_ctcb_ptr t" in sym, simp) - apply (clarsimp simp add: fun_upd_twist) - prefer 3 - apply (simp add: obj_at'_weakenE[OF _ TrueI]) - apply (rule disjI1, erule (1) valid_queues_obj_at'D) - apply clarsimp - apply (fastforce simp: tcb_null_sched_ptrs_def) - apply (simp add: typ_heap_simps c_guard_clift) - apply (simp add: guard_is_UNIV_def) - apply simp - apply (wp threadGet_wp) - apply vcg - apply simp - apply (wp threadGet_wp) - apply vcg - apply (rule ccorres_return_Skip) - apply simp - apply (wp threadGet_wp) - apply vcg - apply (fastforce simp: valid_objs'_def obj_at'_def ran_def projectKOs typ_at'_def - valid_obj'_def inQ_def - dest!: valid_queues_obj_at'D) - done + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule ccorres_rhs_assoc2)+ + apply (simp only: bind_assoc[symmetric]) + apply (rule ccorres_split_nothrow_novcg_dc) + prefer 2 + apply (rule ccorres_move_c_guard_tcb) + apply (simp only: dc_def[symmetric]) + apply ctac + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_symb_exec_r) + apply (rule ccorres_Guard_Seq) + apply (simp add: bind_assoc) + apply (ctac add: getQueue_ccorres) + apply (rename_tac queue cqueue) + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue)" + and R="\s. \ tcbQueueEmpty queue \ tcb_at' (the (tcbQueueHead queue)) s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None)" + and R'="{s'. queue_' s' = cqueue}" + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def + tcbQueueEmpty_def) + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_cond[where R=\]) + apply fastforce + apply (ctac add: addToBitmap_ccorres) + apply (rule ccorres_return_Skip) + apply ceqv + apply (ctac add: tcb_queue_prepend_ccorres) + apply (rule ccorres_Guard) + apply (rule setQueue_ccorres) + apply fastforce + apply wpsimp + apply (vcg exspec=tcb_queue_prepend_modifies) + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift') + apply (vcg exspec=addToBitmap_modifies) + apply vcg + apply wpsimp + apply vcg + apply clarsimp + apply vcg + apply (rule conseqPre, vcg) + apply clarsimp + apply wpsimp + apply (clarsimp simp: guard_is_UNIV_def) + apply (wpsimp wp: threadGet_wp) + apply vcg + apply clarsimp + apply (wpsimp wp: threadGet_wp) + apply vcg + apply (rule ccorres_return_Skip) + apply (wpsimp wp: threadGet_wp) + apply (vcg expsec=thread_state_get_tcbQueued_modifies) + apply wpsimp + apply (wpsimp wp: isRunnable_wp) + apply wpsimp + apply normalise_obj_at' + apply (rename_tac tcb) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (clarsimp simp: valid_tcb'_def) + apply (frule (1) obj_at_cslift_tcb) + apply (rule conjI) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (force dest!: tcbQueueHead_iff_tcbQueueEnd simp: tcbQueueEmpty_def obj_at'_def) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply (rule conjI) + apply (clarsimp simp: maxDomain_def) + apply (cut_tac qdom="tcbDomain tcb" and prio="tcbPriority tcb" + in cready_queues_index_to_C_in_range) + apply fastforce + apply fastforce + apply (clarsimp simp: word_less_nat_alt cready_queues_index_to_C_def2) + done qed -lemmas tcbSchedDequeue_update - = tcbDequeue_update[where tn=tcbSchedNext_C and tn_update=tcbSchedNext_C_update - and tp'=tcbSchedPrev_C and tp_update=tcbSchedPrev_C_update, - simplified] - -lemma tcb_queue_relation_prev_next: - "\ tcb_queue_relation tn tp' mp queue qprev qhead; - tcbp \ set queue; distinct (ctcb_ptr_to_tcb_ptr qprev # queue); - \t \ set queue. tcb_at' t s; qprev \ tcb_Ptr 0 \ mp qprev \ None; - mp (tcb_ptr_to_ctcb_ptr tcbp) = Some tcb \ - \ (tn tcb \ tcb_Ptr 0 \ tn tcb \ tcb_ptr_to_ctcb_ptr ` set queue - \ mp (tn tcb) \ None \ tn tcb \ tcb_ptr_to_ctcb_ptr tcbp) - \ (tp' tcb \ tcb_Ptr 0 \ (tp' tcb \ tcb_ptr_to_ctcb_ptr ` set queue - \ tp' tcb = qprev) - \ mp (tp' tcb) \ None \ tp' tcb \ tcb_ptr_to_ctcb_ptr tcbp) - \ (tn tcb \ tcb_Ptr 0 \ tn tcb \ tp' tcb)" - apply (induct queue arbitrary: qprev qhead) - apply simp - apply simp - apply (erule disjE) - apply clarsimp - apply (case_tac "queue") - apply clarsimp - apply clarsimp - apply (rule conjI) - apply clarsimp - apply clarsimp - apply (drule_tac f=ctcb_ptr_to_tcb_ptr in arg_cong[where y="tp' tcb"], simp) - apply clarsimp - apply fastforce - done +lemma tcbSchedAppend_ccorres: + "ccorres dc xfdc + (tcb_at' t and valid_objs' and pspace_aligned' and pspace_distinct') + \\tcb = tcb_ptr_to_ctcb_ptr t\ hs + (tcbSchedAppend t) (Call tcbSchedAppend_'proc)" +proof - + note prio_and_dom_limit_helpers[simp] word_sle_def[simp] maxDom_to_H[simp] maxPrio_to_H[simp] + note invert_prioToL1Index_c_simp[simp] -lemma tcb_queue_relation_prev_next': - "\ tcb_queue_relation' tn tp' mp queue qhead qend; tcbp \ set queue; distinct queue; - \t \ set queue. tcb_at' t s; mp (tcb_ptr_to_ctcb_ptr tcbp) = Some tcb \ - \ (tn tcb \ tcb_Ptr 0 \ tn tcb \ tcb_ptr_to_ctcb_ptr ` set queue - \ mp (tn tcb) \ None \ tn tcb \ tcb_ptr_to_ctcb_ptr tcbp) - \ (tp' tcb \ tcb_Ptr 0 \ tp' tcb \ tcb_ptr_to_ctcb_ptr ` set queue - \ mp (tp' tcb) \ None \ tp' tcb \ tcb_ptr_to_ctcb_ptr tcbp) - \ (tn tcb \ tcb_Ptr 0 \ tn tcb \ tp' tcb)" - apply (clarsimp simp: tcb_queue_relation'_def split: if_split_asm) - apply (drule(1) tcb_queue_relation_prev_next, simp_all) - apply (fastforce dest: tcb_at_not_NULL) - apply clarsimp - done + (* when numDomains = 1, array bounds checks would become _ = 0 rather than _ < 1, changing the + shape of the proof compared to when numDomains > 1 *) + note word_less_1[simp del] -(* L1 bitmap only updated if L2 entry bits end up all zero *) -lemma rf_sr_drop_bitmaps_dequeue_helper_L2: - "\ (\,\') \ rf_sr ; - cbitmap_L2_relation ksqL2upd' ksqL2upd \ - \ -((\\ksReadyQueues := ksqupd, - ksReadyQueuesL2Bitmap := ksqL2upd\, - \'\idx_' := i', - queue_' := queue_upd', - globals := globals \' - \ksReadyQueuesL2Bitmap_' := ksqL2upd', - ksReadyQueues_' := ksqupd'\\) - \ rf_sr) - = -((\\ksReadyQueues := ksqupd\, - \'\idx_' := i', - queue_' := queue_upd', - globals := globals \' - \ksReadyQueues_' := ksqupd'\\) \ rf_sr) -" - unfolding rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def - by (clarsimp simp: rf_sr_cbitmap_L1_relation rf_sr_cbitmap_L2_relation) - -lemma rf_sr_drop_bitmaps_dequeue_helper: - "\ (\,\') \ rf_sr ; - cbitmap_L1_relation ksqL1upd' ksqL1upd ; cbitmap_L2_relation ksqL2upd' ksqL2upd \ - \ -((\\ksReadyQueues := ksqupd, - ksReadyQueuesL2Bitmap := ksqL2upd, - ksReadyQueuesL1Bitmap := ksqL1upd\, - \'\idx_' := i', - queue_' := queue_upd', - globals := globals \' - \ksReadyQueuesL2Bitmap_' := ksqL2upd', - ksReadyQueuesL1Bitmap_' := ksqL1upd', - ksReadyQueues_' := ksqupd'\\) - \ rf_sr) - = -((\\ksReadyQueues := ksqupd\, - \'\idx_' := i', - queue_' := queue_upd', - globals := globals \' - \ksReadyQueues_' := ksqupd'\\) \ rf_sr) -" - unfolding rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def - by (clarsimp simp: rf_sr_cbitmap_L1_relation rf_sr_cbitmap_L2_relation) + show ?thesis + apply (cinit lift: tcb_') + apply (rule ccorres_stateAssert)+ + apply (rule ccorres_symb_exec_l) + apply (rule ccorres_assert) + apply (thin_tac "runnable") + apply (rule_tac r'="\rv rv'. rv = to_bool rv'" and xf'="ret__unsigned_longlong_'" + in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (simp add: when_def unless_def del: Collect_const split del: if_split) + apply (rule ccorres_cond[where R=\]) + apply (simp add: to_bool_def) + apply (rule ccorres_rhs_assoc)+ + apply csymbr + apply csymbr + apply csymbr + apply csymbr + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="dom_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="prio_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule ccorres_rhs_assoc2)+ + apply (simp only: bind_assoc[symmetric]) + apply (rule ccorres_split_nothrow_novcg_dc) + prefer 2 + apply (rule ccorres_move_c_guard_tcb) + apply (simp only: dc_def[symmetric]) + apply ctac + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_symb_exec_r) + apply (rule ccorres_Guard_Seq) + apply (simp add: bind_assoc) + apply (ctac add: getQueue_ccorres) + apply (rename_tac queue cqueue) + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue)" + and R="\s. \ tcbQueueEmpty queue \ tcb_at' (the (tcbQueueHead queue)) s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None)" + and R'="{s'. queue_' s' = cqueue}" + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def + tcbQueueEmpty_def) + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_cond[where R=\]) + apply (fastforce dest!: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (ctac add: addToBitmap_ccorres) + apply (rule ccorres_return_Skip) + apply ceqv + apply (ctac add: tcb_queue_append_ccorres) + apply (rule ccorres_Guard) + apply (rule setQueue_ccorres) + apply fastforce + apply wpsimp + apply (vcg exspec=tcb_queue_prepend_modifies) + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift') + apply (vcg exspec=addToBitmap_modifies) + apply vcg + apply wpsimp + apply vcg + apply clarsimp + apply vcg + apply (rule conseqPre, vcg) + apply clarsimp + apply wpsimp + apply (clarsimp simp: guard_is_UNIV_def) + apply (wpsimp wp: threadGet_wp) + apply vcg + apply clarsimp + apply (wpsimp wp: threadGet_wp) + apply clarsimp + apply vcg + apply (rule ccorres_return_Skip) + apply (wpsimp wp: threadGet_wp) + apply (vcg expsec=thread_state_get_tcbQueued_modifies) + apply wpsimp + apply (wpsimp wp: isRunnable_wp) + apply wpsimp + apply normalise_obj_at' + apply (rename_tac tcb) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (clarsimp simp: valid_tcb'_def) + apply (frule (1) obj_at_cslift_tcb) + apply (rule conjI) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (frule (3) obj_at'_tcbQueueEnd_ksReadyQueues) + apply (force dest!: tcbQueueHead_iff_tcbQueueEnd simp: tcbQueueEmpty_def obj_at'_def) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply (rule conjI) + apply (clarsimp simp: maxDomain_def) + apply (cut_tac qdom="tcbDomain tcb" and prio="tcbPriority tcb" + in cready_queues_index_to_C_in_range) + apply fastforce + apply fastforce + apply (clarsimp simp: word_less_nat_alt cready_queues_index_to_C_def2 tcbQueueEmpty_def) + done +qed (* FIXME same proofs as bit_set, maybe can generalise? *) lemma cbitmap_L1_relation_bit_clear: @@ -1280,27 +1140,6 @@ lemma cbitmap_L1_relation_bit_clear: invertL1Index_def l2BitmapSize_def' le_maxDomain_eq_less_numDomains word_le_nat_alt num_domains_index_updates) -lemma cready_queues_relation_empty_queue_helper: - "\ tcbDomain ko \ maxDomain ; tcbPriority ko \ maxPriority ; - cready_queues_relation (cslift \') (ksReadyQueues_' (globals \')) (ksReadyQueues \)\ - \ - cready_queues_relation (cslift \') - (Arrays.update (ksReadyQueues_' (globals \')) (unat (tcbDomain ko) * 256 + unat (tcbPriority ko)) - (tcb_queue_C.end_C_update (\_. NULL) - (head_C_update (\_. NULL) - (ksReadyQueues_' (globals \').[unat (tcbDomain ko) * 256 + unat (tcbPriority ko)])))) - ((ksReadyQueues \)((tcbDomain ko, tcbPriority ko) := []))" - unfolding cready_queues_relation_def Let_def - using maxPrio_to_H[simp] maxDom_to_H[simp] - apply clarsimp - apply (frule (1) cready_queues_index_to_C_in_range[simplified maxDom_to_H maxPrio_to_H]) - apply (fold cready_queues_index_to_C_def[simplified numPriorities_def]) - apply (case_tac "qdom = tcbDomain ko", - simp_all add: prio_and_dom_limit_helpers seL4_MinPrio_def - minDom_def) - apply (fastforce simp: cready_queues_index_to_C_in_range simp: cready_queues_index_to_C_distinct)+ - done - lemma cbitmap_L2_relationD: "\ cbitmap_L2_relation cbitmap2 abitmap2 ; d \ maxDomain ; i < l2BitmapSize \ \ cbitmap2.[unat d].[i] = abitmap2 (d, i)" @@ -1330,465 +1169,301 @@ lemma cbitmap_L2_relation_bit_clear: apply (case_tac "da = d" ; clarsimp simp: num_domains_index_updates) done -lemma tcbSchedDequeue_ccorres': +lemma removeFromBitmap_ccorres: "ccorres dc xfdc - ((\s. \d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct (ksReadyQueues s (d, p))) - and valid_queues' and tcb_at' t and valid_objs') - (UNIV \ \\tcb = tcb_ptr_to_ctcb_ptr t\) - [] - (tcbSchedDequeue t) - (Call tcbSchedDequeue_'proc)" + (K (tdom \ maxDomain \ prio \ maxPriority)) (\\dom = ucast tdom\ \ \\prio = ucast prio\) hs + (removeFromBitmap tdom prio) (Call removeFromBitmap_'proc)" proof - - note prio_and_dom_limit_helpers[simp] word_sle_def[simp] (* when numDomains = 1, array bounds checks would become _ = 0 rather than _ < 1, changing the shape of the proof compared to when numDomains > 1 *) include no_less_1_simps - have ksQ_tcb_at': "\s ko d p. - \d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct (ksReadyQueues s (d, p)) \ - \t\set (ksReadyQueues s (d, p)). tcb_at' t s" - by (fastforce dest: spec elim: obj_at'_weakenE) - - have invert_l1_index_limit: "\p. invertL1Index (prioToL1Index p) < 4" + have invert_l1_index_limit: "\p. invertL1Index (prioToL1Index p) < l2BitmapSize" unfolding invertL1Index_def l2BitmapSize_def' prioToL1Index_def by simp show ?thesis - apply (cinit lift: tcb_') - apply (rule_tac r'="\rv rv'. rv = to_bool rv'" and xf'="ret__unsigned_longlong_'" - in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (simp add: when_def del: Collect_const split del: if_split) - apply (rule ccorres_cond[where R=\]) - apply (simp add: to_bool_def) - apply (rule ccorres_rhs_assoc)+ - apply csymbr - apply csymbr - apply csymbr - apply csymbr - apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="dom_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) + supply if_split[split del] + (* pull out static assms *) + apply simp + apply (rule ccorres_grab_asm[where P=\, simplified]) + apply (cinit lift: dom_' prio_') + apply clarsimp + apply csymbr + apply csymbr + (* we can clear up all C guards now *) + apply (clarsimp simp: maxDomain_le_unat_ucast_explicit word_and_less') + apply (simp add: invert_prioToL1Index_c_simp word_less_nat_alt) + apply (simp add: invert_l1_index_limit[simplified l2BitmapSize_def']) + apply ccorres_rewrite + (* handle L2 update *) + apply (rule_tac ccorres_split_nothrow_novcg_dc) + apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply (clarsimp simp: simpler_gets_def get_def modify_def + put_def bind_def return_def bitmap_fun_defs) + apply (frule rf_sr_cbitmap_L2_relation) + apply (erule cbitmap_L2_relation_update) + apply (erule (1) cbitmap_L2_relation_bit_clear) + (* the check on the C side is identical to checking the L2 entry, rewrite the condition *) + apply (simp add: getReadyQueuesL2Bitmap_def) + apply (rule ccorres_symb_exec_l3, rename_tac l2) + apply (rule_tac C'="{s. l2 = 0}" + and Q="\s. l2 = ksReadyQueuesL2Bitmap s (tdom, invertL1Index (prioToL1Index prio))" + in ccorres_rewrite_cond_sr[where Q'=UNIV]) + apply clarsimp + apply (frule rf_sr_cbitmap_L2_relation) + apply (clarsimp simp: cbitmap_L2_relationD invert_l1_index_limit split: if_split) + (* unset L1 bit when L2 entry is empty *) + apply (rule ccorres_from_vcg[where P=\ and P'=UNIV]) apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="prio_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply (clarsimp simp: simpler_gets_def get_def modify_def + put_def bind_def return_def bitmap_fun_defs) + apply (frule rf_sr_cbitmap_L1_relation) + apply (erule cbitmap_L1_relation_update) + apply (erule (1) cbitmap_L1_relation_bit_clear) + apply wpsimp+ + apply (fastforce simp: guard_is_UNIV_def) + apply clarsimp + done +qed + +lemma ctcb_ptr_to_tcb_ptr_option_to_ctcb_ptr[simp]: + "ctcb_ptr_to_tcb_ptr (option_to_ctcb_ptr (Some ptr)) = ptr" + by (clarsimp simp: option_to_ctcb_ptr_def) + +lemma tcb_queue_remove_ccorres: + "ccorres ctcb_queue_relation ret__struct_tcb_queue_C_' + (\s. tcb_at' tcbPtr s \ valid_objs' s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None)) + (\ctcb_queue_relation queue \queue\ \ \\tcb = tcb_ptr_to_ctcb_ptr tcbPtr\) hs + (tcbQueueRemove queue tcbPtr) (Call tcb_queue_remove_'proc)" + (is "ccorres _ _ ?abs _ _ _ _") + supply if_split[split del] + apply (cinit' lift: tcb_') + apply (rename_tac tcb') + apply (simp only: tcbQueueRemove_def) + \ \cinit is not able to lift queue_' because queue_' is later modified in the C program\ + apply (rule_tac xf'=queue_' in ccorres_abstract, ceqv, rename_tac cqueue) + apply (rule_tac P="ctcb_queue_relation queue cqueue" in ccorres_gen_asm2) + apply (rule ccorres_pre_getObject_tcb, rename_tac tcb) + apply (rule ccorres_symb_exec_l, rename_tac beforePtrOpt) + apply (rule ccorres_symb_exec_l, rename_tac afterPtrOpt) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac xf'="before___ptr_to_struct_tcb_C_'" + and val="option_to_ctcb_ptr beforePtrOpt" + and R="ko_at' tcb tcbPtr and K (tcbSchedPrev tcb = beforePtrOpt)" + and R'=UNIV + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: obj_at_cslift_tcb simp: typ_heap_simps ctcb_relation_def) apply ceqv - apply (rule ccorres_rhs_assoc2)+ - apply (simp only: bind_assoc[symmetric]) - apply (rule ccorres_split_nothrow_novcg_dc) - prefer 2 - apply (rule ccorres_move_c_guard_tcb) - apply ctac - prefer 2 - apply (wp, clarsimp, wp+) - apply (rule_tac P="(\s. \d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct(ksReadyQueues s (d, p))) - and valid_queues' and obj_at' (inQ rva rvb) t - and (\s. rva \ maxDomain \ rvb \ maxPriority)" - and P'=UNIV in ccorres_from_vcg) - apply (rule allI, rule conseqPre, vcg) - apply (clarsimp simp: getQueue_def gets_def get_def setQueue_def modify_def - put_def bind_def return_def bitmap_fun_defs when_def - null_def) - - apply (rule conjI; clarsimp simp: queue_in_range[simplified maxDom_to_H maxPrio_to_H]) - apply (rule conjI; clarsimp simp: queue_in_range[simplified maxDom_to_H maxPrio_to_H]) - apply (frule(1) valid_queuesD') - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" in rf_sr_sched_queue_relation) - apply (fastforce simp: maxDom_to_H maxPrio_to_H)+ - apply (frule_tac s=\ in tcb_queue_relation_prev_next'; (fastforce simp: ksQ_tcb_at')?) - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (intro conjI; - clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift)+ - apply (drule(2) filter_empty_unfiltered_contr, simp)+ - apply (rule conjI; clarsimp) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (rule conjI; clarsimp) - apply (subst rf_sr_drop_bitmaps_dequeue_helper, assumption) - apply (fastforce intro: cbitmap_L1_relation_bit_clear) - apply (simp add: invert_prioToL1Index_c_simp) - apply (frule rf_sr_cbitmap_L2_relation) - apply (clarsimp simp: cbitmap_L2_relation_def - word_size prioToL1Index_def wordRadix_def mask_def - word_le_nat_alt - numPriorities_def wordBits_def l2BitmapSize_def' - invertL1Index_def numDomains_less_numeric_explicit) - apply (case_tac "d = tcbDomain ko" - ; fastforce simp: le_maxDomain_eq_less_numDomains - numDomains_less_numeric_explicit) - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: maxDom_to_H maxPrio_to_H)+ - - apply (frule_tac s=\ in tcb_queue_relation_prev_next', assumption) - prefer 3 - apply fastforce - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by ((fastforce simp: ksQ_tcb_at')+) - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - (* trivial case, setting queue to empty *) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def carch_state_relation_def - cmachine_state_relation_def) - apply (erule (2) cready_queues_relation_empty_queue_helper) - (* impossible case, C L2 update disagrees with Haskell update *) - apply (simp add: invert_prioToL1Index_c_simp) - apply (subst (asm) num_domains_index_updates) - subgoal by (simp add: le_maxDomain_eq_less_numDomains word_le_nat_alt) - apply (subst (asm) Arrays.index_update) - apply (simp add: invert_l1_index_limit) - - apply (frule rf_sr_cbitmap_L2_relation) - apply (drule_tac i="invertL1Index (prioToL1Index (tcbPriority ko))" - in cbitmap_L2_relationD, assumption) - apply (fastforce simp: l2BitmapSize_def' invert_l1_index_limit) - apply (fastforce simp: prioToL1Index_def invertL1Index_def mask_def wordRadix_def) - (* impossible case *) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (drule(2) filter_empty_unfiltered_contr, fastforce) - - apply (frule (1) valid_queuesD') - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) - apply fold_subgoals[2] - apply (fastforce simp: maxDom_to_H maxPrio_to_H)+ - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (frule_tac s=\ in tcb_queue_relation_prev_next', assumption) - prefer 3 - apply fastforce - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: ksQ_tcb_at')+ - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - apply (clarsimp simp: filter_noteq_op upd_unless_null_def) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI, clarsimp) - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (rule conjI; clarsimp) - apply (simp add: typ_heap_simps) - apply (clarsimp simp: h_t_valid_c_guard [OF h_t_valid_field, OF h_t_valid_clift] - h_t_valid_field[OF h_t_valid_clift] h_t_valid_clift) - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 typ_heap_simps - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - - apply (fastforce simp: tcb_null_sched_ptrs_def typ_heap_simps c_guard_clift - elim: obj_at'_weaken)+ - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split, - simp_all add: typ_heap_simps')[1] - subgoal by (fastforce simp: tcb_null_sched_ptrs_def) - subgoal by fastforce + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac xf'="after___ptr_to_struct_tcb_C_'" + and val="option_to_ctcb_ptr afterPtrOpt" + and R="ko_at' tcb tcbPtr and K (tcbSchedNext tcb = afterPtrOpt)" + in ccorres_symb_exec_r_known_rv[where R'=UNIV]) + apply (rule conseqPre, vcg) + apply (fastforce dest: obj_at_cslift_tcb simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule ccorres_cond_seq) + apply (rule ccorres_cond[where R="?abs"]) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (rule ccorres_rhs_assoc)+ + apply csymbr + apply csymbr + apply (fastforce intro: ccorres_return_C') + apply (rule ccorres_cond_seq) + apply (rule_tac Q="?abs" and Q'=\ in ccorres_cond_both') + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def split: if_splits) apply clarsimp - apply (rule conjI; clarsimp) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (rule conjI; clarsimp) - (* invalid, missing bitmap updates on haskell side *) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems - by (fastforce dest!: tcb_queue_relation'_empty_ksReadyQueues - elim: obj_at'_weaken)+ - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - apply (fold_subgoals (prefix))[4] - subgoal premises prems using prems - by - (fastforce simp: typ_heap_simps c_guard_clift tcb_null_sched_ptrs_def - clift_heap_update_same[OF h_t_valid_clift])+ - apply (rule conjI; clarsimp simp: queue_in_range[simplified maxDom_to_H maxPrio_to_H]) - apply (frule (1) valid_queuesD') - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: maxDom_to_H maxPrio_to_H)+ - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (frule_tac s=\ in tcb_queue_relation_prev_next') + apply (rule ccorres_assert2) + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb)+ + apply (rule_tac P=\ and P'="tcb_at' tcbPtr" + and Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb (the afterPtrOpt) s}" + in threadSet_ccorres_lemma3) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) apply fastforce - prefer 3 - apply fastforce - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: ksQ_tcb_at')+ - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - apply (clarsimp simp: filter_noteq_op upd_unless_null_def) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI; clarsimp) - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (clarsimp simp: typ_heap_simps) - apply (rule conjI; clarsimp simp: typ_heap_simps) - apply (drule(2) filter_empty_unfiltered_contr[simplified filter_noteq_op], simp) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (rule conjI; clarsimp) - (* impossible case, C L2 update disagrees with Haskell update *) - apply (subst (asm) num_domains_index_updates) - apply (simp add: le_maxDomain_eq_less_numDomains word_le_nat_alt) - apply (subst (asm) Arrays.index_update) - subgoal using invert_l1_index_limit - by (fastforce simp add: invert_prioToL1Index_c_simp intro: nat_Suc_less_le_imp) - apply (frule rf_sr_cbitmap_L2_relation) - apply (simp add: invert_prioToL1Index_c_simp) - apply (drule_tac i="invertL1Index (prioToL1Index (tcbPriority ko))" - in cbitmap_L2_relationD, assumption) - subgoal by (simp add: invert_l1_index_limit l2BitmapSize_def') - apply (fastforce simp: prioToL1Index_def invertL1Index_def mask_def wordRadix_def) - - apply (simp add: invert_prioToL1Index_c_simp) - apply (subst rf_sr_drop_bitmaps_dequeue_helper_L2, assumption) - subgoal by (fastforce dest: rf_sr_cbitmap_L2_relation elim!: cbitmap_L2_relation_bit_clear) - - (* trivial case, setting queue to empty *) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def carch_state_relation_def - cmachine_state_relation_def) - apply (erule (2) cready_queues_relation_empty_queue_helper) - - apply (frule (1) valid_queuesD') - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: maxDom_to_H maxPrio_to_H)+ - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (simp add: invert_prioToL1Index_c_simp) - apply (frule_tac s=\ in tcb_queue_relation_prev_next') - apply (fastforce simp add: ksQ_tcb_at')+ - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - apply (clarsimp simp: filter_noteq_op upd_unless_null_def) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI, clarsimp) - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (clarsimp simp: typ_heap_simps) - apply (rule conjI; clarsimp simp: typ_heap_simps) - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - apply (fastforce simp: tcb_null_sched_ptrs_def) - apply (clarsimp simp: typ_heap_simps) - apply (fastforce simp: typ_heap_simps) - apply (fastforce simp: tcb_null_sched_ptrs_def) - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - apply (fold_subgoals (prefix))[4] - subgoal premises prems using prems - by - (fastforce simp: typ_heap_simps c_guard_clift tcb_null_sched_ptrs_def - clift_heap_update_same[OF h_t_valid_clift])+ - apply (clarsimp) - apply (rule conjI; clarsimp simp: typ_heap_simps) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (rule conjI; clarsimp) - (* invalid, missing bitmap updates on haskell side *) - apply (drule tcb_queue_relation'_empty_ksReadyQueues) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce elim: obj_at'_weaken)+ - (* invalid, missing bitmap updates on haskell side *) - apply (drule tcb_queue_relation'_empty_ksReadyQueues) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce elim: obj_at'_weaken)+ - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 typ_heap_simps - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems - by (fastforce simp: typ_heap_simps c_guard_clift tcb_null_sched_ptrs_def)+ - apply (simp add: guard_is_UNIV_def) - apply simp - apply (wp threadGet_wp) - apply vcg - apply simp - apply (wp threadGet_wp) - apply vcg - apply (rule ccorres_return_Skip) - apply simp - apply (wp threadGet_wp) - apply vcg - by (fastforce simp: valid_objs'_def obj_at'_def ran_def projectKOs typ_at'_def - valid_obj'_def valid_tcb'_def inQ_def) -qed - -lemma tcbSchedDequeue_ccorres: - "ccorres dc xfdc - (valid_queues and valid_queues' and tcb_at' t and valid_objs') - (UNIV \ \\tcb = tcb_ptr_to_ctcb_ptr t\) - [] - (tcbSchedDequeue t) - (Call tcbSchedDequeue_'proc)" - apply (rule ccorres_guard_imp [OF tcbSchedDequeue_ccorres']) - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE) - apply (clarsimp)+ - done - -lemma tcb_queue_relation_append: - "\ tcb_queue_relation tn tp' mp queue qprev qhead; queue \ []; - qend' \ tcb_ptr_to_ctcb_ptr ` set queue; mp qend' = Some tcb; - queue = queue' @ [ctcb_ptr_to_tcb_ptr qend]; distinct queue; - \x \ set queue. tcb_ptr_to_ctcb_ptr x \ NULL; qend' \ NULL; - \v f g. tn (tn_update f v) = f (tn v) \ tp' (tp_update g v) = g (tp' v) - \ tn (tp_update f v) = tn v \ tp' (tn_update g v) = tp' v \ - \ tcb_queue_relation tn tp' - (mp (qend \ tn_update (\_. qend') (the (mp qend)), - qend' \ tn_update (\_. NULL) (tp_update (\_. qend) tcb))) - (queue @ [ctcb_ptr_to_tcb_ptr qend']) qprev qhead" - using [[hypsubst_thin = true]] - apply clarsimp - apply (induct queue' arbitrary: qprev qhead) - apply clarsimp - apply clarsimp - done - -lemma tcbSchedAppend_update: - assumes sr: "sched_queue_relation' mp queue qhead qend" - and qh': "qend' \ tcb_ptr_to_ctcb_ptr ` set queue" - and cs_tcb: "mp qend' = Some tcb" - and valid_ep: "\t\set queue. tcb_at' t s" "distinct queue" - and qhN: "qend' \ NULL" - shows - "sched_queue_relation' - (upd_unless_null qend (tcbSchedNext_C_update (\_. qend') (the (mp qend))) - (mp(qend' \ tcb\tcbSchedNext_C := NULL, tcbSchedPrev_C := qend\))) - (queue @ [ctcb_ptr_to_tcb_ptr qend']) (if queue = [] then qend' else qhead) qend'" - using sr qh' valid_ep cs_tcb qhN - apply - - apply (rule rev_cases[where xs=queue]) - apply (simp add: tcb_queue_relation'_def upd_unless_null_def) - apply (clarsimp simp: tcb_queue_relation'_def upd_unless_null_def tcb_at_not_NULL) - apply (drule_tac qend'=qend' and tn_update=tcbSchedNext_C_update - and tp_update=tcbSchedPrev_C_update and qend="tcb_ptr_to_ctcb_ptr y" - in tcb_queue_relation_append, simp_all) - apply (fastforce simp add: tcb_at_not_NULL) - apply (simp add: fun_upd_twist) - done - -lemma tcb_queue_relation_qend_mems: - "\ tcb_queue_relation' getNext getPrev mp queue qhead qend; - \x \ set queue. tcb_at' x s \ - \ (qend = NULL \ queue = []) - \ (qend \ NULL \ ctcb_ptr_to_tcb_ptr qend \ set queue)" - apply (clarsimp simp: tcb_queue_relation'_def) - apply (drule bspec, erule last_in_set) - apply (simp add: tcb_at_not_NULL) + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb[where thread=tcbPtr]) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule ccorres_symb_exec_r) + apply (fastforce intro: ccorres_return_C') + apply vcg + apply (rule conseqPre, vcg) + apply clarsimp + apply wpsimp + apply vcg + apply wpsimp + apply vcg + apply (rule ccorres_cond_seq) + apply (rule_tac Q="?abs" and Q'=\ in ccorres_cond_both') + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def split: if_splits) + apply clarsimp + apply (rule ccorres_assert2) + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb)+ + apply (rule_tac P=\ and P'="tcb_at' tcbPtr" + and Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb (the beforePtrOpt) s}" + in threadSet_ccorres_lemma3) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply fastforce + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb[where thread=tcbPtr]) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule ccorres_symb_exec_r) + apply (fastforce intro: ccorres_return_C') + apply vcg + apply (rule conseqPre, vcg) + apply clarsimp + apply wpsimp + apply vcg + apply wpsimp + apply vcg + apply clarsimp + apply (rule ccorres_assert2)+ + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb)+ + apply (rule_tac Q="\s tcb'. {s'. (s, s') \ rf_sr \ ko_at' tcb' (the beforePtrOpt) s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb)+ + apply (rule_tac P=\ and P'="tcb_at' tcbPtr" + and Q="\s tcb'. {s'. (s, s') \ rf_sr \ ko_at' tcb' (the afterPtrOpt) s}" + in threadSet_ccorres_lemma3) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb[where thread=tcbPtr]) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb[where thread=tcbPtr]) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply fastforce + apply ceqv + apply (fastforce intro: ccorres_return_C') + apply (wpsimp | vcg)+ + apply (clarsimp split: if_splits) + apply normalise_obj_at' + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + by (intro conjI impI; + clarsimp simp: ctcb_queue_relation_def typ_heap_simps option_to_ctcb_ptr_def + valid_tcb'_def valid_bound_tcb'_def) + +lemma tcbQueueRemove_tcb_at'_head: + "\\s. valid_objs' s \ (\head. tcbQueueHead queue = Some head \ tcb_at' head s)\ + tcbQueueRemove queue t + \\rv s. \ tcbQueueEmpty rv \ tcb_at' (the (tcbQueueHead rv)) s\" + unfolding tcbQueueRemove_def + apply (wpsimp wp: getTCB_wp haskell_assert_wp hoare_vcg_imp_lift') + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (fastforce simp: valid_tcb'_def valid_bound_tcb'_def tcbQueueEmpty_def obj_at'_def) done -lemma tcbSchedAppend_ccorres: +lemma tcbSchedDequeue_ccorres: "ccorres dc xfdc - (valid_queues and tcb_at' t and valid_objs') - (UNIV \ \\tcb = tcb_ptr_to_ctcb_ptr t\) - [] - (tcbSchedAppend t) - (Call tcbSchedAppend_'proc)" + (tcb_at' t and valid_objs' and pspace_aligned' and pspace_distinct') + \\tcb = tcb_ptr_to_ctcb_ptr t\ hs + (tcbSchedDequeue t) (Call tcbSchedDequeue_'proc)" proof - note prio_and_dom_limit_helpers[simp] word_sle_def[simp] maxDom_to_H[simp] maxPrio_to_H[simp] + note invert_prioToL1Index_c_simp[simp] (* when numDomains = 1, array bounds checks would become _ = 0 rather than _ < 1, changing the shape of the proof compared to when numDomains > 1 *) - include no_less_1_simps + note word_less_1[simp del] show ?thesis - apply (cinit lift: tcb_') - apply (rule_tac r'="\rv rv'. rv = to_bool rv'" - and xf'="ret__unsigned_longlong_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (simp add: when_def unless_def del: Collect_const split del: if_split) - apply (rule ccorres_cond[where R=\]) - apply (simp add: to_bool_def) - apply (rule ccorres_rhs_assoc)+ - apply csymbr - apply csymbr - apply csymbr - apply csymbr - apply (rule_tac r'="\rv rv'. rv' = ucast rv" - and xf'="dom_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (rule_tac r'="\rv rv'. rv' = ucast rv" - and xf'="prio_'" in ccorres_split_nothrow) + apply (cinit lift: tcb_') + apply (rule ccorres_stateAssert)+ + apply (rule_tac r'="\rv rv'. rv = to_bool rv'" and xf'="ret__unsigned_longlong_'" + in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (simp add: when_def del: Collect_const split del: if_split) + apply (rule ccorres_cond[where R=\]) + apply (simp add: to_bool_def) + apply (rule ccorres_rhs_assoc)+ + apply csymbr + apply csymbr + apply csymbr + apply csymbr + apply csymbr + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="dom_'" in ccorres_split_nothrow) apply (rule threadGet_vcg_corres) apply (rule allI, rule conseqPre, vcg) apply clarsimp @@ -1796,123 +1471,78 @@ proof - apply (drule spec, drule(1) mp, clarsimp) apply (clarsimp simp: typ_heap_simps ctcb_relation_def) apply ceqv - apply (rule ccorres_rhs_assoc2)+ - apply (simp only: bind_assoc[symmetric]) - apply (rule ccorres_split_nothrow_novcg_dc) - prefer 2 - apply (rule ccorres_move_c_guard_tcb) - apply ctac - prefer 2 - apply (wp, clarsimp, wp+) - apply (rule_tac P="\s. valid_queues s \ (\p. t \ set (ksReadyQueues s p)) - \ (\tcb. ko_at' tcb t s \ tcbDomain tcb =rva - \ tcbPriority tcb = rvb \ valid_tcb' tcb s)" - and P'=UNIV in ccorres_from_vcg) - apply (rule allI, rule conseqPre, vcg) - apply (clarsimp simp: getQueue_def gets_def get_def setQueue_def modify_def - put_def bind_def return_def bitmap_fun_defs null_def) - apply (clarsimp simp: queue_in_range valid_tcb'_def) - apply (rule conjI; clarsimp simp: queue_in_range) - apply (drule (1) obj_at_cslift_tcb) - apply clarsimp - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply (frule_tac s=\ in tcb_queue_relation_qend_mems, simp add: valid_queues_valid_q) - apply (drule_tac qend'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedAppend_update, - simp_all add: valid_queues_valid_q)[1] - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (simp add: invert_prioToL1Index_c_simp) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI; clarsimp) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (simp add: t_hrs_ksReadyQueues_upd_absorb) - apply (subst rf_sr_drop_bitmaps_enqueue_helper, assumption) - apply (fastforce intro: cbitmap_L1_relation_bit_set) - subgoal by (fastforce intro: cbitmap_L2_relation_bit_set simp: wordRadix_def mask_def) - apply (erule(1) state_relation_queue_update_helper[where S="{t}"], - (simp | rule globals.equality)+, - simp_all add: cready_queues_index_to_C_def2 numPriorities_def - t_hrs_ksReadyQueues_upd_absorb upd_unless_null_def - typ_heap_simps)[1] - apply (fastforce simp: tcb_null_sched_ptrs_def elim: obj_at'_weaken) - apply (fastforce simp: tcb_null_sched_ptrs_def elim: obj_at'_weaken) - apply (clarsimp simp: upd_unless_null_def cready_queues_index_to_C_def numPriorities_def) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI; clarsimp simp: queue_in_range) - apply (drule (1) obj_at_cslift_tcb) - apply clarsimp - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply (frule_tac s=\ in tcb_queue_relation_qend_mems, - simp add: valid_queues_valid_q) - apply (drule_tac qend'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedAppend_update, - simp_all add: valid_queues_valid_q)[1] + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="prio_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) apply clarsimp - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (clarsimp simp: upd_unless_null_def cready_queues_index_to_C_def numPriorities_def) - apply (drule (1) obj_at_cslift_tcb) - apply clarsimp - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule ccorres_symb_exec_r) + apply (rule ccorres_Guard_Seq) + apply (simp add: bind_assoc) + apply (ctac add: getQueue_ccorres) + apply (rule_tac r'=ctcb_queue_relation and xf'=new_queue_' in ccorres_split_nothrow) + apply (ctac add: tcb_queue_remove_ccorres) + apply ceqv + apply (rename_tac queue' newqueue) + apply (rule ccorres_Guard_Seq) + apply (ctac add: setQueue_ccorres) + apply (rule ccorres_split_nothrow_novcg_dc) + apply ctac + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue')" + and R="\s. \ tcbQueueEmpty queue' \ tcb_at' (the (tcbQueueHead queue')) s" + in ccorres_symb_exec_r_known_rv[where R'=UNIV]) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def + tcbQueueEmpty_def split: option.splits) + apply ceqv + apply (rule ccorres_cond[where R=\]) + apply fastforce + apply (ctac add: removeFromBitmap_ccorres) + apply (rule ccorres_return_Skip) + apply vcg + apply (wpsimp wp: hoare_vcg_imp_lift') + apply (clarsimp simp: guard_is_UNIV_def) + apply (wpsimp wp: hoare_vcg_imp_lift') + apply vcg + apply ((wpsimp wp: tcbQueueRemove_tcb_at'_head | wp (once) hoare_drop_imps)+)[1] + apply (vcg exspec=tcb_queue_remove_modifies) + apply wpsimp + apply vcg + apply vcg + apply (rule conseqPre, vcg) apply clarsimp - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply (frule_tac s=\ in tcb_queue_relation_qend_mems, - simp add: valid_queues_valid_q) - apply (drule_tac qend'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedAppend_update, - simp_all add: valid_queues_valid_q)[1] - apply clarsimp - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - apply (clarsimp simp: cready_queues_index_to_C_def2 numPriorities_def) - apply (frule(2) obj_at_cslift_tcb[OF valid_queues_obj_at'D]) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (erule_tac S="{t, v}" for v in state_relation_queue_update_helper, - (simp | rule globals.equality)+, - simp_all add: typ_heap_simps if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 upd_unless_null_def - cong: if_cong split del: if_split - del: fun_upd_restrict_conv)[1] - apply simp - apply (rule conjI) - apply clarsimp - apply (drule_tac s="tcb_ptr_to_ctcb_ptr t" in sym, simp) - apply (clarsimp simp add: fun_upd_twist) - prefer 3 - apply (simp add: obj_at'_weakenE[OF _ TrueI]) - apply (rule disjI1, erule valid_queues_obj_at'D) - subgoal by simp - subgoal by simp - subgoal by (fastforce simp: tcb_null_sched_ptrs_def) - apply (simp add: guard_is_UNIV_def) - apply simp - apply (wp threadGet_wp) + apply (wpsimp wp: threadGet_wp) + apply vcg + apply clarsimp + apply (wpsimp wp: threadGet_wp) apply vcg - apply simp - apply (wp threadGet_wp) - apply vcg - apply (rule ccorres_return_Skip) - apply simp - apply (wp threadGet_wp) - apply vcg - by (fastforce simp: valid_objs'_def obj_at'_def ran_def projectKOs typ_at'_def - valid_obj'_def inQ_def - dest!: valid_queues_obj_at'D) + apply (rule ccorres_return_Skip) + apply (wpsimp wp: threadGet_wp) + apply (vcg expsec=thread_state_get_tcbQueued_modifies) + apply normalise_obj_at' + apply (rename_tac tcb) + apply (frule (1) obj_at_cslift_tcb) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (clarsimp simp: valid_tcb'_def) + apply (cut_tac qdom="tcbDomain tcb" and prio="tcbPriority tcb" + in cready_queues_index_to_C_in_range) + apply fastforce + apply fastforce + apply (rule conjI) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (force dest!: tcbQueueHead_iff_tcbQueueEnd simp: tcbQueueEmpty_def obj_at'_def) + by (fastforce simp: word_less_nat_alt + cready_queues_index_to_C_def2 ctcb_relation_def + typ_heap_simps le_maxDomain_eq_less_numDomains(2) unat_trans_ucast_helper) qed lemma isStopped_spec: @@ -1960,8 +1590,11 @@ lemma tcb_at_1: done lemma rescheduleRequired_ccorres: - "ccorres dc xfdc (valid_queues and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_objs') - UNIV [] rescheduleRequired (Call rescheduleRequired_'proc)" + "ccorres dc xfdc + ((\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_objs' + and pspace_aligned' and pspace_distinct') + UNIV [] + rescheduleRequired (Call rescheduleRequired_'proc)" apply cinit apply (rule ccorres_symb_exec_l) apply (rule ccorres_split_nothrow_novcg[where r'=dc and xf'=xfdc]) @@ -2071,10 +1704,12 @@ lemma cguard_UNIV: by fastforce lemma lookupBitmapPriority_le_maxPriority: - "\ ksReadyQueuesL1Bitmap s d \ 0 ; valid_queues s \ + "\ ksReadyQueuesL1Bitmap s d \ 0 ; + \d p. d > maxDomain \ p > maxPriority \ tcbQueueEmpty (ksReadyQueues s (d, p)); + valid_bitmaps s \ \ lookupBitmapPriority d s \ maxPriority" - unfolding valid_queues_def valid_queues_no_bitmap_def - by (fastforce dest!: bitmapQ_from_bitmap_lookup bitmapQ_ksReadyQueuesI intro: ccontr) + apply (clarsimp simp: valid_bitmaps_def) + by (fastforce dest!: bitmapQ_from_bitmap_lookup bitmapQ_ksReadyQueuesI intro: ccontr) lemma rf_sr_ksReadyQueuesL1Bitmap_not_zero: "\ (\, s') \ rf_sr ; d \ maxDomain ; ksReadyQueuesL1Bitmap_' (globals s').[unat d] \ 0 \ @@ -2084,10 +1719,10 @@ lemma rf_sr_ksReadyQueuesL1Bitmap_not_zero: done lemma ksReadyQueuesL1Bitmap_word_log2_max: - "\valid_queues s; ksReadyQueuesL1Bitmap s d \ 0\ - \ word_log2 (ksReadyQueuesL1Bitmap s d) < l2BitmapSize" - unfolding valid_queues_def - by (fastforce dest: word_log2_nth_same bitmapQ_no_L1_orphansD) + "\valid_bitmaps s; ksReadyQueuesL1Bitmap s d \ 0\ + \ word_log2 (ksReadyQueuesL1Bitmap s d) < l2BitmapSize" + unfolding valid_bitmaps_def + by (fastforce dest: word_log2_nth_same bitmapQ_no_L1_orphansD) lemma word_log2_max_word64[simp]: "word_log2 (w :: 64 word) < 64" @@ -2095,7 +1730,7 @@ lemma word_log2_max_word64[simp]: by (simp add: word_size) lemma rf_sr_ksReadyQueuesL2Bitmap_simp: - "\ (\, s') \ rf_sr ; d \ maxDomain ; valid_queues \ ; ksReadyQueuesL1Bitmap \ d \ 0 \ + "\ (\, s') \ rf_sr ; d \ maxDomain ; valid_bitmaps \ ; ksReadyQueuesL1Bitmap \ d \ 0 \ \ ksReadyQueuesL2Bitmap_' (globals s').[unat d].[word_log2 (ksReadyQueuesL1Bitmap \ d)] = ksReadyQueuesL2Bitmap \ (d, word_log2 (ksReadyQueuesL1Bitmap \ d))" apply (frule rf_sr_cbitmap_L2_relation) @@ -2104,9 +1739,9 @@ lemma rf_sr_ksReadyQueuesL2Bitmap_simp: done lemma ksReadyQueuesL2Bitmap_nonzeroI: - "\ d \ maxDomain ; valid_queues s ; ksReadyQueuesL1Bitmap s d \ 0 \ + "\ d \ maxDomain ; valid_bitmaps s ; ksReadyQueuesL1Bitmap s d \ 0 \ \ ksReadyQueuesL2Bitmap s (d, invertL1Index (word_log2 (ksReadyQueuesL1Bitmap s d))) \ 0" - unfolding valid_queues_def + unfolding valid_bitmaps_def apply clarsimp apply (frule bitmapQ_no_L1_orphansD) apply (erule word_log2_nth_same) @@ -2271,9 +1906,9 @@ lemma threadGet_get_obj_at'_has_domain: lemma possibleSwitchTo_ccorres: shows "ccorres dc xfdc - (valid_queues and (\s. weak_sch_act_wf (ksSchedulerAction s) s) + ((\s. weak_sch_act_wf (ksSchedulerAction s) s) and st_tcb_at' runnable' t and (\s. ksCurDomain s \ maxDomain) - and valid_objs') + and valid_objs' and pspace_aligned' and pspace_distinct') ({s. target_' s = tcb_ptr_to_ctcb_ptr t} \ UNIV) [] (possibleSwitchTo t ) @@ -2321,8 +1956,8 @@ lemma possibleSwitchTo_ccorres: lemma scheduleTCB_ccorres': "ccorres dc xfdc - (tcb_at' thread and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_queues - and valid_objs') + (tcb_at' thread and (\s. weak_sch_act_wf (ksSchedulerAction s) s) + and valid_objs' and pspace_aligned' and pspace_distinct') (UNIV \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) [] (do (runnable, curThread, action) \ do @@ -2372,24 +2007,26 @@ lemma scheduleTCB_ccorres': apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def cscheduler_action_relation_def) apply wp+ - apply (simp add: isRunnable_def isStopped_def) - apply wp + apply (simp add: isRunnable_def isStopped_def) apply (simp add: guard_is_UNIV_def) apply clarsimp apply (clarsimp simp: st_tcb_at'_def obj_at'_def weak_sch_act_wf_def) done lemma scheduleTCB_ccorres_valid_queues'_pre: - "ccorresG rf_sr \ dc xfdc (tcb_at' thread and st_tcb_at' (not runnable') thread and valid_queues' and valid_queues and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_objs') - (UNIV \ \\tptr = tcb_ptr_to_ctcb_ptr thread\) [] - (do (runnable, curThread, action) \ do - runnable \ isRunnable thread; - curThread \ getCurThread; - action \ getSchedulerAction; - return (runnable, curThread, action) od; - when (\ runnable \ curThread = thread \ action = ResumeCurrentThread) rescheduleRequired - od) - (Call scheduleTCB_'proc)" + "ccorresG rf_sr \ dc xfdc + (tcb_at' thread and st_tcb_at' (not runnable') thread + and (\s. weak_sch_act_wf (ksSchedulerAction s) s) + and valid_objs' and pspace_aligned' and pspace_distinct') + \\tptr = tcb_ptr_to_ctcb_ptr thread\ [] + (do (runnable, curThread, action) \ do runnable \ isRunnable thread; + curThread \ getCurThread; + action \ getSchedulerAction; + return (runnable, curThread, action) + od; + when (\ runnable \ curThread = thread \ action = ResumeCurrentThread) rescheduleRequired + od) + (Call scheduleTCB_'proc)" supply empty_fail_cond[simp] apply (cinit' lift: tptr_') apply (rule ccorres_rhs_assoc2)+ @@ -2430,17 +2067,17 @@ lemma scheduleTCB_ccorres_valid_queues'_pre: split: scheduler_action.split_asm) apply wp+ apply (simp add: isRunnable_def isStopped_def) - apply wp apply (simp add: guard_is_UNIV_def) apply (clarsimp simp: st_tcb_at'_def obj_at'_def) done - lemmas scheduleTCB_ccorres_valid_queues' = scheduleTCB_ccorres_valid_queues'_pre[unfolded bind_assoc return_bind split_conv] lemma rescheduleRequired_ccorres_valid_queues'_simple: - "ccorresG rf_sr \ dc xfdc (valid_queues' and sch_act_simple) UNIV [] rescheduleRequired (Call rescheduleRequired_'proc)" + "ccorresG rf_sr \ dc xfdc + sch_act_simple UNIV [] + rescheduleRequired (Call rescheduleRequired_'proc)" apply cinit apply (rule ccorres_symb_exec_l) apply (rule ccorres_split_nothrow_novcg[where r'=dc and xf'=xfdc]) @@ -2473,16 +2110,17 @@ lemma rescheduleRequired_ccorres_valid_queues'_simple: split: scheduler_action.split_asm) lemma scheduleTCB_ccorres_valid_queues'_pre_simple: - "ccorresG rf_sr \ dc xfdc (tcb_at' thread and st_tcb_at' (not runnable') thread and valid_queues' and sch_act_simple) - (UNIV \ \\tptr = tcb_ptr_to_ctcb_ptr thread\) [] - (do (runnable, curThread, action) \ do - runnable \ isRunnable thread; - curThread \ getCurThread; - action \ getSchedulerAction; - return (runnable, curThread, action) od; - when (\ runnable \ curThread = thread \ action = ResumeCurrentThread) rescheduleRequired - od) - (Call scheduleTCB_'proc)" + "ccorresG rf_sr \ dc xfdc + (tcb_at' thread and st_tcb_at' (not runnable') thread and valid_queues' and sch_act_simple) + \\tptr = tcb_ptr_to_ctcb_ptr thread\ [] + (do (runnable, curThread, action) \ do runnable \ isRunnable thread; + curThread \ getCurThread; + action \ getSchedulerAction; + return (runnable, curThread, action) + od; + when (\ runnable \ curThread = thread \ action = ResumeCurrentThread) rescheduleRequired + od) + (Call scheduleTCB_'proc)" supply empty_fail_cond[simp] apply (cinit' lift: tptr_' simp del: word_neq_0_conv) apply (rule ccorres_rhs_assoc2)+ @@ -2521,11 +2159,10 @@ lemma scheduleTCB_ccorres_valid_queues'_pre_simple: apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def cscheduler_action_relation_def) apply wp+ - apply (simp add: isRunnable_def isStopped_def) - apply wp + apply (simp add: isRunnable_def isStopped_def) apply (simp add: guard_is_UNIV_def) apply clarsimp - apply (clarsimp simp: st_tcb_at'_def obj_at'_def valid_queues'_def) + apply (clarsimp simp: st_tcb_at'_def obj_at'_def) done lemmas scheduleTCB_ccorres_valid_queues'_simple @@ -2545,47 +2182,34 @@ lemma threadSet_weak_sch_act_wf_runnable': apply (clarsimp) done -lemma threadSet_valid_queues_and_runnable': "\\s. valid_queues s \ (\p. thread \ set (ksReadyQueues s p) \ runnable' st)\ - threadSet (tcbState_update (\_. st)) thread - \\rv s. valid_queues s\" - apply (wp threadSet_valid_queues) - apply (clarsimp simp: inQ_def) -done - lemma setThreadState_ccorres[corres]: "ccorres dc xfdc - (\s. tcb_at' thread s \ valid_queues s \ valid_objs' s \ valid_tcb_state' st s \ - (ksSchedulerAction s = SwitchToThread thread \ runnable' st) \ - (\p. thread \ set (ksReadyQueues s p) \ runnable' st) \ - sch_act_wf (ksSchedulerAction s) s) - ({s'. (\cl fl. cthread_state_relation_lifted st (cl\tsType_CL := ts_' s' && mask 4\, fl))} + (\s. tcb_at' thread s \ valid_objs' s \ valid_tcb_state' st s + \ (ksSchedulerAction s = SwitchToThread thread \ runnable' st) + \ sch_act_wf (ksSchedulerAction s) s \ pspace_aligned' s \ pspace_distinct' s) + ({s'. (\cl fl. cthread_state_relation_lifted st (cl\tsType_CL := ts_' s' && mask 4\, fl))} \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) hs - (setThreadState st thread) (Call setThreadState_'proc)" + (setThreadState st thread) (Call setThreadState_'proc)" apply (cinit lift: tptr_' cong add: call_ignore_cong) apply (ctac (no_vcg) add: threadSet_tcbState_simple_corres) apply (ctac add: scheduleTCB_ccorres) - apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_queues_and_runnable' - threadSet_valid_objs') - by (clarsimp simp: weak_sch_act_wf_def valid_queues_def valid_tcb'_tcbState_update) - -lemma threadSet_valid_queues'_and_not_runnable': "\tcb_at' thread and valid_queues' and (\s. (\ runnable' st))\ - threadSet (tcbState_update (\_. st)) thread - \\rv. tcb_at' thread and st_tcb_at' (not runnable') thread and valid_queues' \" - - apply (wp threadSet_valid_queues' threadSet_tcbState_st_tcb_at') - apply (clarsimp simp: pred_neg_def valid_queues'_def inQ_def)+ -done + apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_objs') + apply (clarsimp simp: weak_sch_act_wf_def valid_tcb'_tcbState_update) + done lemma setThreadState_ccorres_valid_queues': - "ccorres dc xfdc - (\s. tcb_at' thread s \ valid_queues' s \ \ runnable' st \ weak_sch_act_wf (ksSchedulerAction s) s \ Invariants_H.valid_queues s \ (\p. thread \ set (ksReadyQueues s p)) \ sch_act_not thread s \ valid_objs' s \ valid_tcb_state' st s) + "ccorres dc xfdc + (\s. tcb_at' thread s \ \ runnable' st \ weak_sch_act_wf (ksSchedulerAction s) s + \ sch_act_not thread s \ valid_objs' s \ valid_tcb_state' st s + \ pspace_aligned' s \ pspace_distinct' s) ({s'. (\cl fl. cthread_state_relation_lifted st (cl\tsType_CL := ts_' s' && mask 4\, fl))} - \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) [] - (setThreadState st thread) (Call setThreadState_'proc)" + \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) [] + (setThreadState st thread) (Call setThreadState_'proc)" apply (cinit lift: tptr_' cong add: call_ignore_cong) apply (ctac (no_vcg) add: threadSet_tcbState_simple_corres) apply (ctac add: scheduleTCB_ccorres_valid_queues') - apply (wp threadSet_valid_queues'_and_not_runnable' threadSet_weak_sch_act_wf_runnable' threadSet_valid_queues_and_runnable' threadSet_valid_objs') + apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_objs' + threadSet_tcbState_st_tcb_at') by (clarsimp simp: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) lemma simp_list_case_return: @@ -2607,22 +2231,20 @@ lemma cancelSignal_ccorres [corres]: apply (rule ccorres_rhs_assoc2) apply (ctac (no_vcg) add: cancelSignal_ccorres_helper) apply (ctac add: setThreadState_ccorres_valid_queues') - apply ((wp setNotification_nosch setNotification_ksQ hoare_vcg_all_lift set_ntfn_valid_objs' | simp add: valid_tcb_state'_def split del: if_split)+)[1] + apply ((wp setNotification_nosch hoare_vcg_all_lift set_ntfn_valid_objs' | simp add: valid_tcb_state'_def split del: if_split)+)[1] apply (simp add: ThreadState_defs) apply (rule conjI, clarsimp, rule conjI, clarsimp) apply (frule (1) ko_at_valid_ntfn'[OF _ invs_valid_objs']) subgoal by ((auto simp: obj_at'_def projectKOs st_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of cthread_state_relation_def sch_act_wf_weak valid_ntfn'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] | - clarsimp simp: eq_commute)+) + | clarsimp simp: eq_commute)+) apply (clarsimp) apply (frule (1) ko_at_valid_ntfn'[OF _ invs_valid_objs']) apply (frule (2) ntfn_blocked_in_queueD) by (auto simp: obj_at'_def projectKOs st_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of valid_ntfn'_def cthread_state_relation_def sch_act_wf_weak isWaitingNtfn_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: ntfn.splits option.splits | clarsimp simp: eq_commute | drule_tac x=thread in bspec)+ @@ -2927,23 +2549,20 @@ lemma cancelIPC_ccorres_helper: cpspace_relation_def update_ep_map_tos typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - subgoal by (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - subgoal by (simp add: cendpoint_relation_def Let_def EPState_Idle_def) - subgoal by simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - subgoal by simp - apply (erule (1) map_to_ko_atI') - apply (simp add: heap_to_user_data_def Let_def) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - subgoal by (clarsimp simp: comp_def) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + subgoal by (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + subgoal by (simp add: cendpoint_relation_def Let_def EPState_Idle_def) + subgoal by simp + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + subgoal by simp + apply (erule (1) map_to_ko_atI') + apply (simp add: heap_to_user_data_def Let_def) subgoal by (clarsimp simp: carch_state_relation_def carch_globals_def packed_heap_update_collapse_hrs) subgoal by (simp add: cmachine_state_relation_def) @@ -2964,27 +2583,16 @@ lemma cancelIPC_ccorres_helper: cpspace_relation_def update_ep_map_tos typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - subgoal by (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (simp add: cendpoint_relation_def Let_def isSendEP_def isRecvEP_def split: endpoint.splits split del: if_split) - \ \recv case\ - apply (subgoal_tac "pspace_canonical' \") - prefer 2 - apply fastforce - apply (clarsimp - simp: h_t_valid_clift_Some_iff ctcb_offset_defs - tcb_queue_relation'_next_mask tcb_queue_relation'_prev_mask - tcb_queue_relation'_next_sign tcb_queue_relation'_prev_sign - simp flip: canonical_bit_def - cong: tcb_queue_relation'_cong) - subgoal by (intro impI conjI; simp) - \ \send case\ - apply (subgoal_tac "pspace_canonical' \") - prefer 2 - apply fastforce + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + subgoal by (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (simp add: cendpoint_relation_def Let_def isSendEP_def isRecvEP_def split: endpoint.splits split del: if_split) + \ \recv case\ + apply (subgoal_tac "pspace_canonical' \") + prefer 2 + apply fastforce apply (clarsimp simp: h_t_valid_clift_Some_iff ctcb_offset_defs tcb_queue_relation'_next_mask tcb_queue_relation'_prev_mask @@ -2992,16 +2600,24 @@ lemma cancelIPC_ccorres_helper: simp flip: canonical_bit_def cong: tcb_queue_relation'_cong) subgoal by (intro impI conjI; simp) - subgoal by simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - apply simp - apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - subgoal by (clarsimp simp: comp_def) + \ \send case\ + apply (subgoal_tac "pspace_canonical' \") + prefer 2 + apply fastforce + apply (clarsimp + simp: h_t_valid_clift_Some_iff ctcb_offset_defs + tcb_queue_relation'_next_mask tcb_queue_relation'_prev_mask + tcb_queue_relation'_next_sign tcb_queue_relation'_prev_sign + simp flip: canonical_bit_def + cong: tcb_queue_relation'_cong) + subgoal by (intro impI conjI; simp) + subgoal by simp + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp + apply (erule (1) map_to_ko_atI') subgoal by (clarsimp simp: carch_state_relation_def carch_globals_def packed_heap_update_collapse_hrs) subgoal by (simp add: cmachine_state_relation_def) @@ -3214,37 +2830,35 @@ lemma cancelIPC_ccorres1: subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits) + split: thread_state.splits) apply clarsimp apply (frule (2) ep_blocked_in_queueD_recv) apply (frule (1) ko_at_valid_ep'[OF _ invs_valid_objs']) subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of isRecvEP_def cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits endpoint.splits) + split: thread_state.splits endpoint.splits) apply (rule conjI) apply (clarsimp simp: inQ_def) - apply (rule conjI) - apply clarsimp apply clarsimp apply (rule conjI) subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits) + split: thread_state.splits) apply clarsimp apply (rule conjI) subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits) + split: thread_state.splits) apply clarsimp apply (frule (2) ep_blocked_in_queueD_send) apply (frule (1) ko_at_valid_ep'[OF _ invs_valid_objs']) subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of isSendEP_def cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits endpoint.splits)[1] + split: thread_state.splits endpoint.splits)[1] apply (auto simp: isTS_defs cthread_state_relation_def typ_heap_simps weak_sch_act_wf_def) apply (case_tac ts, auto simp: isTS_defs cthread_state_relation_def typ_heap_simps) diff --git a/proof/crefine/RISCV64/Ipc_C.thy b/proof/crefine/RISCV64/Ipc_C.thy index 4c4cf65500..c2e028eb22 100644 --- a/proof/crefine/RISCV64/Ipc_C.thy +++ b/proof/crefine/RISCV64/Ipc_C.thy @@ -1359,18 +1359,14 @@ lemma getRestartPC_ccorres [corres]: done lemma asUser_tcbFault_obj_at: - "\obj_at' (\tcb. P (tcbFault tcb)) t\ asUser t' m - \\rv. obj_at' (\tcb. P (tcbFault tcb)) t\" + "asUser t' m \obj_at' (\tcb. P (tcbFault tcb)) t\" apply (simp add: asUser_def split_def) apply (wp threadGet_wp) apply (simp cong: if_cong) done lemma asUser_atcbContext_obj_at: - "t \ t' \ - \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ - asUser t' m - \\rv. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + "t \ t' \ asUser t' m \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" apply (simp add: asUser_def split_def atcbContextGet_def atcbContextSet_def) apply (wp threadGet_wp) apply simp @@ -4173,10 +4169,6 @@ lemma doReplyTransfer_ccorres [corres]: \ \\grant = from_bool grant\) hs (doReplyTransfer sender receiver slot grant) (Call doReplyTransfer_'proc)" -proof - - have invs_valid_queues_strg: "\s. invs' s \ valid_queues s" - by clarsimp - show ?thesis apply (cinit lift: sender_' receiver_' slot_' grant_') apply (rule getThreadState_ccorres_foo) apply (rule ccorres_assert2) @@ -4208,7 +4200,7 @@ proof - apply (ctac(no_vcg) add: cteDeleteOne_ccorres[where w="scast cap_reply_cap"]) apply (ctac(no_vcg) add: setThreadState_ccorres) apply (ctac(no_vcg) add: possibleSwitchTo_ccorres) - apply (wpsimp wp: sts_running_valid_queues setThreadState_st_tcb)+ + apply (wpsimp wp: sts_valid_objs' setThreadState_st_tcb)+ apply (wp cteDeleteOne_sch_act_wf) apply vcg apply (rule conseqPre, vcg) @@ -4217,8 +4209,7 @@ proof - apply wp apply (simp add: cap_get_tag_isCap) apply (strengthen invs_weak_sch_act_wf_strg - cte_wp_at_imp_consequent'[where P="\ct. Ex (ccap_relation (cteCap ct))" for ct] - invs_valid_queues_strg) + cte_wp_at_imp_consequent'[where P="\ct. Ex (ccap_relation (cteCap ct))" for ct]) apply (simp add: cap_reply_cap_def) apply (wp doIPCTransfer_reply_or_replyslot) apply (clarsimp simp: seL4_Fault_NullFault_def ccorres_cond_iffs @@ -4253,19 +4244,20 @@ proof - apply (ctac (no_vcg)) apply (simp only: K_bind_def) apply (ctac add: possibleSwitchTo_ccorres) - apply (wp sts_running_valid_queues setThreadState_st_tcb | simp)+ - apply (ctac add: setThreadState_ccorres_valid_queues'_simple) + apply (wp sts_valid_objs' setThreadState_st_tcb | simp)+ + apply (ctac add: setThreadState_ccorres_simple) apply wp - apply ((wp threadSet_valid_queues threadSet_sch_act threadSet_valid_queues' hoare_weak_lift_imp + apply ((wp threadSet_sch_act hoare_weak_lift_imp threadSet_valid_objs' threadSet_weak_sch_act_wf | simp add: valid_tcb_state'_def)+)[1] apply (clarsimp simp: guard_is_UNIV_def ThreadState_defs mask_def option_to_ctcb_ptr_def) - apply (rule_tac Q="\rv. valid_queues and tcb_at' receiver and valid_queues' and + apply (rule_tac Q="\rv. tcb_at' receiver and valid_objs' and sch_act_simple and (\s. ksCurDomain s \ maxDomain) and - (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) + (\s. sch_act_wf (ksSchedulerAction s) s) and + pspace_aligned' and pspace_distinct'" in hoare_post_imp) apply (clarsimp simp: inQ_def weak_sch_act_wf_def) - apply (wp threadSet_valid_queues threadSet_sch_act handleFaultReply_sch_act_wf) + apply (wp threadSet_sch_act handleFaultReply_sch_act_wf) apply (clarsimp simp: guard_is_UNIV_def) apply assumption apply clarsimp @@ -4274,7 +4266,7 @@ proof - apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_tcb]) apply (clarsimp simp: ctcb_relation_def typ_heap_simps) apply wp - apply (strengthen vp_invs_strg' invs_valid_queues') + apply (strengthen vp_invs_strg') apply (wp cteDeleteOne_tcbFault cteDeleteOne_sch_act_wf) apply vcg apply (rule conseqPre, vcg) @@ -4290,7 +4282,6 @@ proof - cap_get_tag_isCap) apply fastforce done -qed lemma ccorres_getCTE_cte_at: "ccorresG rf_sr \ r xf P P' hs (getCTE p >>= f) c @@ -4310,7 +4301,7 @@ lemma ccorres_getCTE_cte_at: done lemma setupCallerCap_ccorres [corres]: - "ccorres dc xfdc (valid_queues and valid_pspace' and (\s. \d p. sender \ set (ksReadyQueues s (d, p))) + "ccorres dc xfdc (valid_pspace' and (\s. sch_act_wf (ksSchedulerAction s) s) and sch_act_not sender and tcb_at' sender and tcb_at' receiver and tcb_at' sender and tcb_at' receiver) @@ -4442,23 +4433,20 @@ lemma sendIPC_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def - tcb_queue_relation'_def) - apply simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def + tcb_queue_relation'_def) apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - apply simp - apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp + apply (erule (1) map_to_ko_atI') apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -4482,31 +4470,28 @@ lemma sendIPC_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - isRecvEP_def isSendEP_def - tcb_queue_relation'_def valid_ep'_def - simp flip: canonical_bit_def - split: endpoint.splits list.splits - split del: if_split) - apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") - apply (erule (1) tcb_and_not_mask_canonical[OF invs_pspace_canonical']) - apply (simp add: objBits_simps') - apply (clarsimp split: if_split) - apply simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + isRecvEP_def isSendEP_def + tcb_queue_relation'_def valid_ep'_def + simp flip: canonical_bit_def + split: endpoint.splits list.splits + split del: if_split) + apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") + apply (erule (1) tcb_and_not_mask_canonical[OF invs_pspace_canonical']) + apply (simp add: objBits_simps') + apply (clarsimp split: if_split) apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - apply simp - apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp + apply (erule (1) map_to_ko_atI') apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -4531,10 +4516,10 @@ lemma rf_sr_tcb_update_twice: packed_heap_update_collapse_hrs) lemma sendIPC_block_ccorres_helper: - "ccorres dc xfdc (tcb_at' thread and valid_queues and valid_objs' and pspace_canonical' and + "ccorres dc xfdc (tcb_at' thread and valid_objs' and pspace_canonical' and + pspace_aligned' and pspace_distinct' and sch_act_not thread and ep_at' epptr and - (\s. sch_act_wf (ksSchedulerAction s) s \ - (\d p. thread \ set (ksReadyQueues s (d, p)))) and + (\s. sch_act_wf (ksSchedulerAction s) s) and K (bos = ThreadState_BlockedOnSend \ epptr' = epptr \ badge' = badge \ cg = from_bool canGrant \ cgr = from_bool canGrantReply @@ -4593,7 +4578,7 @@ lemma sendIPC_block_ccorres_helper: apply ceqv apply clarsimp apply ctac - apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_queues + apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_objs') apply (clarsimp simp: guard_is_UNIV_def) apply (clarsimp simp: sch_act_wf_weak valid_tcb'_def valid_tcb_state'_def @@ -4698,6 +4683,19 @@ lemma tcb_queue_relation_qend_valid': apply (simp add: h_t_valid_clift_Some_iff) done +lemma tcb_queue'_head_end_NULL: + assumes qr: "tcb_queue_relation' getNext getPrev mp queue qhead qend" + and tat: "\t\set queue. tcb_at' t s" + shows "(qend = NULL) = (qhead = NULL)" + using qr tat + apply - + apply (erule tcb_queue_relationE') + apply (simp add: tcb_queue_head_empty_iff split: if_splits) + apply (rule tcb_at_not_NULL) + apply (erule bspec) + apply simp + done + lemma tcbEPAppend_spec: "\s queue. \ \ \s. \t. (t, s) \ rf_sr \ (\tcb\set queue. tcb_at' tcb t) \ distinct queue @@ -4820,33 +4818,30 @@ lemma sendIPC_enqueue_ccorres_helper: apply (elim conjE) apply (intro conjI) \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep', assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - mask_def [where n=3] EPState_Send_def) - apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask) - apply (rule conjI, simp add: mask_def) - subgoal - apply (clarsimp simp: valid_pspace'_def objBits_simps' simp flip: canonical_bit_def) - apply (erule (1) tcb_and_not_mask_canonical) - by (simp (no_asm) add: tcbBlockSizeBits_def) + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep', assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + mask_def [where n=3] EPState_Send_def) + apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask) + apply (rule conjI, simp add: mask_def) + subgoal + apply (clarsimp simp: valid_pspace'_def objBits_simps' simp flip: canonical_bit_def) + apply (erule (1) tcb_and_not_mask_canonical) + by (simp (no_asm) add: tcbBlockSizeBits_def) + apply (simp add: isSendEP_def isRecvEP_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue, assumption+) apply (simp add: isSendEP_def isRecvEP_def) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_ep_queue, assumption+) - apply (simp add: isSendEP_def isRecvEP_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (simp only:projectKOs injectKO_ep objBits_simps) - apply clarsimp - apply (clarsimp simp: obj_at'_def projectKOs) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (simp only:projectKOs injectKO_ep objBits_simps) + apply clarsimp + apply (clarsimp simp: obj_at'_def projectKOs) apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) apply (simp add: typ_heap_simps') @@ -4863,42 +4858,39 @@ lemma sendIPC_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep', assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - mask_def [where n=3] EPState_Send_def - split: if_split) - subgoal - apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask - valid_ep'_def - dest: tcb_queue_relation_next_not_NULL) - apply (rule conjI, clarsimp) - apply (rule conjI, fastforce simp: mask_def) - apply (clarsimp simp: valid_pspace'_def objBits_simps' simp flip: canonical_bit_def) - apply (erule (1) tcb_and_not_mask_canonical) - apply (simp (no_asm) add: tcbBlockSizeBits_def) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep', assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + mask_def [where n=3] EPState_Send_def + split: if_split) + subgoal + apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask + valid_ep'_def + dest: tcb_queue_relation_next_not_NULL) + apply (rule conjI, clarsimp) + apply (rule conjI, fastforce simp: mask_def) apply (clarsimp simp: valid_pspace'_def objBits_simps' simp flip: canonical_bit_def) - apply (rule conjI, solves \simp (no_asm) add: mask_def\) apply (erule (1) tcb_and_not_mask_canonical) apply (simp (no_asm) add: tcbBlockSizeBits_def) - done + apply (clarsimp simp: valid_pspace'_def objBits_simps' simp flip: canonical_bit_def) + apply (rule conjI, solves \simp (no_asm) add: mask_def\) + apply (erule (1) tcb_and_not_mask_canonical) + apply (simp (no_asm) add: tcbBlockSizeBits_def) + done + apply (simp add: isSendEP_def isRecvEP_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue, assumption+) apply (simp add: isSendEP_def isRecvEP_def) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_ep_queue, assumption+) - apply (simp add: isSendEP_def isRecvEP_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def projectKOs) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def projectKOs) apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -4918,8 +4910,7 @@ lemma ctcb_relation_blockingIPCCanGrantD: lemma sendIPC_ccorres [corres]: "ccorres dc xfdc (invs' and st_tcb_at' simple' thread - and sch_act_not thread and ep_at' epptr and - (\s. \d p. thread \ set (ksReadyQueues s (d, p)))) + and sch_act_not thread and ep_at' epptr) (UNIV \ \\blocking = from_bool blocking\ \ \\do_call = from_bool do_call\ \ \\badge = badge\ @@ -4950,8 +4941,7 @@ lemma sendIPC_ccorres [corres]: apply ceqv apply (rule_tac A="invs' and st_tcb_at' simple' thread and sch_act_not thread and ko_at' ep epptr - and ep_at' epptr - and (\s. \d p. thread \ set (ksReadyQueues s (d, p)))" + and ep_at' epptr" in ccorres_guard_imp2 [where A'=UNIV]) apply wpc \ \RecvEP case\ @@ -4999,12 +4989,11 @@ lemma sendIPC_ccorres [corres]: apply (ctac add: setThreadState_ccorres) apply (rule ccorres_return_Skip) apply (wpsimp wp: hoare_drop_imps hoare_vcg_all_lift possibleSwitchTo_sch_act_not - possibleSwitchTo_sch_act_not sts_st_tcb' - possibleSwitchTo_ksQ' sts_valid_queues sts_ksQ' + possibleSwitchTo_sch_act_not sts_st_tcb' sts_valid_objs' simp: valid_tcb_state'_def)+ apply vcg - apply (wpsimp wp: doIPCTransfer_sch_act setEndpoint_ksQ hoare_vcg_all_lift - set_ep_valid_objs' setEndpoint_valid_mdb' + apply (wpsimp wp: doIPCTransfer_sch_act hoare_vcg_all_lift + set_ep_valid_objs' setEndpoint_valid_mdb' | wp (once) hoare_drop_imp | strengthen sch_act_wf_weak)+ apply (fastforce simp: guard_is_UNIV_def ThreadState_defs Collect_const_mem mask_def @@ -5125,10 +5114,10 @@ lemma ctcb_relation_blockingIPCCanGrantReplyD: done lemma receiveIPC_block_ccorres_helper: - "ccorres dc xfdc (tcb_at' thread and valid_queues and valid_objs' and pspace_canonical' and + "ccorres dc xfdc (tcb_at' thread and valid_objs' and pspace_canonical' and + pspace_aligned' and pspace_distinct' and sch_act_not thread and ep_at' epptr and - (\s. sch_act_wf (ksSchedulerAction s) s \ - (\d p. thread \ set (ksReadyQueues s (d, p)))) and + (\s. sch_act_wf (ksSchedulerAction s) s) and K (epptr = epptr && ~~ mask 4) and K (isEndpointCap cap \ ccap_relation cap cap')) UNIV hs @@ -5169,7 +5158,7 @@ lemma receiveIPC_block_ccorres_helper: apply ceqv apply clarsimp apply ctac - apply (wp threadSet_valid_queues hoare_vcg_all_lift threadSet_valid_objs' + apply (wp hoare_vcg_all_lift threadSet_valid_objs' threadSet_weak_sch_act_wf_runnable') apply (clarsimp simp: guard_is_UNIV_def) apply (clarsimp simp: sch_act_wf_weak valid_tcb'_def valid_tcb_state'_def @@ -5235,42 +5224,38 @@ lemma receiveIPC_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep', assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - mask_def [where n=3] EPState_Recv_def - split: if_split) - subgoal - apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask - valid_ep'_def - dest: tcb_queue_relation_next_not_NULL) - apply (rule conjI, clarsimp) - apply (rule conjI, fastforce simp: mask_def) - apply (clarsimp simp: valid_pspace'_def objBits_simps' simp flip: canonical_bit_def) - apply (erule (1) tcb_and_not_mask_canonical) - apply (simp (no_asm) add: tcbBlockSizeBits_def) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep', assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + mask_def [where n=3] EPState_Recv_def + split: if_split) + subgoal + apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask valid_ep'_def + dest: tcb_queue_relation_next_not_NULL) + apply (rule conjI, clarsimp) + apply (rule conjI, fastforce simp: mask_def) apply (clarsimp simp: valid_pspace'_def objBits_simps' simp flip: canonical_bit_def) - apply (rule conjI, solves \simp (no_asm) add: mask_def\) apply (erule (1) tcb_and_not_mask_canonical) apply (simp (no_asm) add: tcbBlockSizeBits_def) - done + apply (clarsimp simp: valid_pspace'_def objBits_simps' simp flip: canonical_bit_def) + apply (rule conjI, solves \simp (no_asm) add: mask_def\) + apply (erule (1) tcb_and_not_mask_canonical) + apply (simp (no_asm) add: tcbBlockSizeBits_def) + done + apply (simp add: isSendEP_def isRecvEP_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue, assumption+) apply (simp add: isSendEP_def isRecvEP_def) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_ep_queue, assumption+) - apply (simp add: isSendEP_def isRecvEP_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def projectKOs) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def projectKOs) apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -5287,34 +5272,31 @@ lemma receiveIPC_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep', assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - mask_def [where n=3] EPState_Recv_def) - apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask - simp flip: canonical_bit_def) - subgoal - apply (rule conjI, solves\simp (no_asm) add: mask_def\) - apply (clarsimp simp: valid_pspace'_def) - apply (erule (1) tcb_and_not_mask_canonical, simp (no_asm) add: tcbBlockSizeBits_def) - done + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep', assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + mask_def [where n=3] EPState_Recv_def) + apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask + simp flip: canonical_bit_def) + subgoal + apply (rule conjI, solves\simp (no_asm) add: mask_def\) + apply (clarsimp simp: valid_pspace'_def) + apply (erule (1) tcb_and_not_mask_canonical, simp (no_asm) add: tcbBlockSizeBits_def) + done + apply (simp add: isSendEP_def isRecvEP_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue, assumption+) apply (simp add: isSendEP_def isRecvEP_def) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_ep_queue, assumption+) - apply (simp add: isSendEP_def isRecvEP_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def projectKOs) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def projectKOs) apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) apply (simp add: typ_heap_simps') @@ -5383,23 +5365,20 @@ lemma receiveIPC_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def - tcb_queue_relation'_def) - apply simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def + tcb_queue_relation'_def) apply simp + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) apply (simp add: typ_heap_simps') @@ -5423,31 +5402,28 @@ lemma receiveIPC_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - isRecvEP_def isSendEP_def - tcb_queue_relation'_def valid_ep'_def - simp flip: canonical_bit_def - split: endpoint.splits list.splits - split del: if_split) - apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") - apply (erule (1) tcb_and_not_mask_canonical[OF invs_pspace_canonical']) - apply (clarsimp simp: objBits_simps') - apply (clarsimp split: if_split) - apply simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + isRecvEP_def isSendEP_def + tcb_queue_relation'_def valid_ep'_def + simp flip: canonical_bit_def + split: endpoint.splits list.splits + split del: if_split) + apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") + apply (erule (1) tcb_and_not_mask_canonical[OF invs_pspace_canonical']) + apply (clarsimp simp: objBits_simps') + apply (clarsimp split: if_split) apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - apply simp - apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp + apply (erule (1) map_to_ko_atI') apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) apply (simp add: typ_heap_simps') @@ -5564,7 +5540,6 @@ lemma receiveIPC_ccorres [corres]: notes option.case_cong_weak [cong] shows "ccorres dc xfdc (invs' and st_tcb_at' simple' thread and sch_act_not thread - and (\s. \d p. thread \ set (ksReadyQueues s (d, p))) and valid_cap' cap and K (isEndpointCap cap)) (UNIV \ \\thread = tcb_ptr_to_ctcb_ptr thread\ \ \ccap_relation cap \cap\ @@ -5640,7 +5615,6 @@ lemma receiveIPC_ccorres [corres]: apply ceqv apply (rule_tac A="invs' and st_tcb_at' simple' thread and sch_act_not thread - and (\s. \d p. thread \ set (ksReadyQueues s (d, p))) and ko_at' ep (capEPPtr cap)" in ccorres_guard_imp2 [where A'=UNIV]) apply wpc @@ -5780,27 +5754,25 @@ lemma receiveIPC_ccorres [corres]: apply ccorres_rewrite apply ctac apply (ctac add: possibleSwitchTo_ccorres) - apply (wpsimp wp: sts_st_tcb' sts_valid_queues) + apply (wpsimp wp: sts_st_tcb' sts_valid_objs') apply (vcg exspec=setThreadState_modifies) apply (fastforce simp: guard_is_UNIV_def ThreadState_defs mask_def cap_get_tag_isCap ccap_relation_ep_helpers) apply (clarsimp simp: valid_tcb_state'_def) - apply (rule_tac Q="\_. valid_pspace' and valid_queues + apply (rule_tac Q="\_. valid_pspace' and st_tcb_at' ((=) sendState) sender and tcb_at' thread and (\s. sch_act_wf (ksSchedulerAction s) s) - and (\s. (\a b. sender \ set (ksReadyQueues s (a, b)))) and sch_act_not sender and K (thread \ sender) and (\s. ksCurDomain s \ maxDomain)" in hoare_post_imp) - apply (clarsimp simp: valid_pspace_valid_objs' pred_tcb_at'_def sch_act_wf_weak - obj_at'_def) + apply (fastforce simp: valid_pspace_valid_objs' pred_tcb_at'_def sch_act_wf_weak + obj_at'_def) apply (wpsimp simp: guard_is_UNIV_def option_to_ptr_def option_to_0_def conj_ac)+ - apply (rule_tac Q="\rv. valid_queues and valid_pspace' + apply (rule_tac Q="\rv. valid_pspace' and cur_tcb' and tcb_at' sender and tcb_at' thread and sch_act_not sender and K (thread \ sender) and ep_at' (capEPPtr cap) and (\s. ksCurDomain s \ maxDomain) - and (\s. sch_act_wf (ksSchedulerAction s) s \ - (\d p. sender \ set (ksReadyQueues s (d, p))))" + and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) subgoal by (auto, auto simp: st_tcb_at'_def obj_at'_def) apply (wp hoare_vcg_all_lift set_ep_valid_objs') @@ -5836,14 +5808,11 @@ lemma receiveIPC_ccorres [corres]: split: if_split_asm bool.splits) (*very long *) apply (clarsimp simp: obj_at'_def state_refs_of'_def projectKOs) apply (frule(1) sym_refs_ko_atD' [OF _ invs_sym']) - apply (frule invs_queues) apply clarsimp apply (rename_tac list x xa) apply (rule_tac P="x\set list" in case_split) apply (clarsimp simp:st_tcb_at_refs_of_rev') apply (erule_tac x=x and P="\x. st_tcb_at' P x s" for P in ballE) - apply (drule_tac t=x in valid_queues_not_runnable'_not_ksQ) - apply (clarsimp simp: st_tcb_at'_def obj_at'_def) apply (subgoal_tac "sch_act_not x s") prefer 2 apply (frule invs_sch_act_wf') @@ -5921,23 +5890,20 @@ lemma sendSignal_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) - apply simp+ - apply (erule (1) map_to_ko_atI') - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) - apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def - tcb_queue_relation'_def) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) + apply simp+ + apply (erule (1) map_to_ko_atI') + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) + apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def + tcb_queue_relation'_def) + apply simp apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -5963,33 +5929,30 @@ lemma sendSignal_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) - apply simp+ - apply (erule (1) map_to_ko_atI') - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) - apply (clarsimp simp: cnotification_relation_def Let_def - isWaitingNtfn_def - tcb_queue_relation'_def valid_ntfn'_def - split: Structures_H.notification.splits list.splits - split del: if_split) - apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") - apply (rule conjI) - subgoal by (erule (1) tcb_ptr_sign_extend_canonical[OF invs_pspace_canonical']) - apply (rule context_conjI) - subgoal by (erule (1) tcb_ptr_sign_extend_canonical[OF invs_pspace_canonical']) - apply clarsimp - apply (clarsimp split: if_split) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) + apply simp+ + apply (erule (1) map_to_ko_atI') + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) + apply (clarsimp simp: cnotification_relation_def Let_def + isWaitingNtfn_def + tcb_queue_relation'_def valid_ntfn'_def + split: Structures_H.notification.splits list.splits + split del: if_split) + apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") + apply (rule conjI) + subgoal by (erule (1) tcb_ptr_sign_extend_canonical[OF invs_pspace_canonical']) + apply (rule context_conjI) + subgoal by (erule (1) tcb_ptr_sign_extend_canonical[OF invs_pspace_canonical']) + apply clarsimp + apply (clarsimp split: if_split) + apply simp apply (clarsimp simp: carch_state_relation_def) apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -6096,7 +6059,7 @@ lemma sendSignal_ccorres [corres]: apply (ctac(no_vcg) add: setThreadState_ccorres) apply (ctac(no_vcg) add: setRegister_ccorres) apply (ctac add: possibleSwitchTo_ccorres) - apply (wp sts_running_valid_queues sts_st_tcb_at'_cases + apply (wp sts_valid_objs' sts_st_tcb_at'_cases | simp add: option_to_ctcb_ptr_def split del: if_split)+ apply (rule_tac Q="\_. tcb_at' (the (ntfnBoundTCB ntfn)) and invs'" in hoare_post_imp) @@ -6162,10 +6125,8 @@ lemma sendSignal_ccorres [corres]: apply (ctac (no_vcg)) apply (ctac add: possibleSwitchTo_ccorres) apply (simp) - apply (wp weak_sch_act_wf_lift_linear - setThreadState_oa_queued - sts_valid_queues tcb_in_cur_domain'_lift)[1] - apply (wp sts_valid_queues sts_runnable) + apply (wp weak_sch_act_wf_lift_linear tcb_in_cur_domain'_lift)[1] + apply (wp sts_valid_objs' sts_runnable) apply (wp setThreadState_st_tcb set_ntfn_valid_objs' | clarsimp)+ apply (clarsimp simp: guard_is_UNIV_def ThreadState_defs mask_def badgeRegister_def C_register_defs @@ -6190,10 +6151,10 @@ lemma sendSignal_ccorres [corres]: done lemma receiveSignal_block_ccorres_helper: - "ccorres dc xfdc (tcb_at' thread and valid_queues and sch_act_not thread and + "ccorres dc xfdc (tcb_at' thread and sch_act_not thread and valid_objs' and ntfn_at' ntfnptr and pspace_canonical' and - (\s. sch_act_wf (ksSchedulerAction s) s \ - (\d p. thread \ set (ksReadyQueues s (d, p)))) and + pspace_aligned' and pspace_distinct' and + (\s. sch_act_wf (ksSchedulerAction s) s) and K (ntfnptr = ntfnptr && ~~ mask 4)) UNIV hs (setThreadState (Structures_H.thread_state.BlockedOnNotification @@ -6229,7 +6190,7 @@ lemma receiveSignal_block_ccorres_helper: apply ceqv apply clarsimp apply ctac - apply (wp threadSet_valid_queues hoare_vcg_all_lift threadSet_valid_objs' + apply (wp hoare_vcg_all_lift threadSet_valid_objs' threadSet_weak_sch_act_wf_runnable') apply (clarsimp simp: guard_is_UNIV_def) apply (auto simp: weak_sch_act_wf_def valid_tcb'_def tcb_cte_cases_def @@ -6348,37 +6309,34 @@ lemma receiveSignal_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cendpoint_relation_ntfn_queue, assumption+) + apply (simp add: isWaitingNtfn_def) apply simp - apply (rule cendpoint_relation_ntfn_queue, assumption+) - apply (simp add: isWaitingNtfn_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def projectKOs) - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn', assumption+) - apply (case_tac "ntfn", simp_all)[1] - apply (clarsimp simp: cnotification_relation_def Let_def - mask_def [where n=3] NtfnState_Waiting_def) - subgoal - apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask valid_ntfn'_def - dest: tcb_queue_relation_next_not_NULL) - apply (rule conjI, fastforce simp: mask_def) - apply (rule context_conjI) - subgoal by (fastforce simp: valid_pspace'_def objBits_simps' - intro!: tcb_ptr_sign_extend_canonical - dest!: st_tcb_strg'[rule_format]) - by clarsimp - apply (simp add: isWaitingNtfn_def) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - subgoal by (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def projectKOs) + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn', assumption+) + apply (case_tac "ntfn", simp_all)[1] + apply (clarsimp simp: cnotification_relation_def Let_def + mask_def [where n=3] NtfnState_Waiting_def) + subgoal + apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask valid_ntfn'_def + dest: tcb_queue_relation_next_not_NULL) + apply (rule conjI, fastforce simp: mask_def) + apply (rule context_conjI) + subgoal by (fastforce simp: valid_pspace'_def objBits_simps' + intro!: tcb_ptr_sign_extend_canonical + dest!: st_tcb_strg'[rule_format]) + by clarsimp + apply (simp add: isWaitingNtfn_def) apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -6395,49 +6353,46 @@ lemma receiveSignal_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cendpoint_relation_ntfn_queue, assumption+) + apply (simp add: isWaitingNtfn_def) apply simp - apply (rule cendpoint_relation_ntfn_queue, assumption+) - apply (simp add: isWaitingNtfn_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def projectKOs) - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn', assumption+) - apply (case_tac "ntfn", simp_all)[1] - apply (clarsimp simp: cnotification_relation_def Let_def - mask_def [where n=3] NtfnState_Waiting_def - split: if_split) - subgoal for _ _ ko' - apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask - dest: tcb_queue_relation_next_not_NULL) - apply (rule conjI, clarsimp) - apply (rule conjI, fastforce simp: mask_def) - apply (rule context_conjI) - subgoal by (fastforce intro!: tcb_ptr_sign_extend_canonical - dest!: st_tcb_strg'[rule_format]) - apply clarsimp - apply clarsimp + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def projectKOs) + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn', assumption+) + apply (case_tac "ntfn", simp_all)[1] + apply (clarsimp simp: cnotification_relation_def Let_def + mask_def [where n=3] NtfnState_Waiting_def + split: if_split) + subgoal for _ _ ko' + apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask + dest: tcb_queue_relation_next_not_NULL) + apply (rule conjI, clarsimp) apply (rule conjI, fastforce simp: mask_def) - apply (rule conjI) + apply (rule context_conjI) subgoal by (fastforce intro!: tcb_ptr_sign_extend_canonical dest!: st_tcb_strg'[rule_format]) - apply (subgoal_tac "canonical_address (ntfnQueue_head_CL (notification_lift ko'))") - apply (clarsimp simp: canonical_address_sign_extended sign_extended_iff_sign_extend) - apply (clarsimp simp: notification_lift_def canonical_address_sign_extended - sign_extended_sign_extend - simp flip: canonical_bit_def) - done - apply (simp add: isWaitingNtfn_def) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply clarsimp + apply clarsimp + apply (rule conjI, fastforce simp: mask_def) + apply (rule conjI) + subgoal by (fastforce intro!: tcb_ptr_sign_extend_canonical + dest!: st_tcb_strg'[rule_format]) + apply (subgoal_tac "canonical_address (ntfnQueue_head_CL (notification_lift ko'))") + apply (clarsimp simp: canonical_address_sign_extended sign_extended_iff_sign_extend) + apply (clarsimp simp: notification_lift_def canonical_address_sign_extended + sign_extended_sign_extend + simp flip: canonical_bit_def) + done + apply (simp add: isWaitingNtfn_def) apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs) apply (simp add: cmachine_state_relation_def) apply (simp add: h_t_valid_clift_Some_iff) @@ -6449,7 +6404,6 @@ lemma receiveSignal_enqueue_ccorres_helper: lemma receiveSignal_ccorres [corres]: "ccorres dc xfdc (invs' and valid_cap' cap and st_tcb_at' simple' thread and sch_act_not thread - and (\s. \d p. thread \ set (ksReadyQueues s (d, p))) and K (isNotificationCap cap)) (UNIV \ \\thread = tcb_ptr_to_ctcb_ptr thread\ \ \ccap_relation cap \cap\ diff --git a/proof/crefine/RISCV64/IsolatedThreadAction.thy b/proof/crefine/RISCV64/IsolatedThreadAction.thy index 96b7886d3d..0c5bd15952 100644 --- a/proof/crefine/RISCV64/IsolatedThreadAction.thy +++ b/proof/crefine/RISCV64/IsolatedThreadAction.thy @@ -68,12 +68,12 @@ lemma put_tcb_state_regs_twice[simp]: "put_tcb_state_regs tsr (put_tcb_state_regs tsr' tcb) = put_tcb_state_regs tsr tcb" apply (simp add: put_tcb_state_regs_def put_tcb_state_regs_tcb_def - atcbContextSet_def - makeObject_tcb newArchTCB_def newContext_def initContext_def + makeObject_tcb newArchTCB_def split: tcb_state_regs.split option.split Structures_H.kernel_object.split) apply (intro all_tcbI impI allI) - apply (case_tac q, simp) + using atcbContextSet_def atcbContext_set_set + apply fastforce+ done lemma partial_overwrite_twice[simp]: @@ -914,9 +914,11 @@ lemma oblivious_switchToThread_schact: threadSet_def tcbSchedEnqueue_def unless_when asUser_def getQueue_def setQueue_def storeWordUser_def setRegister_def pointerInUserData_def isRunnable_def isStopped_def - getThreadState_def tcbSchedDequeue_def bitmap_fun_defs) + getThreadState_def tcbSchedDequeue_def tcbQueueRemove_def bitmap_fun_defs + ksReadyQueues_asrt_def) by (safe intro!: oblivious_bind - | simp_all add: oblivious_setVMRoot_schact)+ + | simp_all add: ready_qs_runnable_def idleThreadNotQueued_def + oblivious_setVMRoot_schact)+ (* FIXME move *) lemma empty_fail_getCurThread[intro!, wp, simp]: @@ -956,9 +958,7 @@ lemma tcbSchedEnqueue_tcbPriority[wp]: done crunch obj_at_prio[wp]: cteDeleteOne "obj_at' (\tcb. P (tcbPriority tcb)) t" - (wp: crunch_wps setEndpoint_obj_at'_tcb - setThreadState_obj_at_unchanged setNotification_tcb setBoundNotification_obj_at_unchanged - simp: crunch_simps unless_def) + (wp: crunch_wps setEndpoint_obj_at'_tcb setNotification_tcb simp: crunch_simps unless_def) lemma setThreadState_no_sch_change: "\\s. P (ksSchedulerAction s) \ (runnable' st \ t \ ksCurThread s)\ @@ -1077,8 +1077,6 @@ lemma setCTE_assert_modify: apply (rule word_and_le2) apply (simp add: objBits_simps mask_def field_simps) apply (simp add: simpler_modify_def cong: option.case_cong if_cong) - apply (rule kernel_state.fold_congs[OF refl refl]) - apply (clarsimp simp: projectKO_opt_tcb cong: if_cong) apply (clarsimp simp: lookupAround2_char1 word_and_le2) apply (rule ccontr, clarsimp) apply (erule(2) ps_clearD) @@ -1095,7 +1093,7 @@ lemma setCTE_assert_modify: apply (erule disjE) apply clarsimp apply (frule(1) tcb_cte_cases_aligned_helpers) - apply (clarsimp simp: domI[where m = cte_cte_cases] field_simps) + apply (clarsimp simp: domI field_simps) apply (clarsimp simp: lookupAround2_char1 obj_at'_def projectKOs objBits_simps) apply (clarsimp simp: obj_at'_def lookupAround2_char1 @@ -1221,11 +1219,14 @@ lemma thread_actions_isolatableD: lemma tcbSchedDequeue_rewrite: "monadic_rewrite True True (obj_at' (Not \ tcbQueued) t) (tcbSchedDequeue t) (return ())" apply (simp add: tcbSchedDequeue_def) - apply (wp_pre, monadic_rewrite_symb_exec_l_known False, simp) - apply (rule monadic_rewrite_refl) - apply (wpsimp wp: threadGet_const)+ + apply wp_pre + apply monadic_rewrite_symb_exec_l + apply (monadic_rewrite_symb_exec_l_known False, simp) + apply (rule monadic_rewrite_refl) + apply (wpsimp wp: threadGet_const)+ done +(* FIXME: improve automation here *) lemma switchToThread_rewrite: "monadic_rewrite True True (ct_in_state' (Not \ runnable') and cur_tcb' and obj_at' (Not \ tcbQueued) t) @@ -1233,7 +1234,9 @@ lemma switchToThread_rewrite: (do Arch.switchToThread t; setCurThread t od)" apply (simp add: switchToThread_def Thread_H.switchToThread_def) apply (monadic_rewrite_l tcbSchedDequeue_rewrite, simp) - apply (rule monadic_rewrite_refl) + (* strip LHS of getters and asserts until LHS and RHS are the same *) + apply (repeat_unless \rule monadic_rewrite_refl\ monadic_rewrite_symb_exec_l) + apply wpsimp+ apply (clarsimp simp: comp_def) done @@ -1271,9 +1274,33 @@ lemma threadGet_isolatable: thread_actions_isolatable_fail) done +lemma tcbQueued_put_tcb_state_regs_tcb: + "tcbQueued (put_tcb_state_regs_tcb tsr tcb) = tcbQueued tcb" + apply (clarsimp simp: put_tcb_state_regs_tcb_def) + by (cases tsr; clarsimp) + +lemma idleThreadNotQueued_isolatable: + "thread_actions_isolatable idx (stateAssert idleThreadNotQueued [])" + apply (simp add: stateAssert_def2 stateAssert_def) + apply (intro thread_actions_isolatable_bind[OF _ _ hoare_pre(1)] + gets_isolatable + thread_actions_isolatable_if + thread_actions_isolatable_returns + thread_actions_isolatable_fail) + unfolding idleThreadNotQueued_def + apply (clarsimp simp: obj_at_partial_overwrite_If) + apply (clarsimp simp: obj_at'_def tcbQueued_put_tcb_state_regs_tcb) + apply wpsimp+ + done + lemma setCurThread_isolatable: "thread_actions_isolatable idx (setCurThread t)" - by (simp add: setCurThread_def modify_isolatable) + unfolding setCurThread_def + apply (rule thread_actions_isolatable_bind) + apply (rule idleThreadNotQueued_isolatable) + apply (fastforce intro: modify_isolatable) + apply wpsimp + done lemma isolate_thread_actions_tcbs_at: assumes f: "\x. \tcb_at' (idx x)\ f \\rv. tcb_at' (idx x)\" shows diff --git a/proof/crefine/RISCV64/Recycle_C.thy b/proof/crefine/RISCV64/Recycle_C.thy index f1564bcc83..dc3d306d2e 100644 --- a/proof/crefine/RISCV64/Recycle_C.thy +++ b/proof/crefine/RISCV64/Recycle_C.thy @@ -774,16 +774,6 @@ lemma cnotification_relation_q_cong: apply (auto intro: iffD1[OF tcb_queue_relation'_cong[OF refl refl refl]]) done -lemma tcbSchedEnqueue_ep_at: - "\obj_at' (P :: endpoint \ bool) ep\ - tcbSchedEnqueue t - \\rv. obj_at' P ep\" - including no_pre - apply (simp add: tcbSchedEnqueue_def unless_def null_def) - apply (wp threadGet_wp, clarsimp, wp+) - apply (clarsimp split: if_split, wp) - done - lemma ccorres_duplicate_guard: "ccorres r xf (P and P) Q hs f f' \ ccorres r xf P Q hs f f'" by (erule ccorres_guard_imp, auto) @@ -803,10 +793,11 @@ lemma cancelBadgedSends_ccorres: (UNIV \ {s. epptr_' s = Ptr ptr} \ {s. badge_' s = bdg}) [] (cancelBadgedSends ptr bdg) (Call cancelBadgedSends_'proc)" apply (cinit lift: epptr_' badge_' simp: whileAnno_def) + apply (rule ccorres_stateAssert) apply (simp add: list_case_return cong: list.case_cong Structures_H.endpoint.case_cong call_ignore_cong del: Collect_const) - apply (rule ccorres_pre_getEndpoint) + apply (rule ccorres_pre_getEndpoint, rename_tac ep) apply (rule_tac R="ko_at' ep ptr" and xf'="ret__unsigned_longlong_'" and val="case ep of RecvEP q \ scast EPState_Recv | IdleEP \ scast EPState_Idle | SendEP q \ scast EPState_Send" @@ -855,8 +846,9 @@ lemma cancelBadgedSends_ccorres: st_tcb_at' (\st. isBlockedOnSend st \ blockingObject st = ptr) x s) \ distinct (xs @ list) \ ko_at' IdleEP ptr s \ (\p. \x \ set (xs @ list). \rf. (x, rf) \ {r \ state_refs_of' s p. snd r \ NTFNBound}) - \ valid_queues s \ pspace_aligned' s \ pspace_distinct' s \ pspace_canonical' s - \ sch_act_wf (ksSchedulerAction s) s \ valid_objs' s" + \ pspace_aligned' s \ pspace_distinct' s \ pspace_canonical' s + \ sch_act_wf (ksSchedulerAction s) s \ valid_objs' s + \ ksReadyQueues_head_end s \ ksReadyQueues_head_end_tcb_at' s" and P'="\xs. {s. ep_queue_relation' (cslift s) (xs @ list) (head_C (queue_' s)) (end_C (queue_' s))} \ {s. thread_' s = (case list of [] \ tcb_Ptr 0 @@ -956,8 +948,9 @@ lemma cancelBadgedSends_ccorres: apply (rule_tac rrel=dc and xf=xfdc and P="\s. (\t \ set (x @ a # lista). tcb_at' t s) \ (\p. \t \ set (x @ a # lista). \rf. (t, rf) \ {r \ state_refs_of' s p. snd r \ NTFNBound}) - \ valid_queues s \ distinct (x @ a # lista) - \ pspace_aligned' s \ pspace_distinct' s" + \ distinct (x @ a # lista) + \ pspace_aligned' s \ pspace_distinct' s + \ ksReadyQueues_head_end s \ ksReadyQueues_head_end_tcb_at' s" and P'="{s. ep_queue_relation' (cslift s) (x @ a # lista) (head_C (queue_' s)) (end_C (queue_' s))}" in ccorres_from_vcg) @@ -973,8 +966,7 @@ lemma cancelBadgedSends_ccorres: apply (clarsimp simp: return_def rf_sr_def cstate_relation_def Let_def) apply (rule conjI) apply (clarsimp simp: cpspace_relation_def) - apply (rule conjI, erule ctcb_relation_null_queue_ptrs) - apply (rule null_ep_queue) + apply (rule conjI, erule ctcb_relation_null_ep_ptrs) subgoal by (simp add: o_def) apply (rule conjI) apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) @@ -997,9 +989,6 @@ lemma cancelBadgedSends_ccorres: apply (clarsimp simp: image_iff) apply (drule_tac x=p in spec) subgoal by fastforce - apply (rule conjI) - apply (erule cready_queues_relation_not_queue_ptrs, - auto dest: null_ep_schedD[unfolded o_def] simp: o_def)[1] apply (clarsimp simp: carch_state_relation_def cmachine_state_relation_def) apply (rule ccorres_symb_exec_r2) apply (erule spec) @@ -1008,12 +997,11 @@ lemma cancelBadgedSends_ccorres: apply wp apply simp apply vcg - apply (wp hoare_vcg_const_Ball_lift tcbSchedEnqueue_ep_at - sch_act_wf_lift) + apply (wp hoare_vcg_const_Ball_lift sch_act_wf_lift) apply simp apply (vcg exspec=tcbSchedEnqueue_cslift_spec) apply (wp hoare_vcg_const_Ball_lift sts_st_tcb_at'_cases - sts_sch_act sts_valid_queues setThreadState_oa_queued) + sts_sch_act sts_valid_objs') apply (vcg exspec=setThreadState_cslift_spec) apply (simp add: ccorres_cond_iffs) apply (rule ccorres_symb_exec_r2) @@ -1037,14 +1025,11 @@ lemma cancelBadgedSends_ccorres: apply (clarsimp simp: cscheduler_action_relation_def st_tcb_at'_def split: scheduler_action.split_asm) apply (rename_tac word) - apply (frule_tac x=word in tcbSchedEnqueue_cslift_precond_discharge) - apply simp - subgoal by clarsimp - subgoal by clarsimp + apply (frule_tac x=word in tcbSchedEnqueue_cslift_precond_discharge; simp?) subgoal by clarsimp apply clarsimp apply (rule conjI) - apply (frule(3) tcbSchedEnqueue_cslift_precond_discharge) + apply (frule tcbSchedEnqueue_cslift_precond_discharge; simp?) subgoal by clarsimp apply clarsimp apply (rule context_conjI) @@ -1084,9 +1069,19 @@ lemma cancelBadgedSends_ccorres: apply (clarsimp split: if_split) apply (drule sym_refsD, clarsimp) apply (drule(1) bspec)+ - by (auto simp: obj_at'_def projectKOs state_refs_of'_def pred_tcb_at'_def tcb_bound_refs'_def - dest!: symreftype_inverse') - + apply (frule ksReadyQueues_asrt_ksReadyQueues_head_end) + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (frule (2) ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at') + apply (fastforce simp: obj_at'_def projectKOs state_refs_of'_def pred_tcb_at'_def + tcb_bound_refs'_def + dest!: symreftype_inverse') + apply (frule ksReadyQueues_asrt_ksReadyQueues_head_end) + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (frule (2) ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at') + apply fastforce + done lemma tcb_ptr_to_ctcb_ptr_force_fold: "x + 2 ^ ctcb_size_bits = ptr_val (tcb_ptr_to_ctcb_ptr x)" diff --git a/proof/crefine/RISCV64/Refine_C.thy b/proof/crefine/RISCV64/Refine_C.thy index 1eeb2d9b3b..6dec83c176 100644 --- a/proof/crefine/RISCV64/Refine_C.thy +++ b/proof/crefine/RISCV64/Refine_C.thy @@ -64,7 +64,7 @@ proof - apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply vcg apply vcg apply (clarsimp simp: irqInvalid_def ucast_8_32_neq Kernel_C.irqInvalid_def) @@ -77,7 +77,7 @@ proof - apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (rule_tac Q="\rv s. invs' s \ (\x. rv = Some x \ x \ RISCV64.maxIRQ) \ rv \ Some 0x3FF" in hoare_post_imp) apply (clarsimp simp: non_kernel_IRQs_def) apply (wp getActiveIRQ_le_maxIRQ getActiveIRQ_neq_Some0x3FF | simp)+ @@ -106,14 +106,12 @@ lemma handleUnknownSyscall_ccorres: apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (clarsimp, vcg) apply (clarsimp, rule conseqPre, vcg, clarsimp) apply clarsimp apply (intro impI conjI allI) - apply fastforce - apply (clarsimp simp: ct_not_ksQ) - apply (clarsimp simp add: sch_act_simple_def split: scheduler_action.split) + apply fastforce apply (rule active_ex_cap') apply (erule active_from_running') apply (erule invs_iflive') @@ -163,13 +161,13 @@ lemma handleVMFaultEvent_ccorres: apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (case_tac x, clarsimp, wp) apply (clarsimp, wp, simp) apply wp apply (simp add: guard_is_UNIV_def) apply (clarsimp simp: simple_sane_strg[unfolded sch_act_sane_not]) - apply (auto simp: ct_in_state'_def cfault_rel_def is_cap_fault_def ct_not_ksQ + apply (auto simp: ct_in_state'_def cfault_rel_def is_cap_fault_def elim: pred_tcb'_weakenE st_tcb_ex_cap'' dest: st_tcb_at_idle_thread' rf_sr_ksCurThread) done @@ -195,16 +193,14 @@ lemma handleUserLevelFault_ccorres: apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (clarsimp, vcg) apply (clarsimp, rule conseqPre, vcg, clarsimp) apply clarsimp apply (intro impI conjI allI) - apply (simp add: ct_in_state'_def) - apply (erule pred_tcb'_weakenE) - apply simp - apply (clarsimp simp: ct_not_ksQ) - apply (clarsimp simp add: sch_act_simple_def split: scheduler_action.split) + apply (simp add: ct_in_state'_def) + apply (erule pred_tcb'_weakenE) + apply simp apply (rule active_ex_cap') apply (erule active_from_running') apply (erule invs_iflive') @@ -377,11 +373,10 @@ lemma handleSyscall_ccorres: apply wp[1] apply clarsimp apply wp - apply (rule_tac Q="\rv s. ct_in_state' simple' s \ sch_act_sane s \ - (\p. ksCurThread s \ set (ksReadyQueues s p))" + apply (rule_tac Q="\rv s. ct_in_state' simple' s \ sch_act_sane s" in hoare_post_imp) apply (simp add: ct_in_state'_def) - apply (wp handleReply_sane handleReply_ct_not_ksQ) + apply (wp handleReply_sane) \ \SysYield\ apply (clarsimp simp: syscall_from_H_def syscall_defs) apply (rule ccorres_cond_empty |rule ccorres_cond_univ)+ @@ -407,11 +402,11 @@ lemma handleSyscall_ccorres: apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg_throws) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) - apply (wp schedule_invs' schedule_sch_act_wf | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + apply (wp schedule_invs' schedule_sch_act_wf + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (simp | wpc | wp hoare_drop_imp handleReply_sane handleReply_nonz_cap_to_ct schedule_invs' - handleReply_ct_not_ksQ[simplified] | strengthen ct_active_not_idle'_strengthen invs_valid_objs_strengthen)+ apply (rule_tac Q="\rv. invs' and ct_active'" in hoare_post_imp, simp) apply (wp hy_invs') @@ -429,7 +424,7 @@ lemma handleSyscall_ccorres: apply (frule active_ex_cap') apply (clarsimp simp: invs'_def valid_state'_def) apply (clarsimp simp: simple_sane_strg ct_in_state'_def st_tcb_at'_def obj_at'_def - isReply_def ct_not_ksQ irqInvalid_def Kernel_C.irqInvalid_def) + isReply_def irqInvalid_def Kernel_C.irqInvalid_def) apply (auto simp: syscall_from_H_def Kernel_C.SysSend_def split: option.split_asm) done @@ -516,7 +511,7 @@ lemma handleHypervisorEvent_ccorres: apply simp apply assumption apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply clarsimp+ done @@ -648,7 +643,7 @@ lemma threadSet_all_invs_triv': apply (wp thread_set_invs_trivial thread_set_ct_running thread_set_not_state_valid_sched threadSet_invs_trivial threadSet_ct_running' hoare_weak_lift_imp thread_set_ct_in_state - | simp add: tcb_cap_cases_def tcb_arch_ref_def + | simp add: tcb_cap_cases_def tcb_arch_ref_def exst_same_def | rule threadSet_ct_in_state' | wp (once) hoare_vcg_disj_lift)+ apply clarsimp @@ -869,17 +864,22 @@ lemma dmo_domain_user_mem'[wp]: done lemma do_user_op_corres_C: - "corres_underlying rf_sr False False (=) (invs' and ex_abs einvs) \ - (doUserOp f tc) (doUserOp_C f tc)" + "corres_underlying rf_sr False False (=) + (invs' and ksReadyQueues_asrt and ex_abs einvs) \ + (doUserOp f tc) (doUserOp_C f tc)" apply (simp only: doUserOp_C_def doUserOp_def split_def) apply (rule corres_guard_imp) apply (rule_tac P=\ and P'=\ and r'="(=)" in corres_split) apply (clarsimp simp: simpler_gets_def getCurThread_def corres_underlying_def rf_sr_def cstate_relation_def Let_def) - apply (rule_tac P=valid_state' and P'=\ and r'="(=)" in corres_split) + apply (rule_tac P="valid_state' and ksReadyQueues_asrt" + and P'=\ and r'="(=)" + in corres_split) apply (clarsimp simp: cstate_to_A_def absKState_def rf_sr_def cstate_to_H_correct ptable_lift_def) - apply (rule_tac P=valid_state' and P'=\ and r'="(=)" in corres_split) + apply (rule_tac P="valid_state' and ksReadyQueues_asrt" + and P'=\ and r'="(=)" + in corres_split) apply (clarsimp simp: cstate_to_A_def absKState_def rf_sr_def cstate_to_H_correct ptable_rights_def) apply (rule_tac P=pspace_distinct' and P'=\ and r'="(=)" @@ -977,6 +977,9 @@ lemma refinement2_both: apply (subst cstate_to_H_correct) apply (fastforce simp: full_invs'_def invs'_def) apply (clarsimp simp: rf_sr_def) + apply (clarsimp simp: lift_state_relation_def full_invs_def) + apply (rule ksReadyQueues_asrt_cross) + apply (erule state_relation_ready_queues_relation) apply (simp add:absKState_def observable_memory_def absExst_def) apply (rule MachineTypes.machine_state.equality,simp_all)[1] apply (rule ext) @@ -1003,13 +1006,35 @@ lemma refinement2_both: apply (clarsimp simp add: do_user_op_C_def do_user_op_H_def monad_to_transition_def) apply (rule rev_mp, rule_tac f="uop" and tc=af in do_user_op_corres_C) apply (clarsimp simp: corres_underlying_def invs_def ex_abs_def) - apply (fastforce simp: full_invs'_def ex_abs_def) + apply (drule bspec) + apply fastforce + apply clarsimp + apply (elim impE) + apply (clarsimp simp: full_invs'_def ex_abs_def) + apply (intro conjI) + apply (rule ksReadyQueues_asrt_cross) + apply (erule state_relation_ready_queues_relation) + apply (clarsimp simp: lift_state_relation_def full_invs_def) + apply (frule state_relation_ready_queues_relation) + apply (fastforce simp: ready_queues_relation_def Let_def tcbQueueEmpty_def) + apply fastforce apply (erule_tac P="a \ b \ c \ (\x. e x)" for a b c d e in disjE) apply (clarsimp simp add: do_user_op_C_def do_user_op_H_def monad_to_transition_def) apply (rule rev_mp, rule_tac f="uop" and tc=af in do_user_op_corres_C) apply (clarsimp simp: corres_underlying_def invs_def ex_abs_def) - apply (fastforce simp: full_invs'_def ex_abs_def) + apply (drule bspec) + apply fastforce + apply clarsimp + apply (elim impE) + apply (clarsimp simp: full_invs'_def ex_abs_def) + apply (intro conjI) + apply (rule ksReadyQueues_asrt_cross) + apply (erule state_relation_ready_queues_relation) + apply (clarsimp simp: lift_state_relation_def full_invs_def) + apply (frule state_relation_ready_queues_relation) + apply (fastforce simp: ready_queues_relation_def Let_def tcbQueueEmpty_def) + apply fastforce apply (clarsimp simp: check_active_irq_C_def check_active_irq_H_def) apply (rule rev_mp, rule check_active_irq_corres_C) diff --git a/proof/crefine/RISCV64/Retype_C.thy b/proof/crefine/RISCV64/Retype_C.thy index 9a2bc7f66f..c5001d8e53 100644 --- a/proof/crefine/RISCV64/Retype_C.thy +++ b/proof/crefine/RISCV64/Retype_C.thy @@ -2950,7 +2950,6 @@ lemma cnc_tcb_helper: assumes rfsr: "(\\ksPSpace := ks\, x) \ rf_sr" assumes al: "is_aligned (ctcb_ptr_to_tcb_ptr p) (objBitsKO kotcb)" assumes ptr0: "ctcb_ptr_to_tcb_ptr p \ 0" - assumes vq: "valid_queues \" assumes pal: "pspace_aligned' (\\ksPSpace := ks\)" assumes pno: "pspace_no_overlap' (ctcb_ptr_to_tcb_ptr p) (objBitsKO kotcb) (\\ksPSpace := ks\)" assumes pds: "pspace_distinct' (\\ksPSpace := ks\)" @@ -3308,20 +3307,20 @@ proof - unfolding ctcb_relation_def makeObject_tcb heap_updates_defs initContext_registers_def apply (simp add: fbtcb minBound_word) apply (intro conjI) - apply (simp add: cthread_state_relation_def thread_state_lift_def - eval_nat_numeral ThreadState_defs) - apply (clarsimp simp: ccontext_relation_def newContext_def2 carch_tcb_relation_def - newArchTCB_def cregs_relation_def atcbContextGet_def) - apply (case_tac r; simp add: C_register_defs index_foldr_update - atcbContext_def newArchTCB_def newContext_def - initContext_def) - apply (clarsimp) - apply (simp add: thread_state_lift_def index_foldr_update atcbContextGet_def) - apply (simp add: Kernel_Config.timeSlice_def) - apply (simp add: cfault_rel_def seL4_Fault_lift_def seL4_Fault_get_tag_def Let_def - lookup_fault_lift_def lookup_fault_get_tag_def lookup_fault_invalid_root_def - index_foldr_update seL4_Fault_NullFault_def option_to_ptr_def option_to_0_def - split: if_split)+ + apply (simp add: cthread_state_relation_def thread_state_lift_def + eval_nat_numeral ThreadState_defs) + apply (clarsimp simp: ccontext_relation_def newContext_def2 carch_tcb_relation_def + newArchTCB_def cregs_relation_def atcbContextGet_def) + apply (case_tac r; simp add: C_register_defs index_foldr_update + atcbContext_def newArchTCB_def newContext_def + initContext_def) + apply (simp add: thread_state_lift_def index_foldr_update atcbContextGet_def) + apply (simp add: Kernel_Config.timeSlice_def) + apply (simp add: cfault_rel_def seL4_Fault_lift_def seL4_Fault_get_tag_def Let_def + lookup_fault_lift_def lookup_fault_get_tag_def lookup_fault_invalid_root_def + index_foldr_update seL4_Fault_NullFault_def option_to_ptr_def option_to_0_def + split: if_split)+ + apply (simp add: option_to_ctcb_ptr_def) done have pks: "ks (ctcb_ptr_to_tcb_ptr p) = None" @@ -3372,15 +3371,6 @@ proof - apply (fastforce simp: dom_def) done - hence kstcb: "\qdom prio. ctcb_ptr_to_tcb_ptr p \ set (ksReadyQueues \ (qdom, prio))" using vq - apply (clarsimp simp add: valid_queues_def valid_queues_no_bitmap_def) - apply (drule_tac x = qdom in spec) - apply (drule_tac x = prio in spec) - apply clarsimp - apply (drule (1) bspec) - apply (simp add: obj_at'_def) - done - have ball_subsetE: "\P S R. \ \x \ S. P x; R \ S \ \ \x \ R. P x" by blast @@ -3504,7 +3494,7 @@ proof - apply (simp add: cl_cte [simplified] cl_tcb [simplified] cl_rest [simplified] tag_disj_via_td_name) apply (clarsimp simp: cready_queues_relation_def Let_def htd_safe[simplified] kernel_data_refs_domain_eq_rotate) - apply (simp add: heap_updates_def kstcb tcb_queue_update_other' hrs_htd_update + apply (simp add: heap_updates_def tcb_queue_update_other' hrs_htd_update ptr_retyp_to_array[simplified] irq[simplified]) done qed @@ -4494,7 +4484,8 @@ lemma Arch_initContext_spec': lemma ccorres_placeNewObject_tcb: "ccorresG rf_sr \ dc xfdc - (pspace_aligned' and pspace_distinct' and pspace_no_overlap' regionBase tcbBlockSizeBits and valid_queues and (\s. sym_refs (state_refs_of' s)) + (pspace_aligned' and pspace_distinct' and pspace_no_overlap' regionBase tcbBlockSizeBits + and (\s. sym_refs (state_refs_of' s)) and (\s. 2 ^ tcbBlockSizeBits \ gsMaxObjectSize s) and ret_zero regionBase (2 ^ tcbBlockSizeBits) and K (regionBase \ 0 \ range_cover regionBase tcbBlockSizeBits tcbBlockSizeBits 1 @@ -4765,7 +4756,7 @@ qed lemma placeNewObject_user_data: "ccorresG rf_sr \ dc xfdc (pspace_aligned' and pspace_distinct' and pspace_no_overlap' regionBase (pageBits+us) - and valid_queues and valid_machine_state' + and valid_machine_state' and ret_zero regionBase (2 ^ (pageBits+us)) and (\s. sym_refs (state_refs_of' s)) and (\s. 2^(pageBits + us) \ gsMaxObjectSize s) @@ -4904,7 +4895,7 @@ lemma placeNewObject_user_data_device: "ccorresG rf_sr \ dc xfdc (pspace_aligned' and pspace_distinct' and ret_zero regionBase (2 ^ (pageBits + us)) - and pspace_no_overlap' regionBase (pageBits+us) and valid_queues + and pspace_no_overlap' regionBase (pageBits+us) and (\s. sym_refs (state_refs_of' s)) and (\s. 2^(pageBits + us) \ gsMaxObjectSize s) and K (regionBase \ 0 \ range_cover regionBase (pageBits + us) (pageBits+us) (Suc 0) @@ -5110,7 +5101,7 @@ proof - apply clarify apply (intro conjI) apply (clarsimp simp: invs_pspace_aligned' invs_pspace_distinct' invs_valid_global' - APIType_capBits_def invs_queues invs_valid_objs' + APIType_capBits_def invs_valid_objs' invs_urz pageBits_def) apply clarsimp apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def @@ -5191,15 +5182,11 @@ lemma threadSet_domain_ccorres [corres]: apply (simp add: map_to_ctes_upd_tcb_no_ctes map_to_tcbs_upd tcb_cte_cases_def cteSizeBits_def) apply (simp add: cep_relations_drop_fun_upd cvariable_relation_upd_const ko_at_projectKO_opt) - apply (rule conjI) - apply (drule ko_at_projectKO_opt) - apply (erule (2) cmap_relation_upd_relI) - subgoal by (simp add: ctcb_relation_def) - apply assumption - apply simp - apply (erule cready_queues_relation_not_queue_ptrs) - apply (rule ext, simp split: if_split) - apply (rule ext, simp split: if_split) + apply (drule ko_at_projectKO_opt) + apply (erule (2) cmap_relation_upd_relI) + subgoal by (simp add: ctcb_relation_def) + apply assumption + apply simp done lemma createObject_ccorres: @@ -5326,7 +5313,6 @@ proof - createObject_c_preconds_def) apply (frule invs_pspace_aligned') apply (frule invs_pspace_distinct') - apply (frule invs_queues) apply (frule invs_sym') apply (simp add: getObjectSize_def objBits_simps word_bits_conv apiGetObjectSize_def @@ -5371,7 +5357,6 @@ proof - apply (clarsimp simp: createObject_hs_preconds_def isFrameType_def) apply (frule invs_pspace_aligned') apply (frule invs_pspace_distinct') - apply (frule invs_queues) apply (frule invs_sym') apply (auto simp: getObjectSize_def objBits_simps apiGetObjectSize_def epSizeBits_def word_bits_conv @@ -5409,7 +5394,6 @@ proof - apply (clarsimp simp: createObject_hs_preconds_def isFrameType_def) apply (frule invs_pspace_aligned') apply (frule invs_pspace_distinct') - apply (frule invs_queues) apply (frule invs_sym') apply (auto simp: getObjectSize_def objBits_simps apiGetObjectSize_def @@ -5450,7 +5434,6 @@ proof - apply (clarsimp simp: createObject_hs_preconds_def isFrameType_def) apply (frule invs_pspace_aligned') apply (frule invs_pspace_distinct') - apply (frule invs_queues) apply (frule invs_sym') apply (frule(1) ghost_assertion_size_logic_no_unat) apply (clarsimp simp: getObjectSize_def objBits_simps diff --git a/proof/crefine/RISCV64/SR_lemmas_C.thy b/proof/crefine/RISCV64/SR_lemmas_C.thy index 7f1d299552..e5adf595ef 100644 --- a/proof/crefine/RISCV64/SR_lemmas_C.thy +++ b/proof/crefine/RISCV64/SR_lemmas_C.thy @@ -304,11 +304,15 @@ lemma cmdbnode_relation_mdb_node_to_H [simp]: unfolding cmdbnode_relation_def mdb_node_to_H_def mdb_node_lift_def cte_lift_def by (fastforce split: option.splits) -definition - tcb_no_ctes_proj :: "tcb \ Structures_H.thread_state \ machine_word \ machine_word \ arch_tcb \ bool \ word8 \ word8 \ word8 \ nat \ fault option \ machine_word option" +definition tcb_no_ctes_proj :: + "tcb \ Structures_H.thread_state \ machine_word \ machine_word \ arch_tcb \ bool \ word8 + \ word8 \ word8 \ nat \ fault option \ machine_word option + \ machine_word option \ machine_word option" where - "tcb_no_ctes_proj t \ (tcbState t, tcbFaultHandler t, tcbIPCBuffer t, tcbArch t, tcbQueued t, - tcbMCP t, tcbPriority t, tcbDomain t, tcbTimeSlice t, tcbFault t, tcbBoundNotification t)" + "tcb_no_ctes_proj t \ + (tcbState t, tcbFaultHandler t, tcbIPCBuffer t, tcbArch t, tcbQueued t, + tcbMCP t, tcbPriority t, tcbDomain t, tcbTimeSlice t, tcbFault t, tcbBoundNotification t, + tcbSchedNext t, tcbSchedPrev t)" lemma tcb_cte_cases_proj_eq [simp]: "tcb_cte_cases p = Some (getF, setF) \ @@ -1411,9 +1415,9 @@ lemma cmap_relation_cong: apply (erule imageI) done -lemma ctcb_relation_null_queue_ptrs: +lemma ctcb_relation_null_ep_ptrs: assumes rel: "cmap_relation mp mp' tcb_ptr_to_ctcb_ptr ctcb_relation" - and same: "map_option tcb_null_queue_ptrs \ mp'' = map_option tcb_null_queue_ptrs \ mp'" + and same: "map_option tcb_null_ep_ptrs \ mp'' = map_option tcb_null_ep_ptrs \ mp'" shows "cmap_relation mp mp'' tcb_ptr_to_ctcb_ptr ctcb_relation" using rel apply (rule iffD1 [OF cmap_relation_cong, OF _ map_option_eq_dom_eq, rotated -1]) @@ -1421,7 +1425,7 @@ lemma ctcb_relation_null_queue_ptrs: apply (rule same [symmetric]) apply (drule compD [OF same]) apply (case_tac b, case_tac b') - apply (simp add: ctcb_relation_def tcb_null_queue_ptrs_def) + apply (simp add: ctcb_relation_def tcb_null_ep_ptrs_def) done lemma map_to_ctes_upd_tcb_no_ctes: @@ -2034,6 +2038,14 @@ lemma capTCBPtr_eq: apply clarsimp done +lemma rf_sr_ctcb_queue_relation: + "\ (s, s') \ rf_sr; d \ maxDomain; p \ maxPriority \ + \ ctcb_queue_relation (ksReadyQueues s (d, p)) + (index (ksReadyQueues_' (globals s')) (cready_queues_index_to_C d p))" + unfolding rf_sr_def cstate_relation_def cready_queues_relation_def + apply (clarsimp simp: Let_def seL4_MinPrio_def minDom_def maxDom_to_H maxPrio_to_H) + done + lemma rf_sr_sched_action_relation: "(s, s') \ rf_sr \ cscheduler_action_relation (ksSchedulerAction s) (ksSchedulerAction_' (globals s'))" @@ -2135,5 +2147,11 @@ lemma physBase_spec: apply (simp add: Kernel_Config.physBase_def) done +lemma rf_sr_obj_update_helper: + "(s, s'\ globals := globals s' \ t_hrs_' := t_hrs_' (globals (undefined + \ globals := (undefined \ t_hrs_' := f (globals s') (t_hrs_' (globals s')) \)\))\\) \ rf_sr + \ (s, globals_update (\v. t_hrs_'_update (f v) v) s') \ rf_sr" + by (simp cong: StateSpace.state.fold_congs globals.fold_congs) + end end diff --git a/proof/crefine/RISCV64/Schedule_C.thy b/proof/crefine/RISCV64/Schedule_C.thy index fb02afc6d0..5d97c3c95b 100644 --- a/proof/crefine/RISCV64/Schedule_C.thy +++ b/proof/crefine/RISCV64/Schedule_C.thy @@ -7,7 +7,7 @@ *) theory Schedule_C -imports Tcb_C +imports Tcb_C Detype_C begin (*FIXME: arch_split: move up?*) @@ -38,15 +38,17 @@ lemma switchToIdleThread_ccorres: "ccorres dc xfdc invs_no_cicd' UNIV hs switchToIdleThread (Call switchToIdleThread_'proc)" apply (cinit) + apply (rule ccorres_stateAssert) apply (rule ccorres_symb_exec_l) apply (ctac (no_vcg) add: Arch_switchToIdleThread_ccorres) apply (simp add: setCurThread_def) + apply (rule ccorres_stateAssert) apply (rule_tac P="\s. thread = ksIdleThread s" and P'=UNIV in ccorres_from_vcg) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: simpler_modify_def) apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def carch_state_relation_def cmachine_state_relation_def) - apply (wpsimp simp: RISCV64_H.switchToIdleThread_def)+ + apply (wpsimp simp: RISCV64_H.switchToIdleThread_def wp: hoare_drop_imps)+ done lemma Arch_switchToThread_ccorres: @@ -62,8 +64,25 @@ lemma Arch_switchToThread_ccorres: apply clarsimp done +lemma invs_no_cicd'_pspace_aligned': + "all_invs_but_ct_idle_or_in_cur_domain' s \ pspace_aligned' s" + by (simp add: all_invs_but_ct_idle_or_in_cur_domain'_def valid_pspace'_def) +lemma invs_no_cicd'_pspace_distinct': + "all_invs_but_ct_idle_or_in_cur_domain' s \ pspace_distinct' s" + by (simp add: all_invs_but_ct_idle_or_in_cur_domain'_def valid_pspace'_def) +lemma threadGet_exs_valid[wp]: + "tcb_at' t s \ \(=) s\ threadGet f t \\\r. (=) s\" + unfolding threadGet_def liftM_def + apply (wpsimp wp: exs_getObject) + apply (fastforce simp: obj_at'_def objBits_simps')+ + done + +lemma isRunnable_exs_valid[wp]: + "tcb_at' t s \ \(=) s\ isRunnable t \\\r. (=) s\" + unfolding isRunnable_def getThreadState_def + by (wpsimp wp: exs_getObject) (* FIXME: move *) lemma switchToThread_ccorres: @@ -73,23 +92,28 @@ lemma switchToThread_ccorres: hs (switchToThread t) (Call switchToThread_'proc)" - apply (cinit lift: thread_') + apply (clarsimp simp: switchToThread_def) + apply (rule ccorres_symb_exec_l'[OF _ _ isRunnable_sp]; (solves wpsimp)?) + apply (rule ccorres_symb_exec_l'[OF _ _ assert_sp]; (solves wpsimp)?) + apply (rule ccorres_stateAssert_fwd)+ + apply (cinit' lift: thread_') apply (ctac (no_vcg) add: Arch_switchToThread_ccorres) apply (ctac (no_vcg) add: tcbSchedDequeue_ccorres) + apply (simp add: setCurThread_def) + apply (rule ccorres_stateAssert) apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg) apply clarsimp apply (rule conseqPre, vcg) - apply (clarsimp simp: setCurThread_def simpler_modify_def) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def) - apply wp+ - apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def) + apply (clarsimp simp: setCurThread_def simpler_modify_def rf_sr_def cstate_relation_def + Let_def carch_state_relation_def cmachine_state_relation_def) + apply (wpsimp wp: Arch_switchToThread_invs_no_cicd' hoare_drop_imps + | strengthen invs_no_cicd'_pspace_aligned' invs_no_cicd'_pspace_distinct')+ done lemma activateThread_ccorres: "ccorres dc xfdc (ct_in_state' activatable' and (\s. sch_act_wf (ksSchedulerAction s) s) - and valid_queues and valid_objs') + and valid_objs' and pspace_aligned' and pspace_distinct') UNIV [] activateThread (Call activateThread_'proc)" @@ -181,13 +205,42 @@ lemma switchToThread_ccorres': lemmas word_log2_max_word_word_size = word_log2_max[where 'a=machine_word_len, simplified word_size, simplified] +lemma ccorres_pre_getQueue: + assumes cc: "\queue. ccorres r xf (P queue) (P' queue) hs (f queue) c" + shows "ccorres r xf (\s. P (ksReadyQueues s (d, p)) s \ d \ maxDomain \ p \ maxPriority) + {s'. \queue. (let cqueue = index (ksReadyQueues_' (globals s')) + (cready_queues_index_to_C d p) in + ctcb_queue_relation queue cqueue) \ s' \ P' queue} + hs (getQueue d p >>= (\queue. f queue)) c" + apply (rule ccorres_guard_imp2) + apply (rule ccorres_symb_exec_l2) + defer + defer + apply (rule gq_sp) + defer + apply (rule ccorres_guard_imp) + apply (rule cc) + apply clarsimp + apply assumption + apply assumption + apply (clarsimp simp: getQueue_def gets_exs_valid) + apply clarsimp + apply (drule spec, erule mp) + apply (erule rf_sr_ctcb_queue_relation) + apply (simp add: maxDom_to_H maxPrio_to_H)+ + done + lemma chooseThread_ccorres: - "ccorres dc xfdc all_invs_but_ct_idle_or_in_cur_domain' UNIV [] chooseThread (Call chooseThread_'proc)" + "ccorres dc xfdc all_invs_but_ct_idle_or_in_cur_domain' UNIV [] + chooseThread (Call chooseThread_'proc)" proof - note prio_and_dom_limit_helpers [simp] note ksReadyQueuesL2Bitmap_nonzeroI [simp] note Collect_const_mem [simp] + + note prio_and_dom_limit_helpers[simp] word_sle_def[simp] maxDom_to_H[simp] maxPrio_to_H[simp] + note invert_prioToL1Index_c_simp[simp] (* when numDomains = 1, array bounds checks would become _ = 0 rather than _ < 1, changing the shape of the proof compared to when numDomains > 1 *) include no_less_1_simps @@ -196,9 +249,22 @@ proof - "\s. invs_no_cicd' s \ ksCurDomain s \ maxDomain" by (simp add: invs_no_cicd'_def) + have invs_no_cicd'_valid_bitmaps: + "\s. invs_no_cicd' s \ valid_bitmaps s" + by (simp add: invs_no_cicd'_def) + + have invs_no_cicd'_pspace_aligned': + "\s. invs_no_cicd' s \ pspace_aligned' s" + by (simp add: invs_no_cicd'_def valid_pspace'_def) + + have invs_no_cicd'_pspace_distinct': + "\s. invs_no_cicd' s \ pspace_distinct' s" + by (simp add: invs_no_cicd'_def valid_pspace'_def) + show ?thesis supply if_split[split del] apply (cinit) + apply (rule ccorres_stateAssert)+ apply (simp add: numDomains_sge_1_simp) apply (rule_tac xf'=dom_' and r'="\rv rv'. rv' = ucast rv" in ccorres_split_nothrow_novcg) apply (rule ccorres_from_vcg[where P=\ and P'=UNIV]) @@ -231,7 +297,7 @@ proof - apply (rule_tac P="curdom \ maxDomain" in ccorres_cross_over_guard_no_st) apply (rule_tac P="prio \ maxPriority" in ccorres_cross_over_guard_no_st) apply (rule ccorres_pre_getQueue) - apply (rule_tac P="queue \ []" in ccorres_cross_over_guard_no_st) + apply (rule_tac P="\ tcbQueueEmpty queue" in ccorres_cross_over_guard_no_st) apply (rule ccorres_symb_exec_l) apply (rule ccorres_assert) apply (rule ccorres_symb_exec_r) @@ -246,37 +312,40 @@ proof - apply (rule conseqPre, vcg) apply (rule Collect_mono) apply clarsimp - apply (strengthen queue_in_range) apply assumption apply clarsimp apply (rule conseqPre, vcg) apply clarsimp apply (wp isRunnable_wp)+ apply (clarsimp simp: Let_def guard_is_UNIV_def) - apply (drule invs_no_cicd'_queues) - apply (case_tac queue, simp) - apply (clarsimp simp: tcb_queue_relation'_def cready_queues_index_to_C_def numPriorities_def) - apply (clarsimp simp add: maxDom_to_H maxPrio_to_H - queue_in_range[where qdom=0, simplified, simplified maxPrio_to_H]) - apply (clarsimp simp: le_maxDomain_eq_less_numDomains unat_trans_ucast_helper ) + apply (rule conjI) + apply (clarsimp simp: le_maxDomain_eq_less_numDomains unat_trans_ucast_helper) + apply (intro conjI impI) + apply (clarsimp simp: cready_queues_index_to_C_def numPriorities_def ctcb_queue_relation_def + tcbQueueEmpty_def option_to_ctcb_ptr_def) + apply (frule_tac qdom=curdom and prio=rv in cready_queues_index_to_C_in_range') + apply fastforce + apply (clarsimp simp: num_tcb_queues_val word_less_nat_alt cready_queues_index_to_C_def2) apply wpsimp apply (clarsimp simp: guard_is_UNIV_def le_maxDomain_eq_less_numDomains word_less_nat_alt numDomains_less_numeric_explicit) - apply (frule invs_no_cicd'_queues) + apply clarsimp apply (frule invs_no_cicd'_max_CurDomain) - apply (frule invs_no_cicd'_queues) - apply (clarsimp simp: valid_queues_def lookupBitmapPriority_le_maxPriority) + apply (frule invs_no_cicd'_pspace_aligned') + apply (frule invs_no_cicd'_pspace_distinct') + apply (frule invs_no_cicd'_valid_bitmaps) + apply (frule valid_bitmaps_bitmapQ_no_L1_orphans) + apply (frule valid_bitmaps_valid_bitmapQ) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def cong: conj_cong) apply (intro conjI impI) - apply (fastforce dest: bitmapQ_from_bitmap_lookup simp: valid_bitmapQ_bitmapQ_simp) - apply (fastforce dest: lookupBitmapPriority_obj_at' - simp: pred_conj_def obj_at'_def st_tcb_at'_def) - apply (fastforce dest: bitmapQ_from_bitmap_lookup simp: valid_bitmapQ_bitmapQ_simp) - apply (clarsimp simp: pred_conj_def obj_at'_def st_tcb_at'_def) - apply (clarsimp simp: not_less le_maxDomain_eq_less_numDomains) - apply (prop_tac "ksCurDomain s = 0") - using unsigned_eq_0_iff apply force - apply (cut_tac s=s in lookupBitmapPriority_obj_at'; simp?) - apply (clarsimp simp: pred_conj_def obj_at'_def st_tcb_at'_def) + apply (fastforce intro: lookupBitmapPriority_le_maxPriority) + apply (fastforce dest!: bitmapQ_from_bitmap_lookup valid_bitmapQ_bitmapQ_simp) + apply (fastforce dest!: lookupBitmapPriority_obj_at' + simp: ready_queue_relation_def ksReadyQueues_asrt_def st_tcb_at'_def obj_at'_def) + apply (fastforce dest: lookupBitmapPriority_le_maxPriority) + apply (fastforce dest!: bitmapQ_from_bitmap_lookup valid_bitmapQ_bitmapQ_simp) + apply (fastforce dest!: lookupBitmapPriority_obj_at' + simp: ready_queue_relation_def ksReadyQueues_asrt_def st_tcb_at'_def obj_at'_def) done qed @@ -600,7 +669,7 @@ lemma schedule_ccorres: apply (wp (once) hoare_drop_imps) apply wp apply (strengthen strenghten_False_imp[where P="a = ResumeCurrentThread" for a]) - apply (clarsimp simp: conj_ac invs_queues invs_valid_objs' cong: conj_cong) + apply (clarsimp simp: conj_ac invs_valid_objs' cong: conj_cong) apply wp apply (clarsimp, vcg exspec=tcbSchedEnqueue_modifies) apply (clarsimp, vcg exspec=tcbSchedEnqueue_modifies) @@ -620,9 +689,11 @@ lemma schedule_ccorres: apply wp apply vcg - apply (clarsimp simp: tcb_at_invs' rf_sr_ksCurThread if_apply_def2 invs_queues invs_valid_objs') + apply (clarsimp simp: tcb_at_invs' rf_sr_ksCurThread if_apply_def2 invs_valid_objs') apply (frule invs_sch_act_wf') apply (frule tcb_at_invs') + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') apply (rule conjI) apply (clarsimp dest!: rf_sr_cscheduler_relation simp: cscheduler_action_relation_def) apply (rule conjI; clarsimp) @@ -672,11 +743,7 @@ lemma threadSet_timeSlice_ccorres [corres]: apply (simp add: cep_relations_drop_fun_upd cvariable_relation_upd_const ko_at_projectKO_opt) - apply (rule conjI) defer - apply (erule cready_queues_relation_not_queue_ptrs) - apply (rule ext, simp split: if_split) - apply (rule ext, simp split: if_split) apply (drule ko_at_projectKO_opt) apply (erule (2) cmap_relation_upd_relI) apply (simp add: ctcb_relation_def) @@ -720,7 +787,7 @@ lemma timerTick_ccorres: apply simp apply (ctac (no_vcg) add: tcbSchedAppend_ccorres) apply (ctac add: rescheduleRequired_ccorres) - apply (wp weak_sch_act_wf_lift_linear threadSet_valid_queues + apply (wp weak_sch_act_wf_lift_linear threadSet_pred_tcb_at_state tcbSchedAppend_valid_objs' threadSet_valid_objs' threadSet_tcbDomain_triv | clarsimp simp: st_tcb_at'_def o_def split: if_splits)+ apply (vcg exspec=tcbSchedDequeue_modifies) @@ -771,8 +838,8 @@ lemma timerTick_ccorres: apply (rule conjI, clarsimp simp: invs'_def valid_state'_def valid_tcb'_def)+ apply (auto simp: obj_at'_def inQ_def weak_sch_act_wf_def st_tcb_at'_def valid_pspace'_def ct_idle_or_in_cur_domain'_def valid_tcb'_def valid_idle'_def projectKOs)[1] - apply (auto simp: invs'_def valid_state'_def valid_tcb'_def tcb_cte_cases_def - cteSizeBits_def)[1] + apply (auto simp: invs'_def valid_state'_def valid_tcb'_def tcb_cte_cases_def cur_tcb'_def + obj_at'_def cteSizeBits_def)[1] apply (frule invs_cur') apply (clarsimp simp: cur_tcb'_def) diff --git a/proof/crefine/RISCV64/StateRelation_C.thy b/proof/crefine/RISCV64/StateRelation_C.thy index d5dc162b40..8f1cc0da32 100644 --- a/proof/crefine/RISCV64/StateRelation_C.thy +++ b/proof/crefine/RISCV64/StateRelation_C.thy @@ -17,8 +17,7 @@ definition definition "array_relation r n a c \ \i \ n. r (a i) (index c (unat i))" -(* used for bound ntfn/tcb *) -definition +definition option_to_ctcb_ptr :: "machine_word option \ tcb_C ptr" where "option_to_ctcb_ptr x \ case x of None \ NULL | Some t \ tcb_ptr_to_ctcb_ptr t" @@ -362,7 +361,9 @@ where \ tcbTimeSlice atcb = unat (tcbTimeSlice_C ctcb) \ cfault_rel (tcbFault atcb) (seL4_Fault_lift (tcbFault_C ctcb)) (lookup_fault_lift (tcbLookupFailure_C ctcb)) - \ option_to_ptr (tcbBoundNotification atcb) = tcbBoundNotification_C ctcb" + \ option_to_ptr (tcbBoundNotification atcb) = tcbBoundNotification_C ctcb + \ option_to_ctcb_ptr (tcbSchedPrev atcb) = tcbSchedPrev_C ctcb + \ option_to_ctcb_ptr (tcbSchedNext atcb) = tcbSchedNext_C ctcb" abbreviation "ep_queue_relation' \ tcb_queue_relation' tcbEPNext_C tcbEPPrev_C" @@ -545,17 +546,17 @@ definition where "cready_queues_index_to_C qdom prio \ (unat qdom) * numPriorities + (unat prio)" -definition cready_queues_relation :: - "tcb_C typ_heap \ (tcb_queue_C[num_tcb_queues]) \ (domain \ priority \ ready_queue) \ bool" -where - "cready_queues_relation h_tcb queues aqueues \ - \qdom prio. ((qdom \ ucast minDom \ qdom \ ucast maxDom \ - prio \ ucast minPrio \ prio \ ucast maxPrio) \ - (let cqueue = index queues (cready_queues_index_to_C qdom prio) in - sched_queue_relation' h_tcb (aqueues (qdom, prio)) (head_C cqueue) (end_C cqueue))) - \ (\ (qdom \ ucast minDom \ qdom \ ucast maxDom \ - prio \ ucast minPrio \ prio \ ucast maxPrio) \ aqueues (qdom, prio) = [])" +definition ctcb_queue_relation :: "tcb_queue \ tcb_queue_C \ bool" where + "ctcb_queue_relation aqueue cqueue \ + head_C cqueue = option_to_ctcb_ptr (tcbQueueHead aqueue) + \ end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd aqueue)" +definition cready_queues_relation :: + "(domain \ priority \ ready_queue) \ (tcb_queue_C[num_tcb_queues]) \ bool" + where + "cready_queues_relation aqueues cqueues \ + \d p. d \ maxDomain \ p \ maxPriority + \ ctcb_queue_relation (aqueues (d, p)) (index cqueues (cready_queues_index_to_C d p))" abbreviation "cte_array_relation astate cstate @@ -694,9 +695,7 @@ where "cstate_relation astate cstate \ let cheap = t_hrs_' cstate in cpspace_relation (ksPSpace astate) (underlying_memory (ksMachineState astate)) cheap \ - cready_queues_relation (clift cheap) - (ksReadyQueues_' cstate) - (ksReadyQueues astate) \ + cready_queues_relation (ksReadyQueues astate) (ksReadyQueues_' cstate) \ zero_ranges_are_zero (gsUntypedZeroRanges astate) cheap \ cbitmap_L1_relation (ksReadyQueuesL1Bitmap_' cstate) (ksReadyQueuesL1Bitmap astate) \ cbitmap_L2_relation (ksReadyQueuesL2Bitmap_' cstate) (ksReadyQueuesL2Bitmap astate) \ diff --git a/proof/crefine/RISCV64/SyscallArgs_C.thy b/proof/crefine/RISCV64/SyscallArgs_C.thy index 3345ec7b9f..fa51df1de3 100644 --- a/proof/crefine/RISCV64/SyscallArgs_C.thy +++ b/proof/crefine/RISCV64/SyscallArgs_C.thy @@ -49,9 +49,7 @@ lemma replyOnRestart_invs'[wp]: including no_pre apply (simp add: replyOnRestart_def) apply (wp setThreadState_nonqueued_state_update rfk_invs' hoare_weak_lift_imp) - apply (rule hoare_vcg_all_lift) - apply (wp setThreadState_nonqueued_state_update rfk_invs' hoare_vcg_all_lift rfk_ksQ) - apply (rule hoare_strengthen_post, rule gts_sp') + apply (rule hoare_strengthen_post, rule gts_sp') apply (clarsimp simp: pred_tcb_at') apply (auto elim!: pred_tcb'_weakenE st_tcb_ex_cap'' dest: st_tcb_at_idle_thread') diff --git a/proof/crefine/RISCV64/Syscall_C.thy b/proof/crefine/RISCV64/Syscall_C.thy index d6bdf0ecdd..95332904d1 100644 --- a/proof/crefine/RISCV64/Syscall_C.thy +++ b/proof/crefine/RISCV64/Syscall_C.thy @@ -50,8 +50,7 @@ lemma cap_cases_one_on_true_sum: lemma performInvocation_Endpoint_ccorres: "ccorres (K (K \) \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (invs' and st_tcb_at' simple' thread and ep_at' epptr - and sch_act_sane and (\s. thread = ksCurThread s - \ (\p. ksCurThread s \ set (ksReadyQueues s p)))) + and sch_act_sane and (\s. thread = ksCurThread s)) (UNIV \ {s. block_' s = from_bool blocking} \ {s. call_' s = from_bool do_call} \ {s. badge_' s = badge} @@ -123,7 +122,6 @@ lemma decodeInvocation_ccorres: and (\s. \v \ set extraCaps. ex_cte_cap_wp_to' isCNodeCap (snd v) s) and (\s. \v \ set extraCaps. s \' fst v \ cte_at' (snd v) s) and (\s. \v \ set extraCaps. \y \ zobj_refs' (fst v). ex_nonz_cap_to' y s) - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p)) and sysargs_rel args buffer) (UNIV \ {s. current_extra_caps_' (globals s) = extraCaps'} \ {s. call_' s = from_bool isCall} @@ -200,7 +198,7 @@ lemma decodeInvocation_ccorres: apply simp apply (rule hoare_use_eq[where f=ksCurThread]) apply (wp sts_invs_minor' sts_st_tcb_at'_cases - setThreadState_ct' hoare_vcg_all_lift sts_ksQ')+ + setThreadState_ct' hoare_vcg_all_lift)+ apply simp apply (vcg exspec=setThreadState_modifies) apply vcg @@ -508,7 +506,7 @@ lemma wordFromMessageInfo_spec: lemma handleDoubleFault_ccorres: "ccorres dc xfdc (invs' and tcb_at' tptr and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and - sch_act_not tptr and (\s. \p. tptr \ set (ksReadyQueues s p))) + sch_act_not tptr) (UNIV \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr tptr}) [] (handleDoubleFault tptr ex1 ex2) (Call handleDoubleFault_'proc)" @@ -573,8 +571,7 @@ lemma hrs_mem_update_use_hrs_mem: lemma sendFaultIPC_ccorres: "ccorres (cfault_rel2 \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') - (invs' and st_tcb_at' simple' tptr and sch_act_not tptr and - (\s. \p. tptr \ set (ksReadyQueues s p))) + (invs' and st_tcb_at' simple' tptr and sch_act_not tptr) (UNIV \ {s. (cfault_rel (Some fault) (seL4_Fault_lift(current_fault_' (globals s))) (lookup_fault_lift(current_lookup_fault_' (globals s))))} \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr tptr}) @@ -652,8 +649,8 @@ lemma sendFaultIPC_ccorres: apply (ctac (no_vcg) add: sendIPC_ccorres) apply (ctac (no_vcg) add: ccorres_return_CE [unfolded returnOk_def comp_def]) apply wp - apply (wp threadSet_pred_tcb_no_state threadSet_invs_trivial threadSet_typ_at_lifts - | simp)+ + apply (wpsimp wp: threadSet_invs_trivial) + apply (wpsimp wp: threadSet_pred_tcb_no_state threadSet_typ_at_lifts) apply (clarsimp simp: guard_is_UNIV_def) apply (subgoal_tac "capEPBadge epcap && mask 64 = capEPBadge epcap") @@ -686,8 +683,7 @@ lemma sendFaultIPC_ccorres: apply vcg apply (clarsimp simp: inQ_def) apply (rule_tac Q="\a b. invs' b \ st_tcb_at' simple' tptr b - \ sch_act_not tptr b \ valid_cap' a b - \ (\p. tptr \ set (ksReadyQueues b p))" + \ sch_act_not tptr b \ valid_cap' a b" and E="\ _. \" in hoare_post_impErr) apply (wp) @@ -702,8 +698,7 @@ lemma sendFaultIPC_ccorres: done lemma handleFault_ccorres: - "ccorres dc xfdc (invs' and st_tcb_at' simple' t and - sch_act_not t and (\s. \p. t \ set (ksReadyQueues s p))) + "ccorres dc xfdc (invs' and st_tcb_at' simple' t and sch_act_not t) (UNIV \ {s. (cfault_rel (Some flt) (seL4_Fault_lift(current_fault_' (globals s))) (lookup_fault_lift(current_lookup_fault_' (globals s))) )} \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr t}) @@ -767,9 +762,7 @@ lemma getMRs_length: lemma handleInvocation_ccorres: "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') - (invs' and - ct_active' and sch_act_simple and - (\s. \x. ksCurThread s \ set (ksReadyQueues s x))) + (invs' and ct_active' and sch_act_simple) (UNIV \ {s. isCall_' s = from_bool isCall} \ {s. isBlocking_' s = from_bool isBlocking}) [] (handleInvocation isCall isBlocking) (Call handleInvocation_'proc)" @@ -897,7 +890,7 @@ lemma handleInvocation_ccorres: apply (wp hoare_split_bind_case_sumE hoare_drop_imps setThreadState_nonqueued_state_update ct_in_state'_set setThreadState_st_tcb - hoare_vcg_all_lift sts_ksQ' + hoare_vcg_all_lift | wpc | wps)+ apply auto[1] apply clarsimp @@ -1156,9 +1149,6 @@ lemma ccorres_trim_redundant_throw_break: lemma invs_valid_objs_strengthen: "invs' s \ valid_objs' s" by fastforce -lemma ct_not_ksQ_strengthen: - "thread = ksCurThread s \ ksCurThread s \ set (ksReadyQueues s p) \ thread \ set (ksReadyQueues s p)" by fastforce - lemma option_to_ctcb_ptr_valid_ntfn: "valid_ntfn' ntfn s ==> (option_to_ctcb_ptr (ntfnBoundTCB ntfn) = NULL) = (ntfnBoundTCB ntfn = None)" apply (cases "ntfnBoundTCB ntfn", simp_all add: option_to_ctcb_ptr_def) @@ -1192,8 +1182,7 @@ lemma handleRecv_ccorres: notes rf_sr_upd_safe[simp del] shows "ccorres dc xfdc - (\s. invs' s \ st_tcb_at' simple' (ksCurThread s) s - \ sch_act_sane s \ (\p. ksCurThread s \ set (ksReadyQueues s p))) + (\s. invs' s \ st_tcb_at' simple' (ksCurThread s) s \ sch_act_sane s) {s. isBlocking_' s = from_bool isBlocking} [] (handleRecv isBlocking) @@ -1257,7 +1246,7 @@ lemma handleRecv_ccorres: apply (rule_tac P="\s. ksCurThread s = thread" in ccorres_cross_over_guard) apply (ctac add: receiveIPC_ccorres) - apply (wp deleteCallerCap_ksQ_ct' hoare_vcg_all_lift) + apply (wp hoare_vcg_all_lift) apply (rule conseqPost[where Q'=UNIV and A'="{}"], vcg exspec=deleteCallerCap_modifies) apply (clarsimp dest!: rf_sr_ksCurThread) apply simp @@ -1380,13 +1369,11 @@ lemma handleRecv_ccorres: apply clarsimp apply (rename_tac thread epCPtr) apply (rule_tac Q'="(\rv s. invs' s \ st_tcb_at' simple' thread s - \ sch_act_sane s \ (\p. thread \ set (ksReadyQueues s p)) \ thread = ksCurThread s + \ sch_act_sane s \ thread = ksCurThread s \ valid_cap' rv s)" in hoare_post_imp_R[rotated]) - apply (clarsimp simp: sch_act_sane_def) - apply (auto dest!: obj_at_valid_objs'[OF _ invs_valid_objs'] - simp: projectKOs valid_obj'_def, - auto simp: pred_tcb_at'_def obj_at'_def objBits_simps projectKOs ct_in_state'_def)[1] - apply wp + apply (intro conjI impI allI; clarsimp simp: sch_act_sane_def) + apply (fastforce dest: obj_at_valid_objs'[OF _ invs_valid_objs'] ko_at_valid_ntfn') + apply wp apply clarsimp apply (vcg exspec=isStopped_modifies exspec=lookupCap_modifies) @@ -1435,7 +1422,7 @@ lemma handleYield_ccorres: apply (ctac add: rescheduleRequired_ccorres) apply (wp weak_sch_act_wf_lift_linear tcbSchedAppend_valid_objs') apply (vcg exspec= tcbSchedAppend_modifies) - apply (wp weak_sch_act_wf_lift_linear tcbSchedDequeue_valid_queues) + apply (wp weak_sch_act_wf_lift_linear) apply (vcg exspec= tcbSchedDequeue_modifies) apply (clarsimp simp: tcb_at_invs' invs_valid_objs' valid_objs'_maxPriority valid_objs'_maxDomain) @@ -1582,8 +1569,7 @@ lemma ccorres_return_void_C_Seq: lemma ccorres_handleReservedIRQ: "ccorres dc xfdc - (invs' and (\s. irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s \ - (\p. ksCurThread s \ set (ksReadyQueues s p)))) + (invs' and (\s. irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s)) (UNIV \ {s. irq_' s = ucast irq}) hs (handleReservedIRQ irq) (Call handleReservedIRQ_'proc)" apply (cinit lift: irq_') @@ -1593,8 +1579,7 @@ lemma ccorres_handleReservedIRQ: lemma handleInterrupt_ccorres: "ccorres dc xfdc - (invs' and (\s. irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s \ - (\p. ksCurThread s \ set (ksReadyQueues s p)))) + (invs' and (\s. irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s)) (UNIV \ \\irq = ucast irq\) hs (handleInterrupt irq) diff --git a/proof/crefine/RISCV64/TcbQueue_C.thy b/proof/crefine/RISCV64/TcbQueue_C.thy index 55b52ed358..bca4869138 100644 --- a/proof/crefine/RISCV64/TcbQueue_C.thy +++ b/proof/crefine/RISCV64/TcbQueue_C.thy @@ -967,49 +967,6 @@ lemma tcb_queue_relation'_prev_sign: \ sign_extend canonical_bit (ptr_val (getPrev tcb)) = ptr_val (getPrev tcb)" by (rule tcb_queue_relation_prev_sign [OF tcb_queue_relation'_queue_rel]) - -lemma cready_queues_relation_null_queue_ptrs: - assumes rel: "cready_queues_relation mp cq aq" - and same: "option_map tcb_null_ep_ptrs \ mp' = option_map tcb_null_ep_ptrs \ mp" - shows "cready_queues_relation mp' cq aq" - using rel - apply (clarsimp simp: cready_queues_relation_def Let_def all_conj_distrib) - apply (drule spec, drule spec, drule mp, (erule conjI)+, assumption) - apply (clarsimp simp: tcb_queue_relation'_def) - apply (erule iffD2 [OF tcb_queue_relation_only_next_prev, rotated -1]) - apply (rule ext) - apply (case_tac "mp' x") - apply (frule compD [OF same]) - apply simp - apply (frule compD [OF same]) - apply (clarsimp simp: tcb_null_ep_ptrs_def) - apply (case_tac z, case_tac a) - apply simp - \ \clag\ - apply (rule ext) - apply (case_tac "mp' x") - apply (frule compD [OF same]) - apply simp - apply (frule compD [OF same]) - apply (clarsimp simp: tcb_null_ep_ptrs_def) - apply (case_tac z, case_tac a) - apply simp - done - -lemma cready_queues_relation_not_queue_ptrs: - assumes rel: "cready_queues_relation mp cq aq" - and same: "option_map tcbSchedNext_C \ mp' = option_map tcbSchedNext_C \ mp" - "option_map tcbSchedPrev_C \ mp' = option_map tcbSchedPrev_C \ mp" - shows "cready_queues_relation mp' cq aq" - using rel - apply (clarsimp simp: cready_queues_relation_def tcb_queue_relation'_def Let_def all_conj_distrib) - apply (drule spec, drule spec, drule mp, (erule conjI)+, assumption) - apply clarsimp - apply (erule iffD2 [OF tcb_queue_relation_only_next_prev, rotated -1]) - apply (rule same) - apply (rule same) - done - lemma ntfn_ep_disjoint: assumes srs: "sym_refs (state_refs_of' s)" and epat: "ko_at' ep epptr s" @@ -1376,8 +1333,6 @@ lemma rf_sr_tcb_update_no_queue: (t_hrs_' (globals s')); tcbEPNext_C ctcb = tcbEPNext_C (the (cslift s' (tcb_ptr_to_ctcb_ptr thread))); tcbEPPrev_C ctcb = tcbEPPrev_C (the (cslift s' (tcb_ptr_to_ctcb_ptr thread))); - tcbSchedNext_C ctcb = tcbSchedNext_C (the (cslift s' (tcb_ptr_to_ctcb_ptr thread))); - tcbSchedPrev_C ctcb = tcbSchedPrev_C (the (cslift s' (tcb_ptr_to_ctcb_ptr thread))); (\x\ran tcb_cte_cases. (\(getF, setF). getF tcb' = getF tcb) x); ctcb_relation tcb' ctcb \ @@ -1392,31 +1347,22 @@ lemma rf_sr_tcb_update_no_queue: apply (clarsimp simp: map_comp_update projectKO_opt_tcb cvariable_relation_upd_const typ_heap_simps') apply (intro conjI) - subgoal by (clarsimp simp: cmap_relation_def map_comp_update projectKO_opts_defs inj_eq) - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_upd_tcb_no_queues, assumption+) - subgoal by fastforce - subgoal by fastforce + subgoal by (clarsimp simp: cmap_relation_def map_comp_update projectKO_opts_defs inj_eq) apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_upd_tcb_no_queues, assumption+) + apply (rule cendpoint_relation_upd_tcb_no_queues, assumption+) subgoal by fastforce subgoal by fastforce - apply (erule cready_queues_relation_not_queue_ptrs) + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_upd_tcb_no_queues, assumption+) subgoal by fastforce subgoal by fastforce subgoal by (clarsimp simp: carch_state_relation_def typ_heap_simps') by (simp add: cmachine_state_relation_def) -lemma rf_sr_tcb_update_no_queue_helper: - "(s, s'\ globals := globals s' \ t_hrs_' := t_hrs_' (globals (undefined - \ globals := (undefined \ t_hrs_' := f (globals s') (t_hrs_' (globals s')) \)\))\\) \ rf_sr - \ (s, globals_update (\v. t_hrs_'_update (f v) v) s') \ rf_sr" - by (simp cong: StateSpace.state.fold_congs globals.fold_congs) - -lemmas rf_sr_tcb_update_no_queue2 - = rf_sr_tcb_update_no_queue_helper [OF rf_sr_tcb_update_no_queue, simplified] +lemmas rf_sr_tcb_update_no_queue2 = + rf_sr_obj_update_helper[OF rf_sr_tcb_update_no_queue, simplified] lemma tcb_queue_relation_not_in_q: "ctcb_ptr_to_tcb_ptr x \ set xs \ @@ -1464,13 +1410,7 @@ lemma rf_sr_tcb_update_not_in_queue: apply (drule(1) map_to_ko_atI') apply (drule sym_refs_ko_atD', clarsimp+) subgoal by blast - apply (simp add: cready_queues_relation_def, erule allEI) apply (clarsimp simp: Let_def) - apply (subst tcb_queue_relation_not_in_q) - apply clarsimp - apply (drule valid_queues_obj_at'D, clarsimp) - apply (clarsimp simp: obj_at'_def projectKOs inQ_def) - subgoal by simp apply (simp add: carch_state_relation_def) by (simp add: cmachine_state_relation_def) diff --git a/proof/crefine/RISCV64/Tcb_C.thy b/proof/crefine/RISCV64/Tcb_C.thy index b1ed7a22b0..e3b4086348 100644 --- a/proof/crefine/RISCV64/Tcb_C.thy +++ b/proof/crefine/RISCV64/Tcb_C.thy @@ -60,8 +60,6 @@ lemma doMachineOp_sched: done context begin interpretation Arch . (*FIXME: arch_split*) -crunch queues[wp]: setupReplyMaster "valid_queues" - (simp: crunch_simps wp: crunch_wps) crunch curThread [wp]: restart "\s. P (ksCurThread s)" (wp: crunch_wps simp: crunch_simps) @@ -398,9 +396,10 @@ lemma hrs_mem_update_cong: lemma setPriority_ccorres: "ccorres dc xfdc - (\s. tcb_at' t s \ Invariants_H.valid_queues s \ ksCurDomain s \ maxDomain \ - valid_queues' s \ valid_objs' s \ weak_sch_act_wf (ksSchedulerAction s) s \ (priority \ maxPriority)) - (UNIV \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr t} \ {s. prio_' s = ucast priority}) + (\s. tcb_at' t s \ ksCurDomain s \ maxDomain \ + valid_objs' s \ weak_sch_act_wf (ksSchedulerAction s) s \ (priority \ maxPriority) \ + pspace_aligned' s \ pspace_distinct' s) + ({s. tptr_' s = tcb_ptr_to_ctcb_ptr t} \ {s. prio_' s = ucast priority}) [] (setPriority t priority) (Call setPriority_'proc)" apply (cinit lift: tptr_' prio_') apply (ctac(no_vcg) add: tcbSchedDequeue_ccorres) @@ -423,7 +422,7 @@ lemma setPriority_ccorres: apply (ctac add: possibleSwitchTo_ccorres) apply (rule ccorres_return_Skip') apply (wp isRunnable_wp) - apply (wpsimp wp: hoare_drop_imps threadSet_valid_queues threadSet_valid_objs' + apply (wpsimp wp: hoare_drop_imps threadSet_valid_objs' weak_sch_act_wf_lift_linear threadSet_pred_tcb_at_state threadSet_tcbDomain_triv simp: st_tcb_at'_def o_def split: if_splits) @@ -432,18 +431,13 @@ lemma setPriority_ccorres: where Q="\rv s. obj_at' (\_. True) t s \ priority \ maxPriority \ - Invariants_H.valid_queues s \ ksCurDomain s \ maxDomain \ valid_objs' s \ - valid_queues' s \ weak_sch_act_wf (ksSchedulerAction s) s \ - (\d p. \ t \ set (ksReadyQueues s (d, p)))"]) - apply (wp weak_sch_act_wf_lift_linear tcbSchedDequeue_valid_queues tcbSchedDequeue_nonq) + pspace_aligned' s \ pspace_distinct' s"]) + apply (wp weak_sch_act_wf_lift_linear valid_tcb'_def) apply (clarsimp simp: valid_tcb'_tcbPriority_update) apply clarsimp - apply (frule (1) valid_objs'_maxDomain[where t=t]) - apply (frule (1) valid_objs'_maxPriority[where t=t]) - apply simp done lemma setMCPriority_ccorres: @@ -688,12 +682,12 @@ lemma invokeTCB_ThreadControl_ccorres: apply (clarsimp simp : guard_is_UNIV_def Collect_const_mem) apply (rule hoare_strengthen_post[ where Q= "\rv s. - Invariants_H.valid_queues s \ valid_objs' s \ weak_sch_act_wf (ksSchedulerAction s) s \ ((\a b. priority = Some (a, b)) \ tcb_at' target s \ ksCurDomain s \ maxDomain \ - valid_queues' s \ fst (the priority) \ maxPriority)"]) + fst (the priority) \ maxPriority) \ + pspace_aligned' s \ pspace_distinct' s"]) apply (strengthen sch_act_wf_weak) apply (wp hoare_weak_lift_imp) apply (clarsimp split: if_splits) @@ -782,12 +776,12 @@ lemma invokeTCB_ThreadControl_ccorres: apply (clarsimp simp : guard_is_UNIV_def Collect_const_mem) apply (simp cong: conj_cong) apply (rule hoare_strengthen_post[ - where Q="\a b. (Invariants_H.valid_queues b \ - valid_objs' b \ + where Q="\a b. (valid_objs' b \ sch_act_wf (ksSchedulerAction b) b \ + pspace_aligned' b \ pspace_distinct' b \ ((\a b. priority = Some (a, b)) \ tcb_at' target b \ - ksCurDomain b \ maxDomain \ valid_queues' b \ + ksCurDomain b \ maxDomain \ fst (the priority) \ maxPriority)) \ ((case snd (the buf) of None \ 0 @@ -809,15 +803,15 @@ lemma invokeTCB_ThreadControl_ccorres: prefer 2 apply fastforce apply (strengthen cte_is_derived_capMasterCap_strg - invs_queues invs_weak_sch_act_wf invs_sch_act_wf' + invs_weak_sch_act_wf invs_sch_act_wf' invs_valid_objs' invs_mdb' invs_pspace_aligned', simp add: o_def) apply (rule_tac P="is_aligned (fst (the buf)) msg_align_bits" in hoare_gen_asm) apply (wp threadSet_ipcbuffer_trivial hoare_weak_lift_imp | simp - | strengthen invs_sch_act_wf' invs_valid_objs' invs_weak_sch_act_wf invs_queues - invs_valid_queues' | wp hoare_drop_imps)+ + | strengthen invs_sch_act_wf' invs_valid_objs' invs_weak_sch_act_wf + | wp hoare_drop_imps)+ apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem option_to_0_def split: option.split_asm) @@ -826,7 +820,7 @@ lemma invokeTCB_ThreadControl_ccorres: apply (rule ccorres_return_C_errorE, simp+)[1] apply vcg apply (simp add: conj_comms cong: conj_cong) - apply (strengthen invs_ksCurDomain_maxDomain') + apply (strengthen invs_ksCurDomain_maxDomain' invs_pspace_distinct') apply (wp hoare_vcg_const_imp_lift_R cteDelete_invs') apply simp apply (rule ccorres_split_nothrow_novcg_dc) @@ -843,8 +837,7 @@ lemma invokeTCB_ThreadControl_ccorres: apply (rule conjI) apply (clarsimp simp: objBits_simps' word_bits_conv case_option_If2 if_n_0_0 valid_cap'_def capAligned_def obj_at'_def projectKOs) - apply (clarsimp simp: invs_valid_objs' invs_valid_queues' - Invariants_H.invs_queues invs_ksCurDomain_maxDomain') + apply (fastforce simp: invs_valid_objs' invs_ksCurDomain_maxDomain') apply (rule ccorres_Cond_rhs_Seq) apply (rule ccorres_rhs_assoc)+ apply csymbr @@ -1081,7 +1074,7 @@ lemma restart_ccorres: apply (ctac(no_vcg) add: tcbSchedEnqueue_ccorres) apply (ctac add: possibleSwitchTo_ccorres) apply (wp weak_sch_act_wf_lift)[1] - apply (wp sts_valid_queues setThreadState_st_tcb)[1] + apply (wp sts_valid_objs' setThreadState_st_tcb)[1] apply (simp add: valid_tcb_state'_def) apply wp apply (wp (once) sch_act_wf_lift, (wp tcb_in_cur_domain'_lift)+) @@ -1698,7 +1691,7 @@ lemma invokeTCB_WriteRegisters_ccorres[where S=UNIV]: apply (clarsimp simp: frame_gp_registers_convs word_less_nat_alt sysargs_rel_def n_frameRegisters_def n_msgRegisters_def split: if_split_asm) - apply (simp add: invs_weak_sch_act_wf invs_valid_objs' invs_queues) + apply (simp add: invs_weak_sch_act_wf invs_valid_objs') apply (fastforce dest!: global'_no_ex_cap simp: invs'_def valid_state'_def) done @@ -3163,7 +3156,8 @@ lemma decodeTCBConfigure_ccorres: apply (rule conjI, fastforce) apply (drule interpret_excaps_eq) apply (clarsimp simp: cte_wp_at_ctes_of valid_tcb_state'_def numeral_eqs le_ucast_ucast_le - tcb_at_invs' invs_valid_objs' invs_queues invs_sch_act_wf' + tcb_at_invs' invs_valid_objs' invs_sch_act_wf' + invs_pspace_aligned' invs_pspace_distinct' ct_in_state'_def pred_tcb_at'_def obj_at'_def tcb_st_refs_of'_def) apply (erule disjE; simp add: objBits_defs mask_def) apply (clarsimp simp: idButNot_def interpret_excaps_test_null @@ -4461,9 +4455,8 @@ lemma invokeTCB_SetTLSBase_ccorres: apply (rule ccorres_return_CE, simp+)[1] apply (wpsimp wp: hoare_drop_imp simp: guard_is_UNIV_def)+ apply vcg - apply (clarsimp simp: tlsBaseRegister_def RISCV64.tlsBaseRegister_def - invs_weak_sch_act_wf invs_queues C_register_defs - split: if_split) + apply (fastforce simp: tlsBaseRegister_def RISCV64.tlsBaseRegister_def + invs_weak_sch_act_wf C_register_defs) done lemma decodeSetTLSBase_ccorres: diff --git a/proof/crefine/RISCV64/Wellformed_C.thy b/proof/crefine/RISCV64/Wellformed_C.thy index f28a56f303..f7924396c6 100644 --- a/proof/crefine/RISCV64/Wellformed_C.thy +++ b/proof/crefine/RISCV64/Wellformed_C.thy @@ -151,10 +151,6 @@ where abbreviation "ep_queue_relation \ tcb_queue_relation tcbEPNext_C tcbEPPrev_C" -abbreviation - "sched_queue_relation \ tcb_queue_relation tcbSchedNext_C tcbSchedPrev_C" - - definition wordSizeCase :: "'a \ 'a \ 'a" where "wordSizeCase a b \ (if bitSize (undefined::machine_word) = 32 diff --git a/proof/crefine/X64/ADT_C.thy b/proof/crefine/X64/ADT_C.thy index d113aa6f15..049d7689c0 100644 --- a/proof/crefine/X64/ADT_C.thy +++ b/proof/crefine/X64/ADT_C.thy @@ -75,8 +75,8 @@ lemma Basic_sem_eq: lemma setTCBContext_C_corres: "\ ccontext_relation tc tc'; t' = tcb_ptr_to_ctcb_ptr t \ \ - corres_underlying rf_sr nf nf' dc (pspace_domain_valid and tcb_at' t) \ - (threadSet (\tcb. tcb \ tcbArch := atcbContextSet tc (tcbArch tcb)\) t) (setTCBContext_C tc' t')" + corres_underlying rf_sr nf nf' dc (pspace_domain_valid and tcb_at' t) \ + (threadSet (\tcb. tcb \ tcbArch := atcbContextSet tc (tcbArch tcb)\) t) (setTCBContext_C tc' t')" apply (simp add: setTCBContext_C_def exec_C_def Basic_sem_eq corres_underlying_def) apply clarsimp apply (simp add: threadSet_def bind_assoc split_def exec_gets) @@ -107,8 +107,6 @@ lemma setTCBContext_C_corres: apply (simp add: cep_relations_drop_fun_upd) apply (apply_conjunct \match conclusion in \fpu_null_state_relation _\ \ \simp add: fpu_null_state_heap_update_span_disjoint[OF tcb_at'_non_kernel_data_ref]\\) - apply (apply_conjunct \match conclusion in \cready_queues_relation _ _ _\ \ - \erule cready_queues_relation_not_queue_ptrs; rule ext; simp split: if_split\\) apply (drule ko_at_projectKO_opt) apply (erule (2) cmap_relation_upd_relI) apply (simp add: ctcb_relation_def carch_tcb_relation_def) @@ -619,25 +617,51 @@ lemma tcb_queue_rel'_unique: apply (erule(2) tcb_queue_rel_unique) done -definition - cready_queues_to_H - :: "(tcb_C ptr \ tcb_C) \ (tcb_queue_C[num_tcb_queues]) \ word8 \ word8 \ machine_word list" + +definition tcb_queue_C_to_tcb_queue :: "tcb_queue_C \ tcb_queue" where + "tcb_queue_C_to_tcb_queue q \ + TcbQueue (if head_C q = NULL then None else Some (ctcb_ptr_to_tcb_ptr (head_C q))) + (if end_C q = NULL then None else Some (ctcb_ptr_to_tcb_ptr (end_C q)))" + +definition cready_queues_to_H :: + "tcb_queue_C[num_tcb_queues] \ (domain \ priority \ ready_queue)" where - "cready_queues_to_H h_tcb cs \ \(qdom, prio). if ucast minDom \ qdom \ qdom \ ucast maxDom - \ ucast seL4_MinPrio \ prio \ prio \ ucast seL4_MaxPrio - then THE aq. let cqueue = index cs (cready_queues_index_to_C qdom prio) - in sched_queue_relation' h_tcb aq (head_C cqueue) (StateRelation_C.end_C cqueue) - else []" + "cready_queues_to_H cs \ + \(qdom, prio). + if qdom \ maxDomain \ prio \ maxPriority + then let cqueue = index cs (cready_queues_index_to_C qdom prio) + in tcb_queue_C_to_tcb_queue cqueue + else TcbQueue None None" lemma cready_queues_to_H_correct: - "cready_queues_relation (clift s) cs as \ - cready_queues_to_H (clift s) cs = as" - apply (clarsimp simp: cready_queues_to_H_def cready_queues_relation_def - fun_eq_iff) - apply (rule the_equality) - apply simp - apply (clarsimp simp: Let_def) - apply (rule_tac hp="clift s" in tcb_queue_rel'_unique, simp_all add: lift_t_NULL) + "\cready_queues_relation (ksReadyQueues s) (ksReadyQueues_' ch); + no_0_obj' s; ksReadyQueues_asrt s; pspace_aligned' s; pspace_distinct' s\ + \ cready_queues_to_H (ksReadyQueues_' ch) = ksReadyQueues s" + apply (clarsimp simp: cready_queues_to_H_def cready_queues_relation_def Let_def) + apply (clarsimp simp: fun_eq_iff) + apply (rename_tac d p) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (frule (3) obj_at'_tcbQueueEnd_ksReadyQueues) + apply (frule tcbQueueHead_iff_tcbQueueEnd) + apply (rule conjI) + apply (clarsimp simp: tcb_queue_C_to_tcb_queue_def ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (case_tac "tcbQueueHead (ksReadyQueues s (d, p)) = None") + apply (clarsimp simp: tcb_queue.expand) + apply clarsimp + apply (rename_tac queue_head queue_end) + apply (prop_tac "tcb_at' queue_head s", fastforce simp: tcbQueueEmpty_def obj_at'_def) + apply (prop_tac "tcb_at' queue_end s", fastforce simp: tcbQueueEmpty_def obj_at'_def) + apply (drule kernel.tcb_at_not_NULL)+ + apply (fastforce simp: tcb_queue.expand kernel.ctcb_ptr_to_ctcb_ptr) + apply (clarsimp simp: tcbQueueEmpty_def ctcb_queue_relation_def option_to_ctcb_ptr_def + split: option.splits; + metis tcb_queue.exhaust_sel word_not_le) done (* showing that cpspace_relation is actually unique >>>*) @@ -786,12 +810,15 @@ lemma cthread_state_rel_imp_eq: apply (cases y, simp_all add: ThreadState_defs)+ done -lemma ksPSpace_valid_objs_tcbBoundNotification_nonzero: - "\s. ksPSpace s = ah \ no_0_obj' s \ valid_objs' s - \ map_to_tcbs ah p = Some tcb \ tcbBoundNotification tcb \ Some 0" +lemma map_to_tcbs_Some_refs_nonzero: + "\map_to_tcbs (ksPSpace s) p = Some tcb; no_0_obj' s; valid_objs' s\ + \ tcbBoundNotification tcb \ Some 0 + \ tcbSchedPrev tcb \ Some 0 + \ tcbSchedNext tcb \ Some 0" + supply word_neq_0_conv[simp del] apply (clarsimp simp: map_comp_def split: option.splits) - apply (erule(1) valid_objsE') - apply (clarsimp simp: projectKOs valid_obj'_def valid_tcb'_def) + apply (erule (1) valid_objsE') + apply (fastforce simp: projectKOs valid_obj'_def valid_tcb'_def) done lemma atcbContextGet_inj[simp]: @@ -802,34 +829,75 @@ lemma ccontext_relation_imp_eq2: "\ccontext_relation (atcbContextGet t) x; ccontext_relation (atcbContextGet t') x\ \ t = t'" by (auto dest: ccontext_relation_imp_eq) +lemma tcb_ptr_to_ctcb_ptr_inj: + "tcb_ptr_to_ctcb_ptr x = tcb_ptr_to_ctcb_ptr y \ x = y" + by (auto simp: tcb_ptr_to_ctcb_ptr_def ctcb_offset_def) + +lemma + assumes "pspace_aligned' as" "pspace_distinct' as" "valid_tcb' atcb as" + shows tcb_at'_tcbBoundNotification: + "bound (tcbBoundNotification atcb) \ ntfn_at' (the (tcbBoundNotification atcb)) as" + and tcb_at'_tcbSchedPrev: + "tcbSchedPrev atcb \ None \ tcb_at' (the (tcbSchedPrev atcb)) as" + and tcb_at'_tcbSchedNext: + "tcbSchedNext atcb \ None \ tcb_at' (the (tcbSchedNext atcb)) as" + using assms + by (clarsimp simp: valid_tcb'_def obj_at'_def)+ + lemma cpspace_tcb_relation_unique: - assumes tcbs: "cpspace_tcb_relation ah ch" "cpspace_tcb_relation ah' ch" - and vs: "\s. ksPSpace s = ah \ no_0_obj' s \ valid_objs' s" - and vs': "\s. ksPSpace s = ah' \ no_0_obj' s \ valid_objs' s" - assumes ctes: " \tcb tcb'. (\p. map_to_tcbs ah p = Some tcb \ - map_to_tcbs ah' p = Some tcb') \ - (\x\ran tcb_cte_cases. fst x tcb' = fst x tcb)" - shows "map_to_tcbs ah' = map_to_tcbs ah" + assumes tcbs: "cpspace_tcb_relation (ksPSpace as) ch" "cpspace_tcb_relation (ksPSpace as') ch" + assumes vs: "no_0_obj' as" "valid_objs' as" + assumes vs': "no_0_obj' as'" "valid_objs' as'" + assumes ad: "pspace_aligned' as" "pspace_distinct' as" + assumes ad': "pspace_aligned' as'" "pspace_distinct' as'" + assumes ctes: "\tcb tcb'. (\p. map_to_tcbs (ksPSpace as) p = Some tcb \ + map_to_tcbs (ksPSpace as') p = Some tcb') \ + (\x\ran tcb_cte_cases. fst x tcb' = fst x tcb)" + shows "map_to_tcbs (ksPSpace as') = map_to_tcbs (ksPSpace as)" using tcbs(2) tcbs(1) apply (clarsimp simp add: cmap_relation_def) apply (drule inj_image_inv[OF inj_tcb_ptr_to_ctcb_ptr])+ apply (simp add: tcb_ptr_to_ctcb_ptr_def[abs_def] ctcb_offset_def) apply (rule ext) - apply (case_tac "x:dom (map_to_tcbs ah)") + apply (case_tac "x \ dom (map_to_tcbs (ksPSpace as))") apply (drule bspec, assumption)+ apply (simp add: dom_def Collect_eq, drule_tac x=x in spec) apply clarsimp apply (rename_tac p x y) apply (cut_tac ctes) apply (drule_tac x=x in spec, drule_tac x=y in spec, erule impE, fastforce) - apply (frule ksPSpace_valid_objs_tcbBoundNotification_nonzero[OF vs]) - apply (frule ksPSpace_valid_objs_tcbBoundNotification_nonzero[OF vs']) + apply (frule map_to_tcbs_Some_refs_nonzero[OF _ vs]) + apply (frule map_to_tcbs_Some_refs_nonzero[OF _ vs']) + apply (rename_tac atcb atcb') + apply (prop_tac "valid_tcb' atcb as") + apply (fastforce intro: vs ad map_to_ko_atI tcb_ko_at_valid_objs_valid_tcb') + apply (prop_tac "valid_tcb' atcb' as'") + apply (fastforce intro: vs' ad' map_to_ko_atI tcb_ko_at_valid_objs_valid_tcb') + apply (frule tcb_at'_tcbSchedPrev[OF ad]) + apply (frule tcb_at'_tcbSchedPrev[OF ad']) + apply (frule tcb_at'_tcbSchedNext[OF ad]) + apply (frule tcb_at'_tcbSchedNext[OF ad']) apply (thin_tac "map_to_tcbs x y = Some z" for x y z)+ - apply (case_tac x, case_tac y, case_tac "the (clift ch (tcb_Ptr (p+0x400)))") + apply (case_tac "the (clift ch (tcb_Ptr (p + 2 ^ ctcb_size_bits)))") apply (clarsimp simp: ctcb_relation_def ran_tcb_cte_cases) - apply (clarsimp simp: option_to_ptr_def option_to_0_def split: option.splits) - apply (auto simp: cfault_rel_imp_eq cthread_state_rel_imp_eq carch_tcb_relation_def - ccontext_relation_imp_eq2 up_ucast_inj_eq ctcb_size_bits_def) + apply (clarsimp simp: option_to_ctcb_ptr_def option_to_ptr_def option_to_0_def) + apply (rule tcb.expand) + apply clarsimp + apply (intro conjI) + apply (simp add: cthread_state_rel_imp_eq) + apply (simp add: cfault_rel_imp_eq) + apply (case_tac "tcbBoundNotification atcb'", case_tac "tcbBoundNotification atcb"; clarsimp) + apply (clarsimp split: option.splits) + apply (case_tac "tcbSchedPrev atcb'"; case_tac "tcbSchedPrev atcb"; clarsimp) + apply (force dest!: kernel.tcb_at_not_NULL) + apply (force dest!: kernel.tcb_at_not_NULL) + apply (force simp: tcb_ptr_to_ctcb_ptr_inj) + apply (case_tac "tcbSchedNext atcb'"; case_tac "tcbSchedNext atcb"; clarsimp) + apply (force dest!: kernel.tcb_at_not_NULL) + apply (force dest!: kernel.tcb_at_not_NULL) + apply (force simp: tcb_ptr_to_ctcb_ptr_inj) + apply (force simp: carch_tcb_relation_def ccontext_relation_imp_eq2) + apply auto done lemma tcb_queue_rel_clift_unique: @@ -860,10 +928,6 @@ lemma ksPSpace_valid_pspace_ntfnBoundTCB_nonzero: apply (clarsimp simp: projectKOs valid_obj'_def valid_ntfn'_def) done -lemma tcb_ptr_to_ctcb_ptr_inj: - "tcb_ptr_to_ctcb_ptr x = tcb_ptr_to_ctcb_ptr y \ x = y" - by (auto simp: tcb_ptr_to_ctcb_ptr_def ctcb_offset_def) - lemma cpspace_ntfn_relation_unique: assumes ntfns: "cpspace_ntfn_relation ah ch" "cpspace_ntfn_relation ah' ch" and vs: "\s. ksPSpace s = ah \ valid_pspace' s" @@ -1213,8 +1277,8 @@ proof - OF valid_objs'_imp_wf_asid_pool'[OF valid_objs] valid_objs'_imp_wf_asid_pool'[OF valid_objs']]) apply (drule (1) cpspace_tcb_relation_unique) - apply (fastforce intro: no_0_objs no_0_objs' valid_objs valid_objs') - apply (fastforce intro: no_0_objs no_0_objs' valid_objs valid_objs') + apply (fastforce intro: no_0_objs no_0_objs' valid_objs valid_objs')+ + apply (fastforce intro: aligned distinct aligned' distinct')+ apply (intro allI impI,elim exE conjE) apply (rule_tac p=p in map_to_ctes_tcb_ctes, assumption) apply (frule (1) map_to_ko_atI[OF _ aligned distinct]) @@ -1266,7 +1330,7 @@ lemma ksPSpace_eq_imp_valid_tcb'_eq: by (auto simp: ksPSpace_eq_imp_obj_at'_eq[OF ksPSpace] ksPSpace_eq_imp_valid_cap'_eq[OF ksPSpace] ksPSpace_eq_imp_typ_at'_eq[OF ksPSpace] - valid_tcb'_def valid_tcb_state'_def valid_bound_ntfn'_def + valid_tcb'_def valid_tcb_state'_def valid_bound_ntfn'_def valid_bound_tcb'_def split: thread_state.splits option.splits) lemma ksPSpace_eq_imp_valid_arch_obj'_eq: @@ -1429,7 +1493,7 @@ where ksDomSchedule = cDomSchedule_to_H kernel_all_global_addresses.ksDomSchedule, ksCurDomain = ucast (ksCurDomain_' s), ksDomainTime = ksDomainTime_' s, - ksReadyQueues = cready_queues_to_H (clift (t_hrs_' s)) (ksReadyQueues_' s), + ksReadyQueues = cready_queues_to_H (ksReadyQueues_' s), ksReadyQueuesL1Bitmap = cbitmap_L1_to_H (ksReadyQueuesL1Bitmap_' s), ksReadyQueuesL2Bitmap = cbitmap_L2_to_H (ksReadyQueuesL2Bitmap_' s), ksCurThread = ctcb_ptr_to_tcb_ptr (ksCurThread_' s), @@ -1451,16 +1515,16 @@ lemma trivial_eq_conj: "B = C \ (A \ B) = (A \ C)" lemma cstate_to_H_correct: assumes valid: "valid_state' as" assumes cstate_rel: "cstate_relation as cs" + assumes rdyqs: "ksReadyQueues_asrt as" shows "cstate_to_H cs = as \ksMachineState:= observable_memory (ksMachineState as) (user_mem' as)\" apply (subgoal_tac "cstate_to_machine_H cs = observable_memory (ksMachineState as) (user_mem' as)") apply (rule kernel_state.equality, simp_all add: cstate_to_H_def) - apply (rule cstate_to_pspace_H_correct) + apply (rule cstate_to_pspace_H_correct) using valid apply (simp add: valid_state'_def) using cstate_rel valid apply (clarsimp simp: cstate_relation_def cpspace_relation_def Let_def - observable_memory_def valid_state'_def - valid_pspace'_def) + observable_memory_def valid_state'_def valid_pspace'_def) using cstate_rel apply (clarsimp simp: cstate_relation_def cpspace_relation_def Let_def prod_eq_iff) using cstate_rel @@ -1468,10 +1532,10 @@ lemma cstate_to_H_correct: using valid cstate_rel apply (rule mk_gsUntypedZeroRanges_correct) subgoal - using cstate_rel - by (fastforce simp: cstate_relation_def cpspace_relation_def - Let_def ghost_size_rel_def unat_eq_0 - split: if_split) + using cstate_rel + by (fastforce simp: cstate_relation_def cpspace_relation_def + Let_def ghost_size_rel_def unat_eq_0 + split: if_split) using valid cstate_rel apply (rule cDomScheduleIdx_to_H_correct) using cstate_rel @@ -1485,8 +1549,13 @@ lemma cstate_to_H_correct: using cstate_rel apply (clarsimp simp: cstate_relation_def Let_def) apply (rule cready_queues_to_H_correct) - using cstate_rel - apply (clarsimp simp: cstate_relation_def Let_def) + using cstate_rel rdyqs + apply (fastforce intro!: cready_queues_to_H_correct + simp: cstate_relation_def Let_def) + using valid apply (fastforce simp: valid_state'_def) + using rdyqs apply fastforce + using valid apply (fastforce simp: valid_state'_def) + using valid apply (fastforce simp: valid_state'_def) using cstate_rel apply (clarsimp simp: cstate_relation_def Let_def) using cstate_rel diff --git a/proof/crefine/X64/ArchMove_C.thy b/proof/crefine/X64/ArchMove_C.thy index 26bc611b55..7186d5fb65 100644 --- a/proof/crefine/X64/ArchMove_C.thy +++ b/proof/crefine/X64/ArchMove_C.thy @@ -249,14 +249,8 @@ lemma sign_extend_canonical_address: "(x = sign_extend 47 x) = canonical_address x" by (fastforce simp: sign_extended_iff_sign_extend canonical_address_sign_extended) -crunches Arch.switchToThread - for valid_queues'[wp]: valid_queues' - (simp: crunch_simps) crunches switchToIdleThread for ksCurDomain[wp]: "\s. P (ksCurDomain s)" -crunches switchToIdleThread, switchToThread - for valid_pspace'[wp]: valid_pspace' - (simp: whenE_def crunch_simps) lemma setCurrentUserCR3_valid_arch_state'[wp]: "\valid_arch_state' and K (valid_cr3' c)\ setCurrentUserCR3 c \\_. valid_arch_state'\" diff --git a/proof/crefine/X64/Arch_C.thy b/proof/crefine/X64/Arch_C.thy index c0dd0e17ba..6d39829d42 100644 --- a/proof/crefine/X64/Arch_C.thy +++ b/proof/crefine/X64/Arch_C.thy @@ -1247,8 +1247,8 @@ lemma decodeX64PageTableInvocation_ccorres: sch_act_wf (ksSchedulerAction b) b \ cte_wp_at' (\_. True) slot b" in hoare_strengthen_post) apply wp - apply (clarsimp simp: isCap_simps invs_valid_objs' valid_cap'_def valid_tcb_state'_def - invs_arch_state' invs_no_0_obj') + apply (fastforce simp: isCap_simps invs_valid_objs' valid_cap'_def valid_tcb_state'_def + invs_arch_state' invs_no_0_obj') apply vcg apply wp apply simp @@ -1854,7 +1854,7 @@ lemma performPageGetAddress_ccorres: apply clarsimp apply (rule conseqPre, vcg) apply clarsimp - apply (clarsimp simp: invs_no_0_obj' tcb_at_invs' invs_queues invs_valid_objs' invs_sch_act_wf' + apply (clarsimp simp: invs_no_0_obj' tcb_at_invs' invs_valid_objs' invs_sch_act_wf' rf_sr_ksCurThread msgRegisters_unfold seL4_MessageInfo_lift_def message_info_to_H_def mask_def) apply (cases isCall) @@ -2223,9 +2223,9 @@ lemma decodeX86ModeMapPage_ccorres: apply (wp injection_wp[OF refl] createMappingEntries_wf) apply (simp add: all_ex_eq_helper) apply (vcg exspec=createSafeMappingEntries_PDPTE_modifies) - by (clarsimp simp: invs_valid_objs' tcb_at_invs' vmsz_aligned_addrFromPPtr' invs_queues - valid_tcb_state'_def invs_sch_act_wf' ThreadState_defs rf_sr_ksCurThread - arch_invocation_label_defs mask_def isCap_simps) + by (fastforce simp: invs_valid_objs' tcb_at_invs' vmsz_aligned_addrFromPPtr' + valid_tcb_state'_def invs_sch_act_wf' ThreadState_defs rf_sr_ksCurThread + arch_invocation_label_defs mask_def isCap_simps) lemma valid_cap'_PageCap_kernel_mappings: "\pspace_in_kernel_mappings' s; isPageCap cap; valid_cap' (ArchObjectCap cap) s\ @@ -3236,7 +3236,8 @@ lemma decodeX64PageDirectoryInvocation_ccorres: sch_act_wf (ksSchedulerAction b) b \ cte_wp_at' (\_. True) slot b" in hoare_strengthen_post) apply wp - apply (clarsimp simp: isCap_simps invs_valid_objs' valid_cap'_def valid_tcb_state'_def invs_arch_state' invs_no_0_obj') + apply (fastforce simp: isCap_simps invs_valid_objs' valid_cap'_def valid_tcb_state'_def + invs_arch_state' invs_no_0_obj') apply vcg apply wp apply simp @@ -4389,10 +4390,10 @@ lemma decodeX64MMUInvocation_ccorres: apply (clarsimp simp: invs_valid_objs') apply (rule conjI, fastforce) apply (clarsimp simp: ctes_of_valid' invs_valid_objs' isCap_simps) - apply (clarsimp simp: ex_cte_cap_wp_to'_def cte_wp_at_ctes_of - invs_sch_act_wf' dest!: isCapDs(1)) + apply (clarsimp simp: ex_cte_cap_wp_to'_def cte_wp_at_ctes_of invs_pspace_distinct' + invs_sch_act_wf' invs_pspace_aligned' + dest!: isCapDs(1)) apply (intro conjI) - apply (simp add: Invariants_H.invs_queues) apply (simp add: valid_tcb_state'_def) apply (fastforce elim!: pred_tcb'_weakenE dest!: st_tcb_at_idle_thread') apply (clarsimp simp: st_tcb_at'_def obj_at'_def) @@ -4548,7 +4549,7 @@ lemma invokeX86PortIn8_ccorres: notes Collect_const[simp del] shows "ccorres ((intr_and_se_rel \ Inr) \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') - (valid_objs' and valid_queues and ct_in_state' ((=) Restart) and + (valid_objs' and ct_in_state' ((=) Restart) and pspace_aligned' and pspace_distinct' and (\s. ksCurThread s = thread \ sch_act_wf (ksSchedulerAction s) s)) (UNIV \ \\invLabel = scast Kernel_C.X86IOPortIn8\ \ \\port = port\ @@ -4636,7 +4637,7 @@ lemma invokeX86PortIn16_ccorres: notes Collect_const[simp del] shows "ccorres ((intr_and_se_rel \ Inr) \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') - (valid_objs' and valid_queues and ct_in_state' ((=) Restart) and + (valid_objs' and ct_in_state' ((=) Restart) and pspace_aligned' and pspace_distinct' and (\s. ksCurThread s = thread \ sch_act_wf (ksSchedulerAction s) s)) (UNIV \ \\invLabel = scast Kernel_C.X86IOPortIn16\ \ \\port = port\ @@ -4724,7 +4725,7 @@ lemma invokeX86PortIn32_ccorres: notes Collect_const[simp del] shows "ccorres ((intr_and_se_rel \ Inr) \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') - (valid_objs' and valid_queues and ct_in_state' ((=) Restart) and + (valid_objs' and ct_in_state' ((=) Restart) and pspace_aligned' and pspace_distinct' and (\s. ksCurThread s = thread \ sch_act_wf (ksSchedulerAction s) s)) (UNIV \ \\invLabel = scast Kernel_C.X86IOPortIn32\ \ \\port = port\ @@ -5365,8 +5366,8 @@ proof - and sch_act_simple and cte_wp_at' \ slot and (\s. thread = ksCurThread s)" in hoare_strengthen_post) apply (wpsimp wp: getSlotCap_wp) - apply (clarsimp simp: unat_less_2p_word_bits invs_queues invs_valid_objs' - valid_tcb_state'_def + apply (clarsimp simp: unat_less_2p_word_bits invs_valid_objs' + valid_tcb_state'_def invs_pspace_aligned' invs_pspace_distinct' invs_sch_act_wf' st_tcb_strg'[rule_format] st_tcb_at'_def obj_at'_def projectKOs word_le_not_less split: thread_state.splits) @@ -5472,7 +5473,7 @@ proof - apply (rule ccorres_return_CE, simp+)[1] apply (rule ccorres_return_C_errorE, simp+)[1] apply wp - apply (wpsimp wp: ct_in_state'_set sts_running_valid_queues) + apply (wpsimp wp: ct_in_state'_set sts_valid_objs') apply (simp add: Collect_const_mem intr_and_se_rel_def cintr_def exception_defs) apply (vcg exspec=setThreadState_modifies) apply clarsimp @@ -5516,7 +5517,7 @@ proof - apply (rule ccorres_return_CE, simp+)[1] apply (rule ccorres_return_C_errorE, simp+)[1] apply wp - apply (wpsimp wp: ct_in_state'_set sts_running_valid_queues) + apply (wpsimp wp: ct_in_state'_set sts_valid_objs') apply (simp add: Collect_const_mem intr_and_se_rel_def cintr_def exception_defs) apply (vcg exspec=setThreadState_modifies) apply clarsimp @@ -5559,7 +5560,7 @@ proof - apply (rule ccorres_return_CE, simp+)[1] apply (rule ccorres_return_C_errorE, simp+)[1] apply wp - apply (wpsimp wp: ct_in_state'_set sts_running_valid_queues) + apply (wpsimp wp: ct_in_state'_set sts_valid_objs') apply (simp add: Collect_const_mem intr_and_se_rel_def cintr_def exception_defs) apply (vcg exspec=setThreadState_modifies) apply clarsimp @@ -5727,7 +5728,7 @@ proof - apply (rule syscall_error_throwError_ccorres_n) apply (clarsimp simp: syscall_error_to_H_cases) apply (clarsimp simp: arch_invocation_label_defs sysargs_rel_to_n valid_tcb_state'_def tcb_at_invs' - invs_queues invs_sch_act_wf' ct_active_st_tcb_at_minor' rf_sr_ksCurThread + invs_sch_act_wf' ct_active_st_tcb_at_minor' rf_sr_ksCurThread ucast_mask_drop[where n=16, simplified mask_def, simplified]) apply (safe, simp_all add: unat_eq_0 unat_eq_1) apply (clarsimp dest!: unat_length_2_helper simp: ThreadState_defs mask_def syscall_error_rel_def diff --git a/proof/crefine/X64/Detype_C.thy b/proof/crefine/X64/Detype_C.thy index 9d042490be..eae4571c82 100644 --- a/proof/crefine/X64/Detype_C.thy +++ b/proof/crefine/X64/Detype_C.thy @@ -1686,36 +1686,10 @@ proof - done moreover - from invs have "valid_queues s" .. - hence "\p. \t \ set (ksReadyQueues s p). tcb_at' t s \ ko_wp_at' live' t s" - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def) - apply (drule spec, drule spec) - apply clarsimp - apply (drule (1) bspec) - apply (rule conjI) - apply (erule obj_at'_weakenE) - apply simp - apply (simp add: obj_at'_real_def) - apply (erule ko_wp_at'_weakenE) - apply (clarsimp simp: live'_def projectKOs inQ_def) - done - hence tat: "\p. \t \ set (ksReadyQueues s p). tcb_at' t s" - and tlive: "\p. \t \ set (ksReadyQueues s p). ko_wp_at' live' t s" - by auto from sr have - "cready_queues_relation (clift ?th_s) - (ksReadyQueues_' (globals s')) (ksReadyQueues s)" - unfolding cready_queues_relation_def rf_sr_def cstate_relation_def - cpspace_relation_def - apply (clarsimp simp: Let_def all_conj_distrib) - apply (drule spec, drule spec, drule mp) - apply fastforce - apply ((subst lift_t_typ_region_bytes, rule cm_disj_tcb, assumption+, - simp_all add: objBits_simps archObjSize_def pageBits_def projectKOs)[1])+ - \ \waiting ...\ - apply (simp add: tcb_queue_relation_live_restrict - [OF D.valid_untyped tat tlive rl]) - done + "cready_queues_relation (ksReadyQueues s) (ksReadyQueues_' (globals s'))" + unfolding cready_queues_relation_def rf_sr_def cstate_relation_def cpspace_relation_def + by (clarsimp simp: Let_def all_conj_distrib) moreover from cs have clift: diff --git a/proof/crefine/X64/Finalise_C.thy b/proof/crefine/X64/Finalise_C.thy index c9d67ec922..ad5b1dd96b 100644 --- a/proof/crefine/X64/Finalise_C.thy +++ b/proof/crefine/X64/Finalise_C.thy @@ -17,6 +17,108 @@ declare if_split [split del] definition "option_map2 f m = option_map f \ m" +definition ksReadyQueues_head_end_2 :: "(domain \ priority \ ready_queue) \ bool" where + "ksReadyQueues_head_end_2 qs \ + \d p. tcbQueueHead (qs (d, p)) \ None \ tcbQueueEnd (qs (d, p)) \ None" + +abbreviation "ksReadyQueues_head_end s \ ksReadyQueues_head_end_2 (ksReadyQueues s)" + +lemmas ksReadyQueues_head_end_def = ksReadyQueues_head_end_2_def + +lemma ksReadyQueues_asrt_ksReadyQueues_head_end: + "ksReadyQueues_asrt s \ ksReadyQueues_head_end s" + by (fastforce dest: tcbQueueHead_iff_tcbQueueEnd + simp: ready_queue_relation_def ksReadyQueues_asrt_def ksReadyQueues_head_end_def) + +lemma tcbSchedEnqueue_ksReadyQueues_head_end[wp]: + "tcbSchedEnqueue tcbPtr \ksReadyQueues_head_end\" + unfolding tcbSchedEnqueue_def tcbQueuePrepend_def setQueue_def + apply (wpsimp wp: threadSet_wp threadGet_wp simp: bitmap_fun_defs) + apply (clarsimp simp: tcbQueueEmpty_def obj_at'_def ksReadyQueues_head_end_def split: if_splits) + done + +lemma ksReadyQueues_head_end_ksSchedulerAction_update[simp]: + "ksReadyQueues_head_end (s\ksSchedulerAction := ChooseNewThread\) = ksReadyQueues_head_end s" + by (simp add: ksReadyQueues_head_end_def) + +crunches rescheduleRequired + for ksReadyQueues_head_end[wp]: ksReadyQueues_head_end + +lemma setThreadState_ksReadyQueues_head_end[wp]: + "setThreadState ts tcbPtr \ksReadyQueues_head_end\" + unfolding setThreadState_def + by (wpsimp wp: threadSet_wp threadGet_wp simp: bitmap_fun_defs) + +definition ksReadyQueues_head_end_tcb_at'_2 :: + "(domain \ priority \ ready_queue) \ (obj_ref \ tcb) \ bool" where + "ksReadyQueues_head_end_tcb_at'_2 qs tcbs \ + \d p. (\head. tcbQueueHead (qs (d, p)) = Some head \ tcbs head \ None) + \ (\end. tcbQueueEnd (qs (d, p)) = Some end \ tcbs end \ None)" + +abbreviation "ksReadyQueues_head_end_tcb_at' s \ + ksReadyQueues_head_end_tcb_at'_2 (ksReadyQueues s) (tcbs_of' s)" + +lemmas ksReadyQueues_head_end_tcb_at'_def = ksReadyQueues_head_end_tcb_at'_2_def + +lemma ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at': + "\ksReadyQueues_asrt s; pspace_aligned' s; pspace_distinct' s\ + \ ksReadyQueues_head_end_tcb_at' s" + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def + ksReadyQueues_head_end_tcb_at'_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: list_queue_relation_def) + apply (intro conjI impI allI) + apply (case_tac "ts = []", clarsimp) + apply (fastforce dest!: heap_path_head hd_in_set + simp: opt_pred_def tcbQueueEmpty_def split: option.splits) + apply (fastforce simp: queue_end_valid_def opt_pred_def tcbQueueEmpty_def + split: option.splits) + done + +lemma tcbSchedEnqueue_ksReadyQueues_head_end_tcb_at'[wp]: + "tcbSchedEnqueue tcbPtr \ksReadyQueues_head_end_tcb_at'\" + unfolding tcbSchedEnqueue_def tcbQueuePrepend_def setQueue_def + apply (wpsimp wp: threadSet_wp threadGet_wp simp: bitmap_fun_defs) + apply (clarsimp simp: ksReadyQueues_head_end_tcb_at'_def split: if_splits) + done + +lemma ksReadyQueues_head_end_tcb_at'_ksSchedulerAction_update[simp]: + "ksReadyQueues_head_end_tcb_at' (s\ksSchedulerAction := ChooseNewThread\) + = ksReadyQueues_head_end_tcb_at' s" + by (simp add: ksReadyQueues_head_end_tcb_at'_def) + +crunches rescheduleRequired + for ksReadyQueues_head_end_tcb_at'[wp]: ksReadyQueues_head_end_tcb_at' + +lemma setThreadState_ksReadyQueues_head_end_tcb_at'[wp]: + "setThreadState ts tcbPtr \ksReadyQueues_head_end_tcb_at'\" + unfolding setThreadState_def + apply (wpsimp wp: threadSet_wp) + apply (fastforce simp: ksReadyQueues_head_end_tcb_at'_def split: if_splits) + done + +lemma head_end_ksReadyQueues_': + "\ (s, s') \ rf_sr; ksReadyQueues_head_end s; ksReadyQueues_head_end_tcb_at' s; + pspace_aligned' s; pspace_distinct' s; + d \ maxDomain; p \ maxPriority \ + \ head_C (index (ksReadyQueues_' (globals s')) (cready_queues_index_to_C d p)) = NULL + \ end_C (index (ksReadyQueues_' (globals s')) (cready_queues_index_to_C d p)) = NULL" + apply (frule (2) rf_sr_ctcb_queue_relation[where d=d and p=p]) + apply (clarsimp simp: ksReadyQueues_head_end_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: ksReadyQueues_head_end_tcb_at'_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: ctcb_queue_relation_def option_to_ctcb_ptr_def split: option.splits) + apply (rename_tac "end" head end_tcb head_tcb) + apply (prop_tac "tcb_at' head s \ tcb_at' end s") + apply (fastforce intro!: aligned'_distinct'_ko_wp_at'I + simp: obj_at'_real_def opt_map_def split: option.splits) + apply (fastforce dest: tcb_at_not_NULL) + done + lemma tcbSchedEnqueue_cslift_spec: "\s. \\\<^bsub>/UNIV\<^esub> \s. \d v. option_map2 tcbPriority_C (cslift s) \tcb = Some v \ unat v \ numPriorities @@ -28,7 +130,9 @@ lemma tcbSchedEnqueue_cslift_spec: \ None \ option_map2 tcbDomain_C (cslift s) (head_C (index \ksReadyQueues (unat (d*0x100 + v)))) - \ None)\ + \ None) + \ (head_C (index \ksReadyQueues (unat (d * 0x100 + v))) \ NULL + \ end_C (index \ksReadyQueues (unat (d * 0x100 + v))) \ NULL)\ Call tcbSchedEnqueue_'proc {s'. option_map2 tcbEPNext_C (cslift s') = option_map2 tcbEPNext_C (cslift s) \ option_map2 tcbEPPrev_C (cslift s') = option_map2 tcbEPPrev_C (cslift s) @@ -45,8 +149,8 @@ lemma tcbSchedEnqueue_cslift_spec: apply (rule conjI) apply (clarsimp simp: typ_heap_simps cong: if_cong) apply (simp split: if_split) - apply (clarsimp simp: typ_heap_simps if_Some_helper cong: if_cong) - by (simp split: if_split) + by (auto simp: typ_heap_simps' if_Some_helper numPriorities_def + cong: if_cong split: if_splits) lemma setThreadState_cslift_spec: "\s. \\\<^bsub>/UNIV\<^esub> \s. s \\<^sub>c \tptr \ (\x. ksSchedulerAction_' (globals s) = tcb_Ptr x @@ -142,8 +246,9 @@ lemma ctcb_relation_tcbPriority_maxPriority_numPriorities: done lemma tcbSchedEnqueue_cslift_precond_discharge: - "\ (s, s') \ rf_sr; obj_at' (P :: tcb \ bool) x s; - valid_queues s; valid_objs' s \ \ + "\ (s, s') \ rf_sr; obj_at' (P :: tcb \ bool) x s; valid_objs' s ; + ksReadyQueues_head_end s; ksReadyQueues_head_end_tcb_at' s; + pspace_aligned' s; pspace_distinct' s\ \ (\d v. option_map2 tcbPriority_C (cslift s') (tcb_ptr_to_ctcb_ptr x) = Some v \ unat v < numPriorities \ option_map2 tcbDomain_C (cslift s') (tcb_ptr_to_ctcb_ptr x) = Some d @@ -154,31 +259,49 @@ lemma tcbSchedEnqueue_cslift_precond_discharge: \ None \ option_map2 tcbDomain_C (cslift s') (head_C (index (ksReadyQueues_' (globals s')) (unat (d*0x100 + v)))) - \ None))" + \ None) + \ (head_C (index (ksReadyQueues_' (globals s')) (unat (d * 0x100 + v))) \ NULL + \ end_C (index (ksReadyQueues_' (globals s')) (unat (d * 0x100 + v))) \ NULL))" apply (drule(1) obj_at_cslift_tcb) apply (clarsimp simp: typ_heap_simps' option_map2_def) + apply (rename_tac tcb tcb') apply (frule_tac t=x in valid_objs'_maxPriority, fastforce simp: obj_at'_def) apply (frule_tac t=x in valid_objs'_maxDomain, fastforce simp: obj_at'_def) apply (drule_tac P="\tcb. tcbPriority tcb \ maxPriority" in obj_at_ko_at2', simp) apply (drule_tac P="\tcb. tcbDomain tcb \ maxDomain" in obj_at_ko_at2', simp) apply (simp add: ctcb_relation_tcbDomain_maxDomain_numDomains ctcb_relation_tcbPriority_maxPriority_numPriorities) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) + apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" in rf_sr_ctcb_queue_relation) apply (simp add: maxDom_to_H maxPrio_to_H)+ + apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" in head_end_ksReadyQueues_', fastforce+) apply (simp add: cready_queues_index_to_C_def2 numPriorities_def le_maxDomain_eq_less_numDomains) apply (clarsimp simp: ctcb_relation_def) apply (frule arg_cong[where f=unat], subst(asm) unat_ucast_up_simp, simp) - apply (frule tcb_queue'_head_end_NULL) - apply (erule conjunct1[OF valid_queues_valid_q]) - apply (frule(1) tcb_queue_relation_qhead_valid') - apply (simp add: valid_queues_valid_q) - apply (clarsimp simp: h_t_valid_clift_Some_iff) + apply (frule (3) head_end_ksReadyQueues_', fastforce+) + apply (clarsimp simp: ksReadyQueues_head_end_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (prop_tac "\ tcbQueueEmpty ((ksReadyQueues s (tcbDomain tcb, tcbPriority tcb)))") + apply (clarsimp simp: tcbQueueEmpty_def ctcb_queue_relation_def option_to_ctcb_ptr_def + split: option.splits) + apply (clarsimp simp: ksReadyQueues_head_end_tcb_at'_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (clarsimp simp: tcbQueueEmpty_def) + apply (rename_tac head "end" head_tcb end_tcb) + apply (prop_tac "tcb_at' head s") + apply (fastforce intro: aligned'_distinct'_ko_wp_at'I + simp: obj_at'_real_def opt_map_def split: option.splits) + apply (frule_tac thread=head in obj_at_cslift_tcb) + apply fastforce + apply (clarsimp dest: obj_at_cslift_tcb simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) done lemma cancel_all_ccorres_helper: "ccorres dc xfdc - (\s. valid_objs' s \ valid_queues s + (\s. valid_objs' s \ pspace_aligned' s \ pspace_distinct' s + \ ksReadyQueues_head_end s \ ksReadyQueues_head_end_tcb_at' s \ (\t\set ts. tcb_at' t s \ t \ 0) \ sch_act_wf (ksSchedulerAction s) s) {s'. \p. ep_queue_relation (cslift s') ts @@ -233,11 +356,11 @@ next apply (erule cmap_relationE1 [OF cmap_relation_tcb]) apply (erule ko_at_projectKO_opt) apply (fastforce intro: typ_heap_simps) - apply (wp sts_running_valid_queues | simp)+ + apply (wp sts_valid_objs' | simp)+ apply (rule ceqv_refl) apply (rule "Cons.hyps") apply (wp sts_valid_objs' sts_sch_act sch_act_wf_lift hoare_vcg_const_Ball_lift - sts_running_valid_queues sts_st_tcb' setThreadState_oa_queued | simp)+ + sts_st_tcb' | simp)+ apply (vcg exspec=setThreadState_cslift_spec exspec=tcbSchedEnqueue_cslift_spec) apply (clarsimp simp: tcb_at_not_NULL Collect_const_mem valid_tcb_state'_def @@ -251,16 +374,13 @@ next st_tcb_at'_def split: scheduler_action.split_asm) apply (rename_tac word) - apply (frule_tac x=word in tcbSchedEnqueue_cslift_precond_discharge) - apply simp - apply clarsimp - apply clarsimp - apply clarsimp + apply (frule_tac x=word in tcbSchedEnqueue_cslift_precond_discharge; clarsimp?) + apply simp apply clarsimp apply (rule conjI) apply (frule(3) tcbSchedEnqueue_cslift_precond_discharge) apply clarsimp - apply clarsimp + apply clarsimp+ apply (subst ep_queue_relation_shift, fastforce) apply (drule_tac x="tcb_ptr_to_ctcb_ptr thread" in fun_cong)+ @@ -269,11 +389,17 @@ next done qed +crunches setEndpoint, setNotification + for ksReadyQueues_head_end[wp]: ksReadyQueues_head_end + and ksReadyQueues_head_end_tcb_at'[wp]: ksReadyQueues_head_end_tcb_at' + (simp: updateObject_default_def) + lemma cancelAllIPC_ccorres: "ccorres dc xfdc - (invs') (UNIV \ {s. epptr_' s = Ptr epptr}) [] + invs' (UNIV \ {s. epptr_' s = Ptr epptr}) [] (cancelAllIPC epptr) (Call cancelAllIPC_'proc)" apply (cinit lift: epptr_') + apply (rule ccorres_stateAssert) apply (rule ccorres_symb_exec_l [OF _ getEndpoint_inv _ empty_fail_getEndpoint]) apply (rule_tac xf'=ret__unsigned_longlong_' and val="case ep of IdleEP \ scast EPState_Idle @@ -288,7 +414,7 @@ lemma cancelAllIPC_ccorres: apply (simp add: cendpoint_relation_def Let_def split: endpoint.split_asm) apply ceqv - apply (rule_tac A="invs' and ko_at' ep epptr" + apply (rule_tac A="invs' and ksReadyQueues_asrt and ko_at' ep epptr" in ccorres_guard_imp2[where A'=UNIV]) apply wpc apply (rename_tac list) @@ -330,12 +456,11 @@ lemma cancelAllIPC_ccorres: apply ceqv apply (ctac add: rescheduleRequired_ccorres) apply (wp weak_sch_act_wf_lift_linear - cancelAllIPC_mapM_x_valid_queues | simp)+ apply (rule mapM_x_wp', wp)+ apply (wp sts_st_tcb') apply (clarsimp split: if_split) - apply (rule mapM_x_wp', wp)+ + apply (rule mapM_x_wp', wp sts_valid_objs')+ apply (clarsimp simp: valid_tcb_state'_def) apply (simp add: guard_is_UNIV_def) apply (wp set_ep_valid_objs' hoare_vcg_const_Ball_lift @@ -379,18 +504,21 @@ lemma cancelAllIPC_ccorres: apply (rule cancel_all_ccorres_helper) apply ceqv apply (ctac add: rescheduleRequired_ccorres) - apply (wp cancelAllIPC_mapM_x_valid_queues) - apply (wp mapM_x_wp' weak_sch_act_wf_lift_linear + apply (wp mapM_x_wp' weak_sch_act_wf_lift_linear sts_valid_objs' sts_st_tcb' | clarsimp simp: valid_tcb_state'_def split: if_split)+ apply (simp add: guard_is_UNIV_def) apply (wp set_ep_valid_objs' hoare_vcg_const_Ball_lift weak_sch_act_wf_lift_linear) apply vcg - apply (clarsimp simp: valid_ep'_def invs_valid_objs' invs_queues) + apply (clarsimp simp: valid_ep'_def invs_valid_objs') apply (rule cmap_relationE1[OF cmap_relation_ep], assumption) apply (erule ko_at_projectKO_opt) apply (frule obj_at_valid_objs', clarsimp+) apply (clarsimp simp: projectKOs valid_obj'_def valid_ep'_def) + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (frule ksReadyQueues_asrt_ksReadyQueues_head_end) + apply (frule (2) ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at') subgoal by (auto simp: typ_heap_simps cendpoint_relation_def Let_def tcb_queue_relation'_def invs_valid_objs' valid_objs'_maxDomain valid_objs'_maxPriority @@ -402,9 +530,10 @@ lemma cancelAllIPC_ccorres: lemma cancelAllSignals_ccorres: "ccorres dc xfdc - (invs') (UNIV \ {s. ntfnPtr_' s = Ptr ntfnptr}) [] + invs' (UNIV \ {s. ntfnPtr_' s = Ptr ntfnptr}) [] (cancelAllSignals ntfnptr) (Call cancelAllSignals_'proc)" apply (cinit lift: ntfnPtr_') + apply (rule ccorres_stateAssert) apply (rule ccorres_symb_exec_l [OF _ get_ntfn_inv' _ empty_fail_getNotification]) apply (rule_tac xf'=ret__unsigned_longlong_' and val="case ntfnObj ntfn of IdleNtfn \ scast NtfnState_Idle @@ -419,7 +548,7 @@ lemma cancelAllSignals_ccorres: apply (simp add: cnotification_relation_def Let_def split: ntfn.split_asm) apply ceqv - apply (rule_tac A="invs' and ko_at' ntfn ntfnptr" + apply (rule_tac A="invs' and ksReadyQueues_asrt and ko_at' ntfn ntfnptr" in ccorres_guard_imp2[where A'=UNIV]) apply wpc apply (simp add: notification_state_defs ccorres_cond_iffs) @@ -460,8 +589,7 @@ lemma cancelAllSignals_ccorres: apply (rule cancel_all_ccorres_helper) apply ceqv apply (ctac add: rescheduleRequired_ccorres) - apply (wp cancelAllIPC_mapM_x_valid_queues) - apply (wp mapM_x_wp' weak_sch_act_wf_lift_linear + apply (wp mapM_x_wp' weak_sch_act_wf_lift_linear sts_valid_objs' sts_st_tcb' | clarsimp simp: valid_tcb_state'_def split: if_split)+ apply (simp add: guard_is_UNIV_def) apply (wp set_ntfn_valid_objs' hoare_vcg_const_Ball_lift @@ -472,10 +600,14 @@ lemma cancelAllSignals_ccorres: apply (erule ko_at_projectKO_opt) apply (frule obj_at_valid_objs', clarsimp+) apply (clarsimp simp add: valid_obj'_def valid_ntfn'_def projectKOs) + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (frule ksReadyQueues_asrt_ksReadyQueues_head_end) + apply (frule (2) ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at') subgoal by (auto simp: typ_heap_simps cnotification_relation_def - Let_def tcb_queue_relation'_def - invs_valid_objs' valid_objs'_maxDomain valid_objs'_maxPriority - intro!: obj_at_conj') + Let_def tcb_queue_relation'_def + invs_valid_objs' valid_objs'_maxDomain valid_objs'_maxPriority + intro!: obj_at_conj') apply (clarsimp simp: guard_is_UNIV_def) apply (wp getNotification_wp) apply clarsimp @@ -556,16 +688,16 @@ lemma tcb_queue_relation2_cong: context kernel_m begin -lemma setThreadState_ccorres_valid_queues'_simple: - "ccorres dc xfdc (\s. tcb_at' thread s \ valid_queues' s \ \ runnable' st \ sch_act_simple s) +lemma setThreadState_ccorres_simple: + "ccorres dc xfdc (\s. tcb_at' thread s \ \ runnable' st \ sch_act_simple s) ({s'. (\cl fl. cthread_state_relation_lifted st (cl\tsType_CL := ts_' s' && mask 4\, fl))} \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) [] (setThreadState st thread) (Call setThreadState_'proc)" apply (cinit lift: tptr_' cong add: call_ignore_cong) apply (ctac (no_vcg) add: threadSet_tcbState_simple_corres) apply (ctac add: scheduleTCB_ccorres_valid_queues'_simple) - apply (wp threadSet_valid_queues'_and_not_runnable') - apply (clarsimp simp: weak_sch_act_wf_def valid_queues'_def) + apply (wp threadSet_tcbState_st_tcb_at') + apply (fastforce simp: weak_sch_act_wf_def) done lemma updateRestartPC_ccorres: @@ -581,9 +713,7 @@ lemma updateRestartPC_ccorres: done crunches updateRestartPC - for valid_queues'[wp]: valid_queues' - and sch_act_simple[wp]: sch_act_simple - and valid_queues[wp]: Invariants_H.valid_queues + for sch_act_simple[wp]: sch_act_simple and valid_objs'[wp]: valid_objs' and tcb_at'[wp]: "tcb_at' p" @@ -627,21 +757,12 @@ lemma suspend_ccorres: apply (ctac (no_vcg) add: updateRestartPC_ccorres) apply (rule ccorres_return_Skip) apply ceqv - apply (ctac(no_vcg) add: setThreadState_ccorres_valid_queues'_simple) - apply (ctac add: tcbSchedDequeue_ccorres') - apply (rule_tac Q="\_. - (\s. \t' d p. (t' \ set (ksReadyQueues s (d, p)) \ - obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d - \ tcbPriority tcb = p) t' s \ - (t' \ thread \ st_tcb_at' runnable' t' s)) \ - distinct (ksReadyQueues s (d, p))) and valid_queues' and valid_objs' and tcb_at' thread" - in hoare_post_imp) + apply (ctac(no_vcg) add: setThreadState_ccorres_simple) + apply (ctac add: tcbSchedDequeue_ccorres) + apply (rule_tac Q="\_. valid_objs' and tcb_at' thread and pspace_aligned' and pspace_distinct'" + in hoare_post_imp) apply clarsimp - apply (drule_tac x="t" in spec) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp elim!: obj_at'_weakenE simp: inQ_def) - apply (wp sts_valid_queues_partial)[1] + apply (wp sts_valid_objs')[1] apply clarsimp apply (wpsimp simp: valid_tcb_state'_def) apply clarsimp @@ -656,8 +777,7 @@ lemma suspend_ccorres: apply (rule cancelIPC_sch_act_simple) apply (rule cancelIPC_tcb_at'[where t=thread]) apply (rule delete_one_conc_fr.cancelIPC_invs) - apply (fastforce simp: invs_valid_queues' invs_queues invs_valid_objs' - valid_tcb_state'_def) + apply (fastforce simp: invs_valid_objs' valid_tcb_state'_def) apply (auto simp: ThreadState_defs) done @@ -1747,23 +1867,6 @@ lemma ep_queue_relation_shift2: apply (clarsimp split: option.split_asm) done -lemma sched_queue_relation_shift: - "(option_map2 tcbSchedNext_C (f (cslift s)) - = option_map2 tcbSchedNext_C (cslift s) - \ option_map2 tcbSchedPrev_C (f (cslift s)) - = option_map2 tcbSchedPrev_C (cslift s)) - \ sched_queue_relation (f (cslift s)) ts qPrev qHead - = sched_queue_relation (cslift s) ts qPrev qHead" - apply clarsimp - apply (induct ts arbitrary: qPrev qHead) - apply simp - apply simp - apply (simp add: option_map2_def fun_eq_iff - map_option_case) - apply (drule_tac x=qHead in spec)+ - apply (clarsimp split: option.split_asm) - done - lemma cendpoint_relation_udpate_arch: "\ cslift x p = Some tcb ; cendpoint_relation (cslift x) v v' \ \ cendpoint_relation ((cslift x)(p \ tcbArch_C_update f tcb)) v v'" diff --git a/proof/crefine/X64/Interrupt_C.thy b/proof/crefine/X64/Interrupt_C.thy index f623cebd71..4f21490401 100644 --- a/proof/crefine/X64/Interrupt_C.thy +++ b/proof/crefine/X64/Interrupt_C.thy @@ -258,7 +258,7 @@ lemma decodeIRQHandlerInvocation_ccorres: apply (simp add: syscall_error_to_H_cases) apply simp apply (clarsimp simp: Collect_const_mem tcb_at_invs') - apply (clarsimp simp: invs_queues invs_valid_objs' + apply (clarsimp simp: invs_valid_objs' ct_in_state'_def ccap_rights_relation_def mask_def[where n=4] ThreadState_defs) @@ -274,7 +274,7 @@ lemma decodeIRQHandlerInvocation_ccorres: excaps_map_def excaps_in_mem_def word_less_nat_alt hd_conv_nth slotcap_in_mem_def valid_tcb_state'_def dest!: interpret_excaps_eq split: bool.splits)+ - apply (auto dest: st_tcb_at_idle_thread' ctes_of_valid')[4] + apply (auto dest: st_tcb_at_idle_thread' ctes_of_valid')[6] apply (drule ctes_of_valid') apply fastforce apply (clarsimp simp add:valid_cap_simps' X64.maxIRQ_def) @@ -863,9 +863,9 @@ from assms show ?thesis apply (rule hoare_weaken_pre[where P="?pre"]) apply (rule isIRQActive_wp) apply (clarsimp simp: sysargs_rel_to_n unat_less_2p_word_bits - invs_valid_objs' tcb_at_invs' invs_queues valid_tcb_state'_def + invs_valid_objs' tcb_at_invs' valid_tcb_state'_def invs_sch_act_wf' ct_in_state'_def cte_wp_at_weakenE' - pred_tcb'_weakenE) + pred_tcb'_weakenE invs_pspace_aligned' invs_pspace_distinct') apply (subst pred_tcb'_weakenE, assumption, fastforce)+ apply (rule conjI) apply (rule TrueI) @@ -962,9 +962,9 @@ from assms show ?thesis apply (rule hoare_weaken_pre[where P="?pre"]) apply wp apply (clarsimp simp: invs_valid_objs' tcb_at_invs' - invs_queues valid_tcb_state'_def + valid_tcb_state'_def invs_pspace_aligned' invs_sch_act_wf' ct_in_state'_def - cte_wp_at_weakenE') + cte_wp_at_weakenE' invs_pspace_distinct') apply (subst pred_tcb'_weakenE, assumption, fastforce)+ apply (intro conjI impI) apply (rule TrueI)+ @@ -995,7 +995,7 @@ from assms show ?thesis apply clarsimp apply (fastforce simp: guard_is_UNIV_def interpret_excaps_eq excaps_map_def split: Product_Type.prod.split) - apply (auto simp: invs_queues invs_valid_objs' ct_in_state'_def irqIntOffset_def + apply (auto simp: invs_valid_objs' ct_in_state'_def irqIntOffset_def ccap_rights_relation_def mask_def[where n=4] ThreadState_defs rf_sr_ksCurThread cte_wp_at_ctes_of sysargs_rel_def sysargs_rel_n_def diff --git a/proof/crefine/X64/Invoke_C.thy b/proof/crefine/X64/Invoke_C.thy index 55ed9207d4..c973fecac7 100644 --- a/proof/crefine/X64/Invoke_C.thy +++ b/proof/crefine/X64/Invoke_C.thy @@ -79,15 +79,14 @@ lemma setDomain_ccorres: and (\s. curThread = ksCurThread s)" in hoare_strengthen_post) apply (wp threadSet_all_invs_but_sch_extra) - apply (clarsimp simp: valid_pspace_valid_objs' st_tcb_at_def[symmetric] - sch_act_simple_def st_tcb_at'_def weak_sch_act_wf_def - split: if_splits) + apply (fastforce simp: valid_pspace_valid_objs' st_tcb_at_def[symmetric] + sch_act_simple_def st_tcb_at'_def weak_sch_act_wf_def + split: if_splits) apply (simp add: guard_is_UNIV_def) - apply (rule_tac Q="\_. invs' and tcb_at' t and sch_act_simple - and (\s. curThread = ksCurThread s \ (\p. t \ set (ksReadyQueues s p)))" + apply (rule_tac Q="\_. invs' and tcb_at' t and sch_act_simple and (\s. curThread = ksCurThread s)" in hoare_strengthen_post) apply (wp weak_sch_act_wf_lift_linear tcbSchedDequeue_not_queued - tcbSchedDequeue_not_in_queue hoare_vcg_imp_lift hoare_vcg_all_lift) + hoare_vcg_imp_lift hoare_vcg_all_lift) apply (clarsimp simp: invs'_def valid_pspace'_def valid_state'_def) apply (fastforce simp: valid_tcb'_def tcb_cte_cases_def invs'_def valid_state'_def valid_pspace'_def) @@ -195,8 +194,8 @@ lemma decodeDomainInvocation_ccorres: apply clarsimp apply (vcg exspec=getSyscallArg_modifies) - apply (clarsimp simp: valid_tcb_state'_def invs_valid_queues' invs_valid_objs' - invs_queues invs_sch_act_wf' ct_in_state'_def pred_tcb_at' + apply (clarsimp simp: valid_tcb_state'_def invs_valid_objs' + invs_sch_act_wf' ct_in_state'_def pred_tcb_at' rf_sr_ksCurThread word_sle_def word_sless_def sysargs_rel_to_n mask_eq_iff_w2p mask_eq_iff_w2p word_size ThreadState_defs) apply (rule conjI) @@ -206,7 +205,7 @@ lemma decodeDomainInvocation_ccorres: apply (drule_tac x="extraCaps ! 0" and P="\v. valid_cap' (fst v) s" in bspec) apply (clarsimp simp: nth_mem interpret_excaps_test_null excaps_map_def) apply (clarsimp simp: valid_cap_simps' pred_tcb'_weakenE active_runnable') - apply (rule conjI) + apply (intro conjI; fastforce?) apply (fastforce simp: tcb_st_refs_of'_def elim:pred_tcb'_weakenE) apply (simp add: word_le_nat_alt unat_ucast unat_numDomains_to_H le_maxDomain_eq_less_numDomains) apply (clarsimp simp: ccap_relation_def cap_to_H_simps cap_thread_cap_lift) @@ -758,15 +757,15 @@ lemma decodeCNodeInvocation_ccorres: apply simp apply (wp injection_wp_E[OF refl]) apply (rule hoare_post_imp_R) - apply (rule_tac Q'="\rv. valid_pspace' and valid_queues + apply (rule_tac Q'="\rv. valid_pspace' and valid_cap' rv and valid_objs' and tcb_at' thread and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_vcg_R_conj) apply (rule deriveCap_Null_helper[OF deriveCap_derived]) apply wp apply (clarsimp simp: cte_wp_at_ctes_of) - apply (simp add: is_derived'_def badge_derived'_def - valid_tcb_state'_def) + apply (fastforce simp: is_derived'_def badge_derived'_def + valid_tcb_state'_def) apply (simp add: Collect_const_mem all_ex_eq_helper) apply (vcg exspec=deriveCap_modifies) apply wp @@ -834,14 +833,14 @@ lemma decodeCNodeInvocation_ccorres: apply (simp add: conj_comms valid_tcb_state'_def) apply (wp injection_wp_E[OF refl]) apply (rule hoare_post_imp_R) - apply (rule_tac Q'="\rv. valid_pspace' and valid_queues + apply (rule_tac Q'="\rv. valid_pspace' and valid_cap' rv and valid_objs' and tcb_at' thread and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_vcg_R_conj) apply (rule deriveCap_Null_helper [OF deriveCap_derived]) apply wp apply (clarsimp simp: cte_wp_at_ctes_of) - apply (simp add: is_derived'_def badge_derived'_def) + apply (fastforce simp: is_derived'_def badge_derived'_def) apply (simp add: Collect_const_mem all_ex_eq_helper) apply (vcg exspec=deriveCap_modifies) apply (simp add: Collect_const_mem) @@ -949,12 +948,14 @@ lemma decodeCNodeInvocation_ccorres: apply (rule_tac Q'="\a b. cte_wp_at' (\x. True) a b \ invs' b \ tcb_at' thread b \ sch_act_wf (ksSchedulerAction b) b \ valid_tcb_state' Restart b \ Q2 b" for Q2 in hoare_post_imp_R) - prefer 2 - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (drule ctes_of_valid') - apply (erule invs_valid_objs') - apply (clarsimp simp:valid_updateCapDataI invs_queues invs_valid_objs' invs_valid_pspace') - apply (assumption) + prefer 2 + apply (clarsimp simp:cte_wp_at_ctes_of) + apply (drule ctes_of_valid') + apply (erule invs_valid_objs') + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (clarsimp simp:valid_updateCapDataI invs_valid_objs' invs_valid_pspace') + apply assumption apply (wp hoare_vcg_all_lift_R injection_wp_E[OF refl] lsfco_cte_at' hoare_vcg_const_imp_lift_R )+ @@ -1349,7 +1350,7 @@ lemma decodeCNodeInvocation_ccorres: apply simp apply (vcg exspec=getSyscallArg_modifies) apply (clarsimp simp: valid_tcb_state'_def invs_valid_objs' invs_valid_pspace' - ct_in_state'_def pred_tcb_at' invs_queues + ct_in_state'_def pred_tcb_at' cur_tcb'_def word_sle_def word_sless_def unat_lt2p[where 'a=machine_word_len, folded word_bits_def]) apply (rule conjI) @@ -1381,9 +1382,6 @@ end context begin interpretation Arch . (*FIXME: arch_split*) -crunch valid_queues[wp]: insertNewCap "valid_queues" - (wp: crunch_wps) - lemmas setCTE_def3 = setCTE_def2[THEN eq_reflection] lemma setCTE_sch_act_wf[wp]: @@ -3299,7 +3297,7 @@ lemma decodeUntypedInvocation_ccorres_helper: and sch_act_simple and ct_active'" in hoare_post_imp_R) prefer 2 apply (clarsimp simp: invs_valid_objs' invs_mdb' - invs_queues ct_in_state'_def pred_tcb_at') + ct_in_state'_def pred_tcb_at') apply (subgoal_tac "ksCurThread s \ ksIdleThread sa") prefer 2 apply clarsimp diff --git a/proof/crefine/X64/IpcCancel_C.thy b/proof/crefine/X64/IpcCancel_C.thy index dc119f4023..b02cee0a07 100644 --- a/proof/crefine/X64/IpcCancel_C.thy +++ b/proof/crefine/X64/IpcCancel_C.thy @@ -13,12 +13,12 @@ context kernel_m begin lemma cready_queues_index_to_C_in_range': - assumes prems: "qdom \ ucast maxDom" "prio \ ucast maxPrio" + assumes prems: "qdom \ maxDomain" "prio \ maxPriority" shows "cready_queues_index_to_C qdom prio < num_tcb_queues" proof - have P: "unat prio < numPriorities" using prems - by (simp add: numPriorities_def seL4_MaxPrio_def Suc_le_lessD unat_le_helper) + by (simp add: numPriorities_def Suc_le_lessD unat_le_helper maxDomain_def maxPriority_def) have Q: "unat qdom < numDomains" using prems by (simp add: maxDom_to_H le_maxDomain_eq_less_numDomains word_le_nat_alt) @@ -32,36 +32,18 @@ lemmas cready_queues_index_to_C_in_range = lemma cready_queues_index_to_C_inj: "\ cready_queues_index_to_C qdom prio = cready_queues_index_to_C qdom' prio'; - prio \ ucast maxPrio; prio' \ ucast maxPrio \ \ prio = prio' \ qdom = qdom'" + prio \ maxPriority; prio' \ maxPriority \ \ prio = prio' \ qdom = qdom'" apply (rule context_conjI) - apply (auto simp: cready_queues_index_to_C_def numPriorities_def + apply (auto simp: cready_queues_index_to_C_def numPriorities_def maxPriority_def seL4_MaxPrio_def word_le_nat_alt dest: arg_cong[where f="\x. x mod 256"]) done lemma cready_queues_index_to_C_distinct: - "\ qdom = qdom' \ prio \ prio'; prio \ ucast maxPrio; prio' \ ucast maxPrio \ + "\ qdom = qdom' \ prio \ prio'; prio \ maxPriority; prio' \ maxPriority \ \ cready_queues_index_to_C qdom prio \ cready_queues_index_to_C qdom' prio'" apply (auto simp: cready_queues_index_to_C_inj) done -lemma cstate_relation_ksReadyQueues_update: - "\ cstate_relation hs cs; arr = ksReadyQueues_' cs; - sched_queue_relation' (clift (t_hrs_' cs)) v (head_C v') (end_C v'); - qdom \ ucast maxDom; prio \ ucast maxPrio \ - \ cstate_relation (ksReadyQueues_update (\qs. qs ((qdom, prio) := v)) hs) - (ksReadyQueues_'_update (\_. Arrays.update arr - (cready_queues_index_to_C qdom prio) v') cs)" - apply (clarsimp simp: cstate_relation_def Let_def - cmachine_state_relation_def - carch_state_relation_def carch_globals_def - cready_queues_relation_def seL4_MinPrio_def minDom_def) - apply (frule cready_queues_index_to_C_in_range, assumption) - apply clarsimp - apply (frule_tac qdom=qdoma and prio=prioa in cready_queues_index_to_C_in_range, assumption) - apply (frule cready_queues_index_to_C_distinct, assumption+) - apply clarsimp - done - lemma cmap_relation_drop_fun_upd: "\ cm x = Some v; \v''. rel v'' v = rel v'' v' \ \ cmap_relation am (cm (x \ v')) f rel @@ -72,16 +54,6 @@ lemma cmap_relation_drop_fun_upd: apply (auto split: if_split) done -lemma valid_queuesD': - "\ obj_at' (inQ d p) t s; valid_queues' s \ - \ t \ set (ksReadyQueues s (d, p))" - by (simp add: valid_queues'_def) - -lemma invs_valid_queues'[elim!]: - "invs' s \ valid_queues' s" - by (simp add: invs'_def valid_state'_def) - - lemma ntfn_ptr_get_queue_spec: "\s. \ \ {\. s = \ \ \ \\<^sub>c \<^bsup>\\<^esup>ntfnPtr} \ret__struct_tcb_queue_C :== PROC ntfn_ptr_get_queue(\ntfnPtr) \head_C \ret__struct_tcb_queue_C = Ptr (ntfnQueue_head_CL (notification_lift (the (cslift s \<^bsup>s\<^esup>ntfnPtr)))) \ @@ -236,22 +208,19 @@ lemma cancelSignal_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) - apply simp - apply (erule (1) map_to_ko_atI') - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) - apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def) - apply (simp add: carch_state_relation_def carch_globals_def) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) + apply simp + apply (erule (1) map_to_ko_atI') + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) + apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def) + apply (simp add: carch_state_relation_def carch_globals_def) apply (clarsimp simp: carch_state_relation_def carch_globals_def typ_heap_simps' packed_heap_update_collapse_hrs fpu_null_state_heap_update_tag_disj_simps @@ -275,33 +244,30 @@ lemma cancelSignal_ccorres_helper: apply (elim conjE) apply (intro conjI) \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_ntfn_queue) - apply fastforce - apply assumption+ - apply simp - apply (erule (1) map_to_ko_atI') + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cendpoint_relation_ntfn_queue) + apply fastforce + apply assumption+ + apply simp + apply (erule (1) map_to_ko_atI') \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) - apply (simp add: cnotification_relation_def Let_def isWaitingNtfn_def - split: ntfn.splits split del: if_split) - apply (erule iffD1 [OF tcb_queue_relation'_cong [OF refl _ _ refl], rotated -1]) - apply (clarsimp simp add: h_t_valid_clift_Some_iff) - apply (subst tcb_queue_relation'_next_sign; assumption?) - apply fastforce - apply (simp add: notification_lift_def sign_extend_sign_extend_eq) - apply (clarsimp simp: h_t_valid_clift_Some_iff notification_lift_def sign_extend_sign_extend_eq) - apply (subst tcb_queue_relation'_prev_sign; assumption?) + apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) + apply (simp add: cnotification_relation_def Let_def isWaitingNtfn_def + split: ntfn.splits split del: if_split) + apply (erule iffD1 [OF tcb_queue_relation'_cong [OF refl _ _ refl], rotated -1]) + apply (clarsimp simp add: h_t_valid_clift_Some_iff) + apply (subst tcb_queue_relation'_next_sign; assumption?) apply fastforce - apply simp + apply (simp add: notification_lift_def sign_extend_sign_extend_eq) + apply (clarsimp simp: h_t_valid_clift_Some_iff notification_lift_def sign_extend_sign_extend_eq) + apply (subst tcb_queue_relation'_prev_sign; assumption?) + apply fastforce apply simp - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply simp subgoal by (clarsimp simp: carch_state_relation_def carch_globals_def fpu_null_state_heap_update_tag_disj_simps global_ioport_bitmap_heap_update_tag_disj_simps @@ -470,68 +436,6 @@ lemma isRunnable_ccorres [corres]: apply (simp add: ThreadState_defs)+ done - - -lemma tcb_queue_relation_update_head: - fixes getNext_update :: "(tcb_C ptr \ tcb_C ptr) \ tcb_C \ tcb_C" and - getPrev_update :: "(tcb_C ptr \ tcb_C ptr) \ tcb_C \ tcb_C" - assumes qr: "tcb_queue_relation getNext getPrev mp queue NULL qhead" - and qh': "qhead' \ tcb_ptr_to_ctcb_ptr ` set queue" - and cs_tcb: "mp qhead' = Some tcb" - and valid_ep: "\t\set queue. tcb_at' t s" "distinct queue" - and qhN: "qhead' \ NULL" - and fgN: "fg_cons getNext (getNext_update \ (\x _. x))" - and fgP: "fg_cons getPrev (getPrev_update \ (\x _. x))" - and npu: "\f t. getNext (getPrev_update f t) = getNext t" - and pnu: "\f t. getPrev (getNext_update f t) = getPrev t" - shows "tcb_queue_relation getNext getPrev - (upd_unless_null qhead (getPrev_update (\_. qhead') (the (mp qhead))) - (mp(qhead' := Some (getPrev_update (\_. NULL) (getNext_update (\_. qhead) tcb))))) - (ctcb_ptr_to_tcb_ptr qhead' # queue) NULL qhead'" - using qr qh' cs_tcb valid_ep qhN - apply (subgoal_tac "qhead \ qhead'") - apply (clarsimp simp: pnu upd_unless_null_def fg_consD1 [OF fgN] fg_consD1 [OF fgP] npu) - apply (cases queue) - apply simp - apply (frule (2) tcb_queue_relation_next_not_NULL) - apply simp - apply (clarsimp simp: fg_consD1 [OF fgN] fg_consD1 [OF fgP] pnu npu) - apply (subst tcb_queue_relation_cong [OF refl refl refl, where mp' = mp]) - apply (clarsimp simp: inj_eq) - apply (intro impI conjI) - apply (frule_tac x = x in imageI [where f = tcb_ptr_to_ctcb_ptr]) - apply simp - apply simp - apply simp - apply clarsimp - apply (cases queue) - apply simp - apply simp - done - -lemma tcbSchedEnqueue_update: - assumes sr: "sched_queue_relation' mp queue qhead qend" - and qh': "qhead' \ tcb_ptr_to_ctcb_ptr ` set queue" - and cs_tcb: "mp qhead' = Some tcb" - and valid_ep: "\t\set queue. tcb_at' t s" "distinct queue" - and qhN: "qhead' \ NULL" - shows - "sched_queue_relation' - (upd_unless_null qhead (tcbSchedPrev_C_update (\_. qhead') (the (mp qhead))) - (mp(qhead' \ tcb\tcbSchedNext_C := qhead, tcbSchedPrev_C := NULL\))) - (ctcb_ptr_to_tcb_ptr qhead' # queue) qhead' (if qend = NULL then qhead' else qend)" - using sr qh' cs_tcb valid_ep qhN - apply - - apply (erule tcb_queue_relationE') - apply (rule tcb_queue_relationI') - apply (erule (5) tcb_queue_relation_update_head - [where getNext_update = tcbSchedNext_C_update and getPrev_update = tcbSchedPrev_C_update], simp_all)[1] - apply simp - apply (intro impI) - apply (erule (1) tcb_queue_relation_not_NULL') - apply simp - done - lemma tcb_ptr_to_ctcb_ptr_imageD: "x \ tcb_ptr_to_ctcb_ptr ` S \ ctcb_ptr_to_tcb_ptr x \ S" apply (erule imageE) @@ -544,93 +448,6 @@ lemma ctcb_ptr_to_tcb_ptr_imageI: apply simp done -lemma tcb_queue'_head_end_NULL: - assumes qr: "tcb_queue_relation' getNext getPrev mp queue qhead qend" - and tat: "\t\set queue. tcb_at' t s" - shows "(qend = NULL) = (qhead = NULL)" - using qr tat - apply - - apply (erule tcb_queue_relationE') - apply (simp add: tcb_queue_head_empty_iff) - apply (rule impI) - apply (rule tcb_at_not_NULL) - apply (erule bspec) - apply simp - done - -lemma tcb_queue_relation_qhead_mem: - "\ tcb_queue_relation getNext getPrev mp queue NULL qhead; - (\tcb\set queue. tcb_at' tcb t) \ - \ qhead \ NULL \ ctcb_ptr_to_tcb_ptr qhead \ set queue" - by (clarsimp simp: tcb_queue_head_empty_iff tcb_queue_relation_head_hd) - -lemma tcb_queue_relation_qhead_valid: - "\ tcb_queue_relation getNext getPrev (cslift s') queue NULL qhead; - (s, s') \ rf_sr; (\tcb\set queue. tcb_at' tcb s) \ - \ qhead \ NULL \ s' \\<^sub>c qhead" - apply (frule (1) tcb_queue_relation_qhead_mem) - apply clarsimp - apply(drule (3) tcb_queue_memberD) - apply (simp add: h_t_valid_clift_Some_iff) - done - -lemmas tcb_queue_relation_qhead_mem' = tcb_queue_relation_qhead_mem [OF tcb_queue_relation'_queue_rel] -lemmas tcb_queue_relation_qhead_valid' = tcb_queue_relation_qhead_valid [OF tcb_queue_relation'_queue_rel] - - -lemma valid_queues_valid_q: - "valid_queues s \ (\tcb\set (ksReadyQueues s (qdom, prio)). tcb_at' tcb s) \ distinct (ksReadyQueues s (qdom, prio))" - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def) - apply (drule spec [where x = qdom]) - apply (drule spec [where x = prio]) - apply clarsimp - apply (drule (1) bspec, erule obj_at'_weakenE) - apply simp - done - -lemma invs_valid_q: - "invs' s \ (\tcb\set (ksReadyQueues s (qdom, prio)). tcb_at' tcb s) \ distinct (ksReadyQueues s (qdom, prio))" - apply (rule valid_queues_valid_q) - apply (clarsimp simp: invs'_def valid_state'_def) - done - -lemma tcbQueued_not_in_queues: - assumes vq: "valid_queues s" - and objat: "obj_at' (Not \ tcbQueued) thread s" - shows "thread \ set (ksReadyQueues s (d, p))" - using vq objat - apply - - apply clarsimp - apply (drule (1) valid_queues_obj_at'D) - apply (erule obj_atE')+ - apply (clarsimp simp: inQ_def) - done - - -lemma rf_sr_sched_queue_relation: - "\ (s, s') \ rf_sr; d \ ucast maxDom; p \ ucast maxPrio \ - \ sched_queue_relation' (cslift s') (ksReadyQueues s (d, p)) - (head_C (index (ksReadyQueues_' (globals s')) - (cready_queues_index_to_C d p))) - (end_C (index (ksReadyQueues_' (globals s')) - (cready_queues_index_to_C d p)))" - unfolding rf_sr_def cstate_relation_def cready_queues_relation_def - apply (clarsimp simp: Let_def seL4_MinPrio_def minDom_def) - done - -lemma ready_queue_not_in: - assumes vq: "valid_queues s" - and inq: "t \ set (ksReadyQueues s (d, p))" - and neq: "d \ d' \ p \ p'" - shows "t \ set (ksReadyQueues s (d', p'))" -proof - assume "t \ set (ksReadyQueues s (d', p'))" - hence "obj_at' (inQ d' p') t s" using vq by (rule valid_queues_obj_at'D) - moreover have "obj_at' (inQ d p) t s" using inq vq by (rule valid_queues_obj_at'D) - ultimately show False using neq - by (clarsimp elim!: obj_atE' simp: inQ_def) -qed - lemma ctcb_relation_unat_prio_eq: "ctcb_relation tcb tcb' \ unat (tcbPriority tcb) = unat (tcbPriority_C tcb')" apply (clarsimp simp: ctcb_relation_def) @@ -664,138 +481,6 @@ lemma threadSet_queued_ccorres [corres]: apply (clarsimp simp: typ_heap_simps) done -lemma ccorres_pre_getQueue: - assumes cc: "\queue. ccorres r xf (P queue) (P' queue) hs (f queue) c" - shows "ccorres r xf (\s. P (ksReadyQueues s (d, p)) s \ d \ maxDomain \ p \ maxPriority) - {s'. \queue. (let cqueue = index (ksReadyQueues_' (globals s')) - (cready_queues_index_to_C d p) in - sched_queue_relation' (cslift s') queue (head_C cqueue) (end_C cqueue)) \ s' \ P' queue} - hs (getQueue d p >>= (\queue. f queue)) c" - apply (rule ccorres_guard_imp2) - apply (rule ccorres_symb_exec_l2) - defer - defer - apply (rule gq_sp) - defer - apply (rule ccorres_guard_imp) - apply (rule cc) - apply clarsimp - apply assumption - apply assumption - apply (clarsimp simp: getQueue_def gets_exs_valid) - apply clarsimp - apply (drule spec, erule mp) - apply (simp add: Let_def) - apply (erule rf_sr_sched_queue_relation) - apply (simp add: maxDom_to_H maxPrio_to_H)+ - done - -lemma state_relation_queue_update_helper': - "\ (s, s') \ rf_sr; - (\d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct (ksReadyQueues s (d, p))); - globals t = ksReadyQueues_'_update - (\_. Arrays.update (ksReadyQueues_' (globals s')) prio' q') - (t_hrs_'_update f (globals s')); - sched_queue_relation' (cslift t) q (head_C q') (end_C q'); - cslift t |` ( - tcb_ptr_to_ctcb_ptr ` S ) - = cslift s' |` ( - tcb_ptr_to_ctcb_ptr ` S ); - option_map tcb_null_sched_ptrs \ cslift t - = option_map tcb_null_sched_ptrs \ cslift s'; - cslift_all_but_tcb_C t s'; - zero_ranges_are_zero (gsUntypedZeroRanges s) (f (t_hrs_' (globals s'))) - = zero_ranges_are_zero (gsUntypedZeroRanges s) (t_hrs_' (globals s')); - hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s')); - prio' = cready_queues_index_to_C qdom prio; - \x \ S. obj_at' (inQ qdom prio) x s - \ (obj_at' (\tcb. tcbPriority tcb = prio) x s - \ obj_at' (\tcb. tcbDomain tcb = qdom) x s) - \ (tcb_at' x s \ (\d' p'. (d' \ qdom \ p' \ prio) - \ x \ set (ksReadyQueues s (d', p')))); - S \ {}; qdom \ ucast maxDom; prio \ ucast maxPrio \ - \ (s \ksReadyQueues := (ksReadyQueues s)((qdom, prio) := q)\, t) \ rf_sr" - apply (subst(asm) disj_imp_rhs) - apply (subst obj_at'_and[symmetric]) - apply (rule disjI1, erule obj_at'_weakenE, simp add: inQ_def) - apply (subst(asm) disj_imp_rhs) - apply (subst(asm) obj_at'_and[symmetric]) - apply (rule conjI, erule obj_at'_weakenE, simp) - apply (rule allI, rule allI) - apply (drule_tac x=d' in spec) - apply (drule_tac x=p' in spec) - apply clarsimp - apply (drule(1) bspec) - apply (clarsimp simp: inQ_def obj_at'_def) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def) - apply (intro conjI) - \ \cpspace_relation\ - apply (erule nonemptyE, drule(1) bspec) - apply (clarsimp simp: cpspace_relation_def) - apply (drule obj_at_ko_at', clarsimp) - apply (rule cmap_relationE1, assumption, - erule ko_at_projectKO_opt) - apply (frule null_sched_queue) - apply (frule null_sched_epD) - apply (intro conjI) - \ \tcb relation\ - apply (drule ctcb_relation_null_queue_ptrs, - simp_all)[1] - \ \endpoint relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (erule cendpoint_relation_upd_tcb_no_queues, simp+) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (erule cnotification_relation_upd_tcb_no_queues, simp+) - \ \ready queues\ - apply (simp add: cready_queues_relation_def Let_def cready_queues_index_to_C_in_range - seL4_MinPrio_def minDom_def) - apply clarsimp - apply (frule cready_queues_index_to_C_distinct, assumption+) - apply (clarsimp simp: cready_queues_index_to_C_in_range all_conj_distrib) - apply (rule iffD1 [OF tcb_queue_relation'_cong[OF refl], rotated -1], - drule spec, drule spec, erule mp, simp+) - apply clarsimp - apply (drule_tac x="tcb_ptr_to_ctcb_ptr x" in fun_cong)+ - apply (clarsimp simp: restrict_map_def - split: if_split_asm) - by (auto simp: carch_state_relation_def cmachine_state_relation_def - elim!: fpu_null_state_typ_heap_preservation) - -lemma state_relation_queue_update_helper: - "\ (s, s') \ rf_sr; valid_queues s; - globals t = ksReadyQueues_'_update - (\_. Arrays.update (ksReadyQueues_' (globals s')) prio' q') - (t_hrs_'_update f (globals s')); - sched_queue_relation' (cslift t) q (head_C q') (end_C q'); - cslift t |` ( - tcb_ptr_to_ctcb_ptr ` S ) - = cslift s' |` ( - tcb_ptr_to_ctcb_ptr ` S ); - option_map tcb_null_sched_ptrs \ cslift t - = option_map tcb_null_sched_ptrs \ cslift s'; - cslift_all_but_tcb_C t s'; - zero_ranges_are_zero (gsUntypedZeroRanges s) (f (t_hrs_' (globals s'))) - = zero_ranges_are_zero (gsUntypedZeroRanges s) (t_hrs_' (globals s')); - hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s')); - prio' = cready_queues_index_to_C qdom prio; - \x \ S. obj_at' (inQ qdom prio) x s - \ (obj_at' (\tcb. tcbPriority tcb = prio) x s - \ obj_at' (\tcb. tcbDomain tcb = qdom) x s) - \ (tcb_at' x s \ (\d' p'. (d' \ qdom \ p' \ prio) - \ x \ set (ksReadyQueues s (d', p')))); - S \ {}; qdom \ ucast maxDom; prio \ ucast maxPrio \ - \ (s \ksReadyQueues := (ksReadyQueues s)((qdom, prio) := q)\, t) \ rf_sr" - apply (subgoal_tac "\d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct(ksReadyQueues s (d, p))") - apply (erule(5) state_relation_queue_update_helper', simp_all) - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE, clarsimp) - done - (* FIXME: move *) lemma cmap_relation_no_upd: "\ cmap_relation a c f rel; a p = Some ko; rel ko v; inj f \ \ cmap_relation a (c(f p \ v)) f rel" @@ -840,8 +525,8 @@ lemma cready_queues_index_to_C_def2: lemma ready_queues_index_spec: "\s. \ \ {s'. s' = s \ (Kernel_Config.numDomains \ 1 \ dom_' s' = 0)} Call ready_queues_index_'proc - \\ret__unsigned_long = (dom_' s) * 0x100 + (prio_' s)\" - by vcg (simp add: numDomains_sge_1_simp) + \\ret__unsigned_long = (dom_' s) * word_of_nat numPriorities + (prio_' s)\" + by vcg (simp add: numDomains_sge_1_simp numPriorities_def) lemma prio_to_l1index_spec: "\s. \ \ {s} Call prio_to_l1index_'proc @@ -936,56 +621,6 @@ lemma cbitmap_L2_relation_bit_set: apply (case_tac "da = d" ; clarsimp simp: num_domains_index_updates) done -lemma carch_state_relation_enqueue_simp: - "carch_state_relation (ksArchState \) - (t_hrs_'_update f - (globals \' \ksReadyQueuesL1Bitmap_' := l1upd, ksReadyQueuesL2Bitmap_' := l2upd \) - \ksReadyQueues_' := rqupd \) = - carch_state_relation (ksArchState \) (t_hrs_'_update f (globals \'))" - unfolding carch_state_relation_def - by clarsimp - -lemma t_hrs_ksReadyQueues_upd_absorb: - "t_hrs_'_update f (g s) \ksReadyQueues_' := rqupd \ = - t_hrs_'_update f (g s \ksReadyQueues_' := rqupd\)" - by simp - -lemma rf_sr_drop_bitmaps_enqueue_helper: - "\ (\,\') \ rf_sr ; - cbitmap_L1_relation ksqL1upd' ksqL1upd ; cbitmap_L2_relation ksqL2upd' ksqL2upd \ - \ - ((\\ksReadyQueues := ksqupd, ksReadyQueuesL1Bitmap := ksqL1upd, ksReadyQueuesL2Bitmap := ksqL2upd\, - \'\idx_' := i', queue_' := queue_upd', - globals := t_hrs_'_update f - (globals \' - \ksReadyQueuesL1Bitmap_' := ksqL1upd', - ksReadyQueuesL2Bitmap_' := ksqL2upd', - ksReadyQueues_' := ksqupd'\)\) \ rf_sr) = - ((\\ksReadyQueues := ksqupd\, - \'\idx_' := i', queue_' := queue_upd', - globals := t_hrs_'_update f - (globals \' \ksReadyQueues_' := ksqupd'\)\) \ rf_sr)" - unfolding rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def - by (clarsimp simp: rf_sr_cbitmap_L1_relation rf_sr_cbitmap_L2_relation) - -lemma cmachine_state_relation_enqueue_simp: - "cmachine_state_relation (ksMachineState \) - (t_hrs_'_update f - (globals \' \ksReadyQueuesL1Bitmap_' := l1upd, ksReadyQueuesL2Bitmap_' := l2upd \) - \ksReadyQueues_' := rqupd \) = - cmachine_state_relation (ksMachineState \) (t_hrs_'_update f (globals \'))" - unfolding cmachine_state_relation_def - by clarsimp - -lemma tcb_queue_relation'_empty_ksReadyQueues: - "\ sched_queue_relation' (cslift x) (q s) NULL NULL ; \t\ set (q s). tcb_at' t s \ \ q s = []" - apply (clarsimp simp add: tcb_queue_relation'_def) - apply (subst (asm) eq_commute) - apply (cases "q s" rule: rev_cases, simp) - apply (clarsimp simp: tcb_at_not_NULL) - done - lemma invert_prioToL1Index_c_simp: "p \ maxPriority \ @@ -999,13 +634,247 @@ lemma c_invert_assist: "3 - (ucast (p :: priority) >> 6 :: machine_word) < 4" using prio_ucast_shiftr_wordRadix_helper'[simplified wordRadix_def] by - (rule word_less_imp_diff_less, simp_all) +lemma addToBitmap_ccorres: + "ccorres dc xfdc + (K (tdom \ maxDomain \ prio \ maxPriority)) (\\dom = ucast tdom\ \ \\prio = ucast prio\) hs + (addToBitmap tdom prio) (Call addToBitmap_'proc)" + supply prio_and_dom_limit_helpers[simp] invert_prioToL1Index_c_simp[simp] + apply (rule ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (frule maxDomain_le_unat_ucast_explicit) + apply (clarsimp simp: getQueue_def gets_def get_def setQueue_def modify_def + put_def bind_def return_def bitmap_fun_defs) + apply (intro conjI impI allI) + apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def + carch_state_relation_def cmachine_state_relation_def) + apply (rule conjI) + apply (clarsimp intro!: cbitmap_L1_relation_bit_set) + apply (fastforce dest!: cbitmap_L2_relation_bit_set simp: wordRadix_def mask_def) + done + +lemma rf_sr_tcb_update_twice: + "h_t_valid (hrs_htd (hrs2 (globals s') (t_hrs_' (gs2 (globals s'))))) c_guard + (ptr (t_hrs_' (gs2 (globals s'))) (globals s')) + \ ((s, globals_update (\gs. t_hrs_'_update (\ths. + hrs_mem_update (heap_update (ptr ths gs :: tcb_C ptr) (v ths gs)) + (hrs_mem_update (heap_update (ptr ths gs) (v' ths gs)) (hrs2 gs ths))) (gs2 gs)) s') \ rf_sr) + = ((s, globals_update (\gs. t_hrs_'_update (\ths. + hrs_mem_update (heap_update (ptr ths gs) (v ths gs)) (hrs2 gs ths)) (gs2 gs)) s') \ rf_sr)" + by (simp add: rf_sr_def cstate_relation_def Let_def + cpspace_relation_def typ_heap_simps' + carch_state_relation_def cmachine_state_relation_def + packed_heap_update_collapse_hrs) + +lemmas rf_sr_tcb_update_no_queue_gen2 = + rf_sr_obj_update_helper[OF rf_sr_tcb_update_no_queue_gen, simplified] + +lemma tcb_queue_prepend_ccorres: + "ccorres ctcb_queue_relation ret__struct_tcb_queue_C_' + (\s. tcb_at' tcbPtr s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None) + \ (\head. tcbQueueHead queue = Some head \ tcb_at' head s)) + (\ctcb_queue_relation queue \queue\ \ \\tcb = tcb_ptr_to_ctcb_ptr tcbPtr\) hs + (tcbQueuePrepend queue tcbPtr) (Call tcb_queue_prepend_'proc)" + (is "ccorres _ _ ?abs _ _ _ _") + supply if_split[split del] + apply (cinit lift: tcb_') + \ \cinit is not able to lift queue_' because queue_' is later modified in the C program\ + apply (rule_tac xf'=queue_' in ccorres_abstract, ceqv, rename_tac cqueue) + apply (rule_tac P="ctcb_queue_relation queue cqueue" in ccorres_gen_asm2) + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue)" + and R="?abs" + and R'="\\queue = cqueue\" + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + apply ceqv + apply (rule_tac r'=ctcb_queue_relation and xf'=queue_' in ccorres_split_nothrow) + apply (rule_tac Q="?abs" + and Q'="\s'. queue_' s' = cqueue" + in ccorres_cond_both') + apply fastforce + apply clarsimp + apply (rule ccorres_return[where R=\]) + apply (rule conseqPre, vcg) + apply (fastforce simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (rule ccorres_seq_skip'[THEN iffD1]) + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_Guard) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s + \ head_C cqueue = option_to_ctcb_ptr (tcbQueueHead queue)}" + and R="\head_C cqueue = option_to_ctcb_ptr (tcbQueueHead queue)\" + in threadSet_ccorres_lemma4[where P=\ and P'=\]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce intro!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' tcb_cte_cases_def cteSizeBits_def + ctcb_relation_def option_to_ctcb_ptr_def) + apply (clarsimp simp: ctcb_relation_def option_to_ctcb_ptr_def split: if_splits) + apply ceqv + apply simp + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_Guard) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr + \ ko_at' tcb (the (tcbQueueHead queue)) s + \ head_C cqueue = option_to_ctcb_ptr (tcbQueueHead queue)}" + and R="\head_C cqueue = option_to_ctcb_ptr (tcbQueueHead queue)\" + in threadSet_ccorres_lemma4[where P=\ and P'=\]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce intro!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' tcb_cte_cases_def cteSizeBits_def + ctcb_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + apply fastforce + apply ceqv + apply (rule ccorres_return_Skip') + apply wpsimp + apply vcg + apply wpsimp + apply vcg + apply ceqv + apply csymbr + apply (fastforce intro: ccorres_return_C') + apply wpsimp + apply vcg + apply clarsimp + apply (vcg exspec=tcb_queue_empty_modifies) + apply clarsimp + apply (frule (1) tcb_at_h_t_valid) + by (force dest: tcb_at_h_t_valid + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + +lemma tcb_queue_append_ccorres: + "ccorres ctcb_queue_relation ret__struct_tcb_queue_C_' + (\s. tcb_at' tcbPtr s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None) + \ (\head. tcbQueueHead queue = Some head \ tcb_at' head s) + \ (\end. tcbQueueEnd queue = Some end \ tcb_at' end s)) + (\ctcb_queue_relation queue \queue\ \ \\tcb = tcb_ptr_to_ctcb_ptr tcbPtr\) hs + (tcbQueueAppend queue tcbPtr) (Call tcb_queue_append_'proc)" + (is "ccorres _ _ ?abs _ _ _ _") + supply if_split[split del] + apply (cinit lift: tcb_') + \ \cinit is not able to lift queue_' because queue_' is later modified in the C program\ + apply (rule_tac xf'=queue_' in ccorres_abstract, ceqv, rename_tac cqueue) + apply (rule_tac P="ctcb_queue_relation queue cqueue + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None)" + in ccorres_gen_asm2) + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue)" + and R="?abs" + and R'="\\queue = cqueue\" + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + apply ceqv + apply (rule_tac r'=ctcb_queue_relation and xf'=queue_' in ccorres_split_nothrow) + apply (rule_tac Q="?abs" + and Q'="\s'. queue_' s' = cqueue" + in ccorres_cond_both') + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply clarsimp + apply (rule ccorres_return[where R=\]) + apply (rule conseqPre, vcg) + apply (fastforce simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (rule ccorres_seq_skip'[THEN iffD1]) + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_Guard) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s + \ end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd queue)}" + and R="\end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd queue)\" + in threadSet_ccorres_lemma4[where P=\ and P'=\]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce intro!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' tcb_cte_cases_def cteSizeBits_def + ctcb_relation_def option_to_ctcb_ptr_def) + apply (clarsimp simp: ctcb_relation_def option_to_ctcb_ptr_def split: if_splits) + apply ceqv + apply simp + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_Guard) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr + \ ko_at' tcb (the (tcbQueueEnd queue)) s + \ end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd queue)}" + and R="\end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd queue)\" + in threadSet_ccorres_lemma4[where P=\ and P'=\]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce intro!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' tcb_cte_cases_def cteSizeBits_def + ctcb_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + apply fastforce + apply ceqv + apply (rule ccorres_return_Skip') + apply wpsimp + apply vcg + apply wpsimp + apply vcg + apply ceqv + apply csymbr + apply (fastforce intro: ccorres_return_C') + apply wpsimp + apply vcg + apply (vcg exspec=tcb_queue_empty_modifies) + apply clarsimp + apply (frule (1) tcb_at_h_t_valid) + by (force dest: tcb_at_h_t_valid + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def tcbQueueEmpty_def) + +lemma getQueue_ccorres: + "ccorres ctcb_queue_relation queue_' + (K (tdom \ maxDomain \ prio \ maxPriority)) + \\idx = word_of_nat (cready_queues_index_to_C tdom prio)\ hs + (getQueue tdom prio) (\queue :== \ksReadyQueues.[unat \idx])" + apply (rule ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply (clarsimp simp: getQueue_def gets_def get_def bind_def return_def) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def) + apply (frule (1) cready_queues_index_to_C_in_range) + apply (clarsimp simp: unat_of_nat_eq cready_queues_relation_def) + done + +lemma setQueue_ccorres: + "ctcb_queue_relation queue cqueue \ + ccorres dc xfdc + (K (tdom \ maxDomain \ prio \ maxPriority)) + \\idx = word_of_nat (cready_queues_index_to_C tdom prio)\ hs + (setQueue tdom prio queue) + (Basic (\s. globals_update + (ksReadyQueues_'_update + (\_. Arrays.update (ksReadyQueues_' (globals s)) (unat (idx_' s)) cqueue)) s))" + apply (rule ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply (clarsimp simp: setQueue_def get_def modify_def put_def bind_def) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def + carch_state_relation_def cmachine_state_relation_def) + apply (frule (1) cready_queues_index_to_C_in_range) + apply (clarsimp simp: unat_of_nat_eq cready_queues_relation_def) + apply (frule cready_queues_index_to_C_distinct, assumption+) + apply (frule_tac qdom=d and prio=p in cready_queues_index_to_C_in_range) + apply fastforce + apply clarsimp + done + +crunch (empty_fail) empty_fail[wp]: isRunnable + lemma tcbSchedEnqueue_ccorres: "ccorres dc xfdc - (valid_queues and tcb_at' t and valid_objs') - (UNIV \ \\tcb = tcb_ptr_to_ctcb_ptr t\) - hs - (tcbSchedEnqueue t) - (Call tcbSchedEnqueue_'proc)" + (tcb_at' t and valid_objs' and pspace_aligned' and pspace_distinct') + \\tcb = tcb_ptr_to_ctcb_ptr t\ hs + (tcbSchedEnqueue t) (Call tcbSchedEnqueue_'proc)" proof - note prio_and_dom_limit_helpers[simp] word_sle_def[simp] maxDom_to_H[simp] maxPrio_to_H[simp] note invert_prioToL1Index_c_simp[simp] @@ -1016,24 +885,12 @@ proof - show ?thesis apply (cinit lift: tcb_') - apply (rule_tac r'="\rv rv'. rv = to_bool rv'" and xf'="ret__unsigned_longlong_'" - in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (simp add: when_def unless_def del: Collect_const split del: if_split) - apply (rule ccorres_cond[where R=\]) - apply (simp add: to_bool_def) - apply (rule ccorres_rhs_assoc)+ - apply csymbr - apply csymbr - apply csymbr - apply csymbr - apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="dom_'" in ccorres_split_nothrow) + apply (rule ccorres_stateAssert)+ + apply (rule ccorres_symb_exec_l) + apply (rule ccorres_assert) + apply (thin_tac runnable) + apply (rule_tac r'="\rv rv'. rv = to_bool rv'" and xf'="ret__unsigned_longlong_'" + in ccorres_split_nothrow) apply (rule threadGet_vcg_corres) apply (rule allI, rule conseqPre, vcg) apply clarsimp @@ -1041,245 +898,244 @@ proof - apply (drule spec, drule(1) mp, clarsimp) apply (clarsimp simp: typ_heap_simps ctcb_relation_def) apply ceqv - apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="prio_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (rule ccorres_rhs_assoc2)+ - apply (simp only: bind_assoc[symmetric]) - apply (rule ccorres_split_nothrow_novcg_dc) - prefer 2 - apply (rule ccorres_move_c_guard_tcb) - apply simp - apply ctac - prefer 2 - apply (wp, clarsimp, wp+) - apply (rule_tac P="\s. valid_queues s \ (\p. t \ set (ksReadyQueues s p)) - \ (\tcb. ko_at' tcb t s \ tcbDomain tcb =rva - \ tcbPriority tcb = rvb \ valid_tcb' tcb s)" - and P'=UNIV in ccorres_from_vcg) - apply (rule allI, rule conseqPre, vcg) - apply (clarsimp simp: getQueue_def gets_def get_def setQueue_def modify_def - put_def bind_def return_def bitmap_fun_defs null_def) - apply (clarsimp simp: queue_in_range valid_tcb'_def) - apply (rule conjI; clarsimp simp: queue_in_range) - (* queue is empty, set t to be new queue *) - apply (drule (1) obj_at_cslift_tcb) - apply clarsimp - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply (subgoal_tac - "head_C (ksReadyQueues_' (globals x) - .[cready_queues_index_to_C (tcbDomain tcb) (tcbPriority tcb)]) = NULL") - prefer 2 - apply (frule_tac s=\ in tcb_queue'_head_end_NULL; simp add: valid_queues_valid_q) - apply (subgoal_tac - "end_C (ksReadyQueues_' (globals x) - .[cready_queues_index_to_C (tcbDomain tcb) (tcbPriority tcb)]) = NULL") - prefer 2 - apply (frule_tac s=\ in tcb_queue'_head_end_NULL[symmetric]; simp add: valid_queues_valid_q) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (frule maxDomain_le_unat_ucast_explicit) - apply (clarsimp simp: cready_queues_index_to_C_def numPriorities_def) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (simp add: t_hrs_ksReadyQueues_upd_absorb) - - apply (rule conjI) - apply (clarsimp simp: l2BitmapSize_def' wordRadix_def c_invert_assist) - apply (subst rf_sr_drop_bitmaps_enqueue_helper, assumption) - apply (fastforce intro: cbitmap_L1_relation_bit_set) - apply (fastforce intro: cbitmap_L2_relation_bit_set simp: wordRadix_def mask_def) - - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (drule_tac qhead'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedEnqueue_update, - simp_all add: valid_queues_valid_q)[1] - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - apply (erule(1) state_relation_queue_update_helper[where S="{t}"], - (simp | rule globals.equality)+, - simp_all add: cready_queues_index_to_C_def2 numPriorities_def - t_hrs_ksReadyQueues_upd_absorb upd_unless_null_def - typ_heap_simps)[1] - apply (fastforce simp: tcb_null_sched_ptrs_def typ_heap_simps c_guard_clift - elim: obj_at'_weaken)+ - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply clarsimp - apply (rule conjI; clarsimp simp: queue_in_range) - (* invalid, disagreement between C and Haskell on emptiness of queue *) - apply (drule (1) obj_at_cslift_tcb) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (clarsimp simp: cready_queues_index_to_C_def numPriorities_def) - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply clarsimp - apply (drule tcb_queue_relation'_empty_ksReadyQueues; simp add: valid_queues_valid_q) - (* queue was not empty, add t to queue and leave bitmaps alone *) - apply (drule (1) obj_at_cslift_tcb) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (clarsimp simp: cready_queues_index_to_C_def numPriorities_def) - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply clarsimp - apply (frule_tac t=\ in tcb_queue_relation_qhead_mem') - apply (simp add: valid_queues_valid_q) - apply (frule(1) tcb_queue_relation_qhead_valid') - apply (simp add: valid_queues_valid_q) - apply (clarsimp simp: typ_heap_simps h_t_valid_clift_Some_iff numPriorities_def - cready_queues_index_to_C_def2) - apply (drule_tac qhead'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedEnqueue_update, - simp_all add: valid_queues_valid_q)[1] + apply (simp add: when_def unless_def del: Collect_const split del: if_split) + apply (rule ccorres_cond[where R=\]) + apply (simp add: to_bool_def) + apply (rule ccorres_rhs_assoc)+ + apply csymbr + apply csymbr + apply csymbr + apply csymbr + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="dom_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) apply clarsimp - - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - apply (frule(2) obj_at_cslift_tcb[OF valid_queues_obj_at'D]) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (erule_tac S="{t, v}" for v in state_relation_queue_update_helper, - (simp | rule globals.equality)+, - simp_all add: typ_heap_simps if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 upd_unless_null_def - del: fun_upd_restrict_conv - cong: if_cong - split del: if_split)[1] - apply simp - apply (rule conjI) + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="prio_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule ccorres_rhs_assoc2)+ + apply (simp only: bind_assoc[symmetric]) + apply (rule ccorres_split_nothrow_novcg_dc) + prefer 2 + apply (rule ccorres_move_c_guard_tcb) + apply (simp only: dc_def[symmetric]) + apply ctac + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_symb_exec_r) + apply (rule ccorres_Guard_Seq) + apply (simp add: bind_assoc) + apply (ctac add: getQueue_ccorres) + apply (rename_tac queue cqueue) + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue)" + and R="\s. \ tcbQueueEmpty queue \ tcb_at' (the (tcbQueueHead queue)) s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None)" + and R'="{s'. queue_' s' = cqueue}" + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def + tcbQueueEmpty_def) + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_cond[where R=\]) + apply fastforce + apply (ctac add: addToBitmap_ccorres) + apply (rule ccorres_return_Skip) + apply ceqv + apply (ctac add: tcb_queue_prepend_ccorres) + apply (rule ccorres_Guard) + apply (rule setQueue_ccorres) + apply fastforce + apply wpsimp + apply (vcg exspec=tcb_queue_prepend_modifies) + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift') + apply (vcg exspec=addToBitmap_modifies) + apply vcg + apply wpsimp + apply vcg apply clarsimp - apply (drule_tac s="tcb_ptr_to_ctcb_ptr t" in sym, simp) - apply (clarsimp simp add: fun_upd_twist) - prefer 4 - apply (simp add: obj_at'_weakenE[OF _ TrueI]) - apply (rule disjI1, erule (1) valid_queues_obj_at'D) - apply clarsimp - apply (fastforce simp: tcb_null_sched_ptrs_def) - apply (simp add: fpu_state_preservation[OF _ h_t_valid_clift] typ_heap_simps') - apply (simp add: typ_heap_simps c_guard_clift) - apply (simp add: guard_is_UNIV_def) - apply simp - apply (wp threadGet_wp) - apply vcg - apply simp - apply (wp threadGet_wp) - apply vcg - apply (rule ccorres_return_Skip) - apply simp - apply (wp threadGet_wp) - apply vcg - apply (fastforce simp: valid_objs'_def obj_at'_def ran_def projectKOs typ_at'_def - valid_obj'_def inQ_def - dest!: valid_queues_obj_at'D) - done + apply vcg + apply (rule conseqPre, vcg) + apply clarsimp + apply wpsimp + apply (clarsimp simp: guard_is_UNIV_def) + apply (wpsimp wp: threadGet_wp) + apply vcg + apply clarsimp + apply (wpsimp wp: threadGet_wp) + apply vcg + apply (rule ccorres_return_Skip) + apply (wpsimp wp: threadGet_wp) + apply (vcg expsec=thread_state_get_tcbQueued_modifies) + apply wpsimp + apply (wpsimp wp: isRunnable_wp) + apply wpsimp + apply normalise_obj_at' + apply (rename_tac tcb) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (clarsimp simp: valid_tcb'_def) + apply (frule (1) obj_at_cslift_tcb) + apply (rule conjI) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (force dest!: tcbQueueHead_iff_tcbQueueEnd simp: tcbQueueEmpty_def obj_at'_def) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply (rule conjI) + apply (clarsimp simp: maxDomain_def) + apply (cut_tac qdom="tcbDomain tcb" and prio="tcbPriority tcb" + in cready_queues_index_to_C_in_range) + apply fastforce + apply fastforce + apply (clarsimp simp: word_less_nat_alt cready_queues_index_to_C_def2) + done qed -lemmas tcbSchedDequeue_update - = tcbDequeue_update[where tn=tcbSchedNext_C and tn_update=tcbSchedNext_C_update - and tp=tcbSchedPrev_C and tp_update=tcbSchedPrev_C_update, - simplified] - -lemma tcb_queue_relation_prev_next: - "\ tcb_queue_relation tn tp mp queue qprev qhead; - tcbp \ set queue; distinct (ctcb_ptr_to_tcb_ptr qprev # queue); - \t \ set queue. tcb_at' t s; qprev \ tcb_Ptr 0 \ mp qprev \ None; - mp (tcb_ptr_to_ctcb_ptr tcbp) = Some tcb \ - \ (tn tcb \ tcb_Ptr 0 \ tn tcb \ tcb_ptr_to_ctcb_ptr ` set queue - \ mp (tn tcb) \ None \ tn tcb \ tcb_ptr_to_ctcb_ptr tcbp) - \ (tp tcb \ tcb_Ptr 0 \ (tp tcb \ tcb_ptr_to_ctcb_ptr ` set queue - \ tp tcb = qprev) - \ mp (tp tcb) \ None \ tp tcb \ tcb_ptr_to_ctcb_ptr tcbp) - \ (tn tcb \ tcb_Ptr 0 \ tn tcb \ tp tcb)" - apply (induct queue arbitrary: qprev qhead) - apply simp - apply simp - apply (erule disjE) - apply clarsimp - apply (case_tac "queue") - apply clarsimp - apply clarsimp - apply (rule conjI) - apply clarsimp - apply clarsimp - apply (drule_tac f=ctcb_ptr_to_tcb_ptr in arg_cong[where y="tp tcb"], simp) - apply clarsimp - apply fastforce - done - -lemma tcb_queue_relation_prev_next': - "\ tcb_queue_relation' tn tp mp queue qhead qend; tcbp \ set queue; distinct queue; - \t \ set queue. tcb_at' t s; mp (tcb_ptr_to_ctcb_ptr tcbp) = Some tcb \ - \ (tn tcb \ tcb_Ptr 0 \ tn tcb \ tcb_ptr_to_ctcb_ptr ` set queue - \ mp (tn tcb) \ None \ tn tcb \ tcb_ptr_to_ctcb_ptr tcbp) - \ (tp tcb \ tcb_Ptr 0 \ tp tcb \ tcb_ptr_to_ctcb_ptr ` set queue - \ mp (tp tcb) \ None \ tp tcb \ tcb_ptr_to_ctcb_ptr tcbp) - \ (tn tcb \ tcb_Ptr 0 \ tn tcb \ tp tcb)" - apply (clarsimp simp: tcb_queue_relation'_def split: if_split_asm) - apply (drule(1) tcb_queue_relation_prev_next, simp_all) - apply (fastforce dest: tcb_at_not_NULL) - apply clarsimp - done - -(* L1 bitmap only updated if L2 entry bits end up all zero *) -lemma rf_sr_drop_bitmaps_dequeue_helper_L2: - "\ (\,\') \ rf_sr ; - cbitmap_L2_relation ksqL2upd' ksqL2upd \ - \ -((\\ksReadyQueues := ksqupd, - ksReadyQueuesL2Bitmap := ksqL2upd\, - \'\idx_' := i', - queue_' := queue_upd', - globals := globals \' - \ksReadyQueuesL2Bitmap_' := ksqL2upd', - ksReadyQueues_' := ksqupd'\\) - \ rf_sr) - = -((\\ksReadyQueues := ksqupd\, - \'\idx_' := i', - queue_' := queue_upd', - globals := globals \' - \ksReadyQueues_' := ksqupd'\\) \ rf_sr) -" - unfolding rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def - by (clarsimp simp: rf_sr_cbitmap_L1_relation rf_sr_cbitmap_L2_relation) - -lemma rf_sr_drop_bitmaps_dequeue_helper: - "\ (\,\') \ rf_sr ; - cbitmap_L1_relation ksqL1upd' ksqL1upd ; cbitmap_L2_relation ksqL2upd' ksqL2upd \ - \ -((\\ksReadyQueues := ksqupd, - ksReadyQueuesL2Bitmap := ksqL2upd, - ksReadyQueuesL1Bitmap := ksqL1upd\, - \'\idx_' := i', - queue_' := queue_upd', - globals := globals \' - \ksReadyQueuesL2Bitmap_' := ksqL2upd', - ksReadyQueuesL1Bitmap_' := ksqL1upd', - ksReadyQueues_' := ksqupd'\\) - \ rf_sr) - = -((\\ksReadyQueues := ksqupd\, - \'\idx_' := i', - queue_' := queue_upd', - globals := globals \' - \ksReadyQueues_' := ksqupd'\\) \ rf_sr) -" - unfolding rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def - by (clarsimp simp: rf_sr_cbitmap_L1_relation rf_sr_cbitmap_L2_relation) +lemma tcbSchedAppend_ccorres: + "ccorres dc xfdc + (tcb_at' t and valid_objs' and pspace_aligned' and pspace_distinct') + \\tcb = tcb_ptr_to_ctcb_ptr t\ hs + (tcbSchedAppend t) (Call tcbSchedAppend_'proc)" +proof - + note prio_and_dom_limit_helpers[simp] word_sle_def[simp] maxDom_to_H[simp] maxPrio_to_H[simp] + note invert_prioToL1Index_c_simp[simp] + (* when numDomains = 1, array bounds checks would become _ = 0 rather than _ < 1, changing the + shape of the proof compared to when numDomains > 1 *) + note word_less_1[simp del] + show ?thesis + apply (cinit lift: tcb_') + apply (rule ccorres_stateAssert)+ + apply (rule ccorres_symb_exec_l) + apply (rule ccorres_assert) + apply (thin_tac "runnable") + apply (rule_tac r'="\rv rv'. rv = to_bool rv'" and xf'="ret__unsigned_longlong_'" + in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (simp add: when_def unless_def del: Collect_const split del: if_split) + apply (rule ccorres_cond[where R=\]) + apply (simp add: to_bool_def) + apply (rule ccorres_rhs_assoc)+ + apply csymbr + apply csymbr + apply csymbr + apply csymbr + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="dom_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="prio_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule ccorres_rhs_assoc2)+ + apply (simp only: bind_assoc[symmetric]) + apply (rule ccorres_split_nothrow_novcg_dc) + prefer 2 + apply (rule ccorres_move_c_guard_tcb) + apply (simp only: dc_def[symmetric]) + apply ctac + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_symb_exec_r) + apply (rule ccorres_Guard_Seq) + apply (simp add: bind_assoc) + apply (ctac add: getQueue_ccorres) + apply (rename_tac queue cqueue) + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue)" + and R="\s. \ tcbQueueEmpty queue \ tcb_at' (the (tcbQueueHead queue)) s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None)" + and R'="{s'. queue_' s' = cqueue}" + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def + tcbQueueEmpty_def) + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_cond[where R=\]) + apply (fastforce dest!: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (ctac add: addToBitmap_ccorres) + apply (rule ccorres_return_Skip) + apply ceqv + apply (ctac add: tcb_queue_append_ccorres) + apply (rule ccorres_Guard) + apply (rule setQueue_ccorres) + apply fastforce + apply wpsimp + apply (vcg exspec=tcb_queue_prepend_modifies) + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift') + apply (vcg exspec=addToBitmap_modifies) + apply vcg + apply wpsimp + apply vcg + apply clarsimp + apply vcg + apply (rule conseqPre, vcg) + apply clarsimp + apply wpsimp + apply (clarsimp simp: guard_is_UNIV_def) + apply (wpsimp wp: threadGet_wp) + apply vcg + apply clarsimp + apply (wpsimp wp: threadGet_wp) + apply clarsimp + apply vcg + apply (rule ccorres_return_Skip) + apply (wpsimp wp: threadGet_wp) + apply (vcg expsec=thread_state_get_tcbQueued_modifies) + apply wpsimp + apply (wpsimp wp: isRunnable_wp) + apply wpsimp + apply normalise_obj_at' + apply (rename_tac tcb) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (clarsimp simp: valid_tcb'_def) + apply (frule (1) obj_at_cslift_tcb) + apply (rule conjI) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (frule (3) obj_at'_tcbQueueEnd_ksReadyQueues) + apply (force dest!: tcbQueueHead_iff_tcbQueueEnd simp: tcbQueueEmpty_def obj_at'_def) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply (rule conjI) + apply (clarsimp simp: maxDomain_def) + apply (cut_tac qdom="tcbDomain tcb" and prio="tcbPriority tcb" + in cready_queues_index_to_C_in_range) + apply fastforce + apply fastforce + apply (clarsimp simp: word_less_nat_alt cready_queues_index_to_C_def2 tcbQueueEmpty_def) + done +qed (* FIXME same proofs as bit_set, maybe can generalise? *) lemma cbitmap_L1_relation_bit_clear: @@ -1296,27 +1152,6 @@ lemma cbitmap_L1_relation_bit_clear: invertL1Index_def l2BitmapSize_def' le_maxDomain_eq_less_numDomains word_le_nat_alt num_domains_index_updates) -lemma cready_queues_relation_empty_queue_helper: - "\ tcbDomain ko \ maxDomain ; tcbPriority ko \ maxPriority ; - cready_queues_relation (cslift \') (ksReadyQueues_' (globals \')) (ksReadyQueues \)\ - \ - cready_queues_relation (cslift \') - (Arrays.update (ksReadyQueues_' (globals \')) (unat (tcbDomain ko) * 256 + unat (tcbPriority ko)) - (tcb_queue_C.end_C_update (\_. NULL) - (head_C_update (\_. NULL) - (ksReadyQueues_' (globals \').[unat (tcbDomain ko) * 256 + unat (tcbPriority ko)])))) - ((ksReadyQueues \)((tcbDomain ko, tcbPriority ko) := []))" - unfolding cready_queues_relation_def Let_def - using maxPrio_to_H[simp] maxDom_to_H[simp] - apply clarsimp - apply (frule (1) cready_queues_index_to_C_in_range[simplified maxDom_to_H maxPrio_to_H]) - apply (fold cready_queues_index_to_C_def[simplified numPriorities_def]) - apply (case_tac "qdom = tcbDomain ko", - simp_all add: prio_and_dom_limit_helpers seL4_MinPrio_def - minDom_def) - apply (fastforce simp: cready_queues_index_to_C_in_range simp: cready_queues_index_to_C_distinct)+ - done - lemma cbitmap_L2_relationD: "\ cbitmap_L2_relation cbitmap2 abitmap2 ; d \ maxDomain ; i < l2BitmapSize \ \ cbitmap2.[unat d].[i] = abitmap2 (d, i)" @@ -1346,15 +1181,10 @@ lemma cbitmap_L2_relation_bit_clear: apply (case_tac "da = d" ; clarsimp simp: num_domains_index_updates) done -lemma tcbSchedDequeue_ccorres': +lemma removeFromBitmap_ccorres: "ccorres dc xfdc - ((\s. \d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct (ksReadyQueues s (d, p))) - and valid_queues' and tcb_at' t and valid_objs') - (UNIV \ \\tcb = tcb_ptr_to_ctcb_ptr t\) - [] - (tcbSchedDequeue t) - (Call tcbSchedDequeue_'proc)" + (K (tdom \ maxDomain \ prio \ maxPriority)) (\\dom = ucast tdom\ \ \\prio = ucast prio\) hs + (removeFromBitmap tdom prio) (Call removeFromBitmap_'proc)" proof - note prio_and_dom_limit_helpers[simp] word_sle_def[simp] @@ -1363,451 +1193,290 @@ proof - shape of the proof compared to when numDomains > 1 *) include no_less_1_simps - have ksQ_tcb_at': "\s ko d p. - \d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct (ksReadyQueues s (d, p)) \ - \t\set (ksReadyQueues s (d, p)). tcb_at' t s" - by (fastforce dest: spec elim: obj_at'_weakenE) - - have invert_l1_index_limit: "\p. invertL1Index (prioToL1Index p) < 4" + have invert_l1_index_limit: "\p. invertL1Index (prioToL1Index p) < l2BitmapSize" unfolding invertL1Index_def l2BitmapSize_def' prioToL1Index_def by simp show ?thesis - apply (cinit lift: tcb_') - apply (rule_tac r'="\rv rv'. rv = to_bool rv'" and xf'="ret__unsigned_longlong_'" - in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (simp add: when_def del: Collect_const split del: if_split) - apply (rule ccorres_cond[where R=\]) - apply (simp add: to_bool_def) - apply (rule ccorres_rhs_assoc)+ - apply csymbr - apply csymbr - apply csymbr - apply csymbr - apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="dom_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) + supply if_split[split del] + (* pull out static assms *) + apply simp + apply (rule ccorres_grab_asm[where P=\, simplified]) + apply (cinit lift: dom_' prio_') + apply clarsimp + apply csymbr + apply csymbr + (* we can clear up all C guards now *) + apply (clarsimp simp: maxDomain_le_unat_ucast_explicit word_and_less') + apply (simp add: invert_prioToL1Index_c_simp word_less_nat_alt) + apply (simp add: invert_l1_index_limit[simplified l2BitmapSize_def']) + apply ccorres_rewrite + (* handle L2 update *) + apply (rule_tac ccorres_split_nothrow_novcg_dc) + apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply (clarsimp simp: simpler_gets_def get_def modify_def + put_def bind_def return_def bitmap_fun_defs) + apply (frule rf_sr_cbitmap_L2_relation) + apply (erule cbitmap_L2_relation_update) + apply (erule (1) cbitmap_L2_relation_bit_clear) + (* the check on the C side is identical to checking the L2 entry, rewrite the condition *) + apply (simp add: getReadyQueuesL2Bitmap_def) + apply (rule ccorres_symb_exec_l3, rename_tac l2) + apply (rule_tac C'="{s. l2 = 0}" + and Q="\s. l2 = ksReadyQueuesL2Bitmap s (tdom, invertL1Index (prioToL1Index prio))" + in ccorres_rewrite_cond_sr[where Q'=UNIV]) + apply clarsimp + apply (frule rf_sr_cbitmap_L2_relation) + apply (clarsimp simp: cbitmap_L2_relationD invert_l1_index_limit split: if_split) + (* unset L1 bit when L2 entry is empty *) + apply (rule ccorres_from_vcg[where P=\ and P'=UNIV]) apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="prio_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply (clarsimp simp: simpler_gets_def get_def modify_def + put_def bind_def return_def bitmap_fun_defs) + apply (frule rf_sr_cbitmap_L1_relation) + apply (erule cbitmap_L1_relation_update) + apply (erule (1) cbitmap_L1_relation_bit_clear) + apply wpsimp+ + apply (fastforce simp: guard_is_UNIV_def) + apply clarsimp + done +qed + +lemma ctcb_ptr_to_tcb_ptr_option_to_ctcb_ptr[simp]: + "ctcb_ptr_to_tcb_ptr (option_to_ctcb_ptr (Some ptr)) = ptr" + by (clarsimp simp: option_to_ctcb_ptr_def) + +lemma tcb_queue_remove_ccorres: + "ccorres ctcb_queue_relation ret__struct_tcb_queue_C_' + (\s. tcb_at' tcbPtr s \ valid_objs' s + \ (tcbQueueHead queue \ None \ tcbQueueEnd queue \ None)) + (\ctcb_queue_relation queue \queue\ \ \\tcb = tcb_ptr_to_ctcb_ptr tcbPtr\) hs + (tcbQueueRemove queue tcbPtr) (Call tcb_queue_remove_'proc)" + (is "ccorres _ _ ?abs _ _ _ _") + supply if_split[split del] + apply (cinit' lift: tcb_') + apply (rename_tac tcb') + apply (simp only: tcbQueueRemove_def) + \ \cinit is not able to lift queue_' because queue_' is later modified in the C program\ + apply (rule_tac xf'=queue_' in ccorres_abstract, ceqv, rename_tac cqueue) + apply (rule_tac P="ctcb_queue_relation queue cqueue" in ccorres_gen_asm2) + apply (rule ccorres_pre_getObject_tcb, rename_tac tcb) + apply (rule ccorres_symb_exec_l, rename_tac beforePtrOpt) + apply (rule ccorres_symb_exec_l, rename_tac afterPtrOpt) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac xf'="before___ptr_to_struct_tcb_C_'" + and val="option_to_ctcb_ptr beforePtrOpt" + and R="ko_at' tcb tcbPtr and K (tcbSchedPrev tcb = beforePtrOpt)" + and R'=UNIV + in ccorres_symb_exec_r_known_rv) + apply (rule conseqPre, vcg) + apply (fastforce dest: obj_at_cslift_tcb simp: typ_heap_simps ctcb_relation_def) apply ceqv - apply (rule ccorres_rhs_assoc2)+ - apply (simp only: bind_assoc[symmetric]) - apply (rule ccorres_split_nothrow_novcg_dc) - prefer 2 - apply (rule ccorres_move_c_guard_tcb) - apply ctac - prefer 2 - apply (wp, clarsimp, wp+) - apply (rule_tac P="(\s. \d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) - \ distinct(ksReadyQueues s (d, p))) - and valid_queues' and obj_at' (inQ rva rvb) t - and (\s. rva \ maxDomain \ rvb \ maxPriority)" - and P'=UNIV in ccorres_from_vcg) - apply (rule allI, rule conseqPre, vcg) - apply (clarsimp simp: getQueue_def gets_def get_def setQueue_def modify_def - put_def bind_def return_def bitmap_fun_defs when_def - null_def) - - apply (rule conjI; clarsimp simp: queue_in_range[simplified maxDom_to_H maxPrio_to_H]) - apply (rule conjI; clarsimp simp: queue_in_range[simplified maxDom_to_H maxPrio_to_H]) - apply (frule(1) valid_queuesD') - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" in rf_sr_sched_queue_relation) - apply (fastforce simp: maxDom_to_H maxPrio_to_H)+ - apply (frule_tac s=\ in tcb_queue_relation_prev_next'; (fastforce simp: ksQ_tcb_at')?) - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (intro conjI; - clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift)+ - apply (drule(2) filter_empty_unfiltered_contr, simp)+ - apply (rule conjI; clarsimp) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (rule conjI; clarsimp) - apply (subst rf_sr_drop_bitmaps_dequeue_helper, assumption) - apply (fastforce intro: cbitmap_L1_relation_bit_clear) - apply (simp add: invert_prioToL1Index_c_simp) - apply (frule rf_sr_cbitmap_L2_relation) - apply (clarsimp simp: cbitmap_L2_relation_def - word_size prioToL1Index_def wordRadix_def mask_def - word_le_nat_alt - numPriorities_def wordBits_def l2BitmapSize_def' - invertL1Index_def numDomains_less_numeric_explicit) - apply (case_tac "d = tcbDomain ko" - ; fastforce simp: le_maxDomain_eq_less_numDomains - numDomains_less_numeric_explicit) - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: maxDom_to_H maxPrio_to_H)+ - - apply (frule_tac s=\ in tcb_queue_relation_prev_next', assumption) - prefer 3 - apply fastforce - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by ((fastforce simp: ksQ_tcb_at')+) - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - (* trivial case, setting queue to empty *) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def carch_state_relation_def - cmachine_state_relation_def) - apply (erule (2) cready_queues_relation_empty_queue_helper) - (* impossible case, C L2 update disagrees with Haskell update *) - apply (simp add: invert_prioToL1Index_c_simp) - apply (subst (asm) num_domains_index_updates) - subgoal by (simp add: le_maxDomain_eq_less_numDomains word_le_nat_alt) - apply (subst (asm) Arrays.index_update) - apply (simp add: invert_l1_index_limit) - - apply (frule rf_sr_cbitmap_L2_relation) - apply (drule_tac i="invertL1Index (prioToL1Index (tcbPriority ko))" - in cbitmap_L2_relationD, assumption) - apply (fastforce simp: l2BitmapSize_def' invert_l1_index_limit) - apply (fastforce simp: prioToL1Index_def invertL1Index_def mask_def wordRadix_def) - (* impossible case *) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (drule(2) filter_empty_unfiltered_contr, fastforce) - - apply (frule (1) valid_queuesD') - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) - apply fold_subgoals[2] - apply (fastforce simp: maxDom_to_H maxPrio_to_H)+ - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (frule_tac s=\ in tcb_queue_relation_prev_next', assumption) - prefer 3 - apply fastforce - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: ksQ_tcb_at')+ - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - apply (clarsimp simp: filter_noteq_op upd_unless_null_def) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI, clarsimp) - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (rule conjI; clarsimp) - apply (simp add: typ_heap_simps) - apply (clarsimp simp: h_t_valid_c_guard [OF h_t_valid_field, OF h_t_valid_clift] - h_t_valid_field[OF h_t_valid_clift] h_t_valid_clift) - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 typ_heap_simps - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - - apply (fastforce simp: tcb_null_sched_ptrs_def typ_heap_simps c_guard_clift - elim: obj_at'_weaken)+ - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split, - simp_all add: typ_heap_simps')[1] - subgoal by (fastforce simp: tcb_null_sched_ptrs_def) - subgoal by (simp add: fpu_state_preservation[OF _ h_t_valid_clift] typ_heap_simps') - subgoal by fastforce + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac xf'="after___ptr_to_struct_tcb_C_'" + and val="option_to_ctcb_ptr afterPtrOpt" + and R="ko_at' tcb tcbPtr and K (tcbSchedNext tcb = afterPtrOpt)" + in ccorres_symb_exec_r_known_rv[where R'=UNIV]) + apply (rule conseqPre, vcg) + apply (fastforce dest: obj_at_cslift_tcb simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule ccorres_cond_seq) + apply (rule ccorres_cond[where R="?abs"]) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def) + apply (rule ccorres_rhs_assoc)+ + apply csymbr + apply csymbr + apply (fastforce intro: ccorres_return_C') + apply (rule ccorres_cond_seq) + apply (rule_tac Q="?abs" and Q'=\ in ccorres_cond_both') + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def split: if_splits) apply clarsimp - apply (rule conjI; clarsimp) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (rule conjI; clarsimp) - (* invalid, missing bitmap updates on haskell side *) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems - by (fastforce dest!: tcb_queue_relation'_empty_ksReadyQueues - elim: obj_at'_weaken)+ - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - apply (fold_subgoals (prefix))[4] - subgoal premises prems using prems - by - (fastforce simp: typ_heap_simps c_guard_clift tcb_null_sched_ptrs_def - clift_heap_update_same[OF h_t_valid_clift] - fpu_state_preservation[OF _ h_t_valid_clift])+ - apply (rule conjI; clarsimp simp: queue_in_range[simplified maxDom_to_H maxPrio_to_H]) - apply (frule (1) valid_queuesD') - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: maxDom_to_H maxPrio_to_H)+ - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (frule_tac s=\ in tcb_queue_relation_prev_next') + apply (rule ccorres_assert2) + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb)+ + apply (rule_tac P=\ and P'="tcb_at' tcbPtr" + and Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb (the afterPtrOpt) s}" + in threadSet_ccorres_lemma3) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) apply fastforce - prefer 3 - apply fastforce - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: ksQ_tcb_at')+ - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - apply (clarsimp simp: filter_noteq_op upd_unless_null_def) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI; clarsimp) - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (clarsimp simp: typ_heap_simps) - apply (rule conjI; clarsimp simp: typ_heap_simps) - apply (drule(2) filter_empty_unfiltered_contr[simplified filter_noteq_op], simp) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (rule conjI; clarsimp) - (* impossible case, C L2 update disagrees with Haskell update *) - apply (subst (asm) num_domains_index_updates) - apply (simp add: le_maxDomain_eq_less_numDomains word_le_nat_alt) - apply (subst (asm) Arrays.index_update) - subgoal using invert_l1_index_limit - by (fastforce simp add: invert_prioToL1Index_c_simp intro: nat_Suc_less_le_imp) - apply (frule rf_sr_cbitmap_L2_relation) - apply (simp add: invert_prioToL1Index_c_simp) - apply (drule_tac i="invertL1Index (prioToL1Index (tcbPriority ko))" - in cbitmap_L2_relationD, assumption) - subgoal by (simp add: invert_l1_index_limit l2BitmapSize_def') - apply (fastforce simp: prioToL1Index_def invertL1Index_def mask_def wordRadix_def) - - apply (simp add: invert_prioToL1Index_c_simp) - apply (subst rf_sr_drop_bitmaps_dequeue_helper_L2, assumption) - subgoal by (fastforce dest: rf_sr_cbitmap_L2_relation elim!: cbitmap_L2_relation_bit_clear) - - (* trivial case, setting queue to empty *) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def carch_state_relation_def - cmachine_state_relation_def) - apply (erule (2) cready_queues_relation_empty_queue_helper) - - apply (frule (1) valid_queuesD') - apply (drule (1) obj_at_cslift_tcb, clarsimp simp: inQ_def) - apply (frule_tac d="tcbDomain ko" and p="tcbPriority ko" - in rf_sr_sched_queue_relation) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce simp: maxDom_to_H maxPrio_to_H)+ - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (simp add: invert_prioToL1Index_c_simp) - apply (frule_tac s=\ in tcb_queue_relation_prev_next') - apply (fastforce simp add: ksQ_tcb_at')+ - apply (drule_tac s=\ in tcbSchedDequeue_update, assumption, - simp_all add: remove1_filter ksQ_tcb_at')[1] - apply (clarsimp simp: filter_noteq_op upd_unless_null_def) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI, clarsimp) - apply (clarsimp simp: h_val_field_clift' - h_t_valid_clift[THEN h_t_valid_field] h_t_valid_clift) - apply (clarsimp simp: typ_heap_simps) - apply (rule conjI; clarsimp simp: typ_heap_simps) - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - apply (fastforce simp: tcb_null_sched_ptrs_def) - apply (clarsimp simp: typ_heap_simps) - apply (fastforce simp: typ_heap_simps) - apply (fastforce simp: tcb_null_sched_ptrs_def) - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - apply (fold_subgoals (prefix))[4] - subgoal premises prems using prems - by - (fastforce simp: typ_heap_simps c_guard_clift tcb_null_sched_ptrs_def - clift_heap_update_same[OF h_t_valid_clift] - fpu_state_preservation[OF _ h_t_valid_clift])+ - apply (clarsimp) - apply (rule conjI; clarsimp simp: typ_heap_simps) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (rule conjI; clarsimp) - (* invalid, missing bitmap updates on haskell side *) - apply (drule tcb_queue_relation'_empty_ksReadyQueues) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce elim: obj_at'_weaken)+ - (* invalid, missing bitmap updates on haskell side *) - apply (drule tcb_queue_relation'_empty_ksReadyQueues) - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (fastforce elim: obj_at'_weaken)+ - apply (erule_tac S="set (ksReadyQueues \ (tcbDomain ko, tcbPriority ko))" - in state_relation_queue_update_helper', - (simp | rule globals.equality)+, - simp_all add: clift_field_update if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 typ_heap_simps - maxDom_to_H maxPrio_to_H - cong: if_cong split del: if_split)[1] - apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems - by (fastforce simp: typ_heap_simps c_guard_clift tcb_null_sched_ptrs_def)+ - apply (simp add: guard_is_UNIV_def) - apply simp - apply (wp threadGet_wp) - apply vcg - apply simp - apply (wp threadGet_wp) - apply vcg - apply (rule ccorres_return_Skip) - apply simp - apply (wp threadGet_wp) - apply vcg - by (fastforce simp: valid_objs'_def obj_at'_def ran_def projectKOs typ_at'_def - valid_obj'_def valid_tcb'_def inQ_def) -qed - -lemma tcbSchedDequeue_ccorres: - "ccorres dc xfdc - (valid_queues and valid_queues' and tcb_at' t and valid_objs') - (UNIV \ \\tcb = tcb_ptr_to_ctcb_ptr t\) - [] - (tcbSchedDequeue t) - (Call tcbSchedDequeue_'proc)" - apply (rule ccorres_guard_imp [OF tcbSchedDequeue_ccorres']) - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE) - apply (clarsimp)+ - done - -lemma tcb_queue_relation_append: - "\ tcb_queue_relation tn tp mp queue qprev qhead; queue \ []; - qend' \ tcb_ptr_to_ctcb_ptr ` set queue; mp qend' = Some tcb; - queue = queue' @ [ctcb_ptr_to_tcb_ptr qend]; distinct queue; - \x \ set queue. tcb_ptr_to_ctcb_ptr x \ NULL; qend' \ NULL; - \v f g. tn (tn_update f v) = f (tn v) \ tp (tp_update g v) = g (tp v) - \ tn (tp_update f v) = tn v \ tp (tn_update g v) = tp v \ - \ tcb_queue_relation tn tp - (mp (qend \ tn_update (\_. qend') (the (mp qend)), - qend' \ tn_update (\_. NULL) (tp_update (\_. qend) tcb))) - (queue @ [ctcb_ptr_to_tcb_ptr qend']) qprev qhead" - using [[hypsubst_thin = true]] - apply clarsimp - apply (induct queue' arbitrary: qprev qhead) - apply clarsimp - apply clarsimp - done - -lemma tcbSchedAppend_update: - assumes sr: "sched_queue_relation' mp queue qhead qend" - and qh': "qend' \ tcb_ptr_to_ctcb_ptr ` set queue" - and cs_tcb: "mp qend' = Some tcb" - and valid_ep: "\t\set queue. tcb_at' t s" "distinct queue" - and qhN: "qend' \ NULL" - shows - "sched_queue_relation' - (upd_unless_null qend (tcbSchedNext_C_update (\_. qend') (the (mp qend))) - (mp(qend' \ tcb\tcbSchedNext_C := NULL, tcbSchedPrev_C := qend\))) - (queue @ [ctcb_ptr_to_tcb_ptr qend']) (if queue = [] then qend' else qhead) qend'" - using sr qh' valid_ep cs_tcb qhN - apply - - apply (rule rev_cases[where xs=queue]) - apply (simp add: tcb_queue_relation'_def upd_unless_null_def) - apply (clarsimp simp: tcb_queue_relation'_def upd_unless_null_def tcb_at_not_NULL) - apply (drule_tac qend'=qend' and tn_update=tcbSchedNext_C_update - and tp_update=tcbSchedPrev_C_update and qend="tcb_ptr_to_ctcb_ptr y" - in tcb_queue_relation_append, simp_all) - apply (fastforce simp add: tcb_at_not_NULL) - apply (simp add: fun_upd_twist) - done - -lemma tcb_queue_relation_qend_mems: - "\ tcb_queue_relation' getNext getPrev mp queue qhead qend; - \x \ set queue. tcb_at' x s \ - \ (qend = NULL \ queue = []) - \ (qend \ NULL \ ctcb_ptr_to_tcb_ptr qend \ set queue)" - apply (clarsimp simp: tcb_queue_relation'_def) - apply (drule bspec, erule last_in_set) - apply (simp add: tcb_at_not_NULL) + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb[where thread=tcbPtr]) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule ccorres_symb_exec_r) + apply (fastforce intro: ccorres_return_C') + apply vcg + apply (rule conseqPre, vcg) + apply clarsimp + apply wpsimp + apply vcg + apply wpsimp + apply vcg + apply (rule ccorres_cond_seq) + apply (rule_tac Q="?abs" and Q'=\ in ccorres_cond_both') + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def split: if_splits) + apply clarsimp + apply (rule ccorres_assert2) + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb)+ + apply (rule_tac P=\ and P'="tcb_at' tcbPtr" + and Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb (the beforePtrOpt) s}" + in threadSet_ccorres_lemma3) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply fastforce + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb[where thread=tcbPtr]) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule ccorres_symb_exec_r) + apply (fastforce intro: ccorres_return_C') + apply vcg + apply (rule conseqPre, vcg) + apply clarsimp + apply wpsimp + apply vcg + apply wpsimp + apply vcg + apply clarsimp + apply (rule ccorres_assert2)+ + apply (rule ccorres_rhs_assoc)+ + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb)+ + apply (rule_tac Q="\s tcb'. {s'. (s, s') \ rf_sr \ ko_at' tcb' (the beforePtrOpt) s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb)+ + apply (rule_tac P=\ and P'="tcb_at' tcbPtr" + and Q="\s tcb'. {s'. (s, s') \ rf_sr \ ko_at' tcb' (the afterPtrOpt) s}" + in threadSet_ccorres_lemma3) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb[where thread=tcbPtr]) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply ceqv + apply (rule_tac r'=dc and xf'=xfdc in ccorres_split_nothrow) + apply (rule ccorres_move_c_guard_tcb) + apply (rule_tac Q="\s tcb. {s'. (s, s') \ rf_sr \ ko_at' tcb tcbPtr s}" + in threadSet_ccorres_lemma3[where P=\ and P'=\, simplified]) + apply (rule conseqPre, vcg) + apply clarsimp + apply (frule (1) obj_at_cslift_tcb[where thread=tcbPtr]) + apply (fastforce elim!: rf_sr_tcb_update_no_queue_gen2 + simp: typ_heap_simps' ctcb_relation_def option_to_ctcb_ptr_def + tcb_cte_cases_def cteSizeBits_def) + apply fastforce + apply ceqv + apply (fastforce intro: ccorres_return_C') + apply (wpsimp | vcg)+ + apply (clarsimp split: if_splits) + apply normalise_obj_at' + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + by (intro conjI impI; + clarsimp simp: ctcb_queue_relation_def typ_heap_simps option_to_ctcb_ptr_def + valid_tcb'_def valid_bound_tcb'_def) + +lemma tcbQueueRemove_tcb_at'_head: + "\\s. valid_objs' s \ (\head. tcbQueueHead queue = Some head \ tcb_at' head s)\ + tcbQueueRemove queue t + \\rv s. \ tcbQueueEmpty rv \ tcb_at' (the (tcbQueueHead rv)) s\" + unfolding tcbQueueRemove_def + apply (wpsimp wp: getTCB_wp haskell_assert_wp hoare_vcg_imp_lift') + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (fastforce simp: valid_tcb'_def valid_bound_tcb'_def tcbQueueEmpty_def obj_at'_def) done -lemma tcbSchedAppend_ccorres: +lemma tcbSchedDequeue_ccorres: "ccorres dc xfdc - (valid_queues and tcb_at' t and valid_objs') - (UNIV \ \\tcb = tcb_ptr_to_ctcb_ptr t\) - [] - (tcbSchedAppend t) - (Call tcbSchedAppend_'proc)" + (tcb_at' t and valid_objs' and pspace_aligned' and pspace_distinct') + \\tcb = tcb_ptr_to_ctcb_ptr t\ hs + (tcbSchedDequeue t) (Call tcbSchedDequeue_'proc)" proof - note prio_and_dom_limit_helpers[simp] word_sle_def[simp] maxDom_to_H[simp] maxPrio_to_H[simp] + note invert_prioToL1Index_c_simp[simp] (* when numDomains = 1, array bounds checks would become _ = 0 rather than _ < 1, changing the shape of the proof compared to when numDomains > 1 *) include no_less_1_simps show ?thesis - apply (cinit lift: tcb_') - apply (rule_tac r'="\rv rv'. rv = to_bool rv'" - and xf'="ret__unsigned_longlong_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (simp add: when_def unless_def del: Collect_const split del: if_split) - apply (rule ccorres_cond[where R=\]) - apply (simp add: to_bool_def) - apply (rule ccorres_rhs_assoc)+ - apply csymbr - apply csymbr - apply csymbr - apply csymbr - apply (rule_tac r'="\rv rv'. rv' = ucast rv" - and xf'="dom_'" in ccorres_split_nothrow) - apply (rule threadGet_vcg_corres) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (drule spec, drule(1) mp, clarsimp) - apply (clarsimp simp: typ_heap_simps ctcb_relation_def) - apply ceqv - apply (rule_tac r'="\rv rv'. rv' = ucast rv" - and xf'="prio_'" in ccorres_split_nothrow) + apply (cinit lift: tcb_') + apply (rule ccorres_stateAssert)+ + apply (rule_tac r'="\rv rv'. rv = to_bool rv'" and xf'="ret__unsigned_longlong_'" + in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (simp add: when_def del: Collect_const split del: if_split) + apply (rule ccorres_cond[where R=\]) + apply (simp add: to_bool_def) + apply (rule ccorres_rhs_assoc)+ + apply csymbr + apply csymbr + apply csymbr + apply csymbr + apply csymbr + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="dom_'" in ccorres_split_nothrow) apply (rule threadGet_vcg_corres) apply (rule allI, rule conseqPre, vcg) apply clarsimp @@ -1815,123 +1484,78 @@ proof - apply (drule spec, drule(1) mp, clarsimp) apply (clarsimp simp: typ_heap_simps ctcb_relation_def) apply ceqv - apply (rule ccorres_rhs_assoc2)+ - apply (simp only: bind_assoc[symmetric]) - apply (rule ccorres_split_nothrow_novcg_dc) - prefer 2 - apply (rule ccorres_move_c_guard_tcb) - apply ctac - prefer 2 - apply (wp, clarsimp, wp+) - apply (rule_tac P="\s. valid_queues s \ (\p. t \ set (ksReadyQueues s p)) - \ (\tcb. ko_at' tcb t s \ tcbDomain tcb =rva - \ tcbPriority tcb = rvb \ valid_tcb' tcb s)" - and P'=UNIV in ccorres_from_vcg) - apply (rule allI, rule conseqPre, vcg) - apply (clarsimp simp: getQueue_def gets_def get_def setQueue_def modify_def - put_def bind_def return_def bitmap_fun_defs null_def) - apply (clarsimp simp: queue_in_range valid_tcb'_def) - apply (rule conjI; clarsimp simp: queue_in_range) - apply (drule (1) obj_at_cslift_tcb) - apply clarsimp - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply (frule_tac s=\ in tcb_queue_relation_qend_mems, simp add: valid_queues_valid_q) - apply (drule_tac qend'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedAppend_update, - simp_all add: valid_queues_valid_q)[1] - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (simp add: invert_prioToL1Index_c_simp) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI; clarsimp) - apply (rule conjI) - apply (fastforce simp: c_invert_assist l2BitmapSize_def' wordRadix_def) - apply (simp add: t_hrs_ksReadyQueues_upd_absorb) - apply (subst rf_sr_drop_bitmaps_enqueue_helper, assumption) - apply (fastforce intro: cbitmap_L1_relation_bit_set) - subgoal by (fastforce intro: cbitmap_L2_relation_bit_set simp: wordRadix_def mask_def) - apply (erule(1) state_relation_queue_update_helper[where S="{t}"], - (simp | rule globals.equality)+, - simp_all add: cready_queues_index_to_C_def2 numPriorities_def - t_hrs_ksReadyQueues_upd_absorb upd_unless_null_def - typ_heap_simps)[1] - apply (fastforce simp: tcb_null_sched_ptrs_def elim: obj_at'_weaken) - apply (fastforce simp: tcb_null_sched_ptrs_def elim: obj_at'_weaken) - apply (clarsimp simp: upd_unless_null_def cready_queues_index_to_C_def numPriorities_def) - apply (rule conjI, solves \clarsimp simp: le_maxDomain_eq_less_numDomains - unat_trans_ucast_helper\) - apply (clarsimp simp: maxDomain_le_unat_ucast_explicit) - apply (rule conjI; clarsimp simp: queue_in_range) - apply (drule (1) obj_at_cslift_tcb) - apply clarsimp - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp - apply clarsimp - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply (frule_tac s=\ in tcb_queue_relation_qend_mems, - simp add: valid_queues_valid_q) - apply (drule_tac qend'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedAppend_update, - simp_all add: valid_queues_valid_q)[1] + apply (rule_tac r'="\rv rv'. rv' = ucast rv" and xf'="prio_'" in ccorres_split_nothrow) + apply (rule threadGet_vcg_corres) + apply (rule allI, rule conseqPre, vcg) apply clarsimp - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (clarsimp simp: upd_unless_null_def cready_queues_index_to_C_def numPriorities_def) - apply (drule (1) obj_at_cslift_tcb) - apply clarsimp - apply (frule_tac d="tcbDomain tcb" and p="tcbPriority tcb" - in rf_sr_sched_queue_relation) - apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (drule spec, drule(1) mp, clarsimp) + apply (clarsimp simp: typ_heap_simps ctcb_relation_def) + apply ceqv + apply (rule ccorres_symb_exec_r) + apply (rule ccorres_Guard_Seq) + apply (simp add: bind_assoc) + apply (ctac add: getQueue_ccorres) + apply (rule_tac r'=ctcb_queue_relation and xf'=new_queue_' in ccorres_split_nothrow) + apply (ctac add: tcb_queue_remove_ccorres) + apply ceqv + apply (rename_tac queue' newqueue) + apply (rule ccorres_Guard_Seq) + apply (ctac add: setQueue_ccorres) + apply (rule ccorres_split_nothrow_novcg_dc) + apply ctac + apply (rule_tac xf'=ret__unsigned_long_' + and val="from_bool (tcbQueueEmpty queue')" + and R="\s. \ tcbQueueEmpty queue' \ tcb_at' (the (tcbQueueHead queue')) s" + in ccorres_symb_exec_r_known_rv[where R'=UNIV]) + apply (rule conseqPre, vcg) + apply (fastforce dest: tcb_at_not_NULL + simp: ctcb_queue_relation_def option_to_ctcb_ptr_def + tcbQueueEmpty_def split: option.splits) + apply ceqv + apply (rule ccorres_cond[where R=\]) + apply fastforce + apply (ctac add: removeFromBitmap_ccorres) + apply (rule ccorres_return_Skip) + apply vcg + apply (wpsimp wp: hoare_vcg_imp_lift') + apply (clarsimp simp: guard_is_UNIV_def) + apply (wpsimp wp: hoare_vcg_imp_lift') + apply vcg + apply ((wpsimp wp: tcbQueueRemove_tcb_at'_head | wp (once) hoare_drop_imps)+)[1] + apply (vcg exspec=tcb_queue_remove_modifies) + apply wpsimp + apply vcg + apply vcg + apply (rule conseqPre, vcg) apply clarsimp - apply (frule_tac s=\ in tcb_queue'_head_end_NULL) - apply (simp add: valid_queues_valid_q) - apply (frule_tac s=\ in tcb_queue_relation_qend_mems, - simp add: valid_queues_valid_q) - apply (drule_tac qend'="tcb_ptr_to_ctcb_ptr t" and s=\ in tcbSchedAppend_update, - simp_all add: valid_queues_valid_q)[1] - apply clarsimp - apply (rule tcb_at_not_NULL, erule obj_at'_weakenE, simp) - apply (clarsimp simp: cready_queues_index_to_C_def2 numPriorities_def) - apply (frule(2) obj_at_cslift_tcb[OF valid_queues_obj_at'D]) - apply (clarsimp simp: h_val_field_clift' h_t_valid_clift) - apply (erule_tac S="{t, v}" for v in state_relation_queue_update_helper, - (simp | rule globals.equality)+, - simp_all add: typ_heap_simps if_Some_helper numPriorities_def - cready_queues_index_to_C_def2 upd_unless_null_def - cong: if_cong split del: if_split - del: fun_upd_restrict_conv)[1] - apply simp - apply (rule conjI) - apply clarsimp - apply (drule_tac s="tcb_ptr_to_ctcb_ptr t" in sym, simp) - apply (clarsimp simp add: fun_upd_twist) - prefer 3 - apply (simp add: obj_at'_weakenE[OF _ TrueI]) - apply (rule disjI1, erule valid_queues_obj_at'D) - subgoal by simp - subgoal by simp - subgoal by (fastforce simp: tcb_null_sched_ptrs_def) - apply (simp add: guard_is_UNIV_def) - apply simp - apply (wp threadGet_wp) + apply (wpsimp wp: threadGet_wp) + apply vcg + apply clarsimp + apply (wpsimp wp: threadGet_wp) apply vcg - apply simp - apply (wp threadGet_wp) - apply vcg - apply (rule ccorres_return_Skip) - apply simp - apply (wp threadGet_wp) - apply vcg - by (fastforce simp: valid_objs'_def obj_at'_def ran_def projectKOs typ_at'_def - valid_obj'_def inQ_def - dest!: valid_queues_obj_at'D) + apply (rule ccorres_return_Skip) + apply (wpsimp wp: threadGet_wp) + apply (vcg expsec=thread_state_get_tcbQueued_modifies) + apply normalise_obj_at' + apply (rename_tac tcb) + apply (frule (1) obj_at_cslift_tcb) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (clarsimp simp: valid_tcb'_def) + apply (cut_tac qdom="tcbDomain tcb" and prio="tcbPriority tcb" + in cready_queues_index_to_C_in_range) + apply fastforce + apply fastforce + apply (rule conjI) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (force dest!: tcbQueueHead_iff_tcbQueueEnd simp: tcbQueueEmpty_def obj_at'_def) + by (fastforce simp: word_less_nat_alt + cready_queues_index_to_C_def2 ctcb_relation_def + typ_heap_simps le_maxDomain_eq_less_numDomains(2) unat_trans_ucast_helper) qed lemma isStopped_spec: @@ -1979,8 +1603,11 @@ lemma tcb_at_1: done lemma rescheduleRequired_ccorres: - "ccorres dc xfdc (valid_queues and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_objs') - UNIV [] rescheduleRequired (Call rescheduleRequired_'proc)" + "ccorres dc xfdc + ((\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_objs' + and pspace_aligned' and pspace_distinct') + UNIV [] + rescheduleRequired (Call rescheduleRequired_'proc)" apply cinit apply (rule ccorres_symb_exec_l) apply (rule ccorres_split_nothrow_novcg[where r'=dc and xf'=xfdc]) @@ -2090,10 +1717,12 @@ lemma cguard_UNIV: by fastforce lemma lookupBitmapPriority_le_maxPriority: - "\ ksReadyQueuesL1Bitmap s d \ 0 ; valid_queues s \ + "\ ksReadyQueuesL1Bitmap s d \ 0 ; + \d p. d > maxDomain \ p > maxPriority \ tcbQueueEmpty (ksReadyQueues s (d, p)); + valid_bitmaps s \ \ lookupBitmapPriority d s \ maxPriority" - unfolding valid_queues_def valid_queues_no_bitmap_def - by (fastforce dest!: bitmapQ_from_bitmap_lookup bitmapQ_ksReadyQueuesI intro: ccontr) + apply (clarsimp simp: valid_bitmaps_def) + by (fastforce dest!: bitmapQ_from_bitmap_lookup bitmapQ_ksReadyQueuesI intro: ccontr) lemma rf_sr_ksReadyQueuesL1Bitmap_not_zero: "\ (\, s') \ rf_sr ; d \ maxDomain ; ksReadyQueuesL1Bitmap_' (globals s').[unat d] \ 0 \ @@ -2103,10 +1732,10 @@ lemma rf_sr_ksReadyQueuesL1Bitmap_not_zero: done lemma ksReadyQueuesL1Bitmap_word_log2_max: - "\valid_queues s; ksReadyQueuesL1Bitmap s d \ 0\ - \ word_log2 (ksReadyQueuesL1Bitmap s d) < l2BitmapSize" - unfolding valid_queues_def - by (fastforce dest: word_log2_nth_same bitmapQ_no_L1_orphansD) + "\valid_bitmaps s; ksReadyQueuesL1Bitmap s d \ 0\ + \ word_log2 (ksReadyQueuesL1Bitmap s d) < l2BitmapSize" + unfolding valid_bitmaps_def + by (fastforce dest: word_log2_nth_same bitmapQ_no_L1_orphansD) lemma word_log2_max_word64[simp]: "word_log2 (w :: 64 word) < 64" @@ -2114,7 +1743,7 @@ lemma word_log2_max_word64[simp]: by (simp add: word_size) lemma rf_sr_ksReadyQueuesL2Bitmap_simp: - "\ (\, s') \ rf_sr ; d \ maxDomain ; valid_queues \ ; ksReadyQueuesL1Bitmap \ d \ 0 \ + "\ (\, s') \ rf_sr ; d \ maxDomain ; valid_bitmaps \ ; ksReadyQueuesL1Bitmap \ d \ 0 \ \ ksReadyQueuesL2Bitmap_' (globals s').[unat d].[word_log2 (ksReadyQueuesL1Bitmap \ d)] = ksReadyQueuesL2Bitmap \ (d, word_log2 (ksReadyQueuesL1Bitmap \ d))" apply (frule rf_sr_cbitmap_L2_relation) @@ -2123,9 +1752,9 @@ lemma rf_sr_ksReadyQueuesL2Bitmap_simp: done lemma ksReadyQueuesL2Bitmap_nonzeroI: - "\ d \ maxDomain ; valid_queues s ; ksReadyQueuesL1Bitmap s d \ 0 \ + "\ d \ maxDomain ; valid_bitmaps s ; ksReadyQueuesL1Bitmap s d \ 0 \ \ ksReadyQueuesL2Bitmap s (d, invertL1Index (word_log2 (ksReadyQueuesL1Bitmap s d))) \ 0" - unfolding valid_queues_def + unfolding valid_bitmaps_def apply clarsimp apply (frule bitmapQ_no_L1_orphansD) apply (erule word_log2_nth_same) @@ -2325,9 +1954,9 @@ lemma threadGet_get_obj_at'_has_domain: lemma possibleSwitchTo_ccorres: shows "ccorres dc xfdc - (valid_queues and (\s. weak_sch_act_wf (ksSchedulerAction s) s) + ((\s. weak_sch_act_wf (ksSchedulerAction s) s) and st_tcb_at' runnable' t and (\s. ksCurDomain s \ maxDomain) - and valid_objs') + and valid_objs' and pspace_aligned' and pspace_distinct') ({s. target_' s = tcb_ptr_to_ctcb_ptr t} \ UNIV) [] (possibleSwitchTo t ) @@ -2375,8 +2004,8 @@ lemma possibleSwitchTo_ccorres: lemma scheduleTCB_ccorres': "ccorres dc xfdc - (tcb_at' thread and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_queues - and valid_objs') + (tcb_at' thread and (\s. weak_sch_act_wf (ksSchedulerAction s) s) + and valid_objs' and pspace_aligned' and pspace_distinct') (UNIV \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) [] (do (runnable, curThread, action) \ do @@ -2426,24 +2055,26 @@ lemma scheduleTCB_ccorres': apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def cscheduler_action_relation_def) apply wp+ - apply (simp add: isRunnable_def isStopped_def) - apply wp + apply (simp add: isRunnable_def isStopped_def) apply (simp add: guard_is_UNIV_def) apply clarsimp apply (clarsimp simp: st_tcb_at'_def obj_at'_def weak_sch_act_wf_def) done lemma scheduleTCB_ccorres_valid_queues'_pre: - "ccorresG rf_sr \ dc xfdc (tcb_at' thread and st_tcb_at' (not runnable') thread and valid_queues' and valid_queues and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_objs') - (UNIV \ \\tptr = tcb_ptr_to_ctcb_ptr thread\) [] - (do (runnable, curThread, action) \ do - runnable \ isRunnable thread; - curThread \ getCurThread; - action \ getSchedulerAction; - return (runnable, curThread, action) od; - when (\ runnable \ curThread = thread \ action = ResumeCurrentThread) rescheduleRequired - od) - (Call scheduleTCB_'proc)" + "ccorresG rf_sr \ dc xfdc + (tcb_at' thread and st_tcb_at' (not runnable') thread + and (\s. weak_sch_act_wf (ksSchedulerAction s) s) + and valid_objs' and pspace_aligned' and pspace_distinct') + \\tptr = tcb_ptr_to_ctcb_ptr thread\ [] + (do (runnable, curThread, action) \ do runnable \ isRunnable thread; + curThread \ getCurThread; + action \ getSchedulerAction; + return (runnable, curThread, action) + od; + when (\ runnable \ curThread = thread \ action = ResumeCurrentThread) rescheduleRequired + od) + (Call scheduleTCB_'proc)" supply empty_fail_cond[simp] apply (cinit' lift: tptr_') apply (rule ccorres_rhs_assoc2)+ @@ -2484,17 +2115,17 @@ lemma scheduleTCB_ccorres_valid_queues'_pre: split: scheduler_action.split_asm) apply wp+ apply (simp add: isRunnable_def isStopped_def) - apply wp apply (simp add: guard_is_UNIV_def) apply (clarsimp simp: st_tcb_at'_def obj_at'_def) done - lemmas scheduleTCB_ccorres_valid_queues' = scheduleTCB_ccorres_valid_queues'_pre[unfolded bind_assoc return_bind split_conv] lemma rescheduleRequired_ccorres_valid_queues'_simple: - "ccorresG rf_sr \ dc xfdc (valid_queues' and sch_act_simple) UNIV [] rescheduleRequired (Call rescheduleRequired_'proc)" + "ccorresG rf_sr \ dc xfdc + sch_act_simple UNIV [] + rescheduleRequired (Call rescheduleRequired_'proc)" apply cinit apply (rule ccorres_symb_exec_l) apply (rule ccorres_split_nothrow_novcg[where r'=dc and xf'=xfdc]) @@ -2527,16 +2158,17 @@ lemma rescheduleRequired_ccorres_valid_queues'_simple: split: scheduler_action.split_asm) lemma scheduleTCB_ccorres_valid_queues'_pre_simple: - "ccorresG rf_sr \ dc xfdc (tcb_at' thread and st_tcb_at' (not runnable') thread and valid_queues' and sch_act_simple) - (UNIV \ \\tptr = tcb_ptr_to_ctcb_ptr thread\) [] - (do (runnable, curThread, action) \ do - runnable \ isRunnable thread; - curThread \ getCurThread; - action \ getSchedulerAction; - return (runnable, curThread, action) od; - when (\ runnable \ curThread = thread \ action = ResumeCurrentThread) rescheduleRequired - od) - (Call scheduleTCB_'proc)" + "ccorresG rf_sr \ dc xfdc + (tcb_at' thread and st_tcb_at' (not runnable') thread and valid_queues' and sch_act_simple) + \\tptr = tcb_ptr_to_ctcb_ptr thread\ [] + (do (runnable, curThread, action) \ do runnable \ isRunnable thread; + curThread \ getCurThread; + action \ getSchedulerAction; + return (runnable, curThread, action) + od; + when (\ runnable \ curThread = thread \ action = ResumeCurrentThread) rescheduleRequired + od) + (Call scheduleTCB_'proc)" supply empty_fail_cond[simp] apply (cinit' lift: tptr_' simp del: word_neq_0_conv) apply (rule ccorres_rhs_assoc2)+ @@ -2575,11 +2207,10 @@ lemma scheduleTCB_ccorres_valid_queues'_pre_simple: apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def cscheduler_action_relation_def) apply wp+ - apply (simp add: isRunnable_def isStopped_def) - apply wp + apply (simp add: isRunnable_def isStopped_def) apply (simp add: guard_is_UNIV_def) apply clarsimp - apply (clarsimp simp: st_tcb_at'_def obj_at'_def valid_queues'_def) + apply (clarsimp simp: st_tcb_at'_def obj_at'_def) done lemmas scheduleTCB_ccorres_valid_queues'_simple @@ -2599,48 +2230,35 @@ lemma threadSet_weak_sch_act_wf_runnable': apply (clarsimp) done -lemma threadSet_valid_queues_and_runnable': "\\s. valid_queues s \ (\p. thread \ set (ksReadyQueues s p) \ runnable' st)\ - threadSet (tcbState_update (\_. st)) thread - \\rv s. valid_queues s\" - apply (wp threadSet_valid_queues) - apply (clarsimp simp: inQ_def) -done - lemma setThreadState_ccorres[corres]: "ccorres dc xfdc - (\s. tcb_at' thread s \ valid_queues s \ valid_objs' s \ valid_tcb_state' st s \ - (ksSchedulerAction s = SwitchToThread thread \ runnable' st) \ - (\p. thread \ set (ksReadyQueues s p) \ runnable' st) \ - sch_act_wf (ksSchedulerAction s) s) - ({s'. (\cl fl. cthread_state_relation_lifted st (cl\tsType_CL := ts_' s' && mask 4\, fl))} - \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) hs + (\s. tcb_at' thread s \ valid_objs' s \ valid_tcb_state' st s \ + pspace_aligned' s \ pspace_distinct' s \ + (ksSchedulerAction s = SwitchToThread thread \ runnable' st) \ + sch_act_wf (ksSchedulerAction s) s) + ({s'. (\cl fl. cthread_state_relation_lifted st (cl\tsType_CL := ts_' s' && mask 4\, fl))} + \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) hs (setThreadState st thread) (Call setThreadState_'proc)" - apply (cinit lift: tptr_' cong add: call_ignore_cong) + apply (cinit lift: tptr_' cong add: call_ignore_cong) apply (ctac (no_vcg) add: threadSet_tcbState_simple_corres) apply (ctac add: scheduleTCB_ccorres) - apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_queues_and_runnable' - threadSet_valid_objs') + apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_objs') by (clarsimp simp: weak_sch_act_wf_def valid_queues_def valid_tcb'_tcbState_update) -lemma threadSet_valid_queues'_and_not_runnable': "\tcb_at' thread and valid_queues' and (\s. (\ runnable' st))\ - threadSet (tcbState_update (\_. st)) thread - \\rv. tcb_at' thread and st_tcb_at' (not runnable') thread and valid_queues' \" - - apply (wp threadSet_valid_queues' threadSet_tcbState_st_tcb_at') - apply (clarsimp simp: pred_neg_def valid_queues'_def inQ_def)+ -done - lemma setThreadState_ccorres_valid_queues': - "ccorres dc xfdc - (\s. tcb_at' thread s \ valid_queues' s \ \ runnable' st \ weak_sch_act_wf (ksSchedulerAction s) s \ Invariants_H.valid_queues s \ (\p. thread \ set (ksReadyQueues s p)) \ sch_act_not thread s \ valid_objs' s \ valid_tcb_state' st s) + "ccorres dc xfdc + (\s. tcb_at' thread s \ \ runnable' st \ weak_sch_act_wf (ksSchedulerAction s) s + \ sch_act_not thread s \ valid_objs' s \ valid_tcb_state' st s + \ pspace_aligned' s \ pspace_distinct' s) ({s'. (\cl fl. cthread_state_relation_lifted st (cl\tsType_CL := ts_' s' && mask 4\, fl))} - \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) [] - (setThreadState st thread) (Call setThreadState_'proc)" - apply (cinit lift: tptr_' cong add: call_ignore_cong) + \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr thread}) [] + (setThreadState st thread) (Call setThreadState_'proc)" + apply (cinit lift: tptr_' cong add: call_ignore_cong) apply (ctac (no_vcg) add: threadSet_tcbState_simple_corres) apply (ctac add: scheduleTCB_ccorres_valid_queues') - apply (wp threadSet_valid_queues'_and_not_runnable' threadSet_weak_sch_act_wf_runnable' threadSet_valid_queues_and_runnable' threadSet_valid_objs') - by (clarsimp simp: valid_tcb'_def tcb_cte_cases_def) + apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_objs' + threadSet_tcbState_st_tcb_at') + by (clarsimp simp: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) lemma simp_list_case_return: "(case x of [] \ return e | y # ys \ return f) = return (if x = [] then e else f)" @@ -2661,22 +2279,20 @@ lemma cancelSignal_ccorres [corres]: apply (rule ccorres_rhs_assoc2) apply (ctac (no_vcg) add: cancelSignal_ccorres_helper) apply (ctac add: setThreadState_ccorres_valid_queues') - apply ((wp setNotification_nosch setNotification_ksQ hoare_vcg_all_lift set_ntfn_valid_objs' | simp add: valid_tcb_state'_def split del: if_split)+)[1] + apply ((wp setNotification_nosch hoare_vcg_all_lift set_ntfn_valid_objs' | simp add: valid_tcb_state'_def split del: if_split)+)[1] apply (simp add: ThreadState_defs) apply (rule conjI, clarsimp, rule conjI, clarsimp) apply (frule (1) ko_at_valid_ntfn'[OF _ invs_valid_objs']) subgoal by ((auto simp: obj_at'_def projectKOs st_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of cthread_state_relation_def sch_act_wf_weak valid_ntfn'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] | - clarsimp simp: eq_commute)+) + | clarsimp simp: eq_commute)+) apply (clarsimp) apply (frule (1) ko_at_valid_ntfn'[OF _ invs_valid_objs']) apply (frule (2) ntfn_blocked_in_queueD) by (auto simp: obj_at'_def projectKOs st_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of valid_ntfn'_def cthread_state_relation_def sch_act_wf_weak isWaitingNtfn_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: ntfn.splits option.splits | clarsimp simp: eq_commute | drule_tac x=thread in bspec)+ @@ -2981,28 +2597,25 @@ lemma cancelIPC_ccorres_helper: cpspace_relation_def update_ep_map_tos typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - subgoal by (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - subgoal by (simp add: cendpoint_relation_def Let_def EPState_Idle_def) - subgoal by simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - subgoal by simp - apply (erule (1) map_to_ko_atI') - apply (simp add: heap_to_user_data_def Let_def) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - subgoal by (clarsimp simp: comp_def) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + subgoal by (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + subgoal by (simp add: cendpoint_relation_def Let_def EPState_Idle_def) + subgoal by simp + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + subgoal by simp + apply (erule (1) map_to_ko_atI') + apply (simp add: heap_to_user_data_def Let_def) subgoal by (clarsimp simp: carch_state_relation_def carch_globals_def fpu_null_state_heap_update_tag_disj_simps global_ioport_bitmap_heap_update_tag_disj_simps packed_heap_update_collapse_hrs - elim!: fpu_null_state_typ_heap_preservation) + elim!: fpu_null_state_typ_heap_preservation) subgoal by (simp add: cmachine_state_relation_def) subgoal by (simp add: h_t_valid_clift_Some_iff) subgoal by (simp add: objBits_simps') @@ -3021,53 +2634,56 @@ lemma cancelIPC_ccorres_helper: cpspace_relation_def update_ep_map_tos typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - subgoal by (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (simp add: cendpoint_relation_def Let_def isSendEP_def isRecvEP_def split: endpoint.splits split del: if_split) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + subgoal by (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (simp add: cendpoint_relation_def Let_def isSendEP_def isRecvEP_def + split: endpoint.splits split del: if_split) \ \recv case\ - apply (subgoal_tac "pspace_canonical' \") - prefer 2 - apply fastforce - apply (clarsimp simp add: h_t_valid_clift_Some_iff ctcb_offset_defs - tcb_queue_relation'_next_mask tcb_queue_relation'_prev_mask - tcb_queue_relation'_next_sign tcb_queue_relation'_prev_sign - cong: tcb_queue_relation'_cong) - subgoal by (intro impI conjI; simp) - \ \send case\ - apply (subgoal_tac "pspace_canonical' \") - prefer 2 - apply fastforce - apply (clarsimp simp add: h_t_valid_clift_Some_iff ctcb_offset_defs - tcb_queue_relation'_next_mask tcb_queue_relation'_prev_mask - tcb_queue_relation'_next_sign tcb_queue_relation'_prev_sign - cong: tcb_queue_relation'_cong) + apply (subgoal_tac "pspace_canonical' \") + prefer 2 + apply fastforce + apply (clarsimp simp: h_t_valid_clift_Some_iff ctcb_offset_defs + tcb_queue_relation'_next_mask tcb_queue_relation'_prev_mask + tcb_queue_relation'_next_sign tcb_queue_relation'_prev_sign + cong: tcb_queue_relation'_cong) subgoal by (intro impI conjI; simp) - subgoal by simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - apply simp - apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - subgoal by (clarsimp simp: comp_def) + \ \send case\ + apply (subgoal_tac "pspace_canonical' \") + prefer 2 + apply fastforce + apply (clarsimp simp: h_t_valid_clift_Some_iff ctcb_offset_defs + tcb_queue_relation'_next_mask tcb_queue_relation'_prev_mask + tcb_queue_relation'_next_sign tcb_queue_relation'_prev_sign + cong: tcb_queue_relation'_cong) + subgoal by (intro impI conjI; simp) + \ \send case\ + apply (subgoal_tac "pspace_canonical' \") + prefer 2 + apply fastforce + apply (clarsimp simp: h_t_valid_clift_Some_iff ctcb_offset_defs + tcb_queue_relation'_next_mask tcb_queue_relation'_prev_mask + tcb_queue_relation'_next_sign tcb_queue_relation'_prev_sign + cong: tcb_queue_relation'_cong) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp + apply (erule (1) map_to_ko_atI') subgoal by (clarsimp simp: carch_state_relation_def carch_globals_def fpu_null_state_heap_update_tag_disj_simps global_ioport_bitmap_heap_update_tag_disj_simps packed_heap_update_collapse_hrs - elim!: fpu_null_state_typ_heap_preservation) + elim!: fpu_null_state_typ_heap_preservation) subgoal by (simp add: cmachine_state_relation_def) subgoal by (simp add: h_t_valid_clift_Some_iff) subgoal by (simp add: objBits_simps') subgoal by (simp add: objBits_simps) by assumption -declare empty_fail_get[iff] - lemma getThreadState_ccorres_foo: "(\rv. ccorres r xf (P rv) (P' rv) hs (f rv) c) \ ccorres r xf (\s. \ts. st_tcb_at' ((=) ts) t s \ P ts s) @@ -3271,37 +2887,35 @@ lemma cancelIPC_ccorres1: subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits) + split: thread_state.splits) apply clarsimp apply (frule (2) ep_blocked_in_queueD_recv) apply (frule (1) ko_at_valid_ep'[OF _ invs_valid_objs']) subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of isRecvEP_def cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits endpoint.splits) + split: thread_state.splits endpoint.splits) apply (rule conjI) apply (clarsimp simp: inQ_def) - apply (rule conjI) - apply clarsimp apply clarsimp apply (rule conjI) subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits) + split: thread_state.splits) apply clarsimp apply (rule conjI) subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits) + split: thread_state.splits) apply clarsimp apply (frule (2) ep_blocked_in_queueD_send) apply (frule (1) ko_at_valid_ep'[OF _ invs_valid_objs']) subgoal by (auto simp: obj_at'_def projectKOs pred_tcb_at'_def invs'_def valid_state'_def isTS_defs cte_wp_at_ctes_of isSendEP_def cthread_state_relation_def sch_act_wf_weak valid_ep'_def - dest!: valid_queues_not_runnable'_not_ksQ[where t=thread] split: thread_state.splits endpoint.splits)[1] + split: thread_state.splits endpoint.splits)[1] apply (auto simp: isTS_defs cthread_state_relation_def typ_heap_simps weak_sch_act_wf_def) apply (case_tac ts, auto simp: isTS_defs cthread_state_relation_def typ_heap_simps) diff --git a/proof/crefine/X64/Ipc_C.thy b/proof/crefine/X64/Ipc_C.thy index 95f28b0a2e..5f385378cc 100644 --- a/proof/crefine/X64/Ipc_C.thy +++ b/proof/crefine/X64/Ipc_C.thy @@ -27,10 +27,6 @@ lemma replyFromKernel_success_empty: unfolding replyFromKernel_def replyFromKernel_success_empty_def by (simp add: setMRs_Nil submonad_asUser.fn_stateAssert) -crunch valid_queues[wp]: handleFaultReply valid_queues - -crunch valid_queues'[wp]: handleFaultReply valid_queues' - crunch sch_act_wf: handleFaultReply "\s. sch_act_wf (ksSchedulerAction s) s" crunch valid_ipc_buffer_ptr' [wp]: copyMRs "valid_ipc_buffer_ptr' p" @@ -1366,18 +1362,14 @@ lemma getRestartPC_ccorres [corres]: done lemma asUser_tcbFault_obj_at: - "\obj_at' (\tcb. P (tcbFault tcb)) t\ asUser t' m - \\rv. obj_at' (\tcb. P (tcbFault tcb)) t\" + "asUser t' m \obj_at' (\tcb. P (tcbFault tcb)) t\" apply (simp add: asUser_def split_def) apply (wp threadGet_wp) apply (simp cong: if_cong) done lemma asUser_atcbContext_obj_at: - "t \ t' \ - \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\ - asUser t' m - \\rv. obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" + "t \ t' \ asUser t' m \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" apply (simp add: asUser_def split_def atcbContextGet_def atcbContextSet_def) apply (wp threadGet_wp) apply simp @@ -4185,10 +4177,6 @@ lemma doReplyTransfer_ccorres [corres]: \ \\grant = from_bool grant\) hs (doReplyTransfer sender receiver slot grant) (Call doReplyTransfer_'proc)" -proof - - have invs_valid_queues_strg: "\s. invs' s \ valid_queues s" - by clarsimp - show ?thesis apply (cinit lift: sender_' receiver_' slot_' grant_') apply (rule getThreadState_ccorres_foo) apply (rule ccorres_assert2) @@ -4220,7 +4208,7 @@ proof - apply (ctac(no_vcg) add: cteDeleteOne_ccorres[where w="scast cap_reply_cap"]) apply (ctac(no_vcg) add: setThreadState_ccorres) apply (ctac(no_vcg) add: possibleSwitchTo_ccorres) - apply (wpsimp wp: sts_running_valid_queues setThreadState_st_tcb)+ + apply (wpsimp wp: sts_valid_objs' setThreadState_st_tcb)+ apply (wp cteDeleteOne_sch_act_wf) apply vcg apply (rule conseqPre, vcg) @@ -4229,8 +4217,7 @@ proof - apply wp apply (simp add: cap_get_tag_isCap) apply (strengthen invs_weak_sch_act_wf_strg - cte_wp_at_imp_consequent'[where P="\ct. Ex (ccap_relation (cteCap ct))" for ct] - invs_valid_queues_strg) + cte_wp_at_imp_consequent'[where P="\ct. Ex (ccap_relation (cteCap ct))" for ct]) apply (simp add: cap_reply_cap_def) apply (wp doIPCTransfer_reply_or_replyslot) apply (clarsimp simp: seL4_Fault_NullFault_def ccorres_cond_iffs @@ -4265,19 +4252,20 @@ proof - apply (ctac (no_vcg)) apply (simp only: K_bind_def) apply (ctac add: possibleSwitchTo_ccorres) - apply (wp sts_running_valid_queues setThreadState_st_tcb | simp)+ - apply (ctac add: setThreadState_ccorres_valid_queues'_simple) + apply (wp sts_valid_objs' setThreadState_st_tcb | simp)+ + apply (ctac add: setThreadState_ccorres_simple) apply wp - apply ((wp threadSet_valid_queues threadSet_sch_act threadSet_valid_queues' hoare_weak_lift_imp + apply ((wp threadSet_sch_act hoare_weak_lift_imp threadSet_valid_objs' threadSet_weak_sch_act_wf | simp add: valid_tcb_state'_def)+)[1] apply (clarsimp simp: guard_is_UNIV_def ThreadState_defs mask_def option_to_ctcb_ptr_def) - apply (rule_tac Q="\rv. valid_queues and tcb_at' receiver and valid_queues' and + apply (rule_tac Q="\rv. tcb_at' receiver and valid_objs' and sch_act_simple and (\s. ksCurDomain s \ maxDomain) and - (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) + (\s. sch_act_wf (ksSchedulerAction s) s) and + pspace_aligned' and pspace_distinct'" in hoare_post_imp) apply (clarsimp simp: inQ_def weak_sch_act_wf_def) - apply (wp threadSet_valid_queues threadSet_sch_act handleFaultReply_sch_act_wf) + apply (wp threadSet_sch_act handleFaultReply_sch_act_wf) apply (clarsimp simp: guard_is_UNIV_def) apply assumption apply clarsimp @@ -4286,7 +4274,7 @@ proof - apply (erule(1) cmap_relation_ko_atE [OF cmap_relation_tcb]) apply (clarsimp simp: ctcb_relation_def typ_heap_simps) apply wp - apply (strengthen vp_invs_strg' invs_valid_queues') + apply (strengthen vp_invs_strg') apply (wp cteDeleteOne_tcbFault cteDeleteOne_sch_act_wf) apply vcg apply (rule conseqPre, vcg) @@ -4302,7 +4290,6 @@ proof - cap_get_tag_isCap) apply fastforce done -qed lemma ccorres_getCTE_cte_at: "ccorresG rf_sr \ r xf P P' hs (getCTE p >>= f) c @@ -4322,7 +4309,7 @@ lemma ccorres_getCTE_cte_at: done lemma setupCallerCap_ccorres [corres]: - "ccorres dc xfdc (valid_queues and valid_pspace' and (\s. \d p. sender \ set (ksReadyQueues s (d, p))) + "ccorres dc xfdc (valid_pspace' and (\s. sch_act_wf (ksSchedulerAction s) s) and sch_act_not sender and tcb_at' sender and tcb_at' receiver and tcb_at' sender and tcb_at' receiver) @@ -4454,23 +4441,20 @@ lemma sendIPC_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def - tcb_queue_relation'_def) - apply simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def + tcb_queue_relation'_def) apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - apply simp - apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp + apply (erule (1) map_to_ko_atI') apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs fpu_null_state_heap_update_tag_disj_simps global_ioport_bitmap_heap_update_tag_disj_simps @@ -4497,30 +4481,27 @@ lemma sendIPC_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - isRecvEP_def isSendEP_def - tcb_queue_relation'_def valid_ep'_def - split: endpoint.splits list.splits - split del: if_split) - apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") - apply (erule (1) tcb_and_not_mask_canonical[OF invs_pspace_canonical']) - apply (simp add: objBits_simps') - apply (clarsimp split: if_split) - apply simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + isRecvEP_def isSendEP_def + tcb_queue_relation'_def valid_ep'_def + split: endpoint.splits list.splits + split del: if_split) + apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") + apply (erule (1) tcb_and_not_mask_canonical[OF invs_pspace_canonical']) + apply (simp add: objBits_simps') + apply (clarsimp split: if_split) apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - apply simp - apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp + apply (erule (1) map_to_ko_atI') apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs fpu_null_state_heap_update_tag_disj_simps global_ioport_bitmap_heap_update_tag_disj_simps @@ -4533,25 +4514,11 @@ lemma sendIPC_dequeue_ccorres_helper: apply (clarsimp simp: cendpoint_relation_def Let_def tcb_queue_relation'_def) done -(* FIXME RAF: this is the old formulation, the above one does not work as expected *) -lemma rf_sr_tcb_update_twice: - "h_t_valid (hrs_htd (hrs2 (globals s') (t_hrs_' (gs2 (globals s'))))) c_guard - (ptr (t_hrs_' (gs2 (globals s'))) (globals s')) - \ ((s, globals_update (\gs. t_hrs_'_update (\ths. - hrs_mem_update (heap_update (ptr ths gs :: tcb_C ptr) (v ths gs)) - (hrs_mem_update (heap_update (ptr ths gs) (v' ths gs)) (hrs2 gs ths))) (gs2 gs)) s') \ rf_sr) - = ((s, globals_update (\gs. t_hrs_'_update (\ths. - hrs_mem_update (heap_update (ptr ths gs) (v ths gs)) (hrs2 gs ths)) (gs2 gs)) s') \ rf_sr)" - by (simp add: rf_sr_def cstate_relation_def Let_def - cpspace_relation_def typ_heap_simps' - carch_state_relation_def cmachine_state_relation_def - packed_heap_update_collapse_hrs) - lemma sendIPC_block_ccorres_helper: - "ccorres dc xfdc (tcb_at' thread and valid_queues and valid_objs' and pspace_canonical' and + "ccorres dc xfdc (tcb_at' thread and valid_objs' and pspace_canonical' and + pspace_aligned' and pspace_distinct' and sch_act_not thread and ep_at' epptr and - (\s. sch_act_wf (ksSchedulerAction s) s \ - (\d p. thread \ set (ksReadyQueues s (d, p)))) and + (\s. sch_act_wf (ksSchedulerAction s) s) and K (bos = ThreadState_BlockedOnSend \ epptr' = epptr \ badge' = badge \ cg = from_bool canGrant \ cgr = from_bool canGrantReply @@ -4610,7 +4577,7 @@ lemma sendIPC_block_ccorres_helper: apply ceqv apply clarsimp apply ctac - apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_queues + apply (wp threadSet_weak_sch_act_wf_runnable' threadSet_valid_objs') apply (clarsimp simp: guard_is_UNIV_def) apply (clarsimp simp: sch_act_wf_weak valid_tcb'_def valid_tcb_state'_def @@ -4715,6 +4682,19 @@ lemma tcb_queue_relation_qend_valid': apply (simp add: h_t_valid_clift_Some_iff) done +lemma tcb_queue'_head_end_NULL: + assumes qr: "tcb_queue_relation' getNext getPrev mp queue qhead qend" + and tat: "\t\set queue. tcb_at' t s" + shows "(qend = NULL) = (qhead = NULL)" + using qr tat + apply - + apply (erule tcb_queue_relationE') + apply (simp add: tcb_queue_head_empty_iff split: if_splits) + apply (rule tcb_at_not_NULL) + apply (erule bspec) + apply simp + done + lemma tcbEPAppend_spec: "\s queue. \ \ \s. \t. (t, s) \ rf_sr \ (\tcb\set queue. tcb_at' tcb t) \ distinct queue @@ -4840,34 +4820,31 @@ lemma sendIPC_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep', assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - mask_def [where n=3] EPState_Send_def) - apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask) - apply (rule conjI, simp add: mask_def) - subgoal - by (fastforce simp: valid_pspace'_def objBits_simps' - intro!: tcb_and_not_mask_canonical - dest!: st_tcb_strg'[rule_format]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep', assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + mask_def [where n=3] EPState_Send_def) + apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask) + apply (rule conjI, simp add: mask_def) + subgoal + by (fastforce simp: valid_pspace'_def objBits_simps' + intro!: tcb_and_not_mask_canonical + dest!: st_tcb_strg'[rule_format]) + apply (simp add: isSendEP_def isRecvEP_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue, assumption+) apply (simp add: isSendEP_def isRecvEP_def) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_ep_queue, assumption+) - apply (simp add: isSendEP_def isRecvEP_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (simp only:projectKOs injectKO_ep objBits_simps) - apply clarsimp - apply (clarsimp simp: obj_at'_def projectKOs) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (simp only:projectKOs injectKO_ep objBits_simps) + apply clarsimp + apply (clarsimp simp: obj_at'_def projectKOs) apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs global_ioport_bitmap_heap_update_tag_disj_simps fpu_null_state_heap_update_tag_disj_simps @@ -4887,41 +4864,38 @@ lemma sendIPC_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep', assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - mask_def [where n=3] EPState_Send_def - split: if_split) - subgoal - apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask - valid_ep'_def - dest: tcb_queue_relation_next_not_NULL) - apply (rule conjI, clarsimp) - apply (rule conjI, fastforce simp: mask_def) - apply (fastforce simp: valid_pspace'_def objBits_simps' - intro!: tcb_and_not_mask_canonical - dest!: st_tcb_strg'[rule_format]) - apply (clarsimp, rule conjI, fastforce simp: mask_def) - by (fastforce simp: valid_pspace'_def objBits_simps' - intro!: tcb_and_not_mask_canonical - dest!: st_tcb_strg'[rule_format]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep', assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + mask_def [where n=3] EPState_Send_def + split: if_split) + subgoal + apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask + valid_ep'_def + dest: tcb_queue_relation_next_not_NULL) + apply (rule conjI, clarsimp) + apply (rule conjI, fastforce simp: mask_def) + apply (fastforce simp: valid_pspace'_def objBits_simps' + intro!: tcb_and_not_mask_canonical + dest!: st_tcb_strg'[rule_format]) + apply (clarsimp, rule conjI, fastforce simp: mask_def) + by (fastforce simp: valid_pspace'_def objBits_simps' + intro!: tcb_and_not_mask_canonical + dest!: st_tcb_strg'[rule_format]) + apply (simp add: isSendEP_def isRecvEP_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue, assumption+) apply (simp add: isSendEP_def isRecvEP_def) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_ep_queue, assumption+) - apply (simp add: isSendEP_def isRecvEP_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def projectKOs) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def projectKOs) apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs global_ioport_bitmap_heap_update_tag_disj_simps fpu_null_state_heap_update_tag_disj_simps @@ -4944,8 +4918,7 @@ lemma ctcb_relation_blockingIPCCanGrantD: lemma sendIPC_ccorres [corres]: "ccorres dc xfdc (invs' and st_tcb_at' simple' thread - and sch_act_not thread and ep_at' epptr and - (\s. \d p. thread \ set (ksReadyQueues s (d, p)))) + and sch_act_not thread and ep_at' epptr) (UNIV \ \\blocking = from_bool blocking\ \ \\do_call = from_bool do_call\ \ \\badge = badge\ @@ -4976,8 +4949,7 @@ lemma sendIPC_ccorres [corres]: apply ceqv apply (rule_tac A="invs' and st_tcb_at' simple' thread and sch_act_not thread and ko_at' ep epptr - and ep_at' epptr - and (\s. \d p. thread \ set (ksReadyQueues s (d, p)))" + and ep_at' epptr" in ccorres_guard_imp2 [where A'=UNIV]) apply wpc \ \RecvEP case\ @@ -5025,12 +4997,11 @@ lemma sendIPC_ccorres [corres]: apply (ctac add: setThreadState_ccorres) apply (rule ccorres_return_Skip) apply (wpsimp wp: hoare_drop_imps hoare_vcg_all_lift possibleSwitchTo_sch_act_not - possibleSwitchTo_sch_act_not sts_st_tcb' - possibleSwitchTo_ksQ' sts_valid_queues sts_ksQ' + possibleSwitchTo_sch_act_not sts_st_tcb' sts_valid_objs' simp: valid_tcb_state'_def)+ apply vcg - apply (wpsimp wp: doIPCTransfer_sch_act setEndpoint_ksQ hoare_vcg_all_lift - set_ep_valid_objs' setEndpoint_valid_mdb' + apply (wpsimp wp: doIPCTransfer_sch_act hoare_vcg_all_lift + set_ep_valid_objs' setEndpoint_valid_mdb' | wp (once) hoare_drop_imp | strengthen sch_act_wf_weak)+ apply (fastforce simp: guard_is_UNIV_def ThreadState_defs Collect_const_mem mask_def @@ -5151,10 +5122,10 @@ lemma ctcb_relation_blockingIPCCanGrantReplyD: done lemma receiveIPC_block_ccorres_helper: - "ccorres dc xfdc (tcb_at' thread and valid_queues and valid_objs' and pspace_canonical' and + "ccorres dc xfdc (tcb_at' thread and valid_objs' and pspace_canonical' and + pspace_aligned' and pspace_distinct' and sch_act_not thread and ep_at' epptr and - (\s. sch_act_wf (ksSchedulerAction s) s \ - (\d p. thread \ set (ksReadyQueues s (d, p)))) and + (\s. sch_act_wf (ksSchedulerAction s) s) and K (epptr = epptr && ~~ mask 4) and K (isEndpointCap cap \ ccap_relation cap cap')) UNIV hs @@ -5194,7 +5165,7 @@ lemma receiveIPC_block_ccorres_helper: apply ceqv apply clarsimp apply ctac - apply (wp threadSet_valid_queues hoare_vcg_all_lift threadSet_valid_objs' + apply (wp hoare_vcg_all_lift threadSet_valid_objs' threadSet_weak_sch_act_wf_runnable') apply (clarsimp simp: guard_is_UNIV_def) apply (clarsimp simp: sch_act_wf_weak valid_tcb'_def valid_tcb_state'_def @@ -5260,41 +5231,38 @@ lemma receiveIPC_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep', assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - mask_def [where n=3] EPState_Recv_def - split: if_split) - subgoal - apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask - valid_ep'_def - dest: tcb_queue_relation_next_not_NULL) - apply (rule conjI, clarsimp) - apply (rule conjI, fastforce simp: mask_def) - apply (fastforce simp: valid_pspace'_def objBits_simps' - intro!: tcb_and_not_mask_canonical - dest!: st_tcb_strg'[rule_format]) - apply (clarsimp, rule conjI, fastforce simp: mask_def) - by (fastforce simp: valid_pspace'_def objBits_simps' - intro!: tcb_and_not_mask_canonical - dest!: st_tcb_strg'[rule_format]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep', assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + mask_def [where n=3] EPState_Recv_def + split: if_split) + subgoal + apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask + valid_ep'_def + dest: tcb_queue_relation_next_not_NULL) + apply (rule conjI, clarsimp) + apply (rule conjI, fastforce simp: mask_def) + apply (fastforce simp: valid_pspace'_def objBits_simps' + intro!: tcb_and_not_mask_canonical + dest!: st_tcb_strg'[rule_format]) + apply (clarsimp, rule conjI, fastforce simp: mask_def) + by (fastforce simp: valid_pspace'_def objBits_simps' + intro!: tcb_and_not_mask_canonical + dest!: st_tcb_strg'[rule_format]) + apply (simp add: isSendEP_def isRecvEP_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue, assumption+) apply (simp add: isSendEP_def isRecvEP_def) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_ep_queue, assumption+) - apply (simp add: isSendEP_def isRecvEP_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def projectKOs) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def projectKOs) apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs global_ioport_bitmap_heap_update_tag_disj_simps fpu_null_state_heap_update_tag_disj_simps @@ -5314,33 +5282,30 @@ lemma receiveIPC_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep', assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - mask_def [where n=3] EPState_Recv_def) - apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask) - subgoal - apply (rule conjI, fastforce simp: mask_def) - by (fastforce simp: valid_pspace'_def objBits_simps' - intro!: tcb_and_not_mask_canonical - dest!: st_tcb_strg'[rule_format]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep', assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + mask_def [where n=3] EPState_Recv_def) + apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask) + subgoal + apply (rule conjI, fastforce simp: mask_def) + by (fastforce simp: valid_pspace'_def objBits_simps' + intro!: tcb_and_not_mask_canonical + dest!: st_tcb_strg'[rule_format]) + apply (simp add: isSendEP_def isRecvEP_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue, assumption+) apply (simp add: isSendEP_def isRecvEP_def) - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - apply (rule cnotification_relation_ep_queue, assumption+) - apply (simp add: isSendEP_def isRecvEP_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def projectKOs) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def projectKOs) apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs global_ioport_bitmap_heap_update_tag_disj_simps fpu_null_state_heap_update_tag_disj_simps @@ -5412,24 +5377,21 @@ lemma receiveIPC_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def - tcb_queue_relation'_def) - apply simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (simp add: cendpoint_relation_def Let_def EPState_Idle_def + tcb_queue_relation'_def) apply simp - apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) - apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp + apply (erule (1) map_to_ko_atI') + apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs global_ioport_bitmap_heap_update_tag_disj_simps fpu_null_state_heap_update_tag_disj_simps elim!: fpu_null_state_typ_heap_preservation) @@ -5455,30 +5417,27 @@ lemma receiveIPC_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (rule cpspace_relation_ep_update_ep, assumption+) - apply (clarsimp simp: cendpoint_relation_def Let_def - isRecvEP_def isSendEP_def - tcb_queue_relation'_def valid_ep'_def - split: endpoint.splits list.splits - split del: if_split) - apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") - apply (erule (1) tcb_and_not_mask_canonical[OF invs_pspace_canonical']) - apply (clarsimp simp: objBits_simps') - apply (clarsimp split: if_split) - apply simp - \ \ntfn relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (rule cpspace_relation_ep_update_ep, assumption+) + apply (clarsimp simp: cendpoint_relation_def Let_def + isRecvEP_def isSendEP_def + tcb_queue_relation'_def valid_ep'_def + split: endpoint.splits list.splits + split del: if_split) + apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") + apply (erule (1) tcb_and_not_mask_canonical[OF invs_pspace_canonical']) + apply (clarsimp simp: objBits_simps') + apply (clarsimp split: if_split) apply simp - apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) - apply simp - apply (erule (1) map_to_ko_atI') - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + \ \ntfn relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cnotification_relation_ep_queue [OF invs_sym'], assumption+) + apply simp + apply (erule (1) map_to_ko_atI') apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs global_ioport_bitmap_heap_update_tag_disj_simps fpu_null_state_heap_update_tag_disj_simps @@ -5600,7 +5559,6 @@ lemma receiveIPC_ccorres [corres]: notes option.case_cong_weak [cong] shows "ccorres dc xfdc (invs' and st_tcb_at' simple' thread and sch_act_not thread - and (\s. \d p. thread \ set (ksReadyQueues s (d, p))) and valid_cap' cap and K (isEndpointCap cap)) (UNIV \ \\thread = tcb_ptr_to_ctcb_ptr thread\ \ \ccap_relation cap \cap\ @@ -5676,7 +5634,6 @@ lemma receiveIPC_ccorres [corres]: apply ceqv apply (rule_tac A="invs' and st_tcb_at' simple' thread and sch_act_not thread - and (\s. \d p. thread \ set (ksReadyQueues s (d, p))) and ko_at' ep (capEPPtr cap)" in ccorres_guard_imp2 [where A'=UNIV]) apply wpc @@ -5816,27 +5773,25 @@ lemma receiveIPC_ccorres [corres]: apply ccorres_rewrite apply ctac apply (ctac add: possibleSwitchTo_ccorres) - apply (wpsimp wp: sts_st_tcb' sts_valid_queues) + apply (wpsimp wp: sts_st_tcb' sts_valid_objs') apply (vcg exspec=setThreadState_modifies) apply (fastforce simp: guard_is_UNIV_def ThreadState_defs mask_def cap_get_tag_isCap ccap_relation_ep_helpers) apply (clarsimp simp: valid_tcb_state'_def) - apply (rule_tac Q="\_. valid_pspace' and valid_queues + apply (rule_tac Q="\_. valid_pspace' and st_tcb_at' ((=) sendState) sender and tcb_at' thread and (\s. sch_act_wf (ksSchedulerAction s) s) - and (\s. (\a b. sender \ set (ksReadyQueues s (a, b)))) and sch_act_not sender and K (thread \ sender) and (\s. ksCurDomain s \ maxDomain)" in hoare_post_imp) - apply (clarsimp simp: valid_pspace_valid_objs' pred_tcb_at'_def sch_act_wf_weak - obj_at'_def) + apply (fastforce simp: valid_pspace_valid_objs' pred_tcb_at'_def sch_act_wf_weak + obj_at'_def) apply (wpsimp simp: guard_is_UNIV_def option_to_ptr_def option_to_0_def conj_ac)+ - apply (rule_tac Q="\rv. valid_queues and valid_pspace' + apply (rule_tac Q="\rv. valid_pspace' and cur_tcb' and tcb_at' sender and tcb_at' thread and sch_act_not sender and K (thread \ sender) and ep_at' (capEPPtr cap) and (\s. ksCurDomain s \ maxDomain) - and (\s. sch_act_wf (ksSchedulerAction s) s \ - (\d p. sender \ set (ksReadyQueues s (d, p))))" + and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) subgoal by (auto, auto simp: st_tcb_at'_def obj_at'_def) apply (wp hoare_vcg_all_lift set_ep_valid_objs') @@ -5872,14 +5827,11 @@ lemma receiveIPC_ccorres [corres]: split: if_split_asm bool.splits) (*very long *) apply (clarsimp simp: obj_at'_def state_refs_of'_def projectKOs) apply (frule(1) sym_refs_ko_atD' [OF _ invs_sym']) - apply (frule invs_queues) apply clarsimp apply (rename_tac list x xa) apply (rule_tac P="x\set list" in case_split) apply (clarsimp simp:st_tcb_at_refs_of_rev') apply (erule_tac x=x and P="\x. st_tcb_at' P x s" for P in ballE) - apply (drule_tac t=x in valid_queues_not_runnable'_not_ksQ) - apply (clarsimp simp: st_tcb_at'_def obj_at'_def) apply (subgoal_tac "sch_act_not x s") prefer 2 apply (frule invs_sch_act_wf') @@ -5957,23 +5909,20 @@ lemma sendSignal_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) - apply simp+ - apply (erule (1) map_to_ko_atI') - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) - apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def - tcb_queue_relation'_def) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) + apply simp+ + apply (erule (1) map_to_ko_atI') + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) + apply (simp add: cnotification_relation_def Let_def NtfnState_Idle_def + tcb_queue_relation'_def) + apply simp apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs global_ioport_bitmap_heap_update_tag_disj_simps fpu_null_state_heap_update_tag_disj_simps @@ -6002,33 +5951,30 @@ lemma sendSignal_dequeue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) - apply simp - apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) - apply simp+ - apply (erule (1) map_to_ko_atI') - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) - apply (clarsimp simp: cnotification_relation_def Let_def - isWaitingNtfn_def - tcb_queue_relation'_def valid_ntfn'_def - split: Structures_H.notification.splits list.splits - split del: if_split) - apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") - apply (rule conjI) - subgoal by (erule (1) tcb_ptr_sign_extend_canonical[OF invs_pspace_canonical']) - apply (rule context_conjI) - subgoal by (erule (1) tcb_ptr_sign_extend_canonical[OF invs_pspace_canonical']) - apply clarsimp - apply (clarsimp split: if_split) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) apply simp - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply (rule cendpoint_relation_ntfn_queue [OF invs_sym'], assumption+) + apply simp+ + apply (erule (1) map_to_ko_atI') + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn, assumption+) + apply (clarsimp simp: cnotification_relation_def Let_def + isWaitingNtfn_def + tcb_queue_relation'_def valid_ntfn'_def + split: Structures_H.notification.splits list.splits + split del: if_split) + apply (subgoal_tac "tcb_at' (if x22 = [] then x21 else last x22) \") + apply (rule conjI) + subgoal by (erule (1) tcb_ptr_sign_extend_canonical[OF invs_pspace_canonical']) + apply (rule context_conjI) + subgoal by (erule (1) tcb_ptr_sign_extend_canonical[OF invs_pspace_canonical']) + apply clarsimp + apply (clarsimp split: if_split) + apply simp apply (clarsimp simp: carch_state_relation_def global_ioport_bitmap_heap_update_tag_disj_simps fpu_null_state_heap_update_tag_disj_simps @@ -6139,7 +6085,7 @@ lemma sendSignal_ccorres [corres]: apply (ctac(no_vcg) add: setThreadState_ccorres) apply (ctac(no_vcg) add: setRegister_ccorres) apply (ctac add: possibleSwitchTo_ccorres) - apply (wp sts_running_valid_queues sts_st_tcb_at'_cases + apply (wp sts_valid_objs' sts_st_tcb_at'_cases | simp add: option_to_ctcb_ptr_def split del: if_split)+ apply (rule_tac Q="\_. tcb_at' (the (ntfnBoundTCB ntfn)) and invs'" in hoare_post_imp) @@ -6207,10 +6153,8 @@ lemma sendSignal_ccorres [corres]: apply (ctac (no_vcg)) apply (ctac add: possibleSwitchTo_ccorres) apply (simp) - apply (wp weak_sch_act_wf_lift_linear - setThreadState_oa_queued - sts_valid_queues tcb_in_cur_domain'_lift)[1] - apply (wp sts_valid_queues sts_runnable) + apply (wp weak_sch_act_wf_lift_linear tcb_in_cur_domain'_lift)[1] + apply (wp sts_valid_objs' sts_runnable) apply (wp setThreadState_st_tcb set_ntfn_valid_objs' | clarsimp)+ apply (clarsimp simp: guard_is_UNIV_def ThreadState_defs mask_def badgeRegister_def Kernel_C.badgeRegister_def @@ -6235,10 +6179,10 @@ lemma sendSignal_ccorres [corres]: done lemma receiveSignal_block_ccorres_helper: - "ccorres dc xfdc (tcb_at' thread and valid_queues and sch_act_not thread and + "ccorres dc xfdc (tcb_at' thread and sch_act_not thread and valid_objs' and ntfn_at' ntfnptr and pspace_canonical' and - (\s. sch_act_wf (ksSchedulerAction s) s \ - (\d p. thread \ set (ksReadyQueues s (d, p)))) and + pspace_aligned' and pspace_distinct' and + (\s. sch_act_wf (ksSchedulerAction s) s) and K (ntfnptr = ntfnptr && ~~ mask 4)) UNIV hs (setThreadState (Structures_H.thread_state.BlockedOnNotification @@ -6273,7 +6217,7 @@ lemma receiveSignal_block_ccorres_helper: apply ceqv apply clarsimp apply ctac - apply (wp threadSet_valid_queues hoare_vcg_all_lift threadSet_valid_objs' + apply (wp hoare_vcg_all_lift threadSet_valid_objs' threadSet_weak_sch_act_wf_runnable') apply (clarsimp simp: guard_is_UNIV_def) apply (auto simp: weak_sch_act_wf_def valid_tcb'_def tcb_cte_cases_def @@ -6392,37 +6336,34 @@ lemma receiveSignal_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cendpoint_relation_ntfn_queue, assumption+) + apply (simp add: isWaitingNtfn_def) apply simp - apply (rule cendpoint_relation_ntfn_queue, assumption+) - apply (simp add: isWaitingNtfn_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def projectKOs) - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn', assumption+) - apply (case_tac "ntfn", simp_all)[1] - apply (clarsimp simp: cnotification_relation_def Let_def - mask_def [where n=3] NtfnState_Waiting_def) - subgoal - apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask valid_ntfn'_def - dest: tcb_queue_relation_next_not_NULL) - apply (rule conjI, fastforce simp: mask_def) - apply (rule context_conjI) - subgoal by (fastforce simp: valid_pspace'_def objBits_simps' - intro!: tcb_ptr_sign_extend_canonical - dest!: st_tcb_strg'[rule_format]) - by clarsimp - apply (simp add: isWaitingNtfn_def) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - subgoal by (clarsimp simp: comp_def) + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def projectKOs) + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn', assumption+) + apply (case_tac "ntfn", simp_all)[1] + apply (clarsimp simp: cnotification_relation_def Let_def + mask_def [where n=3] NtfnState_Waiting_def) + subgoal + apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask valid_ntfn'_def + dest: tcb_queue_relation_next_not_NULL) + apply (rule conjI, fastforce simp: mask_def) + apply (rule context_conjI) + subgoal by (fastforce simp: valid_pspace'_def objBits_simps' + intro!: tcb_ptr_sign_extend_canonical + dest!: st_tcb_strg'[rule_format]) + by clarsimp + apply (simp add: isWaitingNtfn_def) apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs global_ioport_bitmap_heap_update_tag_disj_simps fpu_null_state_heap_update_tag_disj_simps @@ -6442,48 +6383,45 @@ lemma receiveSignal_enqueue_ccorres_helper: typ_heap_simps') apply (elim conjE) apply (intro conjI) - \ \tcb relation\ - apply (erule ctcb_relation_null_queue_ptrs) - apply (clarsimp simp: comp_def) - \ \ep relation\ - apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + \ \tcb relation\ + apply (erule ctcb_relation_null_ep_ptrs) + apply (clarsimp simp: comp_def) + \ \ep relation\ + apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) + apply simp + apply (rule cendpoint_relation_ntfn_queue, assumption+) + apply (simp add: isWaitingNtfn_def) apply simp - apply (rule cendpoint_relation_ntfn_queue, assumption+) - apply (simp add: isWaitingNtfn_def) - apply simp - apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) - apply (erule(2) map_to_ko_at_updI') - apply (clarsimp simp: objBitsKO_def) - apply (clarsimp simp: obj_at'_def projectKOs) - \ \ntfn relation\ - apply (rule cpspace_relation_ntfn_update_ntfn', assumption+) - apply (case_tac "ntfn", simp_all)[1] - apply (clarsimp simp: cnotification_relation_def Let_def - mask_def [where n=3] NtfnState_Waiting_def - split: if_split) - subgoal for _ _ ko' - apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask - dest: tcb_queue_relation_next_not_NULL) - apply (rule conjI, clarsimp) - apply (rule conjI, fastforce simp: mask_def) - apply (rule context_conjI) - subgoal by (fastforce intro!: tcb_ptr_sign_extend_canonical - dest!: st_tcb_strg'[rule_format]) - apply clarsimp - apply clarsimp + apply (frule_tac x=p in map_to_ko_atI, clarsimp, clarsimp) + apply (erule(2) map_to_ko_at_updI') + apply (clarsimp simp: objBitsKO_def) + apply (clarsimp simp: obj_at'_def projectKOs) + \ \ntfn relation\ + apply (rule cpspace_relation_ntfn_update_ntfn', assumption+) + apply (case_tac "ntfn", simp_all)[1] + apply (clarsimp simp: cnotification_relation_def Let_def + mask_def [where n=3] NtfnState_Waiting_def + split: if_split) + subgoal for _ _ ko' + apply (clarsimp simp: tcb_queue_relation'_def is_aligned_neg_mask + dest: tcb_queue_relation_next_not_NULL) + apply (rule conjI, clarsimp) apply (rule conjI, fastforce simp: mask_def) - apply (rule conjI) + apply (rule context_conjI) subgoal by (fastforce intro!: tcb_ptr_sign_extend_canonical dest!: st_tcb_strg'[rule_format]) - apply (subgoal_tac "canonical_address (ntfnQueue_head_CL (notification_lift ko'))") - apply (clarsimp simp: canonical_address_sign_extended sign_extended_iff_sign_extend) - apply (clarsimp simp: notification_lift_def canonical_address_sign_extended - sign_extended_sign_extend) - done - apply (simp add: isWaitingNtfn_def) - \ \queue relation\ - apply (rule cready_queues_relation_null_queue_ptrs, assumption+) - apply (clarsimp simp: comp_def) + apply clarsimp + apply clarsimp + apply (rule conjI, fastforce simp: mask_def) + apply (rule conjI) + subgoal by (fastforce intro!: tcb_ptr_sign_extend_canonical + dest!: st_tcb_strg'[rule_format]) + apply (subgoal_tac "canonical_address (ntfnQueue_head_CL (notification_lift ko'))") + apply (clarsimp simp: canonical_address_sign_extended sign_extended_iff_sign_extend) + apply (clarsimp simp: notification_lift_def canonical_address_sign_extended + sign_extended_sign_extend) + done + apply (simp add: isWaitingNtfn_def) apply (clarsimp simp: carch_state_relation_def packed_heap_update_collapse_hrs global_ioport_bitmap_heap_update_tag_disj_simps fpu_null_state_heap_update_tag_disj_simps @@ -6498,7 +6436,6 @@ lemma receiveSignal_enqueue_ccorres_helper: lemma receiveSignal_ccorres [corres]: "ccorres dc xfdc (invs' and valid_cap' cap and st_tcb_at' simple' thread and sch_act_not thread - and (\s. \d p. thread \ set (ksReadyQueues s (d, p))) and K (isNotificationCap cap)) (UNIV \ \\thread = tcb_ptr_to_ctcb_ptr thread\ \ \ccap_relation cap \cap\ diff --git a/proof/crefine/X64/IsolatedThreadAction.thy b/proof/crefine/X64/IsolatedThreadAction.thy index 737a6b0999..f11e35e610 100644 --- a/proof/crefine/X64/IsolatedThreadAction.thy +++ b/proof/crefine/X64/IsolatedThreadAction.thy @@ -67,12 +67,12 @@ lemma put_tcb_state_regs_twice[simp]: "put_tcb_state_regs tsr (put_tcb_state_regs tsr' tcb) = put_tcb_state_regs tsr tcb" apply (simp add: put_tcb_state_regs_def put_tcb_state_regs_tcb_def - atcbContextSet_def - makeObject_tcb newArchTCB_def newContext_def initContext_def + makeObject_tcb newArchTCB_def atcbContextSet_def split: tcb_state_regs.split option.split Structures_H.kernel_object.split) apply (intro all_tcbI impI allI) - apply (case_tac q, simp) + using atcbContextSet_def atcbContext_set_set + apply fastforce+ done lemma partial_overwrite_twice[simp]: @@ -379,7 +379,7 @@ lemma obj_at_partial_overwrite_id2: lemma objBits_2n: "(1 :: machine_word) < 2 ^ objBits obj" - by (simp add: objBits_def objBitsKO_def archObjSize_def pageBits_def objBits_simps' + by (simp add: archObjSize_def pageBits_def objBits_simps' split: kernel_object.split arch_kernel_object.split) lemma getObject_get_assert: @@ -923,9 +923,11 @@ lemma oblivious_switchToThread_schact: threadSet_def tcbSchedEnqueue_def unless_when asUser_def getQueue_def setQueue_def storeWordUser_def setRegister_def pointerInUserData_def isRunnable_def isStopped_def - getThreadState_def tcbSchedDequeue_def bitmap_fun_defs) + getThreadState_def tcbSchedDequeue_def tcbQueueRemove_def bitmap_fun_defs + ksReadyQueues_asrt_def) by (safe intro!: oblivious_bind - | simp_all add: oblivious_setVMRoot_schact)+ + | simp_all add: ready_qs_runnable_def idleThreadNotQueued_def + oblivious_setVMRoot_schact)+ (* FIXME move *) lemma empty_fail_getCurThread[intro!, wp, simp]: @@ -945,29 +947,9 @@ lemma activateThread_simple_rewrite: end -lemma setCTE_obj_at_prio[wp]: - "\obj_at' (\tcb. P (tcbPriority tcb)) t\ setCTE p v \\rv. obj_at' (\tcb. P (tcbPriority tcb)) t\" - unfolding setCTE_def - by (rule setObject_cte_obj_at_tcb', simp+) - -crunch obj_at_prio[wp]: cteInsert "obj_at' (\tcb. P (tcbPriority tcb)) t" - (wp: crunch_wps) - -crunch ctes_of[wp]: asUser "\s. P (ctes_of s)" - (wp: crunch_wps) - -lemma tcbSchedEnqueue_tcbPriority[wp]: - "\obj_at' (\tcb. P (tcbPriority tcb)) t\ - tcbSchedEnqueue t' - \\rv. obj_at' (\tcb. P (tcbPriority tcb)) t\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wp | simp cong: if_cong)+ - done - -crunch obj_at_prio[wp]: cteDeleteOne "obj_at' (\tcb. P (tcbPriority tcb)) t" - (wp: crunch_wps setEndpoint_obj_at_tcb' - setThreadState_obj_at_unchanged setNotification_tcb setBoundNotification_obj_at_unchanged - simp: crunch_simps unless_def) +crunches setBoundNotification, cteDeleteOne + for obj_at_prio[wp]: "obj_at' (\tcb. P (tcbPriority tcb)) t" + (wp: crunch_wps simp: crunch_simps) lemma setThreadState_no_sch_change: "\\s. P (ksSchedulerAction s) \ (runnable' st \ t \ ksCurThread s)\ @@ -1086,8 +1068,6 @@ lemma setCTE_assert_modify: apply (rule word_and_le2) apply (simp add: objBits_simps mask_def field_simps) apply (simp add: simpler_modify_def cong: option.case_cong if_cong) - apply (rule kernel_state.fold_congs[OF refl refl]) - apply (clarsimp simp: projectKO_opt_tcb cong: if_cong) apply (clarsimp simp: lookupAround2_char1 word_and_le2) apply (rule ccontr, clarsimp) apply (erule(2) ps_clearD) @@ -1104,7 +1084,7 @@ lemma setCTE_assert_modify: apply (erule disjE) apply clarsimp apply (frule(1) tcb_cte_cases_aligned_helpers) - apply (clarsimp simp: domI[where m = cte_cte_cases] field_simps) + apply (clarsimp simp: domI field_simps) apply (clarsimp simp: lookupAround2_char1 obj_at'_def projectKOs objBits_simps) apply (clarsimp simp: obj_at'_def lookupAround2_char1 @@ -1232,11 +1212,14 @@ lemma thread_actions_isolatableD: lemma tcbSchedDequeue_rewrite: "monadic_rewrite True True (obj_at' (Not \ tcbQueued) t) (tcbSchedDequeue t) (return ())" apply (simp add: tcbSchedDequeue_def) - apply (wp_pre, monadic_rewrite_symb_exec_l_known False, simp) - apply (rule monadic_rewrite_refl) - apply (wpsimp wp: threadGet_const)+ + apply wp_pre + apply monadic_rewrite_symb_exec_l + apply (monadic_rewrite_symb_exec_l_known False, simp) + apply (rule monadic_rewrite_refl) + apply (wpsimp wp: threadGet_const)+ done +(* FIXME: improve automation here *) lemma switchToThread_rewrite: "monadic_rewrite True True (ct_in_state' (Not \ runnable') and cur_tcb' and obj_at' (Not \ tcbQueued) t) @@ -1244,7 +1227,9 @@ lemma switchToThread_rewrite: (do Arch.switchToThread t; setCurThread t od)" apply (simp add: switchToThread_def Thread_H.switchToThread_def) apply (monadic_rewrite_l tcbSchedDequeue_rewrite, simp) - apply (rule monadic_rewrite_refl) + (* strip LHS of getters and asserts until LHS and RHS are the same *) + apply (repeat_unless \rule monadic_rewrite_refl\ monadic_rewrite_symb_exec_l) + apply wpsimp+ apply (clarsimp simp: comp_def) done @@ -1282,9 +1267,33 @@ lemma threadGet_isolatable: thread_actions_isolatable_fail) done +lemma tcbQueued_put_tcb_state_regs_tcb: + "tcbQueued (put_tcb_state_regs_tcb tsr tcb) = tcbQueued tcb" + apply (clarsimp simp: put_tcb_state_regs_tcb_def) + by (cases tsr; clarsimp) + +lemma idleThreadNotQueued_isolatable: + "thread_actions_isolatable idx (stateAssert idleThreadNotQueued [])" + apply (simp add: stateAssert_def2 stateAssert_def) + apply (intro thread_actions_isolatable_bind[OF _ _ hoare_pre(1)] + gets_isolatable + thread_actions_isolatable_if + thread_actions_isolatable_returns + thread_actions_isolatable_fail) + unfolding idleThreadNotQueued_def + apply (clarsimp simp: obj_at_partial_overwrite_If) + apply (clarsimp simp: obj_at'_def tcbQueued_put_tcb_state_regs_tcb) + apply wpsimp+ + done + lemma setCurThread_isolatable: "thread_actions_isolatable idx (setCurThread t)" - by (simp add: setCurThread_def modify_isolatable) + unfolding setCurThread_def + apply (rule thread_actions_isolatable_bind) + apply (rule idleThreadNotQueued_isolatable) + apply (fastforce intro: modify_isolatable) + apply wpsimp + done lemma isolate_thread_actions_tcbs_at: assumes f: "\x. \tcb_at' (idx x)\ f \\rv. tcb_at' (idx x)\" shows diff --git a/proof/crefine/X64/Recycle_C.thy b/proof/crefine/X64/Recycle_C.thy index 7abc411aca..4363ee8e8d 100644 --- a/proof/crefine/X64/Recycle_C.thy +++ b/proof/crefine/X64/Recycle_C.thy @@ -870,16 +870,6 @@ lemma cnotification_relation_q_cong: apply (auto intro: iffD1[OF tcb_queue_relation'_cong[OF refl refl refl]]) done -lemma tcbSchedEnqueue_ep_at: - "\obj_at' (P :: endpoint \ bool) ep\ - tcbSchedEnqueue t - \\rv. obj_at' P ep\" - including no_pre - apply (simp add: tcbSchedEnqueue_def unless_def null_def) - apply (wp threadGet_wp, clarsimp, wp+) - apply (clarsimp split: if_split, wp) - done - lemma ccorres_duplicate_guard: "ccorres r xf (P and P) Q hs f f' \ ccorres r xf P Q hs f f'" by (erule ccorres_guard_imp, auto) @@ -899,10 +889,11 @@ lemma cancelBadgedSends_ccorres: (UNIV \ {s. epptr_' s = Ptr ptr} \ {s. badge_' s = bdg}) [] (cancelBadgedSends ptr bdg) (Call cancelBadgedSends_'proc)" apply (cinit lift: epptr_' badge_' simp: whileAnno_def) + apply (rule ccorres_stateAssert) apply (simp add: list_case_return cong: list.case_cong Structures_H.endpoint.case_cong call_ignore_cong del: Collect_const) - apply (rule ccorres_pre_getEndpoint) + apply (rule ccorres_pre_getEndpoint, rename_tac ep) apply (rule_tac R="ko_at' ep ptr" and xf'="ret__unsigned_longlong_'" and val="case ep of RecvEP q \ scast EPState_Recv | IdleEP \ scast EPState_Idle | SendEP q \ scast EPState_Send" @@ -952,8 +943,9 @@ lemma cancelBadgedSends_ccorres: st_tcb_at' (\st. isBlockedOnSend st \ blockingObject st = ptr) x s) \ distinct (xs @ list) \ ko_at' IdleEP ptr s \ (\p. \x \ set (xs @ list). \rf. (x, rf) \ {r \ state_refs_of' s p. snd r \ NTFNBound}) - \ valid_queues s \ pspace_aligned' s \ pspace_distinct' s \ pspace_canonical' s - \ sch_act_wf (ksSchedulerAction s) s \ valid_objs' s" + \ pspace_aligned' s \ pspace_distinct' s \ pspace_canonical' s + \ sch_act_wf (ksSchedulerAction s) s \ valid_objs' s + \ ksReadyQueues_head_end s \ ksReadyQueues_head_end_tcb_at' s" and P'="\xs. {s. ep_queue_relation' (cslift s) (xs @ list) (head_C (queue_' s)) (end_C (queue_' s))} \ {s. thread_' s = (case list of [] \ tcb_Ptr 0 @@ -1055,8 +1047,9 @@ lemma cancelBadgedSends_ccorres: apply (rule_tac rrel=dc and xf=xfdc and P="\s. (\t \ set (x @ a # lista). tcb_at' t s) \ (\p. \t \ set (x @ a # lista). \rf. (t, rf) \ {r \ state_refs_of' s p. snd r \ NTFNBound}) - \ valid_queues s \ distinct (x @ a # lista) - \ pspace_aligned' s \ pspace_distinct' s" + \ distinct (x @ a # lista) + \ pspace_aligned' s \ pspace_distinct' s + \ ksReadyQueues_head_end s \ ksReadyQueues_head_end_tcb_at' s" and P'="{s. ep_queue_relation' (cslift s) (x @ a # lista) (head_C (queue_' s)) (end_C (queue_' s))}" in ccorres_from_vcg) @@ -1072,8 +1065,7 @@ lemma cancelBadgedSends_ccorres: apply (clarsimp simp: return_def rf_sr_def cstate_relation_def Let_def) apply (rule conjI) apply (clarsimp simp: cpspace_relation_def) - apply (rule conjI, erule ctcb_relation_null_queue_ptrs) - apply (rule null_ep_queue) + apply (rule conjI, erule ctcb_relation_null_ep_ptrs) subgoal by (simp add: o_def) apply (rule conjI) apply (erule iffD1 [OF cmap_relation_cong, OF refl refl, rotated -1]) @@ -1096,9 +1088,6 @@ lemma cancelBadgedSends_ccorres: apply (clarsimp simp: image_iff) apply (drule_tac x=p in spec) subgoal by fastforce - apply (rule conjI) - apply (erule cready_queues_relation_not_queue_ptrs, - auto dest: null_ep_schedD[unfolded o_def] simp: o_def)[1] apply (clarsimp simp: carch_state_relation_def cmachine_state_relation_def elim!: fpu_null_state_typ_heap_preservation) apply (rule ccorres_symb_exec_r2) @@ -1108,12 +1097,11 @@ lemma cancelBadgedSends_ccorres: apply wp apply simp apply vcg - apply (wp hoare_vcg_const_Ball_lift tcbSchedEnqueue_ep_at - sch_act_wf_lift) + apply (wp hoare_vcg_const_Ball_lift sch_act_wf_lift) apply simp apply (vcg exspec=tcbSchedEnqueue_cslift_spec) apply (wp hoare_vcg_const_Ball_lift sts_st_tcb_at'_cases - sts_sch_act sts_valid_queues setThreadState_oa_queued) + sts_sch_act sts_valid_objs') apply (vcg exspec=setThreadState_cslift_spec) apply (simp add: ccorres_cond_iffs) apply (rule ccorres_symb_exec_r2) @@ -1137,14 +1125,11 @@ lemma cancelBadgedSends_ccorres: apply (clarsimp simp: cscheduler_action_relation_def st_tcb_at'_def split: scheduler_action.split_asm) apply (rename_tac word) - apply (frule_tac x=word in tcbSchedEnqueue_cslift_precond_discharge) - apply simp - subgoal by clarsimp - subgoal by clarsimp + apply (frule_tac x=word in tcbSchedEnqueue_cslift_precond_discharge; simp?) subgoal by clarsimp apply clarsimp apply (rule conjI) - apply (frule(3) tcbSchedEnqueue_cslift_precond_discharge) + apply (frule tcbSchedEnqueue_cslift_precond_discharge; simp?) subgoal by clarsimp apply clarsimp apply (rule context_conjI) @@ -1184,9 +1169,19 @@ lemma cancelBadgedSends_ccorres: apply (clarsimp split: if_split) apply (drule sym_refsD, clarsimp) apply (drule(1) bspec)+ - by (auto simp: obj_at'_def projectKOs state_refs_of'_def pred_tcb_at'_def tcb_bound_refs'_def - dest!: symreftype_inverse') - + apply (frule ksReadyQueues_asrt_ksReadyQueues_head_end) + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (frule (2) ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at') + apply (fastforce simp: obj_at'_def projectKOs state_refs_of'_def pred_tcb_at'_def + tcb_bound_refs'_def + dest!: symreftype_inverse') + apply (frule ksReadyQueues_asrt_ksReadyQueues_head_end) + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') + apply (frule (2) ksReadyQueues_asrt_ksReadyQueues_head_end_tcb_at') + apply fastforce + done lemma tcb_ptr_to_ctcb_ptr_force_fold: "x + 2 ^ ctcb_size_bits = ptr_val (tcb_ptr_to_ctcb_ptr x)" diff --git a/proof/crefine/X64/Refine_C.thy b/proof/crefine/X64/Refine_C.thy index 36701dd201..ccbfbea8c8 100644 --- a/proof/crefine/X64/Refine_C.thy +++ b/proof/crefine/X64/Refine_C.thy @@ -64,7 +64,7 @@ proof - apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply vcg apply vcg apply (clarsimp simp: irqInvalid_def ucast_8_32_neq) @@ -77,7 +77,7 @@ proof - apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (rule_tac Q="\rv s. invs' s \ (\x. rv = Some x \ x \ X64.maxIRQ) \ rv \ Some 0x3FF" in hoare_post_imp) apply (clarsimp simp: non_kernel_IRQs_def) apply (wp getActiveIRQ_le_maxIRQ getActiveIRQ_neq_Some0xFF | simp)+ @@ -106,14 +106,12 @@ lemma handleUnknownSyscall_ccorres: apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (clarsimp, vcg) apply (clarsimp, rule conseqPre, vcg, clarsimp) apply clarsimp apply (intro impI conjI allI) - apply fastforce - apply (clarsimp simp: ct_not_ksQ) - apply (clarsimp simp add: sch_act_simple_def split: scheduler_action.split) + apply fastforce apply (rule active_ex_cap') apply (erule active_from_running') apply (erule invs_iflive') @@ -163,13 +161,13 @@ lemma handleVMFaultEvent_ccorres: apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (case_tac x, clarsimp, wp) apply (clarsimp, wp, simp) apply wp apply (simp add: guard_is_UNIV_def) apply (clarsimp simp: simple_sane_strg[unfolded sch_act_sane_not]) - by (auto simp: ct_in_state'_def cfault_rel_def is_cap_fault_def ct_not_ksQ + by (auto simp: ct_in_state'_def cfault_rel_def is_cap_fault_def elim: pred_tcb'_weakenE st_tcb_ex_cap'' dest: st_tcb_at_idle_thread' rf_sr_ksCurThread) @@ -195,16 +193,14 @@ lemma handleUserLevelFault_ccorres: apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (clarsimp, vcg) apply (clarsimp, rule conseqPre, vcg, clarsimp) apply clarsimp apply (intro impI conjI allI) - apply (simp add: ct_in_state'_def) - apply (erule pred_tcb'_weakenE) - apply simp - apply (clarsimp simp: ct_not_ksQ) - apply (clarsimp simp add: sch_act_simple_def split: scheduler_action.split) + apply (simp add: ct_in_state'_def) + apply (erule pred_tcb'_weakenE) + apply simp apply (rule active_ex_cap') apply (erule active_from_running') apply (erule invs_iflive') @@ -378,11 +374,10 @@ lemma handleSyscall_ccorres: apply wp[1] apply clarsimp apply wp - apply (rule_tac Q="\rv s. ct_in_state' simple' s \ sch_act_sane s \ - (\p. ksCurThread s \ set (ksReadyQueues s p))" + apply (rule_tac Q="\rv s. ct_in_state' simple' s \ sch_act_sane s" in hoare_post_imp) apply (simp add: ct_in_state'_def) - apply (wp handleReply_sane handleReply_ct_not_ksQ) + apply (wp handleReply_sane) \ \SysYield\ apply (clarsimp simp: syscall_from_H_def syscall_defs) apply (rule ccorres_cond_empty |rule ccorres_cond_univ)+ @@ -408,11 +403,11 @@ lemma handleSyscall_ccorres: apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg_throws) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: return_def) - apply (wp schedule_invs' schedule_sch_act_wf | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + apply (wp schedule_invs' schedule_sch_act_wf + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply (simp | wpc | wp hoare_drop_imp handleReply_sane handleReply_nonz_cap_to_ct schedule_invs' - handleReply_ct_not_ksQ[simplified] | strengthen ct_active_not_idle'_strengthen invs_valid_objs_strengthen)+ apply (rule_tac Q="\rv. invs' and ct_active'" in hoare_post_imp, simp) apply (wp hy_invs') @@ -430,7 +425,7 @@ lemma handleSyscall_ccorres: apply (frule active_ex_cap') apply (clarsimp simp: invs'_def valid_state'_def) apply (clarsimp simp: simple_sane_strg ct_in_state'_def st_tcb_at'_def obj_at'_def - isReply_def ct_not_ksQ) + isReply_def) apply (rule conjI, fastforce) apply (auto simp: syscall_from_H_def Kernel_C.SysSend_def split: option.split_asm) @@ -518,7 +513,7 @@ lemma handleHypervisorEvent_ccorres: apply simp apply assumption apply (wp schedule_sch_act_wf schedule_invs' - | strengthen invs_queues_imp invs_valid_objs_strengthen)+ + | strengthen invs_valid_objs_strengthen invs_pspace_aligned' invs_pspace_distinct')+ apply clarsimp+ done @@ -651,12 +646,12 @@ lemma threadSet_all_invs_triv': apply (wp thread_set_invs_trivial thread_set_ct_running thread_set_not_state_valid_sched threadSet_invs_trivial threadSet_ct_running' hoare_weak_lift_imp thread_set_ct_in_state - | simp add: tcb_cap_cases_def tcb_arch_ref_def + | simp add: tcb_cap_cases_def tcb_arch_ref_def exst_same_def | rule threadSet_ct_in_state' | wp (once) hoare_vcg_disj_lift)+ apply clarsimp apply (rule exI, rule conjI, assumption) - apply (clarsimp simp: invs_def invs'_def cur_tcb_def cur_tcb'_def) + apply (clarsimp simp: invs_def invs'_def cur_tcb_def cur_tcb'_def invs_psp_aligned invs_distinct) apply (simp add: state_relation_def) done @@ -869,17 +864,22 @@ lemma dmo_domain_user_mem'[wp]: done lemma do_user_op_corres_C: - "corres_underlying rf_sr False False (=) (invs' and ex_abs einvs) \ - (doUserOp f tc) (doUserOp_C f tc)" + "corres_underlying rf_sr False False (=) + (invs' and ksReadyQueues_asrt and ex_abs einvs) \ + (doUserOp f tc) (doUserOp_C f tc)" apply (simp only: doUserOp_C_def doUserOp_def split_def) apply (rule corres_guard_imp) apply (rule_tac P=\ and P'=\ and r'="(=)" in corres_split) apply (clarsimp simp: simpler_gets_def getCurThread_def corres_underlying_def rf_sr_def cstate_relation_def Let_def) - apply (rule_tac P=valid_state' and P'=\ and r'="(=)" in corres_split) + apply (rule_tac P="valid_state' and ksReadyQueues_asrt" + and P'=\ and r'="(=)" + in corres_split) apply (clarsimp simp: cstate_to_A_def absKState_def rf_sr_def cstate_to_H_correct ptable_lift_def) - apply (rule_tac P=valid_state' and P'=\ and r'="(=)" in corres_split) + apply (rule_tac P="valid_state' and ksReadyQueues_asrt" + and P'=\ and r'="(=)" + in corres_split) apply (clarsimp simp: cstate_to_A_def absKState_def rf_sr_def cstate_to_H_correct ptable_rights_def) apply (rule_tac P=pspace_distinct' and P'=\ and r'="(=)" @@ -977,6 +977,9 @@ lemma refinement2_both: apply (subst cstate_to_H_correct) apply (fastforce simp: full_invs'_def invs'_def) apply (clarsimp simp: rf_sr_def) + apply (clarsimp simp: lift_state_relation_def full_invs_def) + apply (rule ksReadyQueues_asrt_cross) + apply (erule state_relation_ready_queues_relation) apply (simp add:absKState_def observable_memory_def absExst_def) apply (rule MachineTypes.machine_state.equality,simp_all)[1] apply (rule ext) @@ -1003,13 +1006,35 @@ lemma refinement2_both: apply (clarsimp simp add: do_user_op_C_def do_user_op_H_def monad_to_transition_def) apply (rule rev_mp, rule_tac f="uop" and tc=af in do_user_op_corres_C) apply (clarsimp simp: corres_underlying_def invs_def ex_abs_def) - apply (fastforce simp: full_invs'_def ex_abs_def) + apply (drule bspec) + apply fastforce + apply clarsimp + apply (elim impE) + apply (clarsimp simp: full_invs'_def ex_abs_def) + apply (intro conjI) + apply (rule ksReadyQueues_asrt_cross) + apply (erule state_relation_ready_queues_relation) + apply (clarsimp simp: lift_state_relation_def full_invs_def) + apply (frule state_relation_ready_queues_relation) + apply (fastforce simp: ready_queues_relation_def Let_def tcbQueueEmpty_def) + apply fastforce apply (erule_tac P="a \ b \ c \ (\x. e x)" for a b c d e in disjE) apply (clarsimp simp add: do_user_op_C_def do_user_op_H_def monad_to_transition_def) apply (rule rev_mp, rule_tac f="uop" and tc=af in do_user_op_corres_C) apply (clarsimp simp: corres_underlying_def invs_def ex_abs_def) - apply (fastforce simp: full_invs'_def ex_abs_def) + apply (drule bspec) + apply fastforce + apply clarsimp + apply (elim impE) + apply (clarsimp simp: full_invs'_def ex_abs_def) + apply (intro conjI) + apply (rule ksReadyQueues_asrt_cross) + apply (erule state_relation_ready_queues_relation) + apply (clarsimp simp: lift_state_relation_def full_invs_def) + apply (frule state_relation_ready_queues_relation) + apply (fastforce simp: ready_queues_relation_def Let_def tcbQueueEmpty_def) + apply fastforce apply (clarsimp simp: check_active_irq_C_def check_active_irq_H_def) apply (rule rev_mp, rule check_active_irq_corres_C) diff --git a/proof/crefine/X64/Retype_C.thy b/proof/crefine/X64/Retype_C.thy index 66f30e5948..f51d8c09b2 100644 --- a/proof/crefine/X64/Retype_C.thy +++ b/proof/crefine/X64/Retype_C.thy @@ -3533,7 +3533,6 @@ lemma cnc_tcb_helper: assumes rfsr: "(\\ksPSpace := ks\, x) \ rf_sr" assumes al: "is_aligned (ctcb_ptr_to_tcb_ptr p) (objBitsKO kotcb)" assumes ptr0: "ctcb_ptr_to_tcb_ptr p \ 0" - assumes vq: "valid_queues \" assumes pal: "pspace_aligned' (\\ksPSpace := ks\)" assumes pno: "pspace_no_overlap' (ctcb_ptr_to_tcb_ptr p) (objBitsKO kotcb) (\\ksPSpace := ks\)" assumes pds: "pspace_distinct' (\\ksPSpace := ks\)" @@ -3903,20 +3902,20 @@ proof - unfolding ctcb_relation_def makeObject_tcb heap_updates_defs initContext_registers_def apply (simp add: fbtcb minBound_word) apply (intro conjI) - apply (simp add: cthread_state_relation_def thread_state_lift_def - eval_nat_numeral ThreadState_defs) - apply (clarsimp simp: ccontext_relation_def newContext_def2 carch_tcb_relation_def - newArchTCB_def cregs_relation_def atcbContextGet_def fpu_relation_def) - apply (case_tac r; simp add: C_register_defs index_foldr_update - atcbContext_def newArchTCB_def newContext_def - initContext_def selCS3_eq selDS3_eq) - apply (clarsimp simp: fpu_relation_def) - apply (simp add: thread_state_lift_def index_foldr_update atcbContextGet_def) - apply (simp add: Kernel_Config.timeSlice_def) - apply (simp add: cfault_rel_def seL4_Fault_lift_def seL4_Fault_get_tag_def Let_def - lookup_fault_lift_def lookup_fault_get_tag_def lookup_fault_invalid_root_def - index_foldr_update seL4_Fault_NullFault_def option_to_ptr_def option_to_0_def - split: if_split)+ + apply (simp add: cthread_state_relation_def thread_state_lift_def + eval_nat_numeral ThreadState_defs) + apply (clarsimp simp: ccontext_relation_def newContext_def2 carch_tcb_relation_def + newArchTCB_def cregs_relation_def atcbContextGet_def fpu_relation_def) + apply (case_tac r; simp add: C_register_defs index_foldr_update + atcbContext_def newArchTCB_def newContext_def + initContext_def) + apply (simp add: thread_state_lift_def index_foldr_update atcbContextGet_def) + apply (simp add: Kernel_Config.timeSlice_def) + apply (simp add: cfault_rel_def seL4_Fault_lift_def seL4_Fault_get_tag_def Let_def + lookup_fault_lift_def lookup_fault_get_tag_def lookup_fault_invalid_root_def + index_foldr_update seL4_Fault_NullFault_def option_to_ptr_def option_to_0_def + split: if_split)+ + apply (simp add: option_to_ctcb_ptr_def) done have pks: "ks (ctcb_ptr_to_tcb_ptr p) = None" @@ -3967,15 +3966,6 @@ proof - apply (fastforce simp: dom_def) done - hence kstcb: "\qdom prio. ctcb_ptr_to_tcb_ptr p \ set (ksReadyQueues \ (qdom, prio))" using vq - apply (clarsimp simp add: valid_queues_def valid_queues_no_bitmap_def) - apply (drule_tac x = qdom in spec) - apply (drule_tac x = prio in spec) - apply clarsimp - apply (drule (1) bspec) - apply (simp add: obj_at'_def) - done - have ball_subsetE: "\P S R. \ \x \ S. P x; R \ S \ \ \x \ R. P x" by blast @@ -4099,7 +4089,7 @@ proof - apply (simp add: cl_cte [simplified] cl_tcb [simplified] cl_rest [simplified] tag_disj_via_td_name) apply (clarsimp simp: cready_queues_relation_def Let_def htd_safe[simplified] kernel_data_refs_domain_eq_rotate) - apply (simp add: heap_updates_def kstcb tcb_queue_update_other' hrs_htd_update + apply (simp add: heap_updates_def tcb_queue_update_other' hrs_htd_update ptr_retyp_to_array[simplified] irq[simplified]) apply (match premises in H: \fpu_null_state_relation _\ \ \match premises in _[thin]: _ (multi) \ \insert H\\) @@ -5188,7 +5178,8 @@ lemma rf_sr_fpu_null_relation: lemma ccorres_placeNewObject_tcb: "ccorresG rf_sr \ dc xfdc - (pspace_aligned' and pspace_distinct' and pspace_no_overlap' regionBase tcbBlockSizeBits and valid_queues and (\s. sym_refs (state_refs_of' s)) + (pspace_aligned' and pspace_distinct' and pspace_no_overlap' regionBase tcbBlockSizeBits + and (\s. sym_refs (state_refs_of' s)) and (\s. 2 ^ tcbBlockSizeBits \ gsMaxObjectSize s) and ret_zero regionBase (2 ^ tcbBlockSizeBits) and K (regionBase \ 0 \ range_cover regionBase tcbBlockSizeBits tcbBlockSizeBits 1 @@ -5597,7 +5588,7 @@ qed lemma placeNewObject_user_data: "ccorresG rf_sr \ dc xfdc (pspace_aligned' and pspace_distinct' and pspace_no_overlap' regionBase (pageBits+us) - and valid_queues and valid_machine_state' + and valid_machine_state' and ret_zero regionBase (2 ^ (pageBits+us)) and (\s. sym_refs (state_refs_of' s)) and (\s. 2^(pageBits + us) \ gsMaxObjectSize s) @@ -5736,7 +5727,7 @@ lemma placeNewObject_user_data_device: "ccorresG rf_sr \ dc xfdc (pspace_aligned' and pspace_distinct' and ret_zero regionBase (2 ^ (pageBits + us)) - and pspace_no_overlap' regionBase (pageBits+us) and valid_queues + and pspace_no_overlap' regionBase (pageBits+us) and (\s. sym_refs (state_refs_of' s)) and (\s. 2^(pageBits + us) \ gsMaxObjectSize s) and K (regionBase \ 0 \ range_cover regionBase (pageBits + us) (pageBits+us) (Suc 0) @@ -5965,7 +5956,7 @@ proof - apply clarify apply (intro conjI) apply (clarsimp simp: invs_pspace_aligned' invs_pspace_distinct' invs_valid_global' - APIType_capBits_def invs_queues invs_valid_objs' + APIType_capBits_def invs_valid_objs' invs_urz pageBits_def) apply clarsimp apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def @@ -5994,7 +5985,7 @@ proof - apply clarify apply (intro conjI) apply (clarsimp simp: invs_pspace_aligned' invs_pspace_distinct' invs_valid_global' - APIType_capBits_def invs_queues invs_valid_objs' + APIType_capBits_def invs_valid_objs' invs_urz bit_simps) apply clarsimp apply (clarsimp simp: ccap_relation_def APIType_capBits_def @@ -6023,7 +6014,7 @@ proof - apply clarify apply (intro conjI) apply (clarsimp simp: invs_pspace_aligned' invs_pspace_distinct' invs_valid_global' - APIType_capBits_def invs_queues invs_valid_objs' invs_urz bit_simps) + APIType_capBits_def invs_valid_objs' invs_urz bit_simps) apply clarsimp apply (clarsimp simp: ccap_relation_def APIType_capBits_def framesize_to_H_def cap_to_H_simps cap_pdpt_cap_lift @@ -6054,7 +6045,7 @@ proof - apply clarify apply (intro conjI) apply (clarsimp simp: invs_pspace_aligned' invs_pspace_distinct' invs_valid_global' - APIType_capBits_def invs_queues invs_valid_objs' invs_urz bit_simps) + APIType_capBits_def invs_valid_objs' invs_urz bit_simps) apply clarsimp apply (clarsimp simp: ccap_relation_def APIType_capBits_def framesize_to_H_def cap_to_H_simps cap_pml4_cap_lift @@ -6159,15 +6150,11 @@ lemma threadSet_domain_ccorres [corres]: apply (simp add: map_to_ctes_upd_tcb_no_ctes map_to_tcbs_upd tcb_cte_cases_def) apply (simp add: cep_relations_drop_fun_upd cvariable_relation_upd_const ko_at_projectKO_opt) - apply (rule conjI) - apply (drule ko_at_projectKO_opt) - apply (erule (2) cmap_relation_upd_relI) - subgoal by (simp add: ctcb_relation_def) - apply assumption - apply simp - apply (erule cready_queues_relation_not_queue_ptrs) - apply (rule ext, simp split: if_split) - apply (rule ext, simp split: if_split) + apply (drule ko_at_projectKO_opt) + apply (erule (2) cmap_relation_upd_relI) + subgoal by (simp add: ctcb_relation_def) + apply assumption + apply simp done lemma createObject_ccorres: @@ -6294,7 +6281,6 @@ proof - createObject_c_preconds_def) apply (frule invs_pspace_aligned') apply (frule invs_pspace_distinct') - apply (frule invs_queues) apply (frule invs_sym') apply (simp add: getObjectSize_def objBits_simps word_bits_conv apiGetObjectSize_def @@ -6339,7 +6325,6 @@ proof - apply (clarsimp simp: createObject_hs_preconds_def isFrameType_def) apply (frule invs_pspace_aligned') apply (frule invs_pspace_distinct') - apply (frule invs_queues) apply (frule invs_sym') apply (auto simp: getObjectSize_def objBits_simps apiGetObjectSize_def epSizeBits_def word_bits_conv @@ -6377,7 +6362,6 @@ proof - apply (clarsimp simp: createObject_hs_preconds_def isFrameType_def) apply (frule invs_pspace_aligned') apply (frule invs_pspace_distinct') - apply (frule invs_queues) apply (frule invs_sym') apply (auto simp: getObjectSize_def objBits_simps apiGetObjectSize_def @@ -6419,7 +6403,6 @@ proof - apply (clarsimp simp: createObject_hs_preconds_def isFrameType_def) apply (frule invs_pspace_aligned') apply (frule invs_pspace_distinct') - apply (frule invs_queues) apply (frule invs_sym') apply (frule(1) ghost_assertion_size_logic_no_unat) apply (clarsimp simp: getObjectSize_def objBits_simps @@ -7285,14 +7268,6 @@ lemma insertNewCap_sch_act_simple[wp]: "\sch_act_simple\insertNewCap a b c\\_. sch_act_simple\" by (simp add:sch_act_simple_def,wp) -lemma insertNewCap_ct_active'[wp]: - "\ct_active'\insertNewCap a b c\\_. ct_active'\" - apply (simp add:ct_in_state'_def) - apply (rule hoare_pre) - apply wps - apply (wp insertNewCap_ksCurThread | simp)+ - done - lemma updateMDB_ctes_of_cap: "\\s. (\x\ran(ctes_of s). P (cteCap x)) \ no_0 (ctes_of s)\ updateMDB srcSlot t diff --git a/proof/crefine/X64/SR_lemmas_C.thy b/proof/crefine/X64/SR_lemmas_C.thy index d3041b0640..e5103dbdf9 100644 --- a/proof/crefine/X64/SR_lemmas_C.thy +++ b/proof/crefine/X64/SR_lemmas_C.thy @@ -292,11 +292,15 @@ lemma cmdbnode_relation_mdb_node_to_H [simp]: unfolding cmdbnode_relation_def mdb_node_to_H_def mdb_node_lift_def cte_lift_def by (fastforce split: option.splits) -definition - tcb_no_ctes_proj :: "tcb \ Structures_H.thread_state \ machine_word \ machine_word \ arch_tcb \ bool \ word8 \ word8 \ word8 \ nat \ fault option \ machine_word option" +definition tcb_no_ctes_proj :: + "tcb \ Structures_H.thread_state \ machine_word \ machine_word \ arch_tcb \ bool \ word8 + \ word8 \ word8 \ nat \ fault option \ machine_word option + \ machine_word option \ machine_word option" where - "tcb_no_ctes_proj t \ (tcbState t, tcbFaultHandler t, tcbIPCBuffer t, tcbArch t, tcbQueued t, - tcbMCP t, tcbPriority t, tcbDomain t, tcbTimeSlice t, tcbFault t, tcbBoundNotification t)" + "tcb_no_ctes_proj t \ + (tcbState t, tcbFaultHandler t, tcbIPCBuffer t, tcbArch t, tcbQueued t, + tcbMCP t, tcbPriority t, tcbDomain t, tcbTimeSlice t, tcbFault t, tcbBoundNotification t, + tcbSchedNext t, tcbSchedPrev t)" lemma tcb_cte_cases_proj_eq [simp]: "tcb_cte_cases p = Some (getF, setF) \ @@ -1468,9 +1472,9 @@ lemma cmap_relation_cong: apply (erule imageI) done -lemma ctcb_relation_null_queue_ptrs: +lemma ctcb_relation_null_ep_ptrs: assumes rel: "cmap_relation mp mp' tcb_ptr_to_ctcb_ptr ctcb_relation" - and same: "map_option tcb_null_queue_ptrs \ mp'' = map_option tcb_null_queue_ptrs \ mp'" + and same: "map_option tcb_null_ep_ptrs \ mp'' = map_option tcb_null_ep_ptrs \ mp'" shows "cmap_relation mp mp'' tcb_ptr_to_ctcb_ptr ctcb_relation" using rel apply (rule iffD1 [OF cmap_relation_cong, OF _ map_option_eq_dom_eq, rotated -1]) @@ -1478,7 +1482,7 @@ lemma ctcb_relation_null_queue_ptrs: apply (rule same [symmetric]) apply (drule compD [OF same]) apply (case_tac b, case_tac b') - apply (simp add: ctcb_relation_def tcb_null_queue_ptrs_def) + apply (simp add: ctcb_relation_def tcb_null_ep_ptrs_def) done (* FIXME x64: do we still need these? @@ -2363,6 +2367,14 @@ lemma capTCBPtr_eq: apply clarsimp done +lemma rf_sr_ctcb_queue_relation: + "\ (s, s') \ rf_sr; d \ maxDomain; p \ maxPriority \ + \ ctcb_queue_relation (ksReadyQueues s (d, p)) + (index (ksReadyQueues_' (globals s')) (cready_queues_index_to_C d p))" + unfolding rf_sr_def cstate_relation_def cready_queues_relation_def + apply (clarsimp simp: Let_def seL4_MinPrio_def minDom_def maxDom_to_H maxPrio_to_H) + done + lemma rf_sr_sched_action_relation: "(s, s') \ rf_sr \ cscheduler_action_relation (ksSchedulerAction s) (ksSchedulerAction_' (globals s'))" @@ -2480,6 +2492,12 @@ lemma fpu_null_state_heap_update_tag_disj': by (clarsimp simp: fpu_null_state_relation_def hrs_mem_update_def hrs_htd_def split: prod.splits) +lemma rf_sr_obj_update_helper: + "(s, s'\ globals := globals s' \ t_hrs_' := t_hrs_' (globals (undefined + \ globals := (undefined \ t_hrs_' := f (globals s') (t_hrs_' (globals s')) \)\))\\) \ rf_sr + \ (s, globals_update (\v. t_hrs_'_update (f v) v) s') \ rf_sr" + by (simp cong: StateSpace.state.fold_congs globals.fold_congs) + lemmas h_t_valid_nested_fields = h_t_valid_field[OF h_t_valid_field[OF h_t_valid_field]] h_t_valid_field[OF h_t_valid_field] diff --git a/proof/crefine/X64/Schedule_C.thy b/proof/crefine/X64/Schedule_C.thy index 41ddffb772..e0b618e692 100644 --- a/proof/crefine/X64/Schedule_C.thy +++ b/proof/crefine/X64/Schedule_C.thy @@ -6,7 +6,7 @@ *) theory Schedule_C -imports Tcb_C +imports Tcb_C Detype_C begin (*FIXME: arch_split: move up?*) @@ -33,19 +33,41 @@ lemma Arch_switchToIdleThread_ccorres: apply (clarsimp simp: invs_no_cicd'_def valid_pspace'_def valid_idle'_tcb_at'_ksIdleThread) done +lemma invs_no_cicd'_pspace_aligned': + "all_invs_but_ct_idle_or_in_cur_domain' s \ pspace_aligned' s" + by (simp add: all_invs_but_ct_idle_or_in_cur_domain'_def valid_pspace'_def) + +lemma invs_no_cicd'_pspace_distinct': + "all_invs_but_ct_idle_or_in_cur_domain' s \ pspace_distinct' s" + by (simp add: all_invs_but_ct_idle_or_in_cur_domain'_def valid_pspace'_def) + +lemma threadGet_exs_valid[wp]: + "tcb_at' t s \ \(=) s\ threadGet f t \\\r. (=) s\" + unfolding threadGet_def liftM_def + apply (wpsimp wp: exs_getObject) + apply (fastforce simp: obj_at'_def objBits_simps')+ + done + +lemma isRunnable_exs_valid[wp]: + "tcb_at' t s \ \(=) s\ isRunnable t \\\r. (=) s\" + unfolding isRunnable_def getThreadState_def + by (wpsimp wp: exs_getObject) + lemma switchToIdleThread_ccorres: "ccorres dc xfdc invs_no_cicd' UNIV hs switchToIdleThread (Call switchToIdleThread_'proc)" apply (cinit) + apply (rule ccorres_stateAssert) apply (rule ccorres_symb_exec_l) apply (ctac (no_vcg) add: Arch_switchToIdleThread_ccorres) apply (simp add: setCurThread_def) + apply (rule ccorres_stateAssert) apply (rule_tac P="\s. thread = ksIdleThread s" and P'=UNIV in ccorres_from_vcg) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: simpler_modify_def) apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def carch_state_relation_def cmachine_state_relation_def) - apply (wpsimp simp: X64_H.switchToIdleThread_def)+ + apply (wpsimp simp: X64_H.switchToIdleThread_def wp: hoare_drop_imps)+ done lemma Arch_switchToThread_ccorres: @@ -69,23 +91,28 @@ lemma switchToThread_ccorres: hs (switchToThread t) (Call switchToThread_'proc)" - apply (cinit lift: thread_') + apply (clarsimp simp: switchToThread_def) + apply (rule ccorres_symb_exec_l'[OF _ _ isRunnable_sp]; (solves wpsimp)?) + apply (rule ccorres_symb_exec_l'[OF _ _ assert_sp]; (solves wpsimp)?) + apply (rule ccorres_stateAssert_fwd)+ + apply (cinit' lift: thread_') apply (ctac (no_vcg) add: Arch_switchToThread_ccorres) apply (ctac (no_vcg) add: tcbSchedDequeue_ccorres) + apply (simp add: setCurThread_def) + apply (rule ccorres_stateAssert) apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg) apply clarsimp apply (rule conseqPre, vcg) - apply (clarsimp simp: setCurThread_def simpler_modify_def) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def) - apply wp+ - apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def) + apply (clarsimp simp: setCurThread_def simpler_modify_def rf_sr_def cstate_relation_def + Let_def carch_state_relation_def cmachine_state_relation_def) + apply (wpsimp wp: Arch_switchToThread_invs_no_cicd' hoare_drop_imps + | strengthen invs_no_cicd'_pspace_aligned' invs_no_cicd'_pspace_distinct')+ done lemma activateThread_ccorres: "ccorres dc xfdc (ct_in_state' activatable' and (\s. sch_act_wf (ksSchedulerAction s) s) - and valid_queues and valid_objs') + and valid_objs' and pspace_aligned' and pspace_distinct') UNIV [] activateThread (Call activateThread_'proc)" @@ -177,13 +204,42 @@ lemma switchToThread_ccorres': lemmas word_log2_max_word_word_size = word_log2_max[where 'a=machine_word_len, simplified word_size, simplified] +lemma ccorres_pre_getQueue: + assumes cc: "\queue. ccorres r xf (P queue) (P' queue) hs (f queue) c" + shows "ccorres r xf (\s. P (ksReadyQueues s (d, p)) s \ d \ maxDomain \ p \ maxPriority) + {s'. \queue. (let cqueue = index (ksReadyQueues_' (globals s')) + (cready_queues_index_to_C d p) in + ctcb_queue_relation queue cqueue) \ s' \ P' queue} + hs (getQueue d p >>= (\queue. f queue)) c" + apply (rule ccorres_guard_imp2) + apply (rule ccorres_symb_exec_l2) + defer + defer + apply (rule gq_sp) + defer + apply (rule ccorres_guard_imp) + apply (rule cc) + apply clarsimp + apply assumption + apply assumption + apply (clarsimp simp: getQueue_def gets_exs_valid) + apply clarsimp + apply (drule spec, erule mp) + apply (erule rf_sr_ctcb_queue_relation) + apply (simp add: maxDom_to_H maxPrio_to_H)+ + done + lemma chooseThread_ccorres: - "ccorres dc xfdc all_invs_but_ct_idle_or_in_cur_domain' UNIV [] chooseThread (Call chooseThread_'proc)" + "ccorres dc xfdc all_invs_but_ct_idle_or_in_cur_domain' UNIV [] + chooseThread (Call chooseThread_'proc)" proof - note prio_and_dom_limit_helpers [simp] note ksReadyQueuesL2Bitmap_nonzeroI [simp] note Collect_const_mem [simp] + + note prio_and_dom_limit_helpers[simp] word_sle_def[simp] maxDom_to_H[simp] maxPrio_to_H[simp] + note invert_prioToL1Index_c_simp[simp] (* when numDomains = 1, array bounds checks would become _ = 0 rather than _ < 1, changing the shape of the proof compared to when numDomains > 1 *) include no_less_1_simps @@ -192,9 +248,22 @@ proof - "\s. invs_no_cicd' s \ ksCurDomain s \ maxDomain" by (simp add: invs_no_cicd'_def) + have invs_no_cicd'_valid_bitmaps: + "\s. invs_no_cicd' s \ valid_bitmaps s" + by (simp add: invs_no_cicd'_def) + + have invs_no_cicd'_pspace_aligned': + "\s. invs_no_cicd' s \ pspace_aligned' s" + by (simp add: invs_no_cicd'_def valid_pspace'_def) + + have invs_no_cicd'_pspace_distinct': + "\s. invs_no_cicd' s \ pspace_distinct' s" + by (simp add: invs_no_cicd'_def valid_pspace'_def) + show ?thesis supply if_split[split del] apply (cinit) + apply (rule ccorres_stateAssert)+ apply (simp add: numDomains_sge_1_simp) apply (rule_tac xf'=dom_' and r'="\rv rv'. rv' = ucast rv" in ccorres_split_nothrow_novcg) apply (rule ccorres_from_vcg[where P=\ and P'=UNIV]) @@ -227,7 +296,7 @@ proof - apply (rule_tac P="curdom \ maxDomain" in ccorres_cross_over_guard_no_st) apply (rule_tac P="prio \ maxPriority" in ccorres_cross_over_guard_no_st) apply (rule ccorres_pre_getQueue) - apply (rule_tac P="queue \ []" in ccorres_cross_over_guard_no_st) + apply (rule_tac P="\ tcbQueueEmpty queue" in ccorres_cross_over_guard_no_st) apply (rule ccorres_symb_exec_l) apply (rule ccorres_assert) apply (rule ccorres_symb_exec_r) @@ -242,37 +311,40 @@ proof - apply (rule conseqPre, vcg) apply (rule Collect_mono) apply clarsimp - apply (strengthen queue_in_range) apply assumption apply clarsimp apply (rule conseqPre, vcg) apply clarsimp apply (wp isRunnable_wp)+ apply (clarsimp simp: Let_def guard_is_UNIV_def) - apply (drule invs_no_cicd'_queues) - apply (case_tac queue, simp) - apply (clarsimp simp: tcb_queue_relation'_def cready_queues_index_to_C_def numPriorities_def) - apply (clarsimp simp add: maxDom_to_H maxPrio_to_H - queue_in_range[where qdom=0, simplified, simplified maxPrio_to_H]) - apply (clarsimp simp: le_maxDomain_eq_less_numDomains unat_trans_ucast_helper ) + apply (rule conjI) + apply (clarsimp simp: le_maxDomain_eq_less_numDomains unat_trans_ucast_helper) + apply (intro conjI impI) + apply (clarsimp simp: cready_queues_index_to_C_def numPriorities_def ctcb_queue_relation_def + tcbQueueEmpty_def option_to_ctcb_ptr_def) + apply (frule_tac qdom=curdom and prio=rv in cready_queues_index_to_C_in_range') + apply fastforce + apply (clarsimp simp: num_tcb_queues_val word_less_nat_alt cready_queues_index_to_C_def2) apply wpsimp apply (clarsimp simp: guard_is_UNIV_def le_maxDomain_eq_less_numDomains word_less_nat_alt numDomains_less_numeric_explicit) - apply (frule invs_no_cicd'_queues) + apply clarsimp apply (frule invs_no_cicd'_max_CurDomain) - apply (frule invs_no_cicd'_queues) - apply (clarsimp simp: valid_queues_def lookupBitmapPriority_le_maxPriority) + apply (frule invs_no_cicd'_pspace_aligned') + apply (frule invs_no_cicd'_pspace_distinct') + apply (frule invs_no_cicd'_valid_bitmaps) + apply (frule valid_bitmaps_bitmapQ_no_L1_orphans) + apply (frule valid_bitmaps_valid_bitmapQ) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def cong: conj_cong) apply (intro conjI impI) - apply (fastforce dest: bitmapQ_from_bitmap_lookup simp: valid_bitmapQ_bitmapQ_simp) - apply (fastforce dest: lookupBitmapPriority_obj_at' - simp: pred_conj_def obj_at'_def st_tcb_at'_def) - apply (fastforce dest: bitmapQ_from_bitmap_lookup simp: valid_bitmapQ_bitmapQ_simp) - apply (clarsimp simp: pred_conj_def obj_at'_def st_tcb_at'_def) - apply (clarsimp simp: not_less le_maxDomain_eq_less_numDomains) - apply (prop_tac "ksCurDomain s = 0") - using unsigned_eq_0_iff apply force - apply (cut_tac s=s in lookupBitmapPriority_obj_at'; simp?) - apply (clarsimp simp: pred_conj_def obj_at'_def st_tcb_at'_def) + apply (fastforce intro: lookupBitmapPriority_le_maxPriority) + apply (fastforce dest!: bitmapQ_from_bitmap_lookup valid_bitmapQ_bitmapQ_simp) + apply (fastforce dest!: lookupBitmapPriority_obj_at' + simp: ready_queue_relation_def ksReadyQueues_asrt_def st_tcb_at'_def obj_at'_def) + apply (fastforce dest: lookupBitmapPriority_le_maxPriority) + apply (fastforce dest!: bitmapQ_from_bitmap_lookup valid_bitmapQ_bitmapQ_simp) + apply (fastforce dest!: lookupBitmapPriority_obj_at' + simp: ready_queue_relation_def ksReadyQueues_asrt_def st_tcb_at'_def obj_at'_def) done qed @@ -596,7 +668,7 @@ lemma schedule_ccorres: apply (wp (once) hoare_drop_imps) apply wp apply (strengthen strenghten_False_imp[where P="a = ResumeCurrentThread" for a]) - apply (clarsimp simp: conj_ac invs_queues invs_valid_objs' cong: conj_cong) + apply (clarsimp simp: conj_ac invs_valid_objs' cong: conj_cong) apply wp apply (clarsimp, vcg exspec=tcbSchedEnqueue_modifies) apply (clarsimp, vcg exspec=tcbSchedEnqueue_modifies) @@ -616,9 +688,11 @@ lemma schedule_ccorres: apply wp apply vcg - apply (clarsimp simp: tcb_at_invs' rf_sr_ksCurThread if_apply_def2 invs_queues invs_valid_objs') + apply (clarsimp simp: tcb_at_invs' rf_sr_ksCurThread if_apply_def2 invs_valid_objs') apply (frule invs_sch_act_wf') apply (frule tcb_at_invs') + apply (frule invs_pspace_aligned') + apply (frule invs_pspace_distinct') apply (rule conjI) apply (clarsimp dest!: rf_sr_cscheduler_relation simp: cscheduler_action_relation_def) apply (rule conjI; clarsimp) @@ -668,11 +742,7 @@ lemma threadSet_timeSlice_ccorres [corres]: map_to_tcbs_upd) apply (simp add: cep_relations_drop_fun_upd cvariable_relation_upd_const ko_at_projectKO_opt) - apply (rule conjI) defer - apply (erule cready_queues_relation_not_queue_ptrs) - apply (rule ext, simp split: if_split) - apply (rule ext, simp split: if_split) apply (drule ko_at_projectKO_opt) apply (erule (2) cmap_relation_upd_relI) apply (simp add: ctcb_relation_def) @@ -716,7 +786,7 @@ lemma timerTick_ccorres: apply simp apply (ctac (no_vcg) add: tcbSchedAppend_ccorres) apply (ctac add: rescheduleRequired_ccorres) - apply (wp weak_sch_act_wf_lift_linear threadSet_valid_queues + apply (wp weak_sch_act_wf_lift_linear threadSet_pred_tcb_at_state tcbSchedAppend_valid_objs' threadSet_valid_objs' threadSet_tcbDomain_triv | clarsimp simp: st_tcb_at'_def o_def split: if_splits)+ apply (vcg exspec=tcbSchedDequeue_modifies) diff --git a/proof/crefine/X64/StateRelation_C.thy b/proof/crefine/X64/StateRelation_C.thy index 7f1b6b9949..0701acd80b 100644 --- a/proof/crefine/X64/StateRelation_C.thy +++ b/proof/crefine/X64/StateRelation_C.thy @@ -16,8 +16,7 @@ definition definition "array_relation r n a c \ \i \ n. r (a i) (index c (unat i))" -(* used for bound ntfn/tcb *) -definition +definition option_to_ctcb_ptr :: "machine_word option \ tcb_C ptr" where "option_to_ctcb_ptr x \ case x of None \ NULL | Some t \ tcb_ptr_to_ctcb_ptr t" @@ -439,7 +438,9 @@ where \ tcbTimeSlice atcb = unat (tcbTimeSlice_C ctcb) \ cfault_rel (tcbFault atcb) (seL4_Fault_lift (tcbFault_C ctcb)) (lookup_fault_lift (tcbLookupFailure_C ctcb)) - \ option_to_ptr (tcbBoundNotification atcb) = tcbBoundNotification_C ctcb" + \ option_to_ptr (tcbBoundNotification atcb) = tcbBoundNotification_C ctcb + \ option_to_ctcb_ptr (tcbSchedPrev atcb) = tcbSchedPrev_C ctcb + \ option_to_ctcb_ptr (tcbSchedNext atcb) = tcbSchedNext_C ctcb" abbreviation "ep_queue_relation' \ tcb_queue_relation' tcbEPNext_C tcbEPPrev_C" @@ -776,17 +777,17 @@ definition where "cready_queues_index_to_C qdom prio \ (unat qdom) * numPriorities + (unat prio)" -definition cready_queues_relation :: - "tcb_C typ_heap \ (tcb_queue_C[num_tcb_queues]) \ (domain \ priority \ ready_queue) \ bool" -where - "cready_queues_relation h_tcb queues aqueues \ - \qdom prio. ((qdom \ ucast minDom \ qdom \ ucast maxDom \ - prio \ ucast minPrio \ prio \ ucast maxPrio) \ - (let cqueue = index queues (cready_queues_index_to_C qdom prio) in - sched_queue_relation' h_tcb (aqueues (qdom, prio)) (head_C cqueue) (end_C cqueue))) - \ (\ (qdom \ ucast minDom \ qdom \ ucast maxDom \ - prio \ ucast minPrio \ prio \ ucast maxPrio) \ aqueues (qdom, prio) = [])" +definition ctcb_queue_relation :: "tcb_queue \ tcb_queue_C \ bool" where + "ctcb_queue_relation aqueue cqueue \ + head_C cqueue = option_to_ctcb_ptr (tcbQueueHead aqueue) + \ end_C cqueue = option_to_ctcb_ptr (tcbQueueEnd aqueue)" +definition cready_queues_relation :: + "(domain \ priority \ ready_queue) \ (tcb_queue_C[num_tcb_queues]) \ bool" + where + "cready_queues_relation aqueues cqueues \ + \d p. d \ maxDomain \ p \ maxPriority + \ ctcb_queue_relation (aqueues (d, p)) (index cqueues (cready_queues_index_to_C d p))" abbreviation "cte_array_relation astate cstate @@ -926,9 +927,7 @@ where "cstate_relation astate cstate \ let cheap = t_hrs_' cstate in cpspace_relation (ksPSpace astate) (underlying_memory (ksMachineState astate)) cheap \ - cready_queues_relation (clift cheap) - (ksReadyQueues_' cstate) - (ksReadyQueues astate) \ + cready_queues_relation (ksReadyQueues astate) (ksReadyQueues_' cstate) \ zero_ranges_are_zero (gsUntypedZeroRanges astate) cheap \ cbitmap_L1_relation (ksReadyQueuesL1Bitmap_' cstate) (ksReadyQueuesL1Bitmap astate) \ cbitmap_L2_relation (ksReadyQueuesL2Bitmap_' cstate) (ksReadyQueuesL2Bitmap astate) \ diff --git a/proof/crefine/X64/SyscallArgs_C.thy b/proof/crefine/X64/SyscallArgs_C.thy index 64903e2d1f..3ea9b0d9e3 100644 --- a/proof/crefine/X64/SyscallArgs_C.thy +++ b/proof/crefine/X64/SyscallArgs_C.thy @@ -48,9 +48,7 @@ lemma replyOnRestart_invs'[wp]: including no_pre apply (simp add: replyOnRestart_def) apply (wp setThreadState_nonqueued_state_update rfk_invs' hoare_weak_lift_imp) - apply (rule hoare_vcg_all_lift) - apply (wp setThreadState_nonqueued_state_update rfk_invs' hoare_vcg_all_lift rfk_ksQ) - apply (rule hoare_strengthen_post, rule gts_sp') + apply (rule hoare_strengthen_post, rule gts_sp') apply (clarsimp simp: pred_tcb_at') apply (auto elim!: pred_tcb'_weakenE st_tcb_ex_cap'' dest: st_tcb_at_idle_thread') diff --git a/proof/crefine/X64/Syscall_C.thy b/proof/crefine/X64/Syscall_C.thy index c476fbd8b5..183bfac05e 100644 --- a/proof/crefine/X64/Syscall_C.thy +++ b/proof/crefine/X64/Syscall_C.thy @@ -49,8 +49,7 @@ lemma cap_cases_one_on_true_sum: lemma performInvocation_Endpoint_ccorres: "ccorres (K (K \) \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (invs' and st_tcb_at' simple' thread and ep_at' epptr - and sch_act_sane and (\s. thread = ksCurThread s - \ (\p. ksCurThread s \ set (ksReadyQueues s p)))) + and sch_act_sane and (\s. thread = ksCurThread s)) (UNIV \ {s. block_' s = from_bool blocking} \ {s. call_' s = from_bool do_call} \ {s. badge_' s = badge} @@ -122,7 +121,6 @@ lemma decodeInvocation_ccorres: and (\s. \v \ set extraCaps. ex_cte_cap_wp_to' isCNodeCap (snd v) s) and (\s. \v \ set extraCaps. s \' fst v \ cte_at' (snd v) s) and (\s. \v \ set extraCaps. \y \ zobj_refs' (fst v). ex_nonz_cap_to' y s) - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p)) and sysargs_rel args buffer) (UNIV \ {s. call_' s = from_bool isCall} \ {s. block_' s = from_bool isBlocking} @@ -198,7 +196,7 @@ lemma decodeInvocation_ccorres: apply simp apply (rule hoare_use_eq[where f=ksCurThread]) apply (wp sts_invs_minor' sts_st_tcb_at'_cases - setThreadState_ct' hoare_vcg_all_lift sts_ksQ')+ + setThreadState_ct' hoare_vcg_all_lift)+ apply simp apply (vcg exspec=setThreadState_modifies) apply vcg @@ -506,7 +504,7 @@ lemma wordFromMessageInfo_spec: lemma handleDoubleFault_ccorres: "ccorres dc xfdc (invs' and tcb_at' tptr and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and - sch_act_not tptr and (\s. \p. tptr \ set (ksReadyQueues s p))) + sch_act_not tptr) (UNIV \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr tptr}) [] (handleDoubleFault tptr ex1 ex2) (Call handleDoubleFault_'proc)" @@ -571,8 +569,7 @@ lemma hrs_mem_update_use_hrs_mem: lemma sendFaultIPC_ccorres: "ccorres (cfault_rel2 \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') - (invs' and st_tcb_at' simple' tptr and sch_act_not tptr and - (\s. \p. tptr \ set (ksReadyQueues s p))) + (invs' and st_tcb_at' simple' tptr and sch_act_not tptr) (UNIV \ {s. (cfault_rel (Some fault) (seL4_Fault_lift(current_fault_' (globals s))) (lookup_fault_lift(current_lookup_fault_' (globals s))))} \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr tptr}) @@ -649,8 +646,8 @@ lemma sendFaultIPC_ccorres: apply (ctac (no_vcg) add: sendIPC_ccorres) apply (ctac (no_vcg) add: ccorres_return_CE [unfolded returnOk_def comp_def]) apply wp - apply (wp threadSet_pred_tcb_no_state threadSet_invs_trivial threadSet_typ_at_lifts - | simp)+ + apply (wpsimp wp: threadSet_invs_trivial) + apply (wpsimp wp: threadSet_pred_tcb_no_state threadSet_typ_at_lifts) apply (clarsimp simp: guard_is_UNIV_def) apply (subgoal_tac "capEPBadge epcap && mask 64 = capEPBadge epcap") @@ -683,8 +680,7 @@ lemma sendFaultIPC_ccorres: apply vcg apply (clarsimp simp: inQ_def) apply (rule_tac Q="\a b. invs' b \ st_tcb_at' simple' tptr b - \ sch_act_not tptr b \ valid_cap' a b - \ (\p. tptr \ set (ksReadyQueues b p))" + \ sch_act_not tptr b \ valid_cap' a b" and E="\ _. \" in hoare_post_impErr) apply (wp) @@ -699,8 +695,7 @@ lemma sendFaultIPC_ccorres: done lemma handleFault_ccorres: - "ccorres dc xfdc (invs' and st_tcb_at' simple' t and - sch_act_not t and (\s. \p. t \ set (ksReadyQueues s p))) + "ccorres dc xfdc (invs' and st_tcb_at' simple' t and sch_act_not t) (UNIV \ {s. (cfault_rel (Some flt) (seL4_Fault_lift(current_fault_' (globals s))) (lookup_fault_lift(current_lookup_fault_' (globals s))) )} \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr t}) @@ -764,9 +759,7 @@ lemma getMRs_length: lemma handleInvocation_ccorres: "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') - (invs' and - ct_active' and sch_act_simple and - (\s. \x. ksCurThread s \ set (ksReadyQueues s x))) + (invs' and ct_active' and sch_act_simple) (UNIV \ {s. isCall_' s = from_bool isCall} \ {s. isBlocking_' s = from_bool isBlocking}) [] (handleInvocation isCall isBlocking) (Call handleInvocation_'proc)" @@ -894,7 +887,7 @@ lemma handleInvocation_ccorres: apply (wp hoare_split_bind_case_sumE hoare_drop_imps setThreadState_nonqueued_state_update ct_in_state'_set setThreadState_st_tcb - hoare_vcg_all_lift sts_ksQ' + hoare_vcg_all_lift | wpc | wps)+ apply auto[1] apply clarsimp @@ -1154,9 +1147,6 @@ lemma ccorres_trim_redundant_throw_break: lemma invs_valid_objs_strengthen: "invs' s \ valid_objs' s" by fastforce -lemma ct_not_ksQ_strengthen: - "thread = ksCurThread s \ ksCurThread s \ set (ksReadyQueues s p) \ thread \ set (ksReadyQueues s p)" by fastforce - lemma option_to_ctcb_ptr_valid_ntfn: "valid_ntfn' ntfn s ==> (option_to_ctcb_ptr (ntfnBoundTCB ntfn) = NULL) = (ntfnBoundTCB ntfn = None)" apply (cases "ntfnBoundTCB ntfn", simp_all add: option_to_ctcb_ptr_def) @@ -1190,8 +1180,7 @@ lemma handleRecv_ccorres: notes rf_sr_upd_safe[simp del] shows "ccorres dc xfdc - (\s. invs' s \ st_tcb_at' simple' (ksCurThread s) s - \ sch_act_sane s \ (\p. ksCurThread s \ set (ksReadyQueues s p))) + (\s. invs' s \ st_tcb_at' simple' (ksCurThread s) s \ sch_act_sane s) {s. isBlocking_' s = from_bool isBlocking} [] (handleRecv isBlocking) @@ -1255,7 +1244,7 @@ lemma handleRecv_ccorres: apply (rule_tac P="\s. ksCurThread s = thread" in ccorres_cross_over_guard) apply (ctac add: receiveIPC_ccorres) - apply (wp deleteCallerCap_ksQ_ct' hoare_vcg_all_lift) + apply (wp hoare_vcg_all_lift) apply (rule conseqPost[where Q'=UNIV and A'="{}"], vcg exspec=deleteCallerCap_modifies) apply (clarsimp dest!: rf_sr_ksCurThread) apply simp @@ -1378,13 +1367,11 @@ lemma handleRecv_ccorres: apply clarsimp apply (rename_tac thread epCPtr) apply (rule_tac Q'="(\rv s. invs' s \ st_tcb_at' simple' thread s - \ sch_act_sane s \ (\p. thread \ set (ksReadyQueues s p)) \ thread = ksCurThread s + \ sch_act_sane s \ thread = ksCurThread s \ valid_cap' rv s)" in hoare_post_imp_R[rotated]) - apply (clarsimp simp: sch_act_sane_def) - apply (auto dest!: obj_at_valid_objs'[OF _ invs_valid_objs'] - simp: projectKOs valid_obj'_def, - auto simp: pred_tcb_at'_def obj_at'_def objBits_simps projectKOs ct_in_state'_def)[1] - apply wp + apply (intro conjI impI allI; clarsimp simp: sch_act_sane_def) + apply (fastforce dest: obj_at_valid_objs'[OF _ invs_valid_objs'] ko_at_valid_ntfn') + apply wp apply clarsimp apply (vcg exspec=isStopped_modifies exspec=lookupCap_modifies) @@ -1433,7 +1420,7 @@ lemma handleYield_ccorres: apply (ctac add: rescheduleRequired_ccorres) apply (wp weak_sch_act_wf_lift_linear tcbSchedAppend_valid_objs') apply (vcg exspec= tcbSchedAppend_modifies) - apply (wp weak_sch_act_wf_lift_linear tcbSchedDequeue_valid_queues) + apply (wp weak_sch_act_wf_lift_linear) apply (vcg exspec= tcbSchedDequeue_modifies) apply (clarsimp simp: tcb_at_invs' invs_valid_objs' valid_objs'_maxPriority valid_objs'_maxDomain) @@ -1590,8 +1577,7 @@ lemma ccorres_return_void_C_Seq: lemma ccorres_handleReservedIRQ: "ccorres dc xfdc - (invs' and (\s. irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s \ - (\p. ksCurThread s \ set (ksReadyQueues s p)))) + (invs' and (\s. irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s)) (UNIV \ {s. irq_' s = ucast irq}) hs (handleReservedIRQ irq) (Call handleReservedIRQ_'proc)" apply (cinit lift: irq_') @@ -1601,8 +1587,7 @@ lemma ccorres_handleReservedIRQ: lemma handleInterrupt_ccorres: "ccorres dc xfdc - (invs' and (\s. irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s \ - (\p. ksCurThread s \ set (ksReadyQueues s p)))) + (invs' and (\s. irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s)) (UNIV \ \\irq = ucast irq\) hs (handleInterrupt irq) diff --git a/proof/crefine/X64/TcbQueue_C.thy b/proof/crefine/X64/TcbQueue_C.thy index a35c839555..7a79843bdf 100644 --- a/proof/crefine/X64/TcbQueue_C.thy +++ b/proof/crefine/X64/TcbQueue_C.thy @@ -964,49 +964,6 @@ lemma tcb_queue_relation'_prev_sign: \ sign_extend 47 (ptr_val (getPrev tcb)) = ptr_val (getPrev tcb)" by (rule tcb_queue_relation_prev_sign [OF tcb_queue_relation'_queue_rel]) - -lemma cready_queues_relation_null_queue_ptrs: - assumes rel: "cready_queues_relation mp cq aq" - and same: "option_map tcb_null_ep_ptrs \ mp' = option_map tcb_null_ep_ptrs \ mp" - shows "cready_queues_relation mp' cq aq" - using rel - apply (clarsimp simp: cready_queues_relation_def Let_def all_conj_distrib) - apply (drule spec, drule spec, drule mp, (erule conjI)+, assumption) - apply (clarsimp simp: tcb_queue_relation'_def) - apply (erule iffD2 [OF tcb_queue_relation_only_next_prev, rotated -1]) - apply (rule ext) - apply (case_tac "mp' x") - apply (frule compD [OF same]) - apply simp - apply (frule compD [OF same]) - apply (clarsimp simp: tcb_null_ep_ptrs_def) - apply (case_tac z, case_tac a) - apply simp - \ \clag\ - apply (rule ext) - apply (case_tac "mp' x") - apply (frule compD [OF same]) - apply simp - apply (frule compD [OF same]) - apply (clarsimp simp: tcb_null_ep_ptrs_def) - apply (case_tac z, case_tac a) - apply simp - done - -lemma cready_queues_relation_not_queue_ptrs: - assumes rel: "cready_queues_relation mp cq aq" - and same: "option_map tcbSchedNext_C \ mp' = option_map tcbSchedNext_C \ mp" - "option_map tcbSchedPrev_C \ mp' = option_map tcbSchedPrev_C \ mp" - shows "cready_queues_relation mp' cq aq" - using rel - apply (clarsimp simp: cready_queues_relation_def tcb_queue_relation'_def Let_def all_conj_distrib) - apply (drule spec, drule spec, drule mp, (erule conjI)+, assumption) - apply clarsimp - apply (erule iffD2 [OF tcb_queue_relation_only_next_prev, rotated -1]) - apply (rule same) - apply (rule same) - done - lemma ntfn_ep_disjoint: assumes srs: "sym_refs (state_refs_of' s)" and epat: "ko_at' ep epptr s" @@ -1455,8 +1412,6 @@ lemma rf_sr_tcb_update_no_queue: (t_hrs_' (globals s')); tcbEPNext_C ctcb = tcbEPNext_C (the (cslift s' (tcb_ptr_to_ctcb_ptr thread))); tcbEPPrev_C ctcb = tcbEPPrev_C (the (cslift s' (tcb_ptr_to_ctcb_ptr thread))); - tcbSchedNext_C ctcb = tcbSchedNext_C (the (cslift s' (tcb_ptr_to_ctcb_ptr thread))); - tcbSchedPrev_C ctcb = tcbSchedPrev_C (the (cslift s' (tcb_ptr_to_ctcb_ptr thread))); fpuState_C (tcbContext_C (tcbArch_C ctcb)) = fpuState_C (tcbContext_C (tcbArch_C (the (cslift s' (tcb_ptr_to_ctcb_ptr thread))))); (\x\ran tcb_cte_cases. (\(getF, setF). getF tcb' = getF tcb) x); @@ -1484,20 +1439,11 @@ lemma rf_sr_tcb_update_no_queue: apply (rule cnotification_relation_upd_tcb_no_queues, assumption+) subgoal by (clarsimp intro!: ext) subgoal by (clarsimp intro!: ext) - apply (erule cready_queues_relation_not_queue_ptrs) - subgoal by (clarsimp intro!: ext) - subgoal by (clarsimp intro!: ext) subgoal by (clarsimp simp: carch_state_relation_def fpu_null_state_preservation typ_heap_simps') by (simp add: cmachine_state_relation_def) -lemma rf_sr_tcb_update_no_queue_helper: - "(s, s'\ globals := globals s' \ t_hrs_' := t_hrs_' (globals (undefined - \ globals := (undefined \ t_hrs_' := f (globals s') (t_hrs_' (globals s')) \)\))\\) \ rf_sr - \ (s, globals_update (\v. t_hrs_'_update (f v) v) s') \ rf_sr" - by (simp cong: StateSpace.state.fold_congs globals.fold_congs) - -lemmas rf_sr_tcb_update_no_queue2 - = rf_sr_tcb_update_no_queue_helper [OF rf_sr_tcb_update_no_queue, simplified] +lemmas rf_sr_tcb_update_no_queue2 = + rf_sr_obj_update_helper[OF rf_sr_tcb_update_no_queue, simplified] lemma tcb_queue_relation_not_in_q: "ctcb_ptr_to_tcb_ptr x \ set xs \ @@ -1545,13 +1491,7 @@ lemma rf_sr_tcb_update_not_in_queue: apply (drule(1) map_to_ko_atI') apply (drule sym_refs_ko_atD', clarsimp+) subgoal by blast - apply (simp add: cready_queues_relation_def, erule allEI) apply (clarsimp simp: Let_def) - apply (subst tcb_queue_relation_not_in_q) - apply clarsimp - apply (drule valid_queues_obj_at'D, clarsimp) - apply (clarsimp simp: obj_at'_def projectKOs inQ_def) - subgoal by simp apply (simp add: carch_state_relation_def) subgoal by (clarsimp simp: fpu_null_state_heap_update_span_disjoint[OF tcb_at'_non_kernel_data_ref'] global_ioport_bitmap_heap_update_tag_disj_simps obj_at'_def projectKOs) diff --git a/proof/crefine/X64/Tcb_C.thy b/proof/crefine/X64/Tcb_C.thy index 08558cbc95..44b64ceebf 100644 --- a/proof/crefine/X64/Tcb_C.thy +++ b/proof/crefine/X64/Tcb_C.thy @@ -59,8 +59,6 @@ lemma doMachineOp_sched: done context begin interpretation Arch . (*FIXME: arch_split*) -crunch queues[wp]: setupReplyMaster "valid_queues" - (simp: crunch_simps wp: crunch_wps) crunch curThread [wp]: restart "\s. P (ksCurThread s)" (wp: crunch_wps simp: crunch_simps) @@ -391,9 +389,10 @@ lemma hrs_mem_update_cong: lemma setPriority_ccorres: "ccorres dc xfdc - (\s. tcb_at' t s \ Invariants_H.valid_queues s \ ksCurDomain s \ maxDomain \ - valid_queues' s \ valid_objs' s \ weak_sch_act_wf (ksSchedulerAction s) s \ (priority \ maxPriority)) - (UNIV \ {s. tptr_' s = tcb_ptr_to_ctcb_ptr t} \ {s. prio_' s = ucast priority}) + (\s. tcb_at' t s \ ksCurDomain s \ maxDomain \ + valid_objs' s \ weak_sch_act_wf (ksSchedulerAction s) s \ (priority \ maxPriority) \ + pspace_aligned' s \ pspace_distinct' s) + ({s. tptr_' s = tcb_ptr_to_ctcb_ptr t} \ {s. prio_' s = ucast priority}) [] (setPriority t priority) (Call setPriority_'proc)" apply (cinit lift: tptr_' prio_') apply (ctac(no_vcg) add: tcbSchedDequeue_ccorres) @@ -416,7 +415,7 @@ lemma setPriority_ccorres: apply (ctac add: possibleSwitchTo_ccorres) apply (rule ccorres_return_Skip') apply (wp isRunnable_wp) - apply (wpsimp wp: hoare_drop_imps threadSet_valid_queues threadSet_valid_objs' + apply (wpsimp wp: hoare_drop_imps threadSet_valid_objs' weak_sch_act_wf_lift_linear threadSet_pred_tcb_at_state threadSet_tcbDomain_triv simp: st_tcb_at'_def o_def split: if_splits) @@ -425,18 +424,13 @@ lemma setPriority_ccorres: where Q="\rv s. obj_at' (\_. True) t s \ priority \ maxPriority \ - Invariants_H.valid_queues s \ ksCurDomain s \ maxDomain \ valid_objs' s \ - valid_queues' s \ weak_sch_act_wf (ksSchedulerAction s) s \ - (\d p. \ t \ set (ksReadyQueues s (d, p)))"]) - apply (wp weak_sch_act_wf_lift_linear tcbSchedDequeue_valid_queues tcbSchedDequeue_nonq) + pspace_aligned' s \ pspace_distinct' s"]) + apply (wp weak_sch_act_wf_lift_linear valid_tcb'_def) apply (clarsimp simp: valid_tcb'_tcbPriority_update) apply clarsimp - apply (frule (1) valid_objs'_maxDomain[where t=t]) - apply (frule (1) valid_objs'_maxPriority[where t=t]) - apply simp done lemma setMCPriority_ccorres: @@ -681,12 +675,12 @@ lemma invokeTCB_ThreadControl_ccorres: apply (clarsimp simp : guard_is_UNIV_def Collect_const_mem) apply (rule hoare_strengthen_post[ where Q= "\rv s. - Invariants_H.valid_queues s \ valid_objs' s \ weak_sch_act_wf (ksSchedulerAction s) s \ ((\a b. priority = Some (a, b)) \ tcb_at' target s \ ksCurDomain s \ maxDomain \ - valid_queues' s \ fst (the priority) \ maxPriority)"]) + fst (the priority) \ maxPriority) \ + pspace_aligned' s \ pspace_distinct' s"]) apply (strengthen sch_act_wf_weak) apply (wp hoare_weak_lift_imp) apply (clarsimp split: if_splits) @@ -774,12 +768,12 @@ lemma invokeTCB_ThreadControl_ccorres: apply (clarsimp simp : guard_is_UNIV_def Collect_const_mem) apply (simp cong: conj_cong) apply (rule hoare_strengthen_post[ - where Q="\a b. (Invariants_H.valid_queues b \ - valid_objs' b \ + where Q="\a b. (valid_objs' b \ sch_act_wf (ksSchedulerAction b) b \ + pspace_aligned' b \ pspace_distinct' b \ ((\a b. priority = Some (a, b)) \ tcb_at' target b \ - ksCurDomain b \ maxDomain \ valid_queues' b \ + ksCurDomain b \ maxDomain \ fst (the priority) \ maxPriority)) \ ((case snd (the buf) of None \ 0 @@ -801,15 +795,15 @@ lemma invokeTCB_ThreadControl_ccorres: prefer 2 apply fastforce apply (strengthen cte_is_derived_capMasterCap_strg - invs_queues invs_weak_sch_act_wf invs_sch_act_wf' + invs_weak_sch_act_wf invs_sch_act_wf' invs_valid_objs' invs_mdb' invs_pspace_aligned', simp add: o_def) apply (rule_tac P="is_aligned (fst (the buf)) msg_align_bits" in hoare_gen_asm) apply (wp threadSet_ipcbuffer_trivial hoare_weak_lift_imp | simp - | strengthen invs_sch_act_wf' invs_valid_objs' invs_weak_sch_act_wf invs_queues - invs_valid_queues' | wp hoare_drop_imps)+ + | strengthen invs_sch_act_wf' invs_valid_objs' invs_weak_sch_act_wf + | wp hoare_drop_imps)+ apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem option_to_0_def split: option.split_asm) @@ -818,7 +812,7 @@ lemma invokeTCB_ThreadControl_ccorres: apply (rule ccorres_return_C_errorE, simp+)[1] apply vcg apply (simp add: conj_comms cong: conj_cong) - apply (strengthen invs_ksCurDomain_maxDomain') + apply (strengthen invs_ksCurDomain_maxDomain' invs_pspace_distinct') apply (wp hoare_vcg_const_imp_lift_R cteDelete_invs') apply simp apply (rule ccorres_split_nothrow_novcg_dc) @@ -835,8 +829,7 @@ lemma invokeTCB_ThreadControl_ccorres: apply (rule conjI) apply (clarsimp simp: objBits_simps' word_bits_conv case_option_If2 if_n_0_0 valid_cap'_def capAligned_def obj_at'_def projectKOs) - apply (clarsimp simp: invs_valid_objs' invs_valid_queues' - Invariants_H.invs_queues invs_ksCurDomain_maxDomain') + apply (fastforce simp: invs_valid_objs' invs_ksCurDomain_maxDomain') apply (rule ccorres_Cond_rhs_Seq) apply (rule ccorres_rhs_assoc)+ apply csymbr @@ -1066,7 +1059,7 @@ lemma restart_ccorres: apply (ctac(no_vcg) add: tcbSchedEnqueue_ccorres) apply (ctac add: possibleSwitchTo_ccorres) apply (wp weak_sch_act_wf_lift)[1] - apply (wp sts_valid_queues setThreadState_st_tcb)[1] + apply (wp sts_valid_objs' setThreadState_st_tcb)[1] apply (simp add: valid_tcb_state'_def) apply wp apply (wp (once) sch_act_wf_lift, (wp tcb_in_cur_domain'_lift)+) @@ -1688,7 +1681,7 @@ lemma invokeTCB_WriteRegisters_ccorres[where S=UNIV]: apply (clarsimp simp: frame_gp_registers_convs word_less_nat_alt sysargs_rel_def n_frameRegisters_def n_msgRegisters_def split: if_split_asm) - apply (simp add: invs_weak_sch_act_wf invs_valid_objs' invs_queues) + apply (simp add: invs_weak_sch_act_wf invs_valid_objs') apply (fastforce dest!: global'_no_ex_cap simp: invs'_def valid_state'_def) done @@ -3152,7 +3145,8 @@ lemma decodeTCBConfigure_ccorres: apply (rule conjI, fastforce) apply (drule interpret_excaps_eq) apply (clarsimp simp: cte_wp_at_ctes_of valid_tcb_state'_def numeral_eqs le_ucast_ucast_le - tcb_at_invs' invs_valid_objs' invs_queues invs_sch_act_wf' + tcb_at_invs' invs_valid_objs' invs_sch_act_wf' + invs_pspace_aligned' invs_pspace_distinct' ct_in_state'_def pred_tcb_at'_def obj_at'_def tcb_st_refs_of'_def) apply (erule disjE; simp add: objBits_defs mask_def) apply (clarsimp simp: idButNot_def interpret_excaps_test_null @@ -4450,9 +4444,9 @@ lemma invokeTCB_SetTLSBase_ccorres: apply (rule ccorres_return_CE, simp+)[1] apply (wpsimp wp: hoare_drop_imp simp: guard_is_UNIV_def)+ apply vcg - apply (clarsimp simp: tlsBaseRegister_def X64.tlsBaseRegister_def - invs_weak_sch_act_wf invs_queues TLS_BASE_def FS_BASE_def - split: if_split) + apply (fastforce simp: tlsBaseRegister_def X64.tlsBaseRegister_def + invs_weak_sch_act_wf TLS_BASE_def FS_BASE_def + split: if_split) done lemma decodeSetTLSBase_ccorres: diff --git a/proof/crefine/X64/Wellformed_C.thy b/proof/crefine/X64/Wellformed_C.thy index ed017823e2..aad234acd3 100644 --- a/proof/crefine/X64/Wellformed_C.thy +++ b/proof/crefine/X64/Wellformed_C.thy @@ -165,10 +165,6 @@ where abbreviation "ep_queue_relation \ tcb_queue_relation tcbEPNext_C tcbEPPrev_C" -abbreviation - "sched_queue_relation \ tcb_queue_relation tcbSchedNext_C tcbSchedPrev_C" - - definition wordSizeCase :: "'a \ 'a \ 'a" where "wordSizeCase a b \ (if bitSize (undefined::machine_word) = 32 diff --git a/proof/infoflow/Scheduler_IF.thy b/proof/infoflow/Scheduler_IF.thy index 38cfe61b94..1ab0401fbe 100644 --- a/proof/infoflow/Scheduler_IF.thy +++ b/proof/infoflow/Scheduler_IF.thy @@ -1439,10 +1439,6 @@ lemma cur_thread_cur_domain: by (clarsimp simp: pred_tcb_at_def invs_def valid_idle_def valid_state_def obj_at_def guarded_pas_domain_def) -lemma valid_sched_valid_queues[intro]: - "valid_sched s \ valid_queues s" - by (simp add: valid_sched_def) - lemma ethread_get_wp2: "\\s. \etcb. etcb_at ((=) etcb) t s \ Q (f etcb) s\ ethread_get f t diff --git a/proof/infoflow/refine/ADT_IF_Refine.thy b/proof/infoflow/refine/ADT_IF_Refine.thy index f8f1ac5008..e6ac3cdc5c 100644 --- a/proof/infoflow/refine/ADT_IF_Refine.thy +++ b/proof/infoflow/refine/ADT_IF_Refine.thy @@ -304,9 +304,12 @@ lemma kernel_entry_if_corres: apply (rule corres_split) apply simp apply (rule threadset_corresT) - apply (erule arch_tcb_context_set_tcb_relation) - apply (clarsimp simp: tcb_cap_cases_def) - apply (rule allI[OF ball_tcb_cte_casesI]; clarsimp) + apply (erule arch_tcb_context_set_tcb_relation) + apply (clarsimp simp: tcb_cap_cases_def) + apply (rule allI[OF ball_tcb_cte_casesI]; clarsimp) + apply fastforce + apply fastforce + apply fastforce apply (simp add: exst_same_def) apply (rule corres_split[OF handleEvent_corres_arch_extras]) apply (rule corres_stateAssert_assume_stronger[where Q=\ and @@ -506,7 +509,7 @@ lemma scheduler'_if_ex_abs[wp]: apply wp apply (clarsimp simp: ex_abs_def) apply (rule exI, rule conjI, assumption) - apply (frule state_relation_schact) + apply (frule state_relation_sched_act_relation) apply (auto simp: domain_list_rel_eq domain_time_rel_eq) done @@ -1161,7 +1164,7 @@ lemma st_tcb_at_coerce_haskell: apply (drule_tac x=t in bspec) apply fastforce apply clarsimp - apply (simp add: other_obj_relation_def) + apply (simp add: tcb_relation_cut_def) apply clarsimp apply (clarsimp simp: obj_at'_def projectKO_eq projectKO_tcb split: kernel_object.splits) apply (rule_tac x="tcb_state tcb" in exI) diff --git a/proof/infoflow/refine/ADT_IF_Refine_C.thy b/proof/infoflow/refine/ADT_IF_Refine_C.thy index 6f4e5e95f9..2141ade052 100644 --- a/proof/infoflow/refine/ADT_IF_Refine_C.thy +++ b/proof/infoflow/refine/ADT_IF_Refine_C.thy @@ -150,7 +150,8 @@ lemma cur_thread_of_absKState[simp]: by (clarsimp simp: cstate_relation_def Let_def absKState_def cstate_to_H_def) lemma absKState_crelation: - "\ cstate_relation s (globals s'); invs' s \ \ cstate_to_A s' = absKState s" + "\ cstate_relation s (globals s'); invs' s; ksReadyQueues_asrt s\ + \ cstate_to_A s' = absKState s" apply (clarsimp simp add: cstate_to_H_correct invs'_def cstate_to_A_def) apply (clarsimp simp: absKState_def absExst_def observable_memory_def) apply (case_tac s) @@ -224,8 +225,7 @@ locale ADT_IF_Refine_1 = kernel_m + (handleEvent Interrupt) (handleInterruptEntry_C_body_if)" and handleInvocation_ccorres': "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') - (invs' and arch_extras and ct_active' and sch_act_simple - and (\s. \x. ksCurThread s \ set (ksReadyQueues s x))) + (invs' and arch_extras and ct_active' and sch_act_simple) (UNIV \ {s. isCall_' s = from_bool isCall} \ {s. isBlocking_' s = from_bool isBlocking}) [] (handleInvocation isCall isBlocking) (Call handleInvocation_'proc)" and check_active_irq_corres_C: @@ -269,11 +269,10 @@ lemma handleEvent_ccorres: apply wp[1] apply clarsimp apply wp - apply (rule_tac Q="\rv s. ct_in_state' simple' s \ sch_act_sane s \ - (\p. ksCurThread s \ set (ksReadyQueues s p))" + apply (rule_tac Q="\rv s. ct_in_state' simple' s \ sch_act_sane s" in hoare_post_imp) apply (simp add: ct_in_state'_def) - apply (wp handleReply_sane handleReply_ct_not_ksQ) + apply (wp handleReply_sane) \ \SysSend\ apply (simp add: handleSend_def) apply (ctac (no_vcg) add: handleInvocation_ccorres) @@ -356,7 +355,7 @@ lemma handleEvent_ccorres: apply (clarsimp simp: return_def) apply wp apply (simp add: guard_is_UNIV_def) - apply (auto simp: ct_in_state'_def ct_not_ksQ isReply_def is_cap_fault_def + apply (auto simp: ct_in_state'_def isReply_def is_cap_fault_def cfault_rel_def seL4_Fault_UnknownSyscall_lift seL4_Fault_UserException_lift elim: pred_tcb'_weakenE st_tcb_ex_cap'' dest: st_tcb_at_idle_thread' rf_sr_ksCurThread) @@ -613,7 +612,6 @@ definition ADT_C_if where (kernel_call_C_if fp) handle_preemption_C_if schedule_C_if kernel_exit_C_if)\" - lemma c_to_haskell: "uop_nonempty uop \ global_automata_refine checkActiveIRQ_H_if (doUserOp_H_if uop) kernelCall_H_if @@ -626,12 +624,16 @@ lemma c_to_haskell: apply (unfold_locales) apply (simp add: ADT_C_if_def) apply (simp_all add: preserves_trivial preserves'_trivial) + apply (clarsimp simp: full_invs_if'_def ex_abs_def) + apply (frule ksReadyQueues_asrt_cross[OF state_relation_ready_queues_relation]) apply (clarsimp simp: lift_snd_rel_def ADT_C_if_def ADT_H_if_def absKState_crelation rf_sr_def full_invs_if'_def) apply (clarsimp simp: rf_sr_def full_invs_if'_def ex_abs_def) apply (simp add: ADT_H_if_def ADT_C_if_def lift_fst_rel_def lift_snd_rel_def) - apply safe - apply (clarsimp simp: absKState_crelation rf_sr_def full_invs_if'_def) + apply (clarsimp simp: full_invs_if'_def) + apply (frule ex_abs_ksReadyQueues_asrt) + apply (clarsimp simp: absKState_crelation rf_sr_def) + apply (frule invs_valid_stateI') apply (rule_tac x="((a,bb),ba)" in bexI) apply simp apply simp @@ -642,7 +644,8 @@ lemma c_to_haskell: kernelCall_H_if_def kernel_call_C_if_def handlePreemption_H_if_def handle_preemption_C_if_def schedule'_H_if_def schedule_C_if_def - kernelExit_H_if_def kernel_exit_C_if_def) + kernelExit_H_if_def kernel_exit_C_if_def invs'_def) + apply (clarsimp split: sys_mode.splits) apply (rule step_corres_lifts,rule corres_guard_imp[OF check_active_irq_corres_C]; fastforce simp: full_invs_if'_def) apply (rule step_corres_lifts,rule corres_guard_imp[OF check_active_irq_corres_C]; fastforce simp: full_invs_if'_def) apply (rule step_corres_lifts,rule corres_guard_imp[OF do_user_op_if_C_corres]; auto simp: full_invs_if'_def ex_abs_def) diff --git a/proof/infoflow/refine/ARM/ArchADT_IF_Refine_C.thy b/proof/infoflow/refine/ARM/ArchADT_IF_Refine_C.thy index 18518c2964..24dae6043c 100644 --- a/proof/infoflow/refine/ARM/ArchADT_IF_Refine_C.thy +++ b/proof/infoflow/refine/ARM/ArchADT_IF_Refine_C.thy @@ -49,9 +49,7 @@ qed lemma handleInvocation_ccorres'[ADT_IF_Refine_assms]: "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') - (invs' and arch_extras and - ct_active' and sch_act_simple and - (\s. \x. ksCurThread s \ set (ksReadyQueues s x))) + (invs' and arch_extras and ct_active' and sch_act_simple) (UNIV \ {s. isCall_' s = from_bool isCall} \ {s. isBlocking_' s = from_bool isBlocking}) [] (handleInvocation isCall isBlocking) (Call handleInvocation_'proc)" @@ -193,20 +191,24 @@ lemma do_user_op_if_C_corres[ADT_IF_Refine_assms]: apply (rule corres_gen_asm) apply (simp add: doUserOp_if_def doUserOp_C_if_def uop_nonempty_def del: split_paired_All) apply (rule corres_gets_same) - apply (clarsimp simp: absKState_crelation ptable_rights_s'_def ptable_rights_s''_def - rf_sr_def cstate_relation_def Let_def cstate_to_H_correct) + apply (fastforce dest: ex_abs_ksReadyQueues_asrt + simp: absKState_crelation ptable_rights_s'_def ptable_rights_s''_def + rf_sr_def cstate_relation_def Let_def cstate_to_H_correct) apply simp apply (rule corres_gets_same) - apply (clarsimp simp: ptable_xn_s'_def ptable_xn_s''_def ptable_attrs_s_def - absKState_crelation ptable_attrs_s'_def ptable_attrs_s''_def rf_sr_def) + apply (fastforce dest: ex_abs_ksReadyQueues_asrt + simp: ptable_xn_s'_def ptable_xn_s''_def ptable_attrs_s_def + absKState_crelation ptable_attrs_s'_def ptable_attrs_s''_def rf_sr_def) apply simp apply (rule corres_gets_same) + apply clarsimp + apply (frule ex_abs_ksReadyQueues_asrt) apply (clarsimp simp: absKState_crelation curthread_relation ptable_lift_s'_def ptable_lift_s''_def ptable_lift_s_def rf_sr_def) apply simp apply (simp add: getCurThread_def) apply (rule corres_gets_same) - apply (simp add: absKState_crelation rf_sr_def) + apply (fastforce dest: ex_abs_ksReadyQueues_asrt simp: absKState_crelation rf_sr_def) apply simp apply (rule corres_gets_same) apply (rule fun_cong[where x=ptrFromPAddr]) diff --git a/proof/infoflow/refine/ARM/Example_Valid_StateH.thy b/proof/infoflow/refine/ARM/Example_Valid_StateH.thy index e4e1818376..9b93e4fe59 100644 --- a/proof/infoflow/refine/ARM/Example_Valid_StateH.thy +++ b/proof/infoflow/refine/ARM/Example_Valid_StateH.thy @@ -231,6 +231,8 @@ where \ \tcbFaultHandler =\ 0 \ \tcbIPCBuffer =\ 0 \ \tcbBoundNotification =\ None + \ \tcbSchedPrev =\ None + \ \tcbSchedNext =\ None \ \tcbContext =\ (ArchThread undefined)" @@ -255,6 +257,8 @@ where \ \tcbFaultHandler =\ 0 \ \tcbIPCBuffer =\ 0 \ \tcbBoundNotification =\ None + \ \tcbSchedPrev =\ None + \ \tcbSchedNext =\ None \ \tcbContext =\ (ArchThread undefined)" @@ -279,6 +283,8 @@ where \ \tcbFaultHandler =\ 0 \ \tcbIPCBuffer =\ 0 \ \tcbBoundNotification =\ None + \ \tcbSchedPrev =\ None + \ \tcbSchedNext =\ None \ \tcbContext =\ (ArchThread empty_context)" definition @@ -1080,7 +1086,7 @@ where ksDomSchedule = [(0 ,10), (1, 10)], ksCurDomain = 0, ksDomainTime = 5, - ksReadyQueues = const [], + ksReadyQueues = const (TcbQueue None None), ksReadyQueuesL1Bitmap = const 0, ksReadyQueuesL2Bitmap = const 0, ksCurThread = Low_tcb_ptr, @@ -2805,8 +2811,6 @@ lemma s0H_invs: apply (clarsimp simp: sch_act_wf_def s0H_internal_def ct_in_state'_def st_tcb_at'_def obj_at'_def projectKO_eq project_inject objBitsKO_def s0_ptrs_aligned Low_tcbH_def) apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct', simplified s0H_internal_def]) apply (simp add: objBitsKO_def) - apply (rule conjI) - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs s0H_internal_def) apply (rule conjI) apply (clarsimp simp: sym_refs_def state_refs_of'_def refs_of'_def split: option.splits) apply (frule kh0H_SomeD) @@ -2967,9 +2971,16 @@ lemma s0H_invs: apply (rule conjI) apply (clarsimp simp: irqs_masked'_def s0H_internal_def maxIRQ_def timer_irq_def) apply (rule conjI) - apply (clarsimp simp: valid_queues'_def obj_at'_def projectKO_eq project_inject s0H_internal_def inQ_def) - apply (frule kh0H_dom_tcb) - apply (elim disjE, (clarsimp simp: kh0H_obj_def)+)[1] + apply (clarsimp simp: sym_heap_def opt_map_def projectKOs split: option.splits) + using kh0H_dom_tcb + apply (fastforce simp: kh0H_obj_def) + apply (rule conjI) + apply (clarsimp simp: valid_sched_pointers_def opt_map_def projectKOs split: option.splits) + using kh0H_dom_tcb + apply (fastforce simp: kh0H_obj_def) + apply (rule conjI) + apply (clarsimp simp: valid_bitmaps_def valid_bitmapQ_def bitmapQ_def s0H_internal_def + tcbQueueEmpty_def bitmapQ_no_L1_orphans_def bitmapQ_no_L2_orphans_def) apply (rule conjI) apply (clarsimp simp: ct_not_inQ_def obj_at'_def projectKO_eq project_inject s0H_internal_def objBitsKO_def s0_ptrs_aligned Low_tcbH_def) apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct', simplified s0H_internal_def]) @@ -3197,7 +3208,7 @@ lemma s0_pspace_rel: apply (clarsimp simp: kh0H_obj_def split del: if_split) apply (cut_tac x=y in pd_offs_in_range(3)) apply (clarsimp simp: pd_offs_range_def pde_relation_def pde_relation_aligned_def) - apply (clarsimp simp: kh0H_all_obj_def kh0_obj_def other_obj_relation_def + apply (clarsimp simp: kh0H_all_obj_def kh0_obj_def tcb_relation_cut_def tcb_relation_def arch_tcb_relation_def fault_rel_optionation_def word_bits_def the_nat_to_bl_simps)+ apply (clarsimp simp: kh0H_obj_def High_pt_def High_pt'H_def High_pt'_def split del: if_split) @@ -3251,7 +3262,14 @@ lemma s0_srel: apply (clarsimp simp: s0_internal_def s0H_internal_def exst0_def kh0H_def option_update_range_def split: if_split_asm option.splits) apply (clarsimp simp: s0_internal_def s0H_internal_def exst0_def etcb_relation_def idle_tcbH_def High_tcbH_def High_etcb_def Low_tcbH_def Low_etcb_def default_etcb_def split: if_split_asm) apply (simp add: s0_internal_def exst0_def s0H_internal_def sched_act_relation_def) - apply (simp add: s0_internal_def exst0_def s0H_internal_def ready_queues_relation_def) + apply (clarsimp simp: s0_internal_def exst0_def s0H_internal_def + ready_queues_relation_def ready_queue_relation_def + list_queue_relation_def queue_end_valid_def + prev_queue_head_def inQ_def tcbQueueEmpty_def + projectKOs opt_map_def opt_pred_def + split: option.splits) + using kh0H_dom_tcb + apply (fastforce simp: kh0H_obj_def) apply (clarsimp simp: s0_internal_def exst0_def s0H_internal_def ghost_relation_def) apply (rule conjI) apply clarsimp diff --git a/proof/infoflow/refine/RISCV64/ArchADT_IF_Refine_C.thy b/proof/infoflow/refine/RISCV64/ArchADT_IF_Refine_C.thy index 7982e61afb..62a5a61064 100644 --- a/proof/infoflow/refine/RISCV64/ArchADT_IF_Refine_C.thy +++ b/proof/infoflow/refine/RISCV64/ArchADT_IF_Refine_C.thy @@ -47,9 +47,7 @@ qed lemma handleInvocation_ccorres'[ADT_IF_Refine_assms]: "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') - (invs' and arch_extras and - ct_active' and sch_act_simple and - (\s. \x. ksCurThread s \ set (ksReadyQueues s x))) + (invs' and arch_extras and ct_active' and sch_act_simple) (UNIV \ {s. isCall_' s = from_bool isCall} \ {s. isBlocking_' s = from_bool isBlocking}) [] (handleInvocation isCall isBlocking) (Call handleInvocation_'proc)" @@ -119,20 +117,24 @@ lemma do_user_op_if_C_corres[ADT_IF_Refine_assms]: apply (rule corres_gen_asm) apply (simp add: doUserOp_if_def doUserOp_C_if_def uop_nonempty_def del: split_paired_All) apply (rule corres_gets_same) - apply (clarsimp simp: absKState_crelation ptable_rights_s'_def ptable_rights_s''_def - rf_sr_def cstate_relation_def Let_def cstate_to_H_correct) + apply (fastforce dest: ex_abs_ksReadyQueues_asrt + simp: absKState_crelation ptable_rights_s'_def ptable_rights_s''_def + rf_sr_def cstate_relation_def Let_def cstate_to_H_correct) apply simp apply (rule corres_gets_same) - apply (clarsimp simp: ptable_xn_s'_def ptable_xn_s''_def ptable_attrs_s_def - absKState_crelation ptable_attrs_s'_def ptable_attrs_s''_def rf_sr_def) + apply (fastforce dest: ex_abs_ksReadyQueues_asrt + simp: ptable_xn_s'_def ptable_xn_s''_def ptable_attrs_s_def + absKState_crelation ptable_attrs_s'_def ptable_attrs_s''_def rf_sr_def) apply simp apply (rule corres_gets_same) + apply clarsimp + apply (frule ex_abs_ksReadyQueues_asrt) apply (clarsimp simp: absKState_crelation curthread_relation ptable_lift_s'_def ptable_lift_s''_def ptable_lift_s_def rf_sr_def) apply simp apply (simp add: getCurThread_def) apply (rule corres_gets_same) - apply (simp add: absKState_crelation rf_sr_def) + apply (fastforce dest: ex_abs_ksReadyQueues_asrt simp: absKState_crelation rf_sr_def) apply simp apply (rule corres_gets_same) apply (rule fun_cong[where x=ptrFromPAddr]) diff --git a/proof/infoflow/refine/RISCV64/Example_Valid_StateH.thy b/proof/infoflow/refine/RISCV64/Example_Valid_StateH.thy index 5968a1063f..7e47d663af 100644 --- a/proof/infoflow/refine/RISCV64/Example_Valid_StateH.thy +++ b/proof/infoflow/refine/RISCV64/Example_Valid_StateH.thy @@ -216,6 +216,8 @@ definition Low_tcbH :: tcb where \ \tcbFaultHandler =\ 0 \ \tcbIPCBuffer =\ 0 \ \tcbBoundNotification =\ None + \ \tcbSchedPrev =\ None + \ \tcbSchedNext =\ None \ \tcbContext =\ (ArchThread undefined)" @@ -240,6 +242,8 @@ definition High_tcbH :: tcb where \ \tcbFaultHandler =\ 0 \ \tcbIPCBuffer =\ 0 \ \tcbBoundNotification =\ None + \ \tcbSchedPrev =\ None + \ \tcbSchedNext =\ None \ \tcbContext =\ (ArchThread undefined)" @@ -262,6 +266,8 @@ definition idle_tcbH :: tcb where \ \tcbFaultHandler =\ 0 \ \tcbIPCBuffer =\ 0 \ \tcbBoundNotification =\ None + \ \tcbSchedPrev =\ None + \ \tcbSchedNext =\ None \ \tcbContext =\ (ArchThread empty_context)" @@ -1175,7 +1181,7 @@ definition s0H_internal :: "kernel_state" where ksDomSchedule = [(0, 10), (1, 10)], ksCurDomain = 0, ksDomainTime = 5, - ksReadyQueues = const [], + ksReadyQueues = const (TcbQueue None None), ksReadyQueuesL1Bitmap = const 0, ksReadyQueuesL2Bitmap = const 0, ksCurThread = Low_tcb_ptr, @@ -3253,8 +3259,6 @@ lemma s0H_invs: s0H_internal_def s0_ptrs_aligned objBitsKO_def Low_tcbH_def) apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct', simplified s0H_internal_def]) apply (simp add: objBitsKO_def) - apply (rule conjI) - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs s0H_internal_def) apply (rule conjI) apply (clarsimp simp: sym_refs_def state_refs_of'_def refs_of'_def split: option.splits) apply (frule kh0H_SomeD) @@ -3421,9 +3425,16 @@ lemma s0H_invs: apply (rule conjI) apply (clarsimp simp: irqs_masked'_def s0H_internal_def maxIRQ_def timer_irq_def irqInvalid_def) apply (rule conjI) - apply (clarsimp simp: valid_queues'_def obj_at'_def s0H_internal_def inQ_def) - apply (frule kh0H_dom_tcb) - apply (elim disjE, (clarsimp simp: kh0H_obj_def)+)[1] + apply (clarsimp simp: sym_heap_def opt_map_def projectKOs split: option.splits) + using kh0H_dom_tcb + apply (fastforce simp: kh0H_obj_def) + apply (rule conjI) + apply (clarsimp simp: valid_sched_pointers_def opt_map_def projectKOs split: option.splits) + using kh0H_dom_tcb + apply (fastforce simp: kh0H_obj_def) + apply (rule conjI) + apply (clarsimp simp: valid_bitmaps_def valid_bitmapQ_def bitmapQ_def s0H_internal_def + tcbQueueEmpty_def bitmapQ_no_L1_orphans_def bitmapQ_no_L2_orphans_def) apply (rule conjI) apply (clarsimp simp: ct_not_inQ_def obj_at'_def objBitsKO_def s0H_internal_def s0_ptrs_aligned Low_tcbH_def) @@ -3596,7 +3607,7 @@ lemma s0_pspace_rel: apply (clarsimp simp: kh0_obj_def bit_simps dest!: less_0x200_exists_ucast) defer apply ((clarsimp simp: kh0_obj_def kh0H_obj_def bit_simps word_bits_def - other_obj_relation_def fault_rel_optionation_def + fault_rel_optionation_def tcb_relation_cut_def tcb_relation_def arch_tcb_relation_def the_nat_to_bl_simps split del: if_split)+)[3] prefer 13 @@ -3657,7 +3668,14 @@ lemma s0_srel: High_etcb_def Low_etcb_def default_etcb_def split: if_split_asm) apply (simp add: s0_internal_def exst0_def s0H_internal_def sched_act_relation_def) - apply (simp add: s0_internal_def exst0_def s0H_internal_def ready_queues_relation_def) + apply (clarsimp simp: s0_internal_def exst0_def s0H_internal_def + ready_queues_relation_def ready_queue_relation_def + list_queue_relation_def queue_end_valid_def + prev_queue_head_def inQ_def tcbQueueEmpty_def + projectKOs opt_map_def opt_pred_def + split: option.splits) + using kh0H_dom_tcb + apply (fastforce simp: kh0H_obj_def) apply (clarsimp simp: s0_internal_def exst0_def s0H_internal_def ghost_relation_def) apply (rule conjI) apply (fastforce simp: kh0_def kh0_obj_def dest: kh0_SomeD) diff --git a/proof/invariant-abstract/DetSchedInvs_AI.thy b/proof/invariant-abstract/DetSchedInvs_AI.thy index b89890f632..5e4395749a 100644 --- a/proof/invariant-abstract/DetSchedInvs_AI.thy +++ b/proof/invariant-abstract/DetSchedInvs_AI.thy @@ -129,6 +129,11 @@ abbreviation valid_blocked_except :: "obj_ref \ det_ext state \ etcb_at' (\t. tcb_domain t = cdom) thread ekh" @@ -281,6 +286,10 @@ lemma valid_queues_lift: apply (wp hoare_vcg_ball_lift hoare_vcg_all_lift hoare_vcg_conj_lift a) done +lemma valid_sched_valid_queues[elim!]: + "valid_sched s \ valid_queues s" + by (clarsimp simp: valid_sched_def) + lemma typ_at_st_tcb_at_lift: assumes typ_lift: "\P T p. \\s. P (typ_at T p s)\ f \\r s. P (typ_at T p s)\" assumes st_lift: "\P. \st_tcb_at P t\ f \\_. st_tcb_at P t\" @@ -401,6 +410,10 @@ lemma valid_sched_lift: valid_sched_action_lift valid_blocked_lift a b c d e f g h i hoare_vcg_conj_lift) done +lemma valid_sched_valid_etcbs[elim!]: + "valid_sched s \ valid_etcbs s" + by (clarsimp simp: valid_sched_def) + lemma valid_etcbs_tcb_etcb: "\ valid_etcbs s; kheap s ptr = Some (TCB tcb) \ \ \etcb. ekheap s ptr = Some etcb" by (force simp: valid_etcbs_def is_etcb_at_def st_tcb_at_def obj_at_def) diff --git a/proof/invariant-abstract/DetSchedSchedule_AI.thy b/proof/invariant-abstract/DetSchedSchedule_AI.thy index 39c628e750..7e1ec8501b 100644 --- a/proof/invariant-abstract/DetSchedSchedule_AI.thy +++ b/proof/invariant-abstract/DetSchedSchedule_AI.thy @@ -2212,6 +2212,13 @@ end crunch valid_sched[wp]: dec_domain_time valid_sched +lemma thread_set_time_slice_valid_queues[wp]: + "ethread_set (tcb_time_slice_update f) tptr \valid_queues\" + apply (unfold thread_set_time_slice_def ethread_set_def set_eobject_def) + apply wpsimp + apply (fastforce simp: get_etcb_def valid_queues_def is_etcb_at'_def etcb_at'_def) + done + lemma timer_tick_valid_sched[wp]: "\valid_sched\ timer_tick \\rv. valid_sched\" apply (simp add: timer_tick_def crunch_simps thread_set_time_slice_def diff --git a/proof/refine/AARCH64/ADT_H.thy b/proof/refine/AARCH64/ADT_H.thy index d509b4b577..5f6824b914 100644 --- a/proof/refine/AARCH64/ADT_H.thy +++ b/proof/refine/AARCH64/ADT_H.thy @@ -483,7 +483,7 @@ proof - apply (intro conjI impI allI) apply (erule pspace_dom_relatedE[OF _ pspace_relation]) apply clarsimp - apply (case_tac ko; simp add: other_obj_relation_def) + apply (case_tac ko; simp add: tcb_relation_cut_def other_obj_relation_def) apply (clarsimp simp: cte_relation_def split: if_split_asm) apply (clarsimp simp: ep_relation_def EndpointMap_def split: Structures_A.endpoint.splits) @@ -494,7 +494,7 @@ proof - apply (clarsimp split: if_split_asm)+ apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko; simp add: other_obj_relation_def) + apply (case_tac ko; simp add: tcb_relation_cut_def other_obj_relation_def) apply (clarsimp simp: cte_relation_def split: if_split_asm) apply (clarsimp simp: ntfn_relation_def AEndpointMap_def split: Structures_A.ntfn.splits) @@ -505,7 +505,7 @@ proof - apply (clarsimp split: if_split_asm)+ apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko; simp add: other_obj_relation_def) + apply (case_tac ko; simp add: tcb_relation_cut_def other_obj_relation_def) apply (clarsimp simp: cte_relation_def split: if_split_asm) apply (rename_tac arch_kernel_obj) apply (case_tac arch_kernel_obj; simp add: other_obj_relation_def) @@ -513,7 +513,7 @@ proof - apply (clarsimp split: if_split_asm)+ apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko, simp_all add: other_obj_relation_def) + 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) @@ -536,7 +536,7 @@ proof - apply (erule n_less_2p_pageBitsForSize) apply (clarsimp simp: shiftl_t2n mult_ac) apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko, simp_all add: other_obj_relation_def) + 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) @@ -559,7 +559,7 @@ proof - apply (erule n_less_2p_pageBitsForSize) apply (clarsimp simp: shiftl_t2n mult_ac) apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko, simp_all add: other_obj_relation_def) + 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) @@ -585,7 +585,7 @@ proof - 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: other_obj_relation_def + 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) @@ -652,7 +652,7 @@ proof - (* mapping architecture-specific objects *) apply clarsimp apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko, simp_all add: other_obj_relation_def) + 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 @@ -868,7 +868,7 @@ lemma absEkheap_correct: apply (case_tac "ksPSpace s' x", clarsimp) apply (erule_tac x=x in allE, clarsimp) apply clarsimp - apply (case_tac a, simp_all add: other_obj_relation_def) + 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) apply (erule(1) pspace_dom_relatedE) @@ -896,7 +896,7 @@ lemma TCB_implies_KOTCB: apply (clarsimp simp add: pspace_relation_def pspace_dom_def dom_def UNION_eq Collect_eq) apply (erule_tac x=a in allE)+ - apply (clarsimp simp add: other_obj_relation_def + apply (clarsimp simp add: tcb_relation_cut_def split: Structures_H.kernel_object.splits) apply (drule iffD1) apply (fastforce simp add: dom_def image_def) @@ -1651,7 +1651,7 @@ definition domain_index_internal = ksDomScheduleIdx s, cur_domain_internal = ksCurDomain s, domain_time_internal = ksDomainTime s, - ready_queues_internal = curry (ksReadyQueues 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: @@ -1659,12 +1659,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 absEkheap_correct - absCDTList_correct[THEN fun_cong] state_relation_def invs_def valid_state_def - ready_queues_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) + 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 diff --git a/proof/refine/AARCH64/ArchAcc_R.thy b/proof/refine/AARCH64/ArchAcc_R.thy index 28262e4233..c21322d823 100644 --- a/proof/refine/AARCH64/ArchAcc_R.thy +++ b/proof/refine/AARCH64/ArchAcc_R.thy @@ -53,17 +53,23 @@ lemma pspace_aligned_cross: 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) - apply (clarsimp simp: cte_map_def) - apply (simp add: cteSizeBits_def cte_level_bits_def) - apply (rule is_aligned_add) - apply (erule is_aligned_weaken) - apply simp - apply (rule is_aligned_shift) + \\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_shiftl_self, simp) + \\TCB\ + apply (clarsimp simp: tcbBlockSizeBits_def elim!: is_aligned_weaken) + \\PageTable\ apply (rule is_aligned_add) apply (erule is_aligned_weaken) apply (simp add: bit_simps) apply (rule is_aligned_shift) + \\DataPage\ apply (rule is_aligned_add) apply (erule is_aligned_weaken) apply (rule pbfs_atleast_pageBits) @@ -71,9 +77,7 @@ lemma pspace_aligned_cross: apply (simp add: other_obj_relation_def) apply (clarsimp simp: bit_simps' tcbBlockSizeBits_def epSizeBits_def ntfnSizeBits_def split: kernel_object.splits Structures_A.kernel_object.splits) - apply (clarsimp simp: archObjSize_def bit_simps - split: arch_kernel_object.splits arch_kernel_obj.splits) - apply (erule is_aligned_weaken, simp add: bit_simps)+ + apply (fastforce simp: archObjSize_def split: arch_kernel_object.splits arch_kernel_obj.splits) done lemma of_bl_shift_cte_level_bits: @@ -85,10 +89,12 @@ lemma obj_relation_cuts_range_limit: "\ (p', P) \ obj_relation_cuts ko p; P ko ko' \ \ \x n. p' = p + x \ is_aligned x n \ n \ obj_bits ko \ x \ mask (obj_bits ko)" apply (erule (1) obj_relation_cutsE; clarsimp) - apply (drule (1) wf_cs_nD) - apply (clarsimp simp: cte_map_def) - apply (rule_tac x=cte_level_bits in exI) - apply (simp add: is_aligned_shift of_bl_shift_cte_level_bits) + apply (drule (1) wf_cs_nD) + apply (clarsimp simp: cte_map_def) + apply (rule_tac x=cte_level_bits in exI) + apply (simp add: is_aligned_shift of_bl_shift_cte_level_bits) + apply (rule_tac x=tcbBlockSizeBits in exI) + apply (simp add: tcbBlockSizeBits_def) apply (rule_tac x=pte_bits in exI) apply (simp add: is_aligned_shift mask_def) apply (rule shiftl_less_t2n) @@ -233,14 +239,6 @@ lemma getObject_ASIDPool_corres: apply (clarsimp simp: other_obj_relation_def) done -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 project_inject pspace_distinct'_def pspace_aligned'_def) - apply (drule bspec, erule domI)+ - apply simp - done - lemma storePTE_cte_wp_at'[wp]: "storePTE ptr val \\s. P (cte_wp_at' P' p s)\" apply (simp add: storePTE_def) @@ -447,7 +445,8 @@ lemma setObject_PT_corres: apply (drule bspec, assumption) apply clarsimp apply (erule (1) obj_relation_cutsE) - apply simp + apply simp + apply clarsimp apply clarsimp apply (smt (verit, best) pspace_aligned_pts_ofD pts_of_Some pts_of_type_unique aobjs_of_Some table_base_plus) @@ -459,10 +458,14 @@ lemma setObject_PT_corres: apply (drule_tac x=p in bspec, erule domI) apply (simp add: other_obj_relation_def split: Structures_A.kernel_object.splits) - apply (rule conjI) + apply (extract_conjunct \match conclusion in "ghost_relation _ _ _ _" \ -\) apply (clarsimp simp add: ghost_relation_def) apply (erule_tac x="p && ~~ mask (pt_bits (pt_type pt))" in allE)+ apply fastforce + apply (extract_conjunct \match conclusion in "ready_queues_relation_2 _ _ _ _ _" \ -\) + apply (prop_tac "typ_at' (koTypeOf (injectKO pte')) p b") + apply (simp add: typ_at'_def ko_wp_at'_def) + subgoal by (fastforce dest: tcbs_of'_non_tcb_update) apply (simp add: map_to_ctes_upd_other) apply (simp add: fun_upd_def) apply (simp add: caps_of_state_after_update obj_at_def swp_cte_at_caps_of) diff --git a/proof/refine/AARCH64/Arch_R.thy b/proof/refine/AARCH64/Arch_R.thy index bd6f5e5d1e..d265c8b81b 100644 --- a/proof/refine/AARCH64/Arch_R.thy +++ b/proof/refine/AARCH64/Arch_R.thy @@ -275,9 +275,9 @@ lemma performASIDControlInvocation_corres: apply (fold_subgoals (prefix))[2] subgoal premises prems using prems by (clarsimp simp:invs_def valid_state_def)+ apply (clarsimp simp: schact_is_rct_def) - apply (clarsimp simp:cte_wp_at_caps_of_state) + 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 (fastforce simp: cte_wp_at_caps_of_state) apply simp apply (frule_tac ptr = "(aa,ba)" in detype_invariants [rotated 3]) apply fastforce @@ -342,7 +342,7 @@ lemma performASIDControlInvocation_corres: apply (simp add:pageBits_def) apply clarsimp apply (drule(1) cte_cap_in_untyped_range) - apply (fastforce simp:cte_wp_at_ctes_of) + apply (fastforce simp: cte_wp_at_ctes_of) apply assumption+ apply fastforce apply simp @@ -1854,7 +1854,7 @@ lemma assoc_invs': valid_irq_node_lift_asm [where Q=\] valid_irq_handlers_lift' cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift - setObject_typ_at' cur_tcb_lift + setObject_typ_at' cur_tcb_lift valid_bitmaps_lift sym_heap_sched_pointers_lift setVCPU_valid_arch' simp: objBits_simps archObjSize_def vcpuBits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb valid_arch_tcb'_def diff --git a/proof/refine/AARCH64/Bits_R.thy b/proof/refine/AARCH64/Bits_R.thy index a548deb670..8fd5064679 100644 --- a/proof/refine/AARCH64/Bits_R.thy +++ b/proof/refine/AARCH64/Bits_R.thy @@ -67,6 +67,10 @@ lemma projectKO_tcb: "(projectKO_opt ko = Some t) = (ko = KOTCB t)" by (cases ko) (auto simp: projectKO_opts_defs) +lemma tcb_of'_TCB[simp]: + "tcb_of' (KOTCB tcb) = Some tcb" + by (simp add: projectKO_tcb) + lemma projectKO_cte: "(projectKO_opt ko = Some t) = (ko = KOCTE t)" by (cases ko) (auto simp: projectKO_opts_defs) diff --git a/proof/refine/AARCH64/CNodeInv_R.thy b/proof/refine/AARCH64/CNodeInv_R.thy index f724a14ba8..2afaebfe59 100644 --- a/proof/refine/AARCH64/CNodeInv_R.thy +++ b/proof/refine/AARCH64/CNodeInv_R.thy @@ -5044,8 +5044,6 @@ crunch valid_arch_state'[wp]: cteSwap "valid_arch_state'" crunch irq_states'[wp]: cteSwap "valid_irq_states'" -crunch vq'[wp]: cteSwap "valid_queues'" - crunch ksqsL1[wp]: cteSwap "\s. P (ksReadyQueuesL1Bitmap s)" crunch ksqsL2[wp]: cteSwap "\s. P (ksReadyQueuesL2Bitmap s)" @@ -5060,6 +5058,12 @@ crunch ct_not_inQ[wp]: cteSwap "ct_not_inQ" crunch ksDomScheduleIdx [wp]: cteSwap "\s. P (ksDomScheduleIdx s)" +crunches cteSwap + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + and valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift) + lemma cteSwap_invs'[wp]: "\invs' and valid_cap' c and valid_cap' c' and ex_cte_cap_to' c1 and ex_cte_cap_to' c2 and @@ -5509,6 +5513,10 @@ lemma updateCap_untyped_ranges_zero_simple: crunch tcb_in_cur_domain'[wp]: updateCap "tcb_in_cur_domain' t" (wp: crunch_wps simp: crunch_simps rule: tcb_in_cur_domain'_lift) +crunches updateCap + for valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift) + lemma make_zombie_invs': "\\s. invs' s \ s \' cap \ cte_wp_at' (\cte. isFinal (cteCap cte) sl (cteCaps_of s)) sl s \ @@ -5526,7 +5534,8 @@ lemma make_zombie_invs': \ bound_tcb_at' ((=) None) p s \ obj_at' (Not \ tcbQueued) p s \ ko_wp_at' (Not \ hyp_live') p s - \ (\pr. p \ set (ksReadyQueues s pr)))) sl 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_state'_def valid_pspace'_def valid_mdb'_def @@ -5564,7 +5573,9 @@ lemma make_zombie_invs': apply (subgoal_tac "st_tcb_at' ((=) Inactive) p' s \ obj_at' (Not \ tcbQueued) p' s \ bound_tcb_at' ((=) None) p' s - \ ko_wp_at' (Not \ hyp_live') p' s") + \ ko_wp_at' (Not \ hyp_live') 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 live'_def hyp_live'_def) apply (auto dest!: isCapDs)[1] apply (clarsimp simp: cte_wp_at_ctes_of disj_ac @@ -8549,6 +8560,15 @@ lemma cteMove_urz [wp]: apply auto done +crunches updateMDB + for valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift) + +(* FIXME: arch_split *) +lemma haskell_assert_inv: + "haskell_assert Q L \P\" + by wpsimp + lemma cteMove_invs' [wp]: "\\x. invs' x \ ex_cte_cap_to' word2 x \ cte_wp_at' (\c. weak_derived' (cteCap c) capability) word1 x \ @@ -8626,6 +8646,10 @@ crunch ksDomSchedule[wp]: updateCap "\s. P (ksDomSchedule s)" crunch ksDomScheduleIdx[wp]: updateCap "\s. P (ksDomScheduleIdx s)" crunch ksDomainTime[wp]: updateCap "\s. P (ksDomainTime s)" +crunches updateCap + for rdyq_projs[wp]: + "\s. P (ksReadyQueues s) (tcbSchedNexts_of s) (tcbSchedPrevs_of s) (\d p. inQ d p |< tcbs_of' s)" + lemma corres_null_cap_update: "cap_relation cap cap' \ corres dc (invs and cte_wp_at ((=) cap) slot) diff --git a/proof/refine/AARCH64/CSpace1_R.thy b/proof/refine/AARCH64/CSpace1_R.thy index d9c1fb277c..637819592d 100644 --- a/proof/refine/AARCH64/CSpace1_R.thy +++ b/proof/refine/AARCH64/CSpace1_R.thy @@ -234,7 +234,7 @@ lemma pspace_relation_cte_wp_at: apply (clarsimp elim!: cte_wp_at_weakenE') apply clarsimp apply (drule(1) pspace_relation_absD) - apply (clarsimp simp: other_obj_relation_def) + apply (clarsimp simp: tcb_relation_cut_def) apply (simp split: kernel_object.split_asm) apply (drule(2) aligned_distinct_obj_atI'[where 'a=tcb]) apply simp @@ -1632,10 +1632,10 @@ lemma cte_map_pulls_tcb_to_abstract: \ \tcb'. kheap s x = Some (TCB tcb') \ tcb_relation tcb' tcb \ (z = (x, tcb_cnode_index (unat ((y - x) >> cte_level_bits))))" apply (rule pspace_dom_relatedE, assumption+) - apply (erule(1) obj_relation_cutsE, simp_all split: if_split_asm) - apply (clarsimp simp: other_obj_relation_def - split: Structures_A.kernel_object.split_asm - AARCH64_A.arch_kernel_obj.split_asm) + apply (erule(1) obj_relation_cutsE; + clarsimp simp: other_obj_relation_def + split: Structures_A.kernel_object.split_asm + AARCH64_A.arch_kernel_obj.split_asm if_split_asm) apply (drule tcb_cases_related2) apply clarsimp apply (frule(1) cte_wp_at_tcbI [OF _ _ TrueI, where t="(a, b)" for a b, simplified]) @@ -1651,8 +1651,7 @@ lemma pspace_relation_update_tcbs: del: dom_fun_upd) apply (erule conjE) apply (rule ballI, drule(1) bspec) - apply (rule conjI, simp add: other_obj_relation_def) - apply (clarsimp split: Structures_A.kernel_object.split_asm) + apply (clarsimp simp: tcb_relation_cut_def split: Structures_A.kernel_object.split_asm) apply (drule bspec, fastforce) apply clarsimp apply (erule(1) obj_relation_cutsE, simp_all split: if_split_asm) @@ -1874,6 +1873,27 @@ lemma descendants_of_eq': apply simp done +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 + +lemma setObject_cte_tcbSchedNexts_of_use_valid_ksPSpace: + assumes step: "(x, s\ksPSpace := ps\) \ fst (setObject p (cte :: cte) s)" + 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_inQ_of_use_valid_ksPSpace: + assumes step: "(x, s\ksPSpace := ps\) \ fst (setObject p (cte :: cte) s)" + 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))) \ @@ -1887,7 +1907,12 @@ lemma updateCap_stuff: ksSchedulerAction s'' = ksSchedulerAction s' \ (ksArchState s'' = ksArchState s') \ (pspace_aligned' s' \ pspace_aligned' s'') \ - (pspace_distinct' s' \ pspace_distinct' s'')" using assms + (pspace_distinct' s' \ pspace_distinct' s'') \ + 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) @@ -1896,8 +1921,11 @@ lemma updateCap_stuff: apply (frule setCTE_pspace_only) apply (clarsimp simp: setCTE_def) apply (intro conjI impI) - apply (erule(1) use_valid [OF _ setObject_aligned]) - apply (erule(1) use_valid [OF _ setObject_distinct]) + 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 *) @@ -1914,16 +1942,16 @@ lemma pspace_relation_cte_wp_atI': apply (simp split: if_split_asm) apply (erule(1) pspace_dom_relatedE) apply (erule(1) obj_relation_cutsE, simp_all split: if_split_asm) + apply (subgoal_tac "n = x - y", clarsimp) + apply (drule tcb_cases_related2, clarsimp) + apply (intro exI, rule conjI) + apply (erule(1) cte_wp_at_tcbI[where t="(a, b)" for a b, simplified]) + apply fastforce + apply simp + apply clarsimp apply (simp add: other_obj_relation_def split: Structures_A.kernel_object.split_asm AARCH64_A.arch_kernel_obj.split_asm) - apply (subgoal_tac "n = x - y", clarsimp) - apply (drule tcb_cases_related2, clarsimp) - apply (intro exI, rule conjI) - apply (erule(1) cte_wp_at_tcbI[where t="(a, b)" for a b, simplified]) - apply fastforce - apply simp - apply clarsimp done lemma pspace_relation_cte_wp_atI: @@ -2445,7 +2473,7 @@ lemma updateCap_corres: apply (clarsimp simp: in_set_cap_cte_at_swp pspace_relations_def) apply (drule updateCap_stuff) apply simp - apply (rule conjI) + apply (extract_conjunct \match conclusion in "ghost_relation _ _ _ _" \ -\) apply (clarsimp simp: ghost_relation_typ_at set_cap_a_type_inv data_at_def) apply (rule conjI) prefer 2 @@ -2533,9 +2561,9 @@ lemma updateMDB_pspace_relation: apply (clarsimp simp: tcb_ctes_clear cte_level_bits_def objBits_defs) apply clarsimp apply (rule pspace_dom_relatedE, assumption+) - apply (rule obj_relation_cutsE, assumption+, simp_all split: if_split_asm)[1] - apply (clarsimp split: Structures_A.kernel_object.split_asm - AARCH64_A.arch_kernel_obj.split_asm + apply (rule obj_relation_cutsE, assumption+; + clarsimp split: Structures_A.kernel_object.split_asm + AARCH64_A.arch_kernel_obj.split_asm if_split_asm simp: other_obj_relation_def) apply (frule(1) tcb_cte_cases_aligned_helpers(1)) apply (frule(1) tcb_cte_cases_aligned_helpers(2)) @@ -2597,6 +2625,25 @@ lemma updateMDB_ctes_of: crunch aligned[wp]: updateMDB "pspace_aligned'" crunch pdistinct[wp]: updateMDB "pspace_distinct'" +crunch tcbSchedPrevs_of[wp]: updateMDB "\s. P (tcbSchedPrevs_of s)" +crunch tcbSchedNexts_of[wp]: updateMDB "\s. P (tcbSchedNexts_of s)" +crunch inQ_opt_pred[wp]: updateMDB "\s. P (inQ d p |< tcbs_of' s)" +crunch inQ_opt_pred'[wp]: updateMDB "\s. P (\d p. inQ d p |< tcbs_of' s)" +crunch ksReadyQueues[wp]: updateMDB "\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 + +crunches 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')" @@ -2619,7 +2666,11 @@ lemma updateMDB_the_lot: ksDomScheduleIdx s'' = ksDomScheduleIdx s' \ ksDomSchedule s'' = ksDomSchedule s' \ ksCurDomain s'' = ksCurDomain s' \ - ksDomainTime s'' = ksDomainTime s'" + ksDomainTime s'' = ksDomainTime s' \ + 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) @@ -2628,9 +2679,8 @@ using assms apply (erule use_valid) apply wp apply simp - 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 is_cap_revocable_eq: @@ -3793,6 +3843,9 @@ lemma updateUntypedCap_descendants_of: apply (clarsimp simp:mdb_next_rel_def mdb_next_def split:if_splits) done +crunches setCTE + for tcbQueued[wp]: "\s. P (tcbQueued |< tcbs_of' s)" + lemma setCTE_UntypedCap_corres: "\cap_relation cap (cteCap cte); is_untyped_cap cap; idx' = idx\ \ corres dc (cte_wp_at ((=) cap) src and valid_objs and @@ -3822,10 +3875,19 @@ lemma setCTE_UntypedCap_corres: apply assumption apply (clarsimp simp: pspace_relations_def) apply (subst conj_assoc[symmetric]) + apply clarsimp 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) @@ -5105,11 +5167,15 @@ lemma updateMDB_the_lot': ksDomScheduleIdx s'' = ksDomScheduleIdx s' \ ksDomSchedule s'' = ksDomSchedule s' \ ksCurDomain s'' = ksCurDomain s' \ - ksDomainTime s'' = ksDomainTime s'" + ksDomainTime s'' = ksDomainTime s' \ + 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 + done lemma cte_map_inj_eq': "\(cte_map p = cte_map p'); @@ -5211,7 +5277,6 @@ lemma cteInsert_corres: 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 "ksReadyQueues t = p" for p t)+ apply (thin_tac "ksSchedulerAction t = p" for p t)+ apply (clarsimp simp: pspace_relations_def) diff --git a/proof/refine/AARCH64/CSpace_R.thy b/proof/refine/AARCH64/CSpace_R.thy index c077663541..67ea635cea 100644 --- a/proof/refine/AARCH64/CSpace_R.thy +++ b/proof/refine/AARCH64/CSpace_R.thy @@ -1092,43 +1092,6 @@ lemma bitmapQ_no_L2_orphans_lift: apply (rule hoare_vcg_prop, assumption) done -lemma valid_queues_lift_asm: - assumes tat1: "\d p tcb. \obj_at' (inQ d p) tcb and Q \ f \\_. obj_at' (inQ d p) tcb\" - and tat2: "\tcb. \st_tcb_at' runnable' tcb and Q \ f \\_. st_tcb_at' runnable' tcb\" - and prq: "\P. \\s. P (ksReadyQueues s) \ f \\_ s. P (ksReadyQueues s)\" - and prqL1: "\P. \\s. P (ksReadyQueuesL1Bitmap s)\ f \\_ s. P (ksReadyQueuesL1Bitmap s)\" - and prqL2: "\P. \\s. P (ksReadyQueuesL2Bitmap s)\ f \\_ s. P (ksReadyQueuesL2Bitmap s)\" - shows "\Invariants_H.valid_queues and Q\ f \\_. Invariants_H.valid_queues\" - proof - - have tat: "\d p tcb. \obj_at' (inQ d p) tcb and st_tcb_at' runnable' tcb and Q\ f - \\_. obj_at' (inQ d p) tcb and st_tcb_at' runnable' tcb\" - apply (rule hoare_chain [OF hoare_vcg_conj_lift [OF tat1 tat2]]) - apply (fastforce)+ - done - have tat_combined: "\d p tcb. \obj_at' (inQ d p and runnable' \ tcbState) tcb and Q\ f - \\_. obj_at' (inQ d p and runnable' \ tcbState) tcb\" - apply (rule hoare_chain [OF tat]) - apply (fastforce simp add: obj_at'_and pred_tcb_at'_def o_def)+ - done - show ?thesis unfolding valid_queues_def valid_queues_no_bitmap_def - by (wp tat_combined prq prqL1 prqL2 valid_bitmapQ_lift bitmapQ_no_L2_orphans_lift - bitmapQ_no_L1_orphans_lift hoare_vcg_all_lift hoare_vcg_conj_lift hoare_Ball_helper) - simp_all - qed - -lemmas valid_queues_lift = valid_queues_lift_asm[where Q="\_. True", simplified] - -lemma valid_queues_lift': - assumes tat: "\d p tcb. \\s. \ obj_at' (inQ d p) tcb s\ f \\_ s. \ obj_at' (inQ d p) tcb s\" - and prq: "\P. \\s. P (ksReadyQueues s)\ f \\_ s. P (ksReadyQueues s)\" - shows "\valid_queues'\ f \\_. valid_queues'\" - unfolding valid_queues'_def imp_conv_disj - by (wp hoare_vcg_all_lift hoare_vcg_disj_lift tat prq) - -lemma setCTE_norq [wp]: - "\\s. P (ksReadyQueues s)\ setCTE ptr cte \\r s. P (ksReadyQueues s) \" - by (clarsimp simp: valid_def dest!: setCTE_pspace_only) - lemma setCTE_norqL1 [wp]: "\\s. P (ksReadyQueuesL1Bitmap s)\ setCTE ptr cte \\r s. P (ksReadyQueuesL1Bitmap s) \" by (clarsimp simp: valid_def dest!: setCTE_pspace_only) @@ -2787,12 +2750,6 @@ lemma setCTE_inQ[wp]: apply (simp_all add: inQ_def) done -lemma setCTE_valid_queues'[wp]: - "\valid_queues'\ setCTE p cte \\rv. valid_queues'\" - apply (simp only: valid_queues'_def imp_conv_disj) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - done - crunch inQ[wp]: cteInsert "\s. P (obj_at' (inQ d p) t s)" (wp: crunch_wps) @@ -3305,6 +3262,13 @@ lemma cteInsert_untyped_ranges_zero[wp]: apply blast done +crunches cteInsert + 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 (\s. src \ dest) and (\s. cte_wp_at' (is_derived' (ctes_of s) src cap \ cteCap) src s) @@ -3313,9 +3277,9 @@ lemma cteInsert_invs: cteInsert cap src dest \\rv. invs'\" 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 CSpace_R.valid_queues_lift - valid_irq_node_lift valid_queues_lift' irqs_masked_lift cteInsert_norq - simp: st_tcb_at'_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 @@ -3641,10 +3605,13 @@ lemma corres_caps_decomposition: "\P. \\s. P (new_cns s)\ f \\rv s. P (cns_of_heap (kheap s))\" "\P. \\s. P (new_cns' s)\ g \\rv s. P (gsCNodes s)\" "\P. \\s. P (new_pt_types s)\ f \\rv s. P (pt_types_of s)\" - "\P. \\s. P (new_queues s)\ f \\rv s. P (ready_queues s)\" + "\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_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)\" @@ -3660,7 +3627,9 @@ lemma corres_caps_decomposition: "\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 (new_queues s) (new_rqs' s')" + \ ready_queues_relation_2 (new_ready_queues s) (new_ksReadyQueues s') + (new_tcbSchedNexts_of s') (new_tcbSchedPrevs_of s') + (\d p. new_inQs d p s')" "\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 \ @@ -4179,6 +4148,9 @@ crunches setupReplyMaster 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]: @@ -4207,7 +4179,8 @@ lemma setupReplyMaster_invs'[wp]: 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 valid_queues_lift' hoare_vcg_disj_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 @@ -4471,8 +4444,8 @@ lemma arch_update_setCTE_invs: 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 + 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) @@ -5847,7 +5820,7 @@ lemma cteInsert_simple_invs: apply (rule hoare_pre) 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' irqs_masked_lift + 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 @@ -5982,6 +5955,21 @@ lemma arch_update_updateCap_invs: apply clarsimp 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 @@ -6013,6 +6001,8 @@ lemma updateCap_same_master: apply 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 @@ -6241,8 +6231,9 @@ lemma updateFreeIndex_forward_invs': apply (simp add:updateCap_def) apply (wp setCTE_irq_handlers' getCTE_wp) apply (simp add:updateCap_def) - apply (wp irqs_masked_lift valid_queues_lift' cur_tcb_lift ct_idle_or_in_cur_domain'_lift + apply (wp irqs_masked_lift cur_tcb_lift ct_idle_or_in_cur_domain'_lift hoare_vcg_disj_lift untyped_ranges_zero_lift getCTE_wp + sym_heap_sched_pointers_lift valid_bitmaps_lift | wp (once) hoare_use_eq[where f="gsUntypedZeroRanges"] | simp add: getSlotCap_def)+ apply (clarsimp simp: cte_wp_at_ctes_of fun_upd_def[symmetric]) diff --git a/proof/refine/AARCH64/Detype_R.thy b/proof/refine/AARCH64/Detype_R.thy index b3e6358b3c..ca15168e2b 100644 --- a/proof/refine/AARCH64/Detype_R.thy +++ b/proof/refine/AARCH64/Detype_R.thy @@ -628,8 +628,9 @@ lemma valid_objs: "valid_objs' s'" and pa: "pspace_aligned' s'" and pc: "pspace_canonical' s'" and pd: "pspace_distinct' s'" - and vq: "valid_queues s'" - and vq': "valid_queues' s'" + and vbm: "valid_bitmaps s'" + and sym_sched: "sym_heap_sched_pointers s'" + and vsp: "valid_sched_pointers s'" and sym_refs: "sym_refs (state_refs_of' s')" and sym_hyp_refs: "sym_refs (state_hyp_refs_of' s')" and iflive: "if_live_then_nonz_cap' s'" @@ -852,7 +853,6 @@ lemma sym_refs_TCB_hyp_live': apply (simp add: ko_wp_at'_def) apply (clarsimp simp: hyp_refs_of_rev' hyp_live'_def arch_live'_def) done - end context begin interpretation Arch . (*FIXME: arch_split*) @@ -960,6 +960,70 @@ crunches doMachineOp and deletionIsSafe_delete_locale[wp]: "deletionIsSafe_delete_locale base magnitude" (simp: deletionIsSafe_delete_locale_def) +lemma detype_tcbSchedNexts_of: + "\pspace_aligned' s'; pspace_distinct' s'; \p. p \ S \ \ ko_wp_at' live' p s'\ + \ ((\x. if x \ S then None else ksPSpace s' x) |> tcb_of' |> tcbSchedNext) + = tcbSchedNexts_of s'" + using pspace_alignedD' pspace_distinctD' + apply (clarsimp simp: opt_map_def) + apply (rule ext) + apply (rename_tac s) + apply (clarsimp simp: ko_wp_at'_def live'_def split: option.splits) + apply (drule_tac x=s in spec) + apply force + done + +lemma detype_tcbSchedPrevs_of: + "\pspace_aligned' s'; pspace_distinct' s'; \p. p \ S \ \ ko_wp_at' live' p s'\ + \ ((\x. if x \ S then None else ksPSpace s' x) |> tcb_of' |> tcbSchedPrev) + = tcbSchedPrevs_of s'" + using pspace_alignedD' pspace_distinctD' + using pspace_alignedD' pspace_distinctD' + apply (clarsimp simp: opt_map_def) + apply (rule ext) + apply (rename_tac s) + apply (clarsimp simp: ko_wp_at'_def live'_def split: option.splits) + apply (drule_tac x=s in spec) + apply force + done + +lemma detype_inQ: + "\pspace_aligned' s'; pspace_distinct' s'; \p. p \ S \ \ ko_wp_at' live' p s'\ + \ \d p. (inQ d p |< ((\x. if x \ S then None else ksPSpace s' x) |> tcb_of')) + = (inQ d p |< tcbs_of' s')" + using pspace_alignedD' pspace_distinctD' + using pspace_alignedD' pspace_distinctD' + apply (clarsimp simp: opt_map_def) + apply (rule ext) + apply (rename_tac s) + apply (clarsimp simp: inQ_def opt_pred_def ko_wp_at'_def live'_def split: option.splits) + apply (drule_tac x=s in spec) + apply force + done + +lemma detype_ready_queues_relation: + "\pspace_aligned' s'; pspace_distinct' s'; + \p. p \ {lower..upper} \ \ ko_wp_at' live' p s'; + ready_queues_relation s s'; upper = upper'\ + \ ready_queues_relation_2 + (ready_queues (detype {lower..upper'} s)) + (ksReadyQueues s') + ((\x. if lower \ x \ x \ upper then None + else ksPSpace s' x) |> + tcb_of' |> + tcbSchedNext) + ((\x. if lower \ x \ x \ upper then None + else ksPSpace s' x) |> + tcb_of' |> + tcbSchedPrev) + (\d p. inQ d p |< ((\x. if lower \ x \ x \ upper then None else ksPSpace s' x) |> tcb_of'))" + apply (clarsimp simp: detype_ext_def ready_queues_relation_def Let_def) + apply (frule (1) detype_tcbSchedNexts_of[where S="{lower..upper}"]; simp) + apply (frule (1) detype_tcbSchedPrevs_of[where S="{lower..upper}"]; simp) + apply (frule (1) detype_inQ[where S="{lower..upper}"]; simp) + apply (fastforce simp add: detype_def detype_ext_def wrap_ext_det_ext_ext_def) + done + lemma deleteObjects_corres: "is_aligned base magnitude \ magnitude \ 3 \ corres dc @@ -980,19 +1044,19 @@ lemma deleteObjects_corres: apply (rule corres_stateAssert_implied[where P'=\, simplified]) prefer 2 apply clarsimp - 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 p_assoc_help invs_valid_pspace)[1] - apply (simp add:valid_cap_simps) + 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 (fastforce simp: sch_act_simple_def schact_is_rct_def state_relation_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: valid_cap_simps) apply (simp add: ksASIDMapSafe_def) apply (simp add: delete_objects_def) apply (rule corres_underlying_split[where r'=dc]) @@ -1015,39 +1079,44 @@ lemma deleteObjects_corres: untyped_children_in_mdb s \ if_unsafe_then_cap s \ valid_global_refs s" and P'="\s. s \' capability.UntypedCap d base magnitude idx \ - valid_pspace' s" in corres_modify) + valid_pspace' s \ + deletionIsSafe_delete_locale base magnitude s" in corres_modify) 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, rule state.equality; - simp add: detype_ext_def wrap_ext_det_ext_ext_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 wrap_ext_det_ext_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) 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) - 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 (frule(2) pspace_relation_cte_wp_atI + [OF state_relation_pspace_relation]) + apply (elim exE) + apply (frule(4) cte_map_not_null_outside') + apply (rule cte_wp_at_weakenE, erule conjunct1) + apply (case_tac y, clarsimp) + apply (clarsimp simp: valid_mdb'_def valid_mdb_ctes_def + valid_nullcaps_def) + apply clarsimp + apply (frule_tac cref="(aa, ba)" in cte_map_untyped_range, + erule cte_wp_at_weakenE[OF _ TrueI], assumption+) + apply (simp add: add_mask_fold) apply (simp add: add_mask_fold) - apply (simp add: add_mask_fold) - apply (rule detype_pspace_relation[simplified], - simp_all add: state_relation_pspace_relation valid_pspace_def)[1] - apply (simp add: valid_cap'_def capAligned_def) - apply (clarsimp simp: valid_cap_def, assumption) - apply (fastforce simp: detype_def detype_ext_def add_mask_fold wrap_ext_det_ext_ext_def - intro!: ekheap_relation_detype) + 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: detype_def detype_ext_def add_mask_fold wrap_ext_det_ext_ext_def + intro!: ekheap_relation_detype) + apply (rule detype_ready_queues_relation; blast?) + apply (clarsimp simp: deletionIsSafe_delete_locale_def) + apply (erule state_relation_ready_queues_relation) + apply (simp add: add_mask_fold) apply (clarsimp simp: state_relation_def ghost_relation_of_heap detype_def) apply (drule_tac t="gsUserPages s'" in sym) @@ -1063,13 +1132,31 @@ lemma deleteObjects_corres: apply fastforce apply (wpsimp wp: hoare_vcg_op_lift) done - end 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" + apply (case_tac "ko_wp_at' live' 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 invs_valid_idle'[OF invs]) + 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 mask_eq_exp_minus_1) + by fastforce + +lemma untyped_range_live_idle': + "p \ base_bits \ \ (ko_wp_at' live' p s' \ p = idle_thread_ptr)" + using live_idle_untyped_range' by blast + lemma valid_obj': - "\ valid_obj' obj s'; ko_wp_at' ((=) obj) p s' \ \ valid_obj' obj state'" + "\ 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 (rename_tac endpoint) apply (case_tac endpoint, simp_all add: valid_ep'_def)[1] @@ -1096,18 +1183,30 @@ lemma valid_obj': apply (erule(2) cte_wp_at_tcbI') apply fastforce apply simp - apply (rename_tac tcb) - apply (simp only: conj_assoc[symmetric], rule conjI) - apply (case_tac "tcbState tcb"; - clarsimp simp: valid_tcb_state'_def valid_bound_ntfn'_def - dest!: refs_notRange split: option.splits) - using sym_hyp_refs - apply (clarsimp simp add: valid_arch_tcb'_def split: option.split_asm) - apply (drule (1) sym_refs_TCB_hyp_live'[rotated]) - apply (clarsimp simp: ko_wp_at'_def objBits_simps; (rule conjI|assumption)+) - apply (drule live_notRange, clarsimp simp: live'_def) - apply (case_tac ko; simp) - 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 live'_def) + 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 live'_def) + using sym_hyp_refs + apply (clarsimp simp add: valid_arch_tcb'_def split: option.split_asm) + apply (drule (1) sym_refs_TCB_hyp_live'[rotated]) + apply (clarsimp simp: ko_wp_at'_def objBits_simps; (rule conjI|assumption)+) + apply (drule live_notRange, clarsimp simp: live'_def) + apply (case_tac ko; simp) + apply clarsimp 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]) @@ -1115,6 +1214,38 @@ lemma valid_obj': apply simp done +lemma tcbSchedNexts_of_pspace': + "\pspace_aligned' s'; pspace_distinct' s'; pspace_distinct' state'\ + \ (pspace' |> tcb_of' |> tcbSchedNext) = tcbSchedNexts_of s'" + apply (rule ext) + apply (rename_tac p) + apply (case_tac "p \ base_bits") + apply (frule untyped_range_live_idle') + apply (clarsimp simp: opt_map_def) + apply (case_tac "ksPSpace s' p"; clarsimp) + apply (rename_tac obj) + apply (case_tac "tcb_of' obj"; clarsimp) + apply (clarsimp simp: ko_wp_at'_def obj_at'_def live'_def) + apply (fastforce simp: pspace_alignedD' pspace_distinctD') + apply (clarsimp simp: opt_map_def split: option.splits) + done + +lemma tcbSchedPrevs_of_pspace': + "\pspace_aligned' s'; pspace_distinct' s'; pspace_distinct' state'\ + \ (pspace' |> tcb_of' |> tcbSchedPrev) = tcbSchedPrevs_of s'" + apply (rule ext) + apply (rename_tac p) + apply (case_tac "p \ base_bits") + apply (frule untyped_range_live_idle') + apply (clarsimp simp: opt_map_def) + apply (case_tac "ksPSpace s' p"; clarsimp) + apply (rename_tac obj) + apply (case_tac "tcb_of' obj"; clarsimp) + apply (clarsimp simp: ko_wp_at'_def obj_at'_def live'_def) + apply (fastforce simp: pspace_alignedD' pspace_distinctD') + apply (clarsimp simp: opt_map_def split: option.splits) + done + lemma st_tcb: "\P p. \ st_tcb_at' P p s'; \ P Inactive; \ P IdleThreadState \ \ st_tcb_at' P p state'" by (fastforce simp: pred_tcb_at'_def obj_at'_real_def live'_def hyp_live'_def dest: live_notRange) @@ -1324,17 +1455,18 @@ proof (simp add: invs'_def valid_state'_def valid_pspace'_def show "pspace_canonical' ?s" using pc by (simp add: pspace_canonical'_def dom_def) - show "pspace_distinct' ?s" using pd + show pspace_distinct'_state': "pspace_distinct' ?s" using pd by (clarsimp simp add: pspace_distinct'_def ps_clear_def dom_if_None Diff_Int_distrib) - show "valid_objs' ?s" using valid_objs + show "valid_objs' ?s" using valid_objs sym_sched apply (clarsimp simp: valid_objs'_def ran_def) 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 + apply (frule pspace_alignedD'[OF _ pa]) + apply (frule pspace_distinctD'[OF _ pd]) + apply (clarsimp simp: ko_wp_at'_def) + apply fastforce done from sym_refs show "sym_refs (state_refs_of' ?s)" @@ -1355,19 +1487,6 @@ proof (simp add: invs'_def valid_state'_def valid_pspace'_def apply (simp add: hyp_refs_notRange[simplified] state_hyp_refs_ko_wp_at_eq) done - 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: inQ_def live'_def) - apply (clarsimp dest!: ex_nonz_cap_notRange) - done - - from vq' show "valid_queues' ?s" - by (simp add: valid_queues'_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) @@ -1609,6 +1728,20 @@ proof (simp add: invs'_def valid_state'_def valid_pspace'_def apply simp done + from vbm + show "valid_bitmaps state'" + by (simp add: valid_bitmaps_def bitmapQ_defs) + + from sym_sched + show "sym_heap (pspace' |> tcb_of' |> tcbSchedNext) (pspace' |> tcb_of' |> tcbSchedPrev)" + using pa pd pspace_distinct'_state' + by (fastforce simp: tcbSchedNexts_of_pspace' tcbSchedPrevs_of_pspace') + + from vsp show "valid_sched_pointers_2 (pspace' |> tcb_of' |> tcbSchedPrev) + (pspace' |> tcb_of' |> tcbSchedNext) + (tcbQueued |< (pspace' |> tcb_of'))" + by (clarsimp simp: valid_sched_pointers_def opt_pred_def opt_map_def) + qed (clarsimp) lemma (in delete_locale) delete_ko_wp_at': diff --git a/proof/refine/AARCH64/EmptyFail_H.thy b/proof/refine/AARCH64/EmptyFail_H.thy index 9eebd65456..5b3b6380bf 100644 --- a/proof/refine/AARCH64/EmptyFail_H.thy +++ b/proof/refine/AARCH64/EmptyFail_H.thy @@ -183,7 +183,7 @@ lemma ignoreFailure_empty_fail[intro!, wp, simp]: by (simp add: ignoreFailure_def empty_fail_catch) crunch (empty_fail) empty_fail[intro!, wp, simp]: cancelIPC, setThreadState, tcbSchedDequeue, setupReplyMaster, isStopped, possibleSwitchTo, tcbSchedAppend -(simp: Let_def setNotification_def setBoundNotification_def) +(simp: Let_def setNotification_def setBoundNotification_def wp: empty_fail_getObject) crunch (empty_fail) "_H_empty_fail"[intro!, wp, simp]: "ThreadDecls_H.suspend" (ignore_del: ThreadDecls_H.suspend) diff --git a/proof/refine/AARCH64/Finalise_R.thy b/proof/refine/AARCH64/Finalise_R.thy index 7c6b922749..ccd451937a 100644 --- a/proof/refine/AARCH64/Finalise_R.thy +++ b/proof/refine/AARCH64/Finalise_R.thy @@ -79,20 +79,10 @@ crunch ksRQL1[wp]: emptySlot "\s. P (ksReadyQueuesL1Bitmap s)" crunch ksRQL2[wp]: emptySlot "\s. P (ksReadyQueuesL2Bitmap s)" crunch obj_at'[wp]: postCapDeletion "obj_at' P p" -lemmas postCapDeletion_valid_queues[wp] = - valid_queues_lift [OF postCapDeletion_obj_at' - postCapDeletion_pred_tcb_at' - postCapDeletion_ksRQ] - crunch inQ[wp]: clearUntypedFreeIndex "\s. P (obj_at' (inQ d p) t s)" crunch tcbDomain[wp]: clearUntypedFreeIndex "obj_at' (\tcb. P (tcbDomain tcb)) t" crunch tcbPriority[wp]: clearUntypedFreeIndex "obj_at' (\tcb. P (tcbPriority tcb)) t" -lemma emptySlot_queues [wp]: - "\Invariants_H.valid_queues\ emptySlot sl opt \\rv. Invariants_H.valid_queues\" - unfolding emptySlot_def - by (wp | wpcw | wp valid_queues_lift | simp)+ - crunch nosch[wp]: emptySlot "\s. P (ksSchedulerAction s)" crunch ksCurDomain[wp]: emptySlot "\s. P (ksCurDomain s)" @@ -1169,8 +1159,7 @@ definition "removeable' sl \ \s cap. (\p. p \ sl \ cte_wp_at' (\cte. capMasterCap (cteCap cte) = capMasterCap cap) p s) \ ((\p \ cte_refs' cap (irq_node' s). p \ sl \ cte_wp_at' (\cte. cteCap cte = NullCap) p s) - \ (\p \ zobj_refs' cap. ko_wp_at' (Not \ live') p s) - \ (\t \ threadCapRefs cap. \p. t \ set (ksReadyQueues s p)))" + \ (\p \ zobj_refs' cap. ko_wp_at' (Not \ live') p s))" lemma not_Final_removeable: "\ isFinal cap sl (cteCaps_of s) @@ -1388,11 +1377,6 @@ crunch irq_states' [wp]: emptySlot valid_irq_states' crunch no_0_obj' [wp]: emptySlot no_0_obj' (wp: crunch_wps) -crunch valid_queues'[wp]: setInterruptState "valid_queues'" - (simp: valid_queues'_def) - -crunch valid_queues'[wp]: emptySlot "valid_queues'" - end lemma deletedIRQHandler_irqs_masked'[wp]: @@ -1484,6 +1468,13 @@ crunches deletedIRQHandler, updateMDB, updateCap, clearUntypedFreeIndex crunches global.postCapDeletion for valid_arch'[wp]: valid_arch_state' +crunches emptySlot + 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 \ (info \ NullCap \ post_cap_delete_pre' info sl (cteCaps_of s) )\ @@ -2279,6 +2270,14 @@ 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) +crunches 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]: "\invs'\ unbindNotification tcb \\rv. invs'\" apply (simp add: unbindNotification_def invs'_def valid_state'_def) @@ -2287,8 +2286,8 @@ lemma unbindNotification_invs[wp]: apply clarsimp apply (rule hoare_seq_ext[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 + 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 (clarsimp elim!: obj_atE' @@ -2328,7 +2327,7 @@ lemma unbindMaybeNotification_invs[wp]: apply (simp add: unbindMaybeNotification_def invs'_def valid_state'_def) apply (rule hoare_seq_ext[OF _ get_ntfn_sp']) apply (rule hoare_pre) - apply (wp sbn'_valid_pspace'_inv sbn_sch_act' sbn_valid_queues valid_irq_node_lift + 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)+ @@ -2551,14 +2550,6 @@ lemma archThreadSet_valid_arch_state'[wp]: apply (clarsimp simp: pred_conj_def) done -lemma archThreadSet_valid_queues'[wp]: - "archThreadSet f t \valid_queues'\" - unfolding valid_queues'_def - apply (rule hoare_lift_Pf[where f=ksReadyQueues]; wp?) - apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift) - apply auto - done - lemma archThreadSet_ct_not_inQ[wp]: "archThreadSet f t \ct_not_inQ\" unfolding ct_not_inQ_def @@ -2588,6 +2579,51 @@ lemma archThreadSet_tcb_at'[wp]: unfolding archThreadSet_def by (wpsimp wp: getObject_tcb_wp simp: obj_at'_def) +lemma setObject_tcb_tcbs_of'[wp]: + "\\s. P ((tcbs_of' s) (t \ tcb))\ + setObject t tcb + \\_ s. P (tcbs_of' s)\" + unfolding setObject_def + apply (wpsimp simp: updateObject_default_def) + apply (erule rsubst[where P=P]) + apply (rule ext) + apply (clarsimp simp: opt_map_def split: option.splits) + done + +lemma archThreadSet_tcbSchedPrevs_of[wp]: + "archThreadSet f t \\s. P (tcbSchedPrevs_of s)\" + unfolding archThreadSet_def + apply (wp getObject_tcb_wp) + apply normalise_obj_at' + apply (erule rsubst[where P=P]) + apply (rule ext) + apply (clarsimp simp: opt_map_def obj_at'_def split: option.splits) + done + +lemma archThreadSet_tcbSchedNexts_of[wp]: + "archThreadSet f t \\s. P (tcbSchedNexts_of s)\" + unfolding archThreadSet_def + apply (wp getObject_tcb_wp) + apply normalise_obj_at' + apply (erule rsubst[where P=P]) + apply (rule ext) + apply (clarsimp simp: opt_map_def obj_at'_def split: option.splits) + done + +lemma archThreadSet_tcbQueued[wp]: + "archThreadSet f t \\s. P (tcbQueued |< tcbs_of' s)\" + unfolding archThreadSet_def + apply (wp getObject_tcb_wp) + apply normalise_obj_at' + apply (erule rsubst[where P=P]) + apply (rule ext) + apply (clarsimp simp: opt_pred_def opt_map_def obj_at'_def split: option.splits) + done + +lemma archThreadSet_valid_sched_pointers[wp]: + "archThreadSet f t \valid_sched_pointers\" + by (wp_pre, wps, wp, assumption) + lemma dissoc_invs': "\invs' and (\s. \p. (\a. armHSCurVCPU (ksArchState s) = Some (p, a)) \ p \ v) and ko_at' vcpu v and K (vcpuTCBPtr vcpu = Some t) and @@ -2605,8 +2641,8 @@ lemma dissoc_invs': valid_irq_node_lift_asm [where Q=\] valid_irq_handlers_lift' cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift - setObject_typ_at' cur_tcb_lift - setVCPU_valid_arch' archThreadSet_if_live' + setObject_typ_at' cur_tcb_lift valid_bitmaps_lift + setVCPU_valid_arch' archThreadSet_if_live' sym_heap_sched_pointers_lift simp: objBits_simps archObjSize_def vcpuBits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb valid_arch_tcb'_def | clarsimp simp: live'_def hyp_live'_def arch_live'_def)+ @@ -2651,7 +2687,7 @@ lemma when_assert_eq: lemma dissociateVCPUTCB_invs'[wp]: "dissociateVCPUTCB vcpu tcb \invs'\" unfolding dissociateVCPUTCB_def setVCPU_archThreadSet_None_eq when_assert_eq - apply ( wpsimp wp: dissoc_invs' getVCPU_wp | wpsimp wp: getObject_tcb_wp simp: archThreadGet_def)+ + apply (wpsimp wp: dissoc_invs' getVCPU_wp | wpsimp wp: getObject_tcb_wp simp: archThreadGet_def)+ apply (drule tcb_ko_at') apply clarsimp apply (rule exI, rule conjI, assumption) @@ -2699,9 +2735,7 @@ lemma asUser_unlive[wp]: apply (case_tac ko; simp) apply (rename_tac tcb) apply (rule_tac x=tcb in exI) - apply (clarsimp simp: obj_at'_def) - apply (rule_tac x=tcb in exI, rule conjI; clarsimp simp: o_def) - apply (clarsimp simp: ko_wp_at'_def live'_def hyp_live'_def) + apply (clarsimp simp: obj_at'_def ko_wp_at'_def live'_def hyp_live'_def) done lemma dissociateVCPUTCB_unlive: @@ -2793,7 +2827,6 @@ lemma cteDeleteOne_isFinal: lemmas setEndpoint_cteCaps_of[wp] = cteCaps_of_ctes_of_lift [OF set_ep_ctes_of] lemmas setNotification_cteCaps_of[wp] = cteCaps_of_ctes_of_lift [OF set_ntfn_ctes_of] -lemmas setQueue_cteCaps_of[wp] = cteCaps_of_ctes_of_lift [OF setQueue_ctes_of] lemmas threadSet_cteCaps_of = cteCaps_of_ctes_of_lift [OF threadSet_ctes_of] crunches archThreadSet, vcpuUpdate, dissociateVCPUTCB @@ -2882,16 +2915,6 @@ lemma unbindNotification_valid_objs'_helper': by (clarsimp simp: valid_bound_tcb'_def valid_ntfn'_def split: option.splits ntfn.splits) -lemma typ_at'_valid_tcb'_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_tcb' tcb s\ f \\rv s. valid_tcb' tcb s\" - including no_pre - apply (simp add: valid_tcb'_def) - apply (case_tac "tcbState tcb", simp_all add: valid_tcb_state'_def split_def valid_bound_ntfn'_def) - apply (wp hoare_vcg_const_Ball_lift typ_at_lifts[OF P] - | case_tac "tcbBoundNotification tcb", simp_all)+ - done - lemmas setNotification_valid_tcb' = typ_at'_valid_tcb'_lift [OF setNotification_typ_at'] lemma unbindNotification_valid_objs'[wp]: @@ -3040,10 +3063,6 @@ lemma unbindNotification_bound_tcb_at': apply (wp setBoundNotification_bound_tcb gbn_wp' | wpc | simp)+ done -crunches unbindNotification, unbindMaybeNotification - for valid_queues[wp]: "Invariants_H.valid_queues" - (wp: sbn_valid_queues) - crunches unbindNotification, unbindMaybeNotification for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" @@ -3126,6 +3145,52 @@ crunch invs[wp]: prepareThreadDelete "invs'" (ignore: doMachineOp) end +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 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 + split: option.splits) + +crunches updateRestartPC, cancelIPC + for valid_sched_pointers[wp]: valid_sched_pointers + (simp: crunch_simps wp: crunch_wps) + +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') + +context begin interpretation Arch . (*FIXME: arch_split*) + +lemma archThreadSet_tcbSchedPrevNext[wp]: + "archThreadSet f t' \obj_at' (\tcb. P (tcbSchedNext tcb) (tcbSchedPrev tcb)) t\" + unfolding archThreadSet_def + apply (wpsimp wp: setObject_tcb_strongest getObject_tcb_wp) + apply normalise_obj_at' + apply auto + done + +crunches prepareThreadDelete + for tcbSchedPrevNext[wp]: "obj_at' (\tcb. P (tcbSchedNext tcb) (tcbSchedPrev tcb)) t" + (wp: threadGet_wp getVCPU_wp archThreadGet_wp crunch_wps simp: crunch_simps) + +end + 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))) @@ -3146,21 +3211,22 @@ lemma (in delete_one_conc_pre) finaliseCap_replaceable: \ obj_at' (Not \ tcbQueued) p s \ bound_tcb_at' ((=) None) p s \ ko_wp_at' (Not \ hyp_live') p s - \ (\pr. p \ set (ksReadyQueues s pr))))\" + \ 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 (wp prepares_delete_helper'' [OF cancelAllIPC_unlive] prepares_delete_helper'' [OF cancelAllSignals_unlive] - suspend_isFinal prepareThreadDelete_unqueued prepareThreadDelete_nonq + suspend_isFinal prepareThreadDelete_unqueued prepareThreadDelete_inactive prepareThreadDelete_isFinal - suspend_makes_inactive suspend_nonq + 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]], @@ -3227,7 +3293,9 @@ lemma cancelIPC_cte_wp_at': apply (clarsimp simp: cteCaps_of_def cte_wp_at_ctes_of x) done -crunch cte_wp_at'[wp]: tcbSchedDequeue "cte_wp_at' P p" +crunches tcbSchedDequeue + for cte_wp_at'[wp]: "cte_wp_at' P p" + (wp: crunch_wps) lemma suspend_cte_wp_at': assumes x: "\cap final. P cap \ finaliseCap cap final True = fail" @@ -3355,25 +3423,6 @@ crunch sch_act_not[wp]: cteDeleteOne "sch_act_not t" (simp: crunch_simps case_Null_If unless_def wp: crunch_wps getObject_inv loadObject_default_inv) -lemma cancelAllIPC_mapM_x_valid_queues: - "\Invariants_H.valid_queues and valid_objs' and (\s. \t\set q. tcb_at' t s)\ - mapM_x (\t. do - y \ setThreadState Structures_H.thread_state.Restart t; - tcbSchedEnqueue t - od) q - \\rv. Invariants_H.valid_queues\" - apply (rule_tac R="\_ s. (\t\set q. tcb_at' t s) \ valid_objs' s" - in hoare_post_add) - apply (rule hoare_pre) - apply (rule mapM_x_wp') - apply (rule hoare_name_pre_state) - apply (wp hoare_vcg_const_Ball_lift - tcbSchedEnqueue_valid_queues tcbSchedEnqueue_not_st - sts_valid_queues sts_st_tcb_at'_cases setThreadState_not_st - | simp - | ((elim conjE)?, drule (1) bspec, clarsimp elim!: obj_at'_weakenE simp: valid_tcb_state'_def))+ - done - lemma cancelAllIPC_mapM_x_weak_sch_act: "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ mapM_x (\t. do @@ -3387,13 +3436,15 @@ lemma cancelAllIPC_mapM_x_weak_sch_act: done lemma cancelAllIPC_mapM_x_valid_objs': - "\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 (wpsimp wp: mapM_x_wp' sts_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 @@ -3404,17 +3455,12 @@ lemma cancelAllIPC_mapM_x_tcbDomain_obj_at': tcbSchedEnqueue t od) q \\_. obj_at' (\tcb. P (tcbDomain tcb)) t'\" - by (wp mapM_x_wp' tcbSchedEnqueue_not_st setThreadState_oa_queued | simp)+ + by (wp mapM_x_wp' | simp)+ 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) - apply (wp tcbSchedEnqueue_not_st - | wpc - | simp)+ - done + "rescheduleRequired \obj_at' (\tcb. Q (tcbDomain tcb) (tcbPriority tcb)) t\" + unfolding rescheduleRequired_def tcbSchedEnqueue_def tcbQueuePrepend_def + by wpsimp lemma cancelAllIPC_tcbDomain_obj_at': "\obj_at' (\tcb. P (tcbDomain tcb)) t'\ @@ -3428,21 +3474,6 @@ lemma cancelAllIPC_tcbDomain_obj_at': | simp)+ done -lemma cancelAllIPC_valid_queues[wp]: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - cancelAllIPC ep_ptr - \\rv. Invariants_H.valid_queues\" - apply (simp add: cancelAllIPC_def ep'_Idle_case_helper) - apply (wp hoare_vcg_conj_lift hoare_vcg_const_Ball_lift - cancelAllIPC_mapM_x_valid_queues cancelAllIPC_mapM_x_valid_objs' cancelAllIPC_mapM_x_weak_sch_act - set_ep_valid_objs' getEndpoint_wp) - apply (clarsimp simp: valid_ep'_def) - apply (drule (1) ko_at_valid_objs') - apply (auto simp: valid_obj'_def valid_ep'_def valid_tcb'_def - split: endpoint.splits - elim: valid_objs_valid_tcbE) - done - lemma cancelAllSignals_tcbDomain_obj_at': "\obj_at' (\tcb. P (tcbDomain tcb)) t'\ cancelAllSignals epptr @@ -3459,41 +3490,8 @@ lemma unbindMaybeNotification_tcbDomain_obj_at': "\obj_at' (\tcb. P (tcbDomain tcb)) t'\ unbindMaybeNotification r \\_. obj_at' (\tcb. P (tcbDomain tcb)) t'\" - apply (simp add: unbindMaybeNotification_def) - apply (wp setBoundNotification_oa_queued getNotification_wp gbn_wp' | wpc | simp)+ - done - -lemma cancelAllSignals_valid_queues[wp]: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - cancelAllSignals ntfn - \\rv. Invariants_H.valid_queues\" - apply (simp add: cancelAllSignals_def) - apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) - apply (case_tac "ntfnObj ntfna", simp_all) - apply (wp, simp)+ - apply (wp hoare_vcg_conj_lift hoare_vcg_const_Ball_lift - cancelAllIPC_mapM_x_valid_queues cancelAllIPC_mapM_x_valid_objs' cancelAllIPC_mapM_x_weak_sch_act - set_ntfn_valid_objs' - | simp)+ - apply (clarsimp simp: valid_ep'_def) - apply (drule (1) ko_at_valid_objs') - apply (auto simp: valid_obj'_def valid_ntfn'_def valid_tcb'_def - split: endpoint.splits - elim: valid_objs_valid_tcbE) - done - -lemma finaliseCapTrue_standin_valid_queues[wp]: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - finaliseCapTrue_standin cap final - \\_. Invariants_H.valid_queues\" - apply (simp add: finaliseCapTrue_standin_def Let_def) - apply (safe) - apply (wp | clarsimp | wpc)+ - done - - -crunch valid_queues[wp]: isFinalCapability "Invariants_H.valid_queues" - (simp: crunch_simps) + unfolding unbindMaybeNotification_def + by (wpsimp wp: getNotification_wp gbn_wp' simp: setBoundNotification_def)+ crunch sch_act[wp]: isFinalCapability "\s. sch_act_wf (ksSchedulerAction s) s" (simp: crunch_simps) @@ -3502,93 +3500,6 @@ crunch weak_sch_act[wp]: isFinalCapability "\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. \obj_at' (inQ d p) tcb\ f \\_. obj_at' (inQ d p) tcb\" - and prq: "\P. \\s. P (ksReadyQueues s)\ f \\_ s. P (ksReadyQueues s)\" - shows "\valid_inQ_queues\ f \\_. valid_inQ_queues\" - proof - - show ?thesis - apply (clarsimp simp: valid_def valid_inQ_queues_def) - apply safe - apply (rule use_valid [OF _ tat], assumption) - apply (drule spec, drule spec, erule conjE, erule bspec) - apply (rule ccontr) - apply (erule notE[rotated], erule(1) use_valid [OF _ prq]) - apply (erule use_valid [OF _ prq]) - apply simp - done - qed - -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)+ - -lemma cancelAllIPC_mapM_x_valid_inQ_queues: - "\valid_inQ_queues\ - mapM_x (\t. do - y \ setThreadState Structures_H.thread_state.Restart t; - tcbSchedEnqueue t - od) q - \\rv. valid_inQ_queues\" - apply (rule mapM_x_wp_inv) - apply (wp sts_valid_queues [where st="Structures_H.thread_state.Restart", simplified] - setThreadState_st_tcb) - done - -lemma cancelAllIPC_valid_inQ_queues[wp]: - "\valid_inQ_queues\ - cancelAllIPC ep_ptr - \\rv. valid_inQ_queues\" - apply (simp add: cancelAllIPC_def ep'_Idle_case_helper) - apply (wp cancelAllIPC_mapM_x_valid_inQ_queues) - apply (wp hoare_conjI hoare_drop_imp | simp)+ - done - -lemma cancelAllSignals_valid_inQ_queues[wp]: - "\valid_inQ_queues\ - cancelAllSignals ntfn - \\rv. valid_inQ_queues\" - apply (simp add: cancelAllSignals_def) - apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) - apply (case_tac "ntfnObj ntfna", simp_all) - apply (wp, simp)+ - apply (wp cancelAllIPC_mapM_x_valid_inQ_queues)+ - apply (simp) - done - -crunches unbindNotification, unbindMaybeNotification - for valid_inQ_queues[wp]: "valid_inQ_queues" - -lemma finaliseCapTrue_standin_valid_inQ_queues[wp]: - "\valid_inQ_queues\ - finaliseCapTrue_standin cap final - \\_. valid_inQ_queues\" - apply (simp add: finaliseCapTrue_standin_def Let_def) - apply (safe) - apply (wp | clarsimp | wpc)+ - done - -crunch valid_inQ_queues[wp]: isFinalCapability valid_inQ_queues - (simp: crunch_simps) - -lemma cteDeleteOne_valid_inQ_queues[wp]: - "\valid_inQ_queues\ - cteDeleteOne sl - \\_. valid_inQ_queues\" - apply (simp add: cteDeleteOne_def unless_def) - apply (wpsimp wp: hoare_drop_imp hoare_vcg_all_lift) - done - crunch ksCurDomain[wp]: cteDeleteOne "\s. P (ksCurDomain s)" (wp: crunch_wps simp: crunch_simps unless_def) @@ -4114,178 +4025,6 @@ lemma isFinal_lift: lemmas final_matters'_simps = final_matters'_def [split_simps capability.split arch_capability.split] -definition set_thread_all :: "obj_ref \ Structures_A.tcb \ etcb - \ unit det_ext_monad" where - "set_thread_all ptr tcb etcb \ - do s \ get; - kh \ return $ (kheap s)(ptr \ (TCB tcb)); - ekh \ return $ (ekheap s)(ptr \ etcb); - put (s\kheap := kh, ekheap := ekh\) - od" - -definition thread_gets_the_all :: "obj_ref \ (Structures_A.tcb \ etcb) det_ext_monad" where - "thread_gets_the_all tptr \ - do tcb \ gets_the $ get_tcb tptr; - etcb \ gets_the $ get_etcb tptr; - return $ (tcb, etcb) od" - -definition thread_set_all :: "(Structures_A.tcb \ Structures_A.tcb) \ (etcb \ etcb) - \ obj_ref \ unit det_ext_monad" where - "thread_set_all f g tptr \ - do (tcb, etcb) \ thread_gets_the_all tptr; - set_thread_all tptr (f tcb) (g etcb) - od" - -lemma set_thread_all_corres: - fixes ob' :: "'a :: pspace_storable" - assumes x: "updateObject ob' = updateObject_default ob'" - assumes z: "\s. obj_at' P ptr s - \ map_to_ctes ((ksPSpace s) (ptr \ injectKO ob')) = map_to_ctes (ksPSpace s)" - assumes b: "\ko. P ko \ objBits ko = objBits ob'" - assumes P: "\(v::'a::pspace_storable). (1 :: machine_word) < 2 ^ (objBits v)" - assumes e: "etcb_relation etcb tcb'" - assumes is_t: "injectKO (ob' :: 'a :: pspace_storable) = KOTCB tcb'" - shows "other_obj_relation (TCB tcb) (injectKO (ob' :: 'a :: pspace_storable)) \ - corres dc (obj_at (same_caps (TCB tcb)) ptr and is_etcb_at ptr) - (obj_at' (P :: 'a \ bool) ptr) - (set_thread_all ptr tcb etcb) (setObject ptr ob')" - apply (rule corres_no_failI) - apply (rule no_fail_pre) - apply wp - apply (rule x) - apply (clarsimp simp: b elim!: obj_at'_weakenE) - apply (unfold set_thread_all_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 - updateObject_default_def in_magnitude_check [OF _ P]) - apply (clarsimp simp add: state_relation_def z) - apply (simp flip: trans_state_update) - apply (clarsimp simp add: swp_def fun_upd_def obj_at_def is_etcb_at_def) - apply (subst cte_wp_at_after_update,fastforce simp add: obj_at_def) - apply (subst caps_of_state_after_update,fastforce simp add: obj_at_def) - apply clarsimp - 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 - split: Structures_A.kernel_object.splits if_split_asm) - - apply (fold fun_upd_def) - apply (simp only: pspace_relation_def dom_fun_upd2 simp_thms) - apply (subst pspace_dom_update) - apply assumption - apply simp - 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: is_other_obj_relation_type) - apply (drule(1) bspec) - apply clarsimp - apply (frule_tac ko'="TCB tcb'" and x'=ptr in obj_relation_cut_same_type, - (fastforce simp add: is_other_obj_relation_type)+)[1] - 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 is_t) - by (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) - -lemma tcb_update_all_corres': - assumes tcbs: "tcb_relation tcb tcb' \ tcb_relation tcbu tcbu'" - assumes tables: "\(getF, v) \ ran tcb_cap_cases. getF tcbu = getF tcb" - assumes tables': "\(getF, v) \ ran tcb_cte_cases. getF tcbu' = getF tcb'" - assumes r: "r () ()" - assumes e: "etcb_relation etcb tcb' \ etcb_relation etcbu tcbu'" - shows "corres r (ko_at (TCB tcb) add and (\s. ekheap s add = Some etcb)) - (ko_at' tcb' add) - (set_thread_all add tcbu etcbu) (setObject add tcbu')" - apply (rule_tac F="tcb_relation tcb tcb' \ 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 (force simp: other_obj_relation_def ekheap_relation_def e) - apply (erule conjE) - apply (rule corres_guard_imp) - apply (rule corres_rel_imp) - apply (rule set_thread_all_corres[where P="(=) tcb'"]) - apply (rule ext)+ - apply simp - defer - apply (simp add: is_other_obj_relation_type_def - objBits_simps' other_obj_relation_def tcbs r)+ - apply (fastforce simp: is_etcb_at_def elim!: obj_at_weakenE dest: bspec[OF tables]) - apply (subst(asm) eq_commute, assumption) - apply (clarsimp simp: 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 thread_gets_the_all_corres: - shows "corres (\(tcb, etcb) tcb'. tcb_relation tcb tcb' \ etcb_relation etcb tcb') - (tcb_at t and is_etcb_at t) (tcb_at' t) - (thread_gets_the_all t) (getObject t)" - apply (rule corres_no_failI) - apply wp - apply (clarsimp simp: gets_def get_def return_def bind_def get_tcb_def thread_gets_the_all_def - threadGet_def ethread_get_def gets_the_def assert_opt_def get_etcb_def - is_etcb_at_def tcb_at_def liftM_def - split: option.splits Structures_A.kernel_object.splits) - 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 ko) - apply (simp_all add: fail_def return_def) - apply (clarsimp simp add: state_relation_def pspace_relation_def ekheap_relation_def) - apply (drule bspec) - apply clarsimp - apply blast - apply (drule bspec, erule domI) - apply (clarsimp simp add: other_obj_relation_def - lookupAround2_known1) - done - -lemma thread_set_all_corresT: - assumes x: "\tcb tcb'. tcb_relation tcb tcb' \ - tcb_relation (f tcb) (f' tcb')" - 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" - assumes e: "\etcb tcb'. etcb_relation etcb tcb' \ - etcb_relation (g etcb) (f' tcb')" - shows "corres dc (tcb_at t and valid_etcbs) - (tcb_at' t) - (thread_set_all f g t) (threadSet f' t)" - apply (simp add: thread_set_all_def threadSet_def bind_assoc) - apply (rule corres_guard_imp) - apply (rule corres_split[OF thread_gets_the_all_corres]) - apply (simp add: split_def) - apply (rule tcb_update_all_corres') - apply (erule x) - apply (rule y) - apply (clarsimp simp: bspec_split [OF spec [OF z]]) - apply fastforce - apply (erule e) - apply (simp add: thread_gets_the_all_def, wp+) - apply clarsimp - apply (frule(1) tcb_at_is_etcb_at) - apply (clarsimp simp add: tcb_at_def get_etcb_def obj_at_def) - apply (drule get_tcb_SomeD) - apply fastforce - apply simp - done - -lemmas thread_set_all_corres = - thread_set_all_corresT [OF _ _ all_tcbI, OF _ ball_tcb_cap_casesI ball_tcb_cte_casesI] - crunch idle_thread[wp]: deleteCallerCap "\s. P (ksIdleThread s)" (wp: crunch_wps) crunch sch_act_simple: deleteCallerCap sch_act_simple @@ -4301,89 +4040,6 @@ lemma setEndpoint_sch_act_not_ct[wp]: setEndpoint ptr val \\_ s. sch_act_not (ksCurThread s) s\" by (rule hoare_weaken_pre, wps setEndpoint_ct', wp, simp) -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 - -lemma cancelAllIPC_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - cancelAllIPC epptr - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - (is "\?PRE\ _ \\_. ?POST\") - apply (simp add: cancelAllIPC_def) - apply (wp, wpc, wp) - apply (wps rescheduleRequired_ct') - apply (wp rescheduleRequired_ksQ') - apply (clarsimp) - apply (wp cancelAll_ct_not_ksQ_helper mapM_x_wp_inv) - apply (wp hoare_lift_Pf2 [OF setEndpoint_ksQ setEndpoint_ct'])+ - apply (wps rescheduleRequired_ct') - apply (wp rescheduleRequired_ksQ') - apply (clarsimp) - apply (wp cancelAll_ct_not_ksQ_helper mapM_x_wp_inv) - apply (wp hoare_lift_Pf2 [OF setEndpoint_ksQ setEndpoint_ct'])+ - prefer 2 - apply assumption - apply (rule_tac Q="\ep. ?PRE and ko_at' ep epptr" in hoare_post_imp) - apply (clarsimp) - apply (rule conjI) - apply ((clarsimp simp: invs'_def valid_state'_def - sch_act_sane_def - | drule(1) ct_not_in_epQueue)+)[2] - apply (wp get_ep_sp') - done - -lemma cancelAllSignals_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - cancelAllSignals ntfnptr - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - (is "\?PRE\ _ \\_. ?POST\") - apply (simp add: cancelAllSignals_def) - apply (wp, wpc, wp+) - apply (wps rescheduleRequired_ct') - apply (wp rescheduleRequired_ksQ') - apply clarsimp - apply (wp cancelAll_ct_not_ksQ_helper mapM_x_wp_inv) - apply (wp hoare_lift_Pf2 [OF setNotification_ksQ setNotification_ksCurThread]) - apply (wps setNotification_ksCurThread, wp) - prefer 2 - apply assumption - apply (rule_tac Q="\ep. ?PRE and ko_at' ep ntfnptr" in hoare_post_imp) - apply ((clarsimp simp: invs'_def valid_state'_def sch_act_sane_def - | drule(1) ct_not_in_ntfnQueue)+)[1] - apply (wp get_ntfn_sp') - done - -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 hoare_seq_ext[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 setNotification_ksCurThread, wp) - apply clarsimp - done - lemma sbn_ct_in_state'[wp]: "\ct_in_state' P\ setBoundNotification ntfn t \\_. ct_in_state' P\" apply (simp add: ct_in_state'_def) @@ -4416,37 +4072,6 @@ lemma unbindMaybeNotification_sch_act_sane[wp]: apply (wp setNotification_sch_act_sane sbn_sch_act_sane | wpc | clarsimp)+ done -lemma finaliseCapTrue_standin_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - finaliseCapTrue_standin cap final - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - apply (simp add: finaliseCapTrue_standin_def Let_def) - apply (safe) - apply (wp cancelAllIPC_ct_not_ksQ cancelAllSignals_ct_not_ksQ - hoare_drop_imps unbindMaybeNotification_ct_not_ksQ - | wpc - | clarsimp simp: isNotificationCap_def isReplyCap_def split:capability.splits)+ - done - -lemma cteDeleteOne_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - cteDeleteOne slot - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - apply (simp add: cteDeleteOne_def unless_def split_def) - apply (rule hoare_seq_ext [OF _ getCTE_sp]) - apply (case_tac "\final. finaliseCap (cteCap cte) final True = fail") - apply (simp add: finaliseCapTrue_standin_simple_def) - apply wp - apply (clarsimp) - apply (wp emptySlot_cteCaps_of hoare_lift_Pf2 [OF emptySlot_ksRQ emptySlot_ct]) - apply (simp add: cteCaps_of_def) - apply (wp (once) hoare_drop_imps) - apply (wp finaliseCapTrue_standin_ct_not_ksQ isFinalCapability_inv)+ - apply (clarsimp) - done - end end diff --git a/proof/refine/AARCH64/Init_R.thy b/proof/refine/AARCH64/Init_R.thy index 9b15030e68..ce9e5cbc2b 100644 --- a/proof/refine/AARCH64/Init_R.thy +++ b/proof/refine/AARCH64/Init_R.thy @@ -98,7 +98,7 @@ definition zeroed_intermediate_state :: ksDomSchedule = [], ksCurDomain = 0, ksDomainTime = 0, - ksReadyQueues = K [], + ksReadyQueues = K (TcbQueue None None), ksReadyQueuesL1Bitmap = K 0, ksReadyQueuesL2Bitmap = K 0, ksCurThread = 0, @@ -119,9 +119,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: ekheap_relation_def) - apply (clarsimp simp: ready_queues_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/AARCH64/InterruptAcc_R.thy b/proof/refine/AARCH64/InterruptAcc_R.thy index 3f046d309e..d5d604d382 100644 --- a/proof/refine/AARCH64/InterruptAcc_R.thy +++ b/proof/refine/AARCH64/InterruptAcc_R.thy @@ -50,14 +50,14 @@ lemma setIRQState_invs[wp]: apply (simp add: setIRQState_def setInterruptState_def getInterruptState_def) apply (wp dmo_maskInterrupt) apply (clarsimp simp: invs'_def valid_state'_def cur_tcb'_def - Invariants_H.valid_queues_def valid_queues'_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 split: option.splits) + bitmapQ_defs valid_bitmaps_def + split: option.splits) apply (rule conjI, clarsimp) apply (clarsimp simp: irqs_masked'_def ct_not_inQ_def) apply (rule conjI, fastforce) @@ -150,8 +150,7 @@ lemma invs'_irq_state_independent [simp, intro!]: 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_queues_no_bitmap_def - valid_queues'_def + irqs_masked'_def bitmapQ_defs valid_bitmaps_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 diff --git a/proof/refine/AARCH64/Interrupt_R.thy b/proof/refine/AARCH64/Interrupt_R.thy index c93c7b9f24..fb63b89d88 100644 --- a/proof/refine/AARCH64/Interrupt_R.thy +++ b/proof/refine/AARCH64/Interrupt_R.thy @@ -599,13 +599,6 @@ lemma decDomainTime_corres: apply (clarsimp simp:state_relation_def) done -lemma tcbSchedAppend_valid_objs': - "\valid_objs'\tcbSchedAppend t \\r. valid_objs'\" - apply (simp add:tcbSchedAppend_def) - apply (wpsimp wp: unless_wp threadSet_valid_objs' threadGet_wp) - apply (clarsimp simp add:obj_at'_def typ_at'_def) - done - lemma thread_state_case_if: "(case state of Structures_A.thread_state.Running \ f | _ \ g) = (if state = Structures_A.thread_state.Running then f else g)" @@ -616,26 +609,19 @@ lemma threadState_case_if: (if state = Structures_H.thread_state.Running then f else g)" by (case_tac state,auto) -lemma tcbSchedAppend_invs_but_ct_not_inQ': - "\invs' and st_tcb_at' runnable' t \ - tcbSchedAppend t \\_. all_invs_but_ct_not_inQ'\" - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp 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 - | fastforce elim!: st_tcb_ex_cap'' split: thread_state.split_asm)+ - done +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 timerTick_corres: - "corres dc (cur_tcb and valid_sched and pspace_aligned and pspace_distinct) - invs' - timer_tick timerTick" + "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="\ and (cur_tcb and valid_sched and pspace_aligned and pspace_distinct)" - and Q'="\ and invs'" in corres_guard_imp) + 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 @@ -655,41 +641,51 @@ lemma timerTick_corres: 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]) + apply (rule corres_split[OF tcbSchedAppend_corres], simp) apply (rule rescheduleRequired_corres) - apply (wp)[1] - apply (rule hoare_strengthen_post) - apply (rule tcbSchedAppend_invs_but_ct_not_inQ', clarsimp simp: sch_act_wf_weak) - apply (wp threadSet_timeslice_invs threadSet_valid_queues - threadSet_valid_queues' threadSet_pred_tcb_at_state)+ - apply simp - apply (rule corres_when,simp) + 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 (simp add:dec_domain_time_def) - apply wp+ - apply (simp add:decDomainTime_def) - apply wp - apply (wpsimp wp: hoare_weak_lift_imp threadSet_timeslice_invs threadSet_valid_queues - threadSet_valid_queues' tcbSchedAppend_valid_objs' + 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 tcbSchedAppend_valid_queues)+ - apply (strengthen sch_act_wf_weak) - apply (clarsimp simp:conj_comms) - apply (wp tcbSchedAppend_valid_queues tcbSchedAppend_sch_act_wf) - apply simp - apply (wpsimp wp: threadSet_valid_queues threadSet_pred_tcb_at_state threadSet_sch_act - threadSet_tcbDomain_triv threadSet_valid_queues' threadSet_valid_objs' - threadGet_wp gts_wp gts_wp')+ - apply (clarsimp simp: cur_tcb_def tcb_at_is_etcb_at valid_sched_def valid_sched_action_def) - apply (clarsimp simp: invs'_def valid_state'_def sch_act_wf_weak cur_tcb'_def inQ_def - ct_in_state'_def obj_at'_def) - apply (clarsimp simp:st_tcb_at'_def valid_idle'_def ct_idle_or_in_cur_domain'_def obj_at'_def) - apply simp - apply simp + 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 lemma corres_return_VGICMaintenance [corres]: @@ -749,7 +745,7 @@ lemma not_pred_tcb': lemma vgic_maintenance_corres [corres]: "corres dc einvs - (\s. invs' s \ sch_act_not (ksCurThread s) s \ (\p. ksCurThread s \ set (ksReadyQueues s p))) + (\s. invs' s \ sch_act_not (ksCurThread s) s) vgic_maintenance vgicMaintenance" proof - (* hoare_lift_Pf-style rules match too often, slowing down proof unless specialised *) @@ -760,7 +756,6 @@ proof - note wplr' = vilr'[where P="sch_act_not"] vilr'[where P="ex_nonz_cap_to'"] vilr'[where P="st_tcb_at' simple'"] - vilr'[where P="\t s. t \ set (ksReadyQueues s x)" for x] show ?thesis unfolding vgic_maintenance_def vgicMaintenance_def isRunnable_def Let_def apply (rule corres_guard_imp) @@ -819,8 +814,7 @@ proof - apply clarsimp apply (rule_tac Q="\rv x. tcb_at' rv x \ invs' x - \ sch_act_not rv x - \ (\d p. rv \ set (ksReadyQueues x (d, p)))" + \ sch_act_not rv x" in hoare_post_imp) apply (rename_tac rv s) apply clarsimp @@ -850,7 +844,7 @@ qed lemma vppiEvent_corres: "corres dc einvs - (\s. invs' s \ sch_act_not (ksCurThread s) s \ (\p. ksCurThread s \ set (ksReadyQueues s p))) + (\s. invs' s \ sch_act_not (ksCurThread s) s) (vppi_event irq) (vppiEvent irq)" unfolding vppi_event_def vppiEvent_def isRunnable_def supply [[simproc del: defined_all]] @@ -893,8 +887,7 @@ lemma vppiEvent_corres: apply (clarsimp cong: imp_cong conj_cong simp: pred_conj_def) apply (rule_tac Q="\rv x. tcb_at' rv x \ invs' x - \ sch_act_not rv x - \ (\d p. rv \ set (ksReadyQueues x (d, p)))" in hoare_post_imp) + \ sch_act_not rv x" in hoare_post_imp) apply (rename_tac rv s) apply (strengthen st_tcb_ex_cap''[where P=active']) apply (strengthen invs_iflive') @@ -922,8 +915,7 @@ lemma vppiEvent_corres: lemma handle_reserved_irq_corres[corres]: "corres dc einvs - (\s. invs' s \ (irq \ non_kernel_IRQs \ - sch_act_not (ksCurThread s) s \ (\p. ksCurThread s \ set (ksReadyQueues s p)))) + (\s. invs' s \ (irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s)) (handle_reserved_irq irq) (handleReservedIRQ irq)" apply (clarsimp simp: handle_reserved_irq_def handleReservedIRQ_def irqVPPIEventIndex_def irq_vppi_event_index_def non_kernel_IRQs_def IRQ_def irqVGICMaintenance_def @@ -981,16 +973,10 @@ lemma handleInterrupt_corres: apply (rule corres_machine_op) apply (rule corres_eq_trivial; simp) apply wp+ - apply (clarsimp simp: invs_distinct invs_psp_aligned) + apply (clarsimp simp: invs_distinct invs_psp_aligned schact_is_rct_def) apply clarsimp done -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 ksDomainTime[wp]: rescheduleRequired "\s. P (ksDomainTime s)" (simp:tcbSchedEnqueue_def wp:unless_wp) @@ -1004,14 +990,6 @@ lemma updateTimeSlice_valid_pspace[wp]: apply (auto simp:tcb_cte_cases_def cteSizeBits_def) done -lemma updateTimeSlice_valid_queues[wp]: - "\\s. Invariants_H.valid_queues s \ - threadSet (tcbTimeSlice_update (\_. ts')) thread - \\r s. Invariants_H.valid_queues s\" - apply (wp threadSet_valid_queues,simp) - apply (clarsimp simp:obj_at'_def inQ_def) - done - lemma dom_upd_eq: "f t = Some y \ dom (\a. if a = t then Some x else f a) = dom f" by (auto split: if_split_asm) @@ -1036,29 +1014,29 @@ crunches tcbSchedAppend (simp: unless_def tcb_cte_cases_def cteSizeBits_def wp: crunch_wps cur_tcb_lift) lemma timerTick_invs'[wp]: - "\invs'\ timerTick \\rv. invs'\" + "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 - tcbSchedAppend_invs_but_ct_not_inQ' - simp: tcb_cte_cases_def) - apply (rule_tac Q="\rv. invs'" in hoare_post_imp) - apply (clarsimp simp add:invs'_def valid_state'_def) + 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' - del: tcbSchedAppend_sch_act_wf)+ - apply (rule hoare_strengthen_post[OF tcbSchedAppend_invs_but_ct_not_inQ']) - apply (wpsimp simp: valid_pspace'_def sch_act_wf_weak)+ - apply (wpsimp wp: threadSet_pred_tcb_no_state threadSet_tcbDomain_triv - threadSet_valid_objs' threadSet_timeslice_invs)+ - apply (wp threadGet_wp) + 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 (clarsimp simp: invs'_def st_tcb_at'_def obj_at'_def valid_state'_def) + apply (auto simp: invs'_def st_tcb_at'_def obj_at'_def valid_state'_def cong: conj_cong) done lemma resetTimer_invs'[wp]: @@ -1088,7 +1066,7 @@ lemma runnable'_eq: by (cases st; simp) lemma vgicMaintenance_invs'[wp]: - "\invs' and (\s. sch_act_not (ksCurThread s) s \ (\p. ksCurThread s \ set (ksReadyQueues s p)))\ + "\invs' and (\s. sch_act_not (ksCurThread s) s)\ vgicMaintenance \\_. invs'\" supply if_split[split del] @@ -1101,8 +1079,7 @@ lemma vgicMaintenance_invs'[wp]: apply (clarsimp cong: imp_cong conj_cong simp: pred_conj_def) apply (rule_tac Q="\_ s. tcb_at' (ksCurThread s) s \ invs' s - \ sch_act_not (ksCurThread s) s - \ (\d p. (ksCurThread s) \ set (ksReadyQueues s (d, p)))" + \ sch_act_not (ksCurThread s) s" in hoare_post_imp) apply (clarsimp cong: imp_cong conj_cong simp: not_pred_tcb') apply (clarsimp simp: st_tcb_at'_def obj_at'_def runnable'_eq) @@ -1126,7 +1103,7 @@ lemma vgicMaintenance_invs'[wp]: done lemma vppiEvent_invs'[wp]: - "\invs' and (\s. sch_act_not (ksCurThread s) s \ (\p. ksCurThread s \ set (ksReadyQueues s p)))\ + "\invs' and (\s. sch_act_not (ksCurThread s) s)\ vppiEvent irq \\y. invs'\" supply if_split[split del] apply (clarsimp simp: vppiEvent_def doMachineOp_bind) @@ -1136,8 +1113,7 @@ lemma vppiEvent_invs'[wp]: apply (clarsimp cong: imp_cong conj_cong simp: pred_conj_def) apply (rule_tac Q="\_ s. tcb_at' (ksCurThread s) s \ invs' s - \ sch_act_not (ksCurThread s) s - \ (\d p. (ksCurThread s) \ set (ksReadyQueues s (d, p)))" + \ sch_act_not (ksCurThread s) s" in hoare_post_imp) apply (clarsimp cong: imp_cong conj_cong simp: not_pred_tcb') apply (clarsimp simp: st_tcb_at'_def obj_at'_def runnable'_eq) @@ -1152,8 +1128,7 @@ lemma vppiEvent_invs'[wp]: done lemma hint_invs[wp]: - "\invs' and (\s. irq \ non_kernel_IRQs \ - sch_act_not (ksCurThread s) s \ (\p. ksCurThread s \ set (ksReadyQueues s p)))\ + "\invs' and (\s. irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s)\ handleInterrupt irq \\rv. invs'\" apply (simp add: handleInterrupt_def getSlotCap_def cong: irqstate.case_cong) apply (rule conjI; rule impI) diff --git a/proof/refine/AARCH64/InvariantUpdates_H.thy b/proof/refine/AARCH64/InvariantUpdates_H.thy index 95253db5ad..899ed9627d 100644 --- a/proof/refine/AARCH64/InvariantUpdates_H.thy +++ b/proof/refine/AARCH64/InvariantUpdates_H.thy @@ -38,8 +38,9 @@ lemma invs'_machine: proof - show ?thesis apply (cases "ksSchedulerAction s") - 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_queues_def valid_queues_no_bitmap_def bitmapQ_defs + 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 @@ -56,12 +57,13 @@ lemma invs_no_cicd'_machine: 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_queues_def valid_queues_no_bitmap_def bitmapQ_defs - vms ct_not_inQ_def - state_refs_of'_def ps_clear_def - valid_irq_node'_def mask - cong: option.case_cong) + 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) done qed @@ -103,14 +105,9 @@ 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_queues_ksSchedulerAction_update[simp]: - "valid_queues (ksSchedulerAction_update f s) = valid_queues s" - unfolding valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs - by simp - -lemma valid_queues'_ksSchedulerAction_update[simp]: - "valid_queues' (ksSchedulerAction_update f s) = valid_queues' s" - by (simp add: valid_queues'_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'" @@ -145,45 +142,25 @@ lemma tcb_in_cur_domain_ct[simp]: "tcb_in_cur_domain' t (ksCurThread_update f s) = tcb_in_cur_domain' t s" by (fastforce simp: tcb_in_cur_domain'_def) -lemma valid_queues'_ksCurDomain[simp]: - "valid_queues' (ksCurDomain_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) - -lemma valid_queues'_ksDomScheduleIdx[simp]: - "valid_queues' (ksDomScheduleIdx_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) +lemma valid_bitmaps_ksCurDomain[simp]: + "valid_bitmaps (ksCurDomain_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) -lemma valid_queues'_ksDomSchedule[simp]: - "valid_queues' (ksDomSchedule_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) +lemma valid_bitmaps_ksDomScheduleIdx[simp]: + "valid_bitmaps (ksDomScheduleIdx_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) -lemma valid_queues'_ksDomainTime[simp]: - "valid_queues' (ksDomainTime_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) +lemma valid_bitmaps_ksDomSchedule[simp]: + "valid_bitmaps (ksDomSchedule_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) -lemma valid_queues'_ksWorkUnitsCompleted[simp]: - "valid_queues' (ksWorkUnitsCompleted_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) +lemma valid_bitmaps_ksDomainTime[simp]: + "valid_bitmaps (ksDomainTime_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) -lemma valid_queues_ksCurDomain[simp]: - "valid_queues (ksCurDomain_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_ksDomScheduleIdx[simp]: - "valid_queues (ksDomScheduleIdx_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_ksDomSchedule[simp]: - "valid_queues (ksDomSchedule_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_ksDomainTime[simp]: - "valid_queues (ksDomainTime_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_ksWorkUnitsCompleted[simp]: - "valid_queues (ksWorkUnitsCompleted_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) +lemma valid_bitmaps_ksWorkUnitsCompleted[simp]: + "valid_bitmaps (ksWorkUnitsCompleted_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) lemma valid_irq_node'_ksCurDomain[simp]: "valid_irq_node' w (ksCurDomain_update f s) = valid_irq_node' w s" @@ -260,6 +237,10 @@ lemma valid_mdb_interrupts'[simp]: "valid_mdb' (ksInterruptState_update f s) = valid_mdb' s" by (simp add: valid_mdb'_def) +lemma valid_mdb'_ksReadyQueues_update[simp]: + "valid_mdb' (ksReadyQueues_update f s) = valid_mdb' s" + by (simp add: valid_mdb'_def) + lemma vms_ksReadyQueues_update[simp]: "valid_machine_state' (ksReadyQueues_update f s) = valid_machine_state' s" by (simp add: valid_machine_state'_def) @@ -284,10 +265,10 @@ lemma ct_in_state_ksSched[simp]: lemma invs'_wu [simp]: "invs' (ksWorkUnitsCompleted_update f s) = invs' s" - apply (simp add: invs'_def cur_tcb'_def valid_state'_def Invariants_H.valid_queues_def - valid_queues'_def valid_irq_node'_def valid_machine_state'_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 valid_queues_no_bitmap_def) + bitmapQ_defs) done lemma valid_arch_state'_interrupt[simp]: @@ -339,9 +320,8 @@ lemma sch_act_simple_ksReadyQueuesL2Bitmap[simp]: lemma ksDomainTime_invs[simp]: "invs' (ksDomainTime_update f s) = invs' s" - 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) + 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" @@ -369,10 +349,8 @@ lemma ct_not_inQ_update_stt[simp]: lemma invs'_update_cnt[elim!]: "invs' s \ invs' (s\ksSchedulerAction := ChooseNewThread\)" - by (clarsimp simp: invs'_def valid_state'_def valid_queues_def valid_queues'_def - valid_irq_node'_def cur_tcb'_def ct_idle_or_in_cur_domain'_def - tcb_in_cur_domain'_def valid_queues_no_bitmap_def - bitmapQ_no_L2_orphans_def bitmapQ_no_L1_orphans_def) + by (clarsimp simp: invs'_def valid_state'_def valid_queues_def valid_irq_node'_def cur_tcb'_def + ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def bitmapQ_defs) context begin interpretation Arch . diff --git a/proof/refine/AARCH64/Invariants_H.thy b/proof/refine/AARCH64/Invariants_H.thy index d925849ad3..f03c85e5f1 100644 --- a/proof/refine/AARCH64/Invariants_H.thy +++ b/proof/refine/AARCH64/Invariants_H.thy @@ -9,6 +9,7 @@ theory Invariants_H imports LevityCatch "AInvs.ArchDetSchedSchedule_AI" + "Lib.Heap_List" begin (* global data and code of the kernel, not covered by any cap *) @@ -141,6 +142,21 @@ definition cte_wp_at' :: "(cte \ bool) \ obj_ref \ kernel_state \ bool" where "cte_at' \ cte_wp_at' \" +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 tcbSchedPrevs_of :: "kernel_state \ obj_ref \ obj_ref option" where + "tcbSchedPrevs_of s \ tcbs_of' s |> tcbSchedPrev" + +abbreviation tcbSchedNexts_of :: "kernel_state \ obj_ref \ obj_ref option" where + "tcbSchedNexts_of s \ tcbs_of' s |> tcbSchedNext" + +abbreviation sym_heap_sched_pointers :: "global.kernel_state \ bool" where + "sym_heap_sched_pointers s \ sym_heap (tcbSchedNexts_of s) (tcbSchedPrevs_of s)" + definition tcb_cte_cases :: "machine_word \ ((tcb \ cte) \ ((cte \ cte) \ tcb \ tcb))" where "tcb_cte_cases \ [ 0 << cteSizeBits \ (tcbCTable, tcbCTable_update), 1 << cteSizeBits \ (tcbVTable, tcbVTable_update), @@ -193,8 +209,10 @@ definition state_refs_of' :: "kernel_state \ obj_ref \ ( (* the non-hyp, non-arch part of live' *) primrec live0' :: "Structures_H.kernel_object \ bool" where "live0' (KOTCB tcb) = - (bound (tcbBoundNotification 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))" | "live0' (KOCTE cte) = False" | "live0' (KOEndpoint ep) = (ep \ IdleEP)" | "live0' (KONotification ntfn) = (bound (ntfnBoundTCB ntfn) \ (\ts. ntfnObj ntfn = WaitingNtfn ts))" @@ -252,14 +270,14 @@ definition hyp_live' :: "kernel_object \ bool" where definition live' :: "kernel_object \ bool" where "live' ko \ case ko of - (KOTCB tcb) => live0' ko \ hyp_live' ko - | (KOCTE cte) => False - | (KOEndpoint ep) => live0' ko - | (KONotification ntfn) => live0' ko - | (KOUserData) => False - | (KOUserDataDevice) => False - | (KOKernelData) => False - | (KOArch ako) => hyp_live' ko" + KOTCB tcb => live0' ko \ hyp_live' ko + | KOCTE cte => False + | KOEndpoint ep => live0' ko + | KONotification ntfn => live0' ko + | KOUserData => False + | KOUserDataDevice => False + | KOKernelData => False + | KOArch ako => hyp_live' ko" context begin interpretation Arch . (*FIXME: arch_split*) @@ -483,6 +501,11 @@ definition is_device_frame_cap' :: "capability \ bool" where definition valid_arch_tcb' :: "Structures_H.arch_tcb \ kernel_state \ bool" where "valid_arch_tcb' \ \t s. \v. atcbVCPUPtr t = Some v \ vcpu_at' v s " +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 "valid_tcb' t s \ (\(getF, setF) \ ran tcb_cte_cases. s \' cteCap (getF t)) \ valid_tcb_state' (tcbState t) s @@ -491,6 +514,8 @@ definition valid_tcb' :: "tcb \ kernel_state \ bool" whe \ tcbDomain t \ maxDomain \ tcbPriority t \ maxPriority \ tcbMCP t \ maxPriority + \ opt_tcb_at' (tcbSchedPrev t) s + \ opt_tcb_at' (tcbSchedNext t) s \ valid_arch_tcb' (tcbArch t) s" definition valid_ep' :: "Structures_H.endpoint \ kernel_state \ bool" where @@ -499,7 +524,6 @@ definition valid_ep' :: "Structures_H.endpoint \ kernel_state \ (ts \ [] \ (\t \ set ts. tcb_at' t s) \ distinct ts) | RecvEP ts \ (ts \ [] \ (\t \ set ts. tcb_at' t s) \ distinct ts)" - definition valid_bound_tcb' :: "machine_word option \ kernel_state \ bool" where "valid_bound_tcb' tcb_opt s \ case tcb_opt of None \ True | Some t \ tcb_at' t s" @@ -838,10 +862,15 @@ where | "runnable' (Structures_H.BlockedOnSend a b c d e) = False" | "runnable' (Structures_H.BlockedOnNotification x) = False" -definition - inQ :: "domain \ priority \ tcb \ bool" -where - "inQ d p tcb \ tcbQueued tcb \ tcbPriority tcb = p \ tcbDomain tcb = d" +definition inQ :: "domain \ priority \ tcb \ bool" where + "inQ d p tcb \ tcbQueued tcb \ tcbPriority tcb = p \ tcbDomain tcb = d" + +lemma inQ_implies_tcbQueueds_of: + "(inQ domain priority |< tcbs_of' s') tcbPtr \ (tcbQueued |< tcbs_of' s') tcbPtr" + by (clarsimp simp: opt_map_def opt_pred_def inQ_def split: option.splits) + +defs ready_qs_runnable_def: + "ready_qs_runnable s \ \t. obj_at' tcbQueued t s \ st_tcb_at' runnable' t s" definition (* for given domain and priority, the scheduler bitmap indicates a thread is in the queue *) @@ -851,15 +880,6 @@ where "bitmapQ d p s \ ksReadyQueuesL1Bitmap s d !! prioToL1Index p \ ksReadyQueuesL2Bitmap s (d, invertL1Index (prioToL1Index p)) !! unat (p && mask wordRadix)" - -definition - valid_queues_no_bitmap :: "kernel_state \ bool" -where - "valid_queues_no_bitmap \ \s. - (\d p. (\t \ set (ksReadyQueues s (d, p)). obj_at' (inQ d p and runnable' \ tcbState) t s) - \ distinct (ksReadyQueues s (d, p)) - \ (d > maxDomain \ p > maxPriority \ ksReadyQueues s (d,p) = []))" - 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 @@ -883,31 +903,62 @@ where \d i. ksReadyQueuesL1Bitmap s d !! i \ ksReadyQueuesL2Bitmap s (d, invertL1Index i) \ 0 \ i < l2BitmapSize" -definition - valid_bitmapQ :: "kernel_state \ bool" -where - "valid_bitmapQ \ \s. (\d p. bitmapQ d p s \ ksReadyQueues s (d,p) \ [])" +definition valid_bitmapQ :: "kernel_state \ bool" where + "valid_bitmapQ \ \s. \d p. bitmapQ d p s \ \ tcbQueueEmpty (ksReadyQueues s (d,p))" -definition - valid_queues :: "kernel_state \ bool" -where - "valid_queues \ \s. valid_queues_no_bitmap s \ valid_bitmapQ s \ - bitmapQ_no_L2_orphans s \ bitmapQ_no_L1_orphans s" +definition valid_bitmaps :: "kernel_state \ bool" where + "valid_bitmaps \ \s. valid_bitmapQ s \ bitmapQ_no_L2_orphans s \ bitmapQ_no_L1_orphans s" -definition - (* when a thread gets added to / removed from a queue, but before bitmap updated *) - valid_bitmapQ_except :: "domain \ priority \ kernel_state \ bool" -where +lemma valid_bitmaps_valid_bitmapQ[elim!]: + "valid_bitmaps s \ valid_bitmapQ s" + by (simp add: valid_bitmaps_def) + +lemma valid_bitmaps_bitmapQ_no_L2_orphans[elim!]: + "valid_bitmaps s \ bitmapQ_no_L2_orphans s" + by (simp add: valid_bitmaps_def) + +lemma valid_bitmaps_bitmapQ_no_L1_orphans[elim!]: + "valid_bitmaps s \ bitmapQ_no_L1_orphans s" + by (simp add: valid_bitmaps_def) + +lemma valid_bitmaps_lift: + assumes prq: "\P. f \\s. P (ksReadyQueues s)\" + assumes prqL1: "\P. f \\s. P (ksReadyQueuesL1Bitmap s)\" + assumes prqL2: "\P. f \\s. P (ksReadyQueuesL2Bitmap s)\" + shows "f \valid_bitmaps\" + unfolding valid_bitmaps_def valid_bitmapQ_def bitmapQ_def + bitmapQ_no_L1_orphans_def bitmapQ_no_L2_orphans_def + apply (rule hoare_pre) + apply (wps assms | wpsimp)+ + done + +(* when a thread gets added to / removed from a queue, but before bitmap updated *) +definition valid_bitmapQ_except :: "domain \ priority \ kernel_state \ bool" where "valid_bitmapQ_except d' p' \ \s. - (\d p. (d \ d' \ p \ p') \ (bitmapQ d p s \ ksReadyQueues s (d,p) \ []))" + \d p. (d \ d' \ p \ p') \ (bitmapQ d p s \ \ tcbQueueEmpty (ksReadyQueues s (d,p)))" lemmas bitmapQ_defs = valid_bitmapQ_def valid_bitmapQ_except_def bitmapQ_def bitmapQ_no_L2_orphans_def bitmapQ_no_L1_orphans_def -definition - valid_queues' :: "kernel_state \ bool" -where - "valid_queues' \ \s. \d p t. obj_at' (inQ d p) t s \ t \ set (ksReadyQueues s (d, p))" +\ \ + The tcbSchedPrev and tcbSchedNext fields of a TCB are used only to indicate membership in + one of the ready queues. \ +definition valid_sched_pointers_2 :: + "(obj_ref \ obj_ref) \ (obj_ref \ obj_ref) \ (obj_ref \ bool) \ bool " + where + "valid_sched_pointers_2 prevs nexts ready \ + \ptr. prevs ptr \ None \ nexts ptr \ None \ ready ptr" + +abbreviation valid_sched_pointers :: "kernel_state \ bool" where + "valid_sched_pointers s \ + valid_sched_pointers_2 (tcbSchedPrevs_of s) (tcbSchedNexts_of s) (tcbQueued |< tcbs_of' s)" + +lemmas valid_sched_pointers_def = valid_sched_pointers_2_def + +lemma valid_sched_pointersD: + "\valid_sched_pointers s; \ (tcbQueued |< tcbs_of' s) t\ + \ tcbSchedPrevs_of s t = None \ tcbSchedNexts_of s t = None" + by (fastforce simp: valid_sched_pointers_def in_opt_pred opt_map_red) definition tcb_in_cur_domain' :: "machine_word \ kernel_state \ bool" where "tcb_in_cur_domain' t \ \s. obj_at' (\tcb. ksCurDomain s = tcbDomain tcb) t s" @@ -1058,7 +1109,7 @@ abbreviation definition valid_state' :: "kernel_state \ bool" where "valid_state' \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s - \ valid_queues s \ sym_refs (state_refs_of' s) \ sym_refs (state_hyp_refs_of' s) + \ sym_refs (state_refs_of' s) \ sym_refs (state_hyp_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 @@ -1067,7 +1118,9 @@ definition valid_state' :: "kernel_state \ bool" where \ valid_irq_states' s \ valid_machine_state' s \ irqs_masked' s - \ valid_queues' s + \ sym_heap_sched_pointers s + \ valid_sched_pointers s + \ valid_bitmaps s \ ct_not_inQ s \ ct_idle_or_in_cur_domain' s \ pspace_domain_valid s @@ -1119,6 +1172,11 @@ definition abbreviation "active' st \ st = Structures_H.Running \ st = Structures_H.Restart" +lemma runnable_eq_active': "runnable' = active'" + apply (rule ext) + apply (case_tac st, simp_all) + done + abbreviation "simple' st \ st = Structures_H.Inactive \ st = Structures_H.Running \ @@ -1134,11 +1192,13 @@ abbreviation abbreviation(input) "all_invs_but_sym_refs_ct_not_inQ' \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s - \ valid_queues s \ if_live_then_nonz_cap' s \ if_unsafe_then_cap' 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 - \ cur_tcb' s \ valid_queues' s \ ct_idle_or_in_cur_domain' s + \ valid_irq_states' s \ irqs_masked' s + \ sym_heap_sched_pointers s \ valid_sched_pointers s \ valid_bitmaps s + \ valid_machine_state' s + \ cur_tcb' s \ ct_idle_or_in_cur_domain' s \ pspace_domain_valid s \ ksCurDomain s \ maxDomain \ valid_dom_schedule' s \ untyped_ranges_zero' s" @@ -1146,12 +1206,14 @@ abbreviation(input) abbreviation(input) "all_invs_but_ct_not_inQ' \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s - \ valid_queues s \ sym_refs (state_refs_of' s) \ sym_refs (state_hyp_refs_of' s) + \ sym_refs (state_refs_of' s) \ sym_refs (state_hyp_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 - \ cur_tcb' s \ valid_queues' s \ ct_idle_or_in_cur_domain' s + \ valid_irq_states' s \ irqs_masked' s + \ sym_heap_sched_pointers s \ valid_sched_pointers s \ valid_bitmaps s + \ valid_machine_state' s + \ cur_tcb' s \ ct_idle_or_in_cur_domain' s \ pspace_domain_valid s \ ksCurDomain s \ maxDomain \ valid_dom_schedule' s \ untyped_ranges_zero' s" @@ -1167,12 +1229,14 @@ lemma all_invs_but_not_ct_inQ_check': definition "all_invs_but_ct_idle_or_in_cur_domain' \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s - \ valid_queues s \ sym_refs (state_refs_of' s) \ sym_refs (state_hyp_refs_of' s) + \ sym_refs (state_refs_of' s) \ sym_refs (state_hyp_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 - \ cur_tcb' s \ valid_queues' s \ ct_not_inQ s + \ valid_irq_states' s \ irqs_masked' s + \ sym_heap_sched_pointers s \ valid_sched_pointers s \ valid_bitmaps s + \ valid_machine_state' s + \ cur_tcb' s \ ct_not_inQ s \ pspace_domain_valid s \ ksCurDomain s \ maxDomain \ valid_dom_schedule' s \ untyped_ranges_zero' s" @@ -2983,9 +3047,9 @@ lemma sch_act_wf_arch [simp]: "sch_act_wf sa (ksArchState_update f s) = sch_act_wf sa s" by (cases sa) (simp_all add: ct_in_state'_def tcb_in_cur_domain'_def) -lemma valid_queues_arch [simp]: - "valid_queues (ksArchState_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) +lemma valid_bitmaps_arch[simp]: + "valid_bitmaps (ksArchState_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) lemma if_unsafe_then_cap_arch' [simp]: "if_unsafe_then_cap' (ksArchState_update f s) = if_unsafe_then_cap' s" @@ -3003,22 +3067,14 @@ lemma sch_act_wf_machine_state [simp]: "sch_act_wf sa (ksMachineState_update f s) = sch_act_wf sa s" by (cases sa) (simp_all add: ct_in_state'_def tcb_in_cur_domain'_def) -lemma valid_queues_machine_state [simp]: - "valid_queues (ksMachineState_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_arch' [simp]: - "valid_queues' (ksArchState_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) - -lemma valid_queues_machine_state' [simp]: - "valid_queues' (ksMachineState_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) - lemma valid_irq_node'_machine_state [simp]: "valid_irq_node' x (ksMachineState_update f s) = valid_irq_node' x s" by (simp add: valid_irq_node'_def) +lemma valid_bitmaps_machine_state[simp]: + "valid_bitmaps (ksMachineState_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) + (* these should be reasonable safe for automation because of the 0 pattern *) lemma no_0_ko_wp' [elim!]: "\ ko_wp_at' Q 0 s; no_0_obj' s \ \ P" @@ -3101,19 +3157,6 @@ lemma typ_at_aligned': "\ typ_at' tp p s \ \ is_aligned p (objBitsT tp)" by (clarsimp simp add: typ_at'_def ko_wp_at'_def objBitsT_koTypeOf) -lemma valid_queues_obj_at'D: - "\ t \ set (ksReadyQueues s (d, p)); valid_queues s \ - \ obj_at' (inQ d p) t s" - apply (unfold valid_queues_def valid_queues_no_bitmap_def) - apply (elim conjE) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE) - apply (clarsimp) - done - lemma obj_at'_and: "obj_at' (P and P') t s = (obj_at' P t s \ obj_at' P' t s)" by (rule iffI, (clarsimp simp: obj_at'_def)+) @@ -3155,21 +3198,6 @@ lemma obj_at'_ko_at'_prop: "ko_at' ko t s \ obj_at' P t s = P ko" by (drule obj_at_ko_at', clarsimp simp: obj_at'_def) -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 \ st_tcb_at' runnable' t s) \ - distinct (ksReadyQueues s (d, p)) \ (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_queues_running: - assumes Q: "t \ set(ksReadyQueues s (d, p))" "valid_queues s" - shows "st_tcb_at' runnable' t s" - using assms by (clarsimp simp add: valid_queues_def valid_queues_no_bitmap_def') - 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) @@ -3254,8 +3282,16 @@ lemma invs_sch_act_wf' [elim!]: "invs' s \ sch_act_wf (ksSchedulerAction s) s" by (simp add: invs'_def valid_state'_def) -lemma invs_queues [elim!]: - "invs' s \ valid_queues s" +lemma invs_valid_bitmaps[elim!]: + "invs' s \ valid_bitmaps s" + by (simp add: invs'_def valid_state'_def) + +lemma invs_sym_heap_sched_pointers[elim!]: + "invs' s \ sym_heap_sched_pointers s" + by (simp add: invs'_def valid_state'_def) + +lemma invs_valid_sched_pointers[elim!]: + "invs' s \ valid_sched_pointers s" by (simp add: invs'_def valid_state'_def) lemma invs_valid_idle'[elim!]: @@ -3278,18 +3314,12 @@ 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_valid_queues'_strg: - "invs' s \ valid_queues' s" - by (clarsimp simp: invs'_def valid_state'_def) - -lemmas invs_valid_queues'[elim!] = invs_valid_queues'_strg[rule_format] - lemma einvs_valid_etcbs: "einvs s \ valid_etcbs s" by (clarsimp simp: valid_sched_def) lemma invs'_bitmapQ_no_L1_orphans: "invs' s \ bitmapQ_no_L1_orphans s" - by (drule invs_queues, simp add: valid_queues_def) + by (simp add: invs'_def valid_state'_def valid_bitmaps_def) lemma invs_ksCurDomain_maxDomain' [elim!]: "invs' s \ ksCurDomain s \ maxDomain" @@ -3314,32 +3344,22 @@ lemma invs_no_0_obj'[elim!]: lemma invs'_gsCNodes_update[simp]: "invs' (gsCNodes_update f s') = invs' s'" - apply (clarsimp simp: invs'_def valid_state'_def valid_queues_def valid_queues_no_bitmap_def - bitmapQ_defs - valid_queues'_def 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'") - apply (simp_all add: ct_in_state'_def tcb_in_cur_domain'_def ct_idle_or_in_cur_domain'_def ct_not_inQ_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_state'_def valid_queues_def valid_queues_no_bitmap_def - bitmapQ_defs - valid_queues'_def 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'") - apply (simp_all add: ct_in_state'_def ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def ct_not_inQ_def) - done - -lemma invs_queues_tcb_in_cur_domain': - "\ ksReadyQueues s (d, p) = x # xs; invs' s; d = ksCurDomain s\ - \ tcb_in_cur_domain' x s" - apply (subgoal_tac "x \ set (ksReadyQueues s (d, p))") - apply (drule (1) valid_queues_obj_at'D[OF _ invs_queues]) - apply (auto simp: inQ_def tcb_in_cur_domain'_def elim: obj_at'_weakenE) + 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: @@ -3355,7 +3375,7 @@ lemma invs'_ksDomScheduleIdx: unfolding invs'_def valid_state'_def by clarsimp lemma valid_bitmap_valid_bitmapQ_exceptE: - "\ valid_bitmapQ_except d p s ; (bitmapQ d p s \ ksReadyQueues s (d,p) \ []) ; + "\ valid_bitmapQ_except d p s; bitmapQ d p s \ \ tcbQueueEmpty (ksReadyQueues s (d,p)); bitmapQ_no_L2_orphans s \ \ valid_bitmapQ s" unfolding valid_bitmapQ_def valid_bitmapQ_except_def diff --git a/proof/refine/AARCH64/IpcCancel_R.thy b/proof/refine/AARCH64/IpcCancel_R.thy index b9330594ed..d5d792d5fc 100644 --- a/proof/refine/AARCH64/IpcCancel_R.thy +++ b/proof/refine/AARCH64/IpcCancel_R.thy @@ -39,25 +39,6 @@ lemma cancelSignal_pred_tcb_at': crunch pred_tcb_at'[wp]: emptySlot "pred_tcb_at' proj P t" (wp: setCTE_pred_tcb_at') -(* valid_queues is too strong *) -definition valid_inQ_queues :: "KernelStateData_H.kernel_state \ bool" where - "valid_inQ_queues \ - \s. \d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) \ distinct (ksReadyQueues s (d, p))" - -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_inQ_queues_ksReadyQueuesL1Bitmap_upd[simp]: - "valid_inQ_queues (ksReadyQueuesL1Bitmap_update f s) = valid_inQ_queues s" - unfolding valid_inQ_queues_def - by simp - -lemma valid_inQ_queues_ksReadyQueuesL2Bitmap_upd[simp]: - "valid_inQ_queues (ksReadyQueuesL2Bitmap_update f s) = valid_inQ_queues s" - unfolding valid_inQ_queues_def - by simp - defs capHasProperty_def: "capHasProperty ptr P \ cte_wp_at' (\c. P (cteCap c)) ptr" @@ -76,11 +57,6 @@ locale delete_one_conc_pre = "\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_queues: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - cteDeleteOne sl \\rv. Invariants_H.valid_queues\" - assumes delete_one_inQ_queues: - "\valid_inQ_queues\ cteDeleteOne sl \\rv. valid_inQ_queues\" assumes delete_one_sch_act_simple: "\sch_act_simple\ cteDeleteOne sl \\rv. sch_act_simple\" assumes delete_one_sch_act_not: @@ -538,7 +514,7 @@ lemma (in delete_one) cancelIPC_ReplyCap_corres: and Q'="\_. invs' and st_tcb_at' awaiting_reply' t" in corres_underlying_split) apply (rule corres_guard_imp) - apply (rule threadset_corresT) + 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 cteSizeBits_def) @@ -662,16 +638,15 @@ lemma sch_act_simple_not_t[simp]: "sch_act_simple s \ sch_act_no context begin interpretation Arch . (*FIXME: arch_split*) +crunches setNotification + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_bitmaps[wp]: valid_bitmaps + (wp: valid_bitmaps_lift) + lemma cancelSignal_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. \ Invariants_H.valid_queues s; st_tcb_at' (Not \ runnable') t s \ - \ \x. t \ set (ksReadyQueues s x)" - 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\" @@ -682,9 +657,9 @@ lemma cancelSignal_invs': show ?thesis 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 setNotification_ksQ] sts_valid_queues + hoare_vcg_all_lift setThreadState_ct_not_inQ NTFNSN - hoare_vcg_all_lift setNotification_ksQ + hoare_vcg_all_lift | simp add: valid_tcb_state'_def list_case_If split del: if_split)+ prefer 2 apply assumption @@ -692,8 +667,6 @@ lemma cancelSignal_invs': apply (rule get_ntfn_sp') apply (rename_tac rv s) apply (clarsimp simp: pred_tcb_at') - apply (frule NIQ) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) apply (rule conjI) apply (clarsimp simp: valid_ntfn'_def) apply (case_tac "ntfnObj rv", simp_all add: isWaitingNtfn_def) @@ -733,6 +706,7 @@ lemma cancelSignal_invs': 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") @@ -790,23 +764,25 @@ lemma setEndpoint_ct_not_inQ[wp]: done lemma setEndpoint_ksDomScheduleIdx[wp]: - "\\s. P (ksDomScheduleIdx s)\ setEndpoint ptr ep \\_ s. P (ksDomScheduleIdx s)\" + "setEndpoint ptr ep \\s. P (ksDomScheduleIdx s)\" apply (simp add: setEndpoint_def setObject_def split_def) apply (wp updateObject_default_inv | simp)+ done + end +crunches 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 NIQ: "\s. \ Invariants_H.valid_queues s; st_tcb_at' (Not \ runnable') t s \ - \ \x. t \ set (ksReadyQueues s x)" - 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 EPSCHN: "\eeptr ep'. \\s. sch_act_not (ksCurThread s) s\ setEndpoint eeptr ep' \\_ s. sch_act_not (ksCurThread s) s\" @@ -830,21 +806,20 @@ proof - apply (subst P) apply (wp valid_irq_node_lift valid_global_refs_lift' irqs_masked_lift sts_sch_act' - hoare_vcg_all_lift [OF setEndpoint_ksQ] - sts_valid_queues setThreadState_ct_not_inQ EPSCHN - hoare_vcg_all_lift setNotification_ksQ getEndpoint_wp + setThreadState_ct_not_inQ EPSCHN + hoare_vcg_all_lift getEndpoint_wp | simp add: valid_tcb_state'_def split del: if_split | wpc)+ 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: valid_obj'_def) apply (rule conjI) apply (clarsimp simp: obj_at'_def valid_ep'_def dest!: pred_tcb_at') - apply (frule NIQ) - apply (erule pred_tcb'_weakenE, fastforce) apply (clarsimp, rule conjI) apply (auto simp: pred_tcb_at'_def obj_at'_def)[1] apply (rule conjI) @@ -1049,18 +1024,20 @@ lemma setBoundNotification_tcb_in_cur_domain'[wp]: apply (wp setBoundNotification_not_ntfn | simp)+ done -lemma cancelSignal_tcb_obj_at': - "(\tcb st qd. P (tcb\tcbState := st, tcbQueued := qd\) \ P tcb) - \ \obj_at' P t'\ cancelSignal t word \\_. obj_at' P t'\" - apply (simp add: cancelSignal_def setNotification_def) - apply (wp setThreadState_not_st getNotification_wp | wpc | simp)+ - done +lemma setThreadState_tcbDomain_obj_at'[wp]: + "setThreadState ts t \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding setThreadState_def + by wpsimp + +crunches 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 (simp add: cancelIPC_def Let_def) apply (wp hoare_vcg_conj_lift - setThreadState_not_st delete_one_tcbDomain_obj_at' cancelSignal_tcb_obj_at' + delete_one_tcbDomain_obj_at' | wpc | rule hoare_drop_imps | simp add: getThreadReplySlot_def o_def if_fun_split)+ @@ -1167,198 +1144,17 @@ lemma setNotification_weak_sch_act_wf[wp]: lemmas ipccancel_weak_sch_act_wfs = weak_sch_act_wf_lift[OF _ setCTE_pred_tcb_at'] -lemma tcbSchedDequeue_corres': - "corres dc (is_etcb_at t and tcb_at t and pspace_aligned and pspace_distinct) - (valid_inQ_queues) - (tcb_sched_action (tcb_sched_dequeue) t) (tcbSchedDequeue t)" - apply (rule corres_cross_over_guard[where P'=P' and Q="tcb_at' t and P'" for P']) - apply (fastforce simp: tcb_at_cross dest: state_relation_pspace_relation) - apply (simp only: tcbSchedDequeue_def tcb_sched_action_def) - apply (rule corres_symb_exec_r[OF _ _ threadGet_inv, where Q'="\rv. tcb_at' t and valid_inQ_queues and obj_at' (\obj. tcbQueued obj = rv) t"]) - defer - apply (wp threadGet_obj_at', simp, simp) - apply (wp, simp) - apply (case_tac queued) - defer - apply (simp add: unless_def when_def) - apply (rule corres_no_failI) - apply (wp) - apply (clarsimp simp: in_monad ethread_get_def get_etcb_def set_tcb_queue_def is_etcb_at_def state_relation_def gets_the_def gets_def get_def return_def bind_def assert_opt_def get_tcb_queue_def modify_def put_def) - apply (subgoal_tac "t \ set (ready_queues a (tcb_domain y) (tcb_priority y))") - prefer 2 - apply (force simp: tcb_sched_dequeue_def valid_inQ_queues_def - ready_queues_relation_def obj_at'_def inQ_def project_inject) - apply (simp add: ready_queues_relation_def) - apply (simp add: unless_def when_def) - apply (rule corres_guard_imp) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres, simp add: etcb_relation_def) - apply (simp split del: if_split) - apply (rule corres_split_eqr) - apply (rule ethreadget_corres, simp add: etcb_relation_def) - apply (rule corres_split_eqr[OF getQueue_corres]) - apply (simp split del: if_split) - apply (subst bind_return_unit, rule corres_split[where r'=dc]) - apply (simp add: tcb_sched_dequeue_def) - apply (rule setQueue_corres) - apply (rule corres_split_noop_rhs) - apply (clarsimp, rule removeFromBitmap_corres_noop) - apply (simp add: dc_def[symmetric]) - apply (rule threadSet_corres_noop, simp_all add: tcb_relation_def exst_same_def)[1] - apply (wp | simp)+ - done - -lemma setQueue_valid_inQ_queues: - "\valid_inQ_queues - and (\s. \t \ set ts. obj_at' (inQ d p) t s) - and K (distinct ts)\ - setQueue d p ts - \\_. valid_inQ_queues\" - apply (simp add: setQueue_def valid_inQ_queues_def) - apply wp - apply clarsimp - done - -lemma threadSet_valid_inQ_queues: - "\valid_inQ_queues and (\s. \d p. (\tcb. (inQ d p tcb) \ \(inQ d p (f tcb))) - \ obj_at' (\tcb. (inQ d p tcb) \ \(inQ d p (f tcb))) t s - \ t \ set (ksReadyQueues s (d, p)))\ - threadSet f t - \\rv. valid_inQ_queues\" - apply (simp add: threadSet_def) - apply wp - apply (simp add: valid_inQ_queues_def pred_tcb_at'_def) - apply (wp setObject_queues_unchanged_tcb - hoare_Ball_helper - hoare_vcg_all_lift - setObject_tcb_strongest)[1] - apply (wp getObject_tcb_wp) - apply (clarsimp simp: valid_inQ_queues_def pred_tcb_at'_def) - apply (clarsimp simp: obj_at'_def) - apply (fastforce) - done - -(* reorder the threadSet before the setQueue, useful for lemmas that don't refer to bitmap *) -lemma setQueue_after_addToBitmap: - "(setQueue d p q >>= (\rv. (when P (addToBitmap d p)) >>= (\rv. threadSet f t))) = - (when P (addToBitmap d p) >>= (\rv. (threadSet f t) >>= (\rv. setQueue d p q)))" - 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 (simp add: threadSet_def getObject_def setObject_def - loadObject_default_def bitmap_fun_defs - split_def projectKO_def2 alignCheck_assert - magnitudeCheck_assert updateObject_default_def) - apply (intro oblivious_bind, simp_all) - apply (clarsimp simp: bind_assoc) - done - -lemma tcbSchedEnqueue_valid_inQ_queues[wp]: - "\valid_inQ_queues\ tcbSchedEnqueue t \\_. valid_inQ_queues\" - apply (simp add: tcbSchedEnqueue_def setQueue_after_addToBitmap) - apply (rule hoare_pre) - apply (rule_tac B="\rv. valid_inQ_queues and obj_at' (\obj. tcbQueued obj = rv) t" - in hoare_seq_ext) - apply (rename_tac queued) - apply (case_tac queued, simp_all add: unless_def)[1] - apply (wp setQueue_valid_inQ_queues threadSet_valid_inQ_queues threadGet_wp - hoare_vcg_const_Ball_lift - | simp add: inQ_def bitmap_fun_defs - | fastforce simp: valid_inQ_queues_def inQ_def obj_at'_def)+ - done - - (* prevents wp from splitting on the when; stronger technique than hoare_when_weak_wp - FIXME: possible to replace with hoare_when_weak_wp? - *) -definition - "removeFromBitmap_conceal d p q t \ when (null [x\q . x \ t]) (removeFromBitmap d p)" - -lemma removeFromBitmap_conceal_valid_inQ_queues[wp]: - "\ valid_inQ_queues \ removeFromBitmap_conceal d p q t \ \_. valid_inQ_queues \" - unfolding valid_inQ_queues_def removeFromBitmap_conceal_def - by (wp|clarsimp simp: bitmap_fun_defs)+ - -lemma rescheduleRequired_valid_inQ_queues[wp]: - "\valid_inQ_queues\ rescheduleRequired \\_. valid_inQ_queues\" - apply (simp add: rescheduleRequired_def) - apply wpsimp - done - -lemma sts_valid_inQ_queues[wp]: - "\valid_inQ_queues\ setThreadState st t \\rv. valid_inQ_queues\" - apply (simp add: setThreadState_def) - apply (wp threadSet_valid_inQ_queues [THEN hoare_strengthen_post]) - apply (clarsimp simp: sch_act_simple_def Invariants_H.valid_queues_def inQ_def)+ - done - lemma updateObject_ep_inv: "\P\ updateObject (obj::endpoint) ko p q n \\rv. P\" by simp (rule updateObject_default_inv) -lemma sbn_valid_inQ_queues[wp]: - "\valid_inQ_queues\ setBoundNotification ntfn t \\rv. valid_inQ_queues\" - apply (simp add: setBoundNotification_def) - apply (wp threadSet_valid_inQ_queues [THEN hoare_strengthen_post]) - apply (clarsimp simp: sch_act_simple_def Invariants_H.valid_queues_def inQ_def)+ - done - -lemma setEndpoint_valid_inQ_queues[wp]: - "\valid_inQ_queues\ setEndpoint ptr ep \\rv. valid_inQ_queues\" - apply (unfold setEndpoint_def) - apply (rule setObject_ep_pre) - apply (simp add: valid_inQ_queues_def) - apply (wp hoare_Ball_helper hoare_vcg_all_lift setObject_queues_unchanged[OF updateObject_ep_inv]) - apply simp - done - -lemma set_ntfn_valid_inQ_queues[wp]: - "\valid_inQ_queues\ setNotification ptr ntfn \\rv. valid_inQ_queues\" - apply (unfold setNotification_def) - apply (rule setObject_ntfn_pre) - apply (simp add: valid_inQ_queues_def) - apply (wp hoare_Ball_helper hoare_vcg_all_lift) - apply (clarsimp simp: updateObject_default_def in_monad) - apply (wp updateObject_default_inv | simp)+ - done - -crunch valid_inQ_queues[wp]: cancelSignal valid_inQ_queues - (simp: updateObject_tcb_inv crunch_simps wp: crunch_wps) - -lemma (in delete_one_conc_pre) cancelIPC_valid_inQ_queues[wp]: - "\valid_inQ_queues\ cancelIPC t \\_. valid_inQ_queues\" - apply (simp add: cancelIPC_def Let_def getThreadReplySlot_def) - apply (wp hoare_drop_imps delete_one_inQ_queues threadSet_valid_inQ_queues | wpc | simp add:if_apply_def2 Fun.comp_def)+ - apply (clarsimp simp: valid_inQ_queues_def inQ_def)+ - done - -lemma valid_queues_inQ_queues: - "Invariants_H.valid_queues s \ valid_inQ_queues s" - by (force simp: Invariants_H.valid_queues_def valid_inQ_queues_def obj_at'_def - valid_queues_no_bitmap_def) - lemma asUser_tcbQueued_inv[wp]: "\obj_at' (\tcb. P (tcbQueued tcb)) t'\ asUser t m \\_. obj_at' (\tcb. P (tcbQueued tcb)) t'\" 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_valid_inQ_queues[wp]: - "\valid_inQ_queues\ asUser t f \\rv. valid_inQ_queues\" - unfolding valid_inQ_queues_def Ball_def - apply (wpsimp wp: hoare_vcg_all_lift) - defer - apply (wp asUser_ksQ) - apply assumption - apply (simp add: inQ_def[abs_def] obj_at'_conj) - apply (rule hoare_convert_imp) - apply (wp asUser_ksQ) - apply wp - done - -context begin -interpretation Arch . +context begin interpretation Arch . crunches cancel_ipc for pspace_aligned[wp]: "pspace_aligned :: det_state \ _" @@ -1367,6 +1163,30 @@ crunches cancel_ipc end +crunches asUser + for valid_sched_pointers[wp]: valid_sched_pointers + (wp: crunch_wps) + +crunches set_thread_state + for in_correct_ready_q[wp]: in_correct_ready_q + (wp: crunch_wps) + +crunches set_thread_state_ext + for ready_qs_distinct[wp]: ready_qs_distinct + (wp: crunch_wps) + +lemma set_thread_state_ready_qs_distinct[wp]: + "set_thread_state ref ts \ready_qs_distinct\" + unfolding set_thread_state_def + apply (wpsimp wp: set_object_wp) + by (clarsimp simp: ready_qs_distinct_def) + +lemma as_user_ready_qs_distinct[wp]: + "as_user tptr f \ready_qs_distinct\" + unfolding as_user_def + apply (wpsimp wp: set_object_wp) + by (clarsimp simp: ready_qs_distinct_def) + lemma (in delete_one) suspend_corres: "corres dc (einvs and tcb_at t) invs' (IpcCancel_A.suspend t) (ThreadDecls_H.suspend t)" @@ -1390,15 +1210,18 @@ lemma (in delete_one) suspend_corres: apply (rule corres_return_trivial) apply (rule corres_split_nor[OF setThreadState_corres]) apply wpsimp - apply (rule tcbSchedDequeue_corres') + apply (rule tcbSchedDequeue_corres, simp) apply wp - apply wpsimp - apply (wpsimp simp: update_restart_pc_def updateRestartPC_def)+ - apply (rule hoare_post_imp[where Q = "\rv s. tcb_at t s \ is_etcb_at t s \ pspace_aligned s \ pspace_distinct s"]) - apply simp - apply (wp | simp)+ - apply (fastforce simp: valid_sched_def tcb_at_is_etcb_at) - apply (clarsimp simp add: invs'_def valid_state'_def valid_queues_inQ_queues) + 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 context begin interpretation Arch . @@ -1461,11 +1284,10 @@ proof - by (simp add: tcb_relation_def) show ?thesis unfolding arch_thread_set_def archThreadSet_def - apply (corres' \rotate_tac, erule tcb_rel | rule ball_tcb_cte_casesI; simp\ - corres: getObject_TCB_corres setObject_update_TCB_corres' - wp: getObject_tcb_wp - simp: exst_same_def tcb_cap_cases_def tcb_ko_at') - done + by (corres' \(rotate_tac, erule tcb_rel) | + (rule ball_tcb_cte_casesI; simp) | + simp add: exst_same_def tcb_cap_cases_def\ + corres: getObject_TCB_corres setObject_update_TCB_corres') qed lemma archThreadSet_VCPU_None_corres[corres]: @@ -1573,261 +1395,8 @@ lemma (in delete_one_conc_pre) cancelIPC_it[wp]: apply (wp hoare_drop_imps delete_one_it | wpc | simp add:if_apply_def2 Fun.comp_def)+ done -lemma tcbSchedDequeue_notksQ: - "\\s. t' \ set(ksReadyQueues s p)\ - tcbSchedDequeue t - \\_ s. t' \ set(ksReadyQueues s p)\" - 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+ - apply clarsimp - apply (rule_tac Q="\_ s. t' \ set(ksReadyQueues s p)" in hoare_post_imp) - apply (wp | clarsimp)+ - done - -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 B="\rv s. (rv = ResumeCurrentThread \ rv = ChooseNewThread) - \ ?OAQ t' p s" in hoare_seq_ext) - including classic_wp_pre - apply (wp | clarsimp)+ - apply (case_tac x) - apply (wp | clarsimp)+ - done - -lemma setThreadState_oa_queued: - "\\s. P' (obj_at' (\tcb. P (tcbQueued tcb) (tcbDomain tcb) (tcbPriority tcb)) t' s) \ - setThreadState st 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 \ setThreadState st t \\_. ?Q R \" - apply (simp add: setThreadState_def) - apply (wp rescheduleRequired_oa_queued) - apply (simp add: sch_act_simple_def) - apply (rule_tac Q="\_. ?Q R" in hoare_post_imp, clarsimp) - apply (wp threadSet_obj_at'_strongish) - apply (clarsimp) - done - show "\\s. \ ?Q P s\ setThreadState st t \\_ s. \ ?Q P s\" - by (simp add: not_obj_at' comp_def, wp hoare_convert_imp pos) - qed - -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 tcbSchedDequeue_ksQ_distinct[wp]: - "\\s. distinct (ksReadyQueues s p)\ - tcbSchedDequeue t - \\_ s. distinct (ksReadyQueues s p)\" - 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+ - apply (rule_tac Q="\_ s. distinct (ksReadyQueues s p)" in hoare_post_imp) - apply (clarsimp | wp)+ - done - -lemma sts_valid_queues_partial: - "\Invariants_H.valid_queues and sch_act_simple\ - setThreadState st t - \\_ s. \t' d p. - (t' \ set(ksReadyQueues s (d, p)) \ - (obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t' s - \ (t' \ t \ st_tcb_at' runnable' t' s))) - \ distinct (ksReadyQueues s (d, p))\" - (is "\_\ _ \\_ s. \t' d p. ?OA t' d p s \ ?DISTINCT d p s \") - apply (rule_tac Q="\_ s. (\t' d p. ?OA t' d p s) \ (\d p. ?DISTINCT d p s)" - in hoare_post_imp) - apply (clarsimp) - apply (rule hoare_conjI) - apply (rule_tac Q="\s. \t' d p. - ((t'\set(ksReadyQueues s (d, p)) - \ \ (sch_act_simple s)) - \ (obj_at'(\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t' s - \ st_tcb_at' runnable' t' s))" in hoare_pre_imp) - apply (fastforce simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def - pred_tcb_at'_def obj_at'_def inQ_def) - apply (rule hoare_vcg_all_lift)+ - apply (rule hoare_convert_imp) - including classic_wp_pre - apply (wp sts_ksQ setThreadState_oa_queued hoare_impI sts_pred_tcb_neq' - | clarsimp)+ - apply (rule_tac Q="\s. \d p. ?DISTINCT d p s \ sch_act_simple s" in hoare_pre_imp) - apply (clarsimp simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def) - apply (wp hoare_vcg_all_lift sts_ksQ) - apply (clarsimp) - done - -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 Q="(\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) - done - -lemma sts_invs_minor'_no_valid_queues: - "\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 \ obj_at' tcbQueued t s \ st_tcb_at' runnable' t s) - and sch_act_simple - and invs'\ - setThreadState st t - \\_ s. (\t' d p. - (t' \ set(ksReadyQueues s (d, p)) \ - (obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t' s - \ (t' \ t \ st_tcb_at' runnable' t' s))) - \ distinct (ksReadyQueues s (d, p)) \ (maxDomain < d \ maxPriority < p \ ksReadyQueues s (d, p) = [])) \ - valid_bitmapQ s \ - bitmapQ_no_L2_orphans s \ - bitmapQ_no_L1_orphans s \ - valid_pspace' s \ - sch_act_wf (ksSchedulerAction s) s \ - sym_refs (state_refs_of' s) \ - sym_refs (state_hyp_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 \ - valid_queues' s \ - ct_not_inQ s \ - ct_idle_or_in_cur_domain' s \ - pspace_domain_valid s \ - ksCurDomain s \ maxDomain \ - valid_dom_schedule' s \ - untyped_ranges_zero' s \ - cur_tcb' s \ - tcb_at' t s\" - apply (simp add: invs'_def valid_state'_def valid_queues_def) - apply (wp sts_valid_queues_partial sts_ksQ - setThreadState_oa_queued sts_st_tcb_at'_cases - irqs_masked_lift - valid_irq_node_lift - setThreadState_ct_not_inQ - sts_valid_bitmapQ_sch_act_simple - sts_valid_bitmapQ_no_L2_orphans_sch_act_simple - sts_valid_bitmapQ_no_L1_orphans_sch_act_simple - hoare_vcg_conj_lift hoare_vcg_imp_lift hoare_vcg_all_lift)+ - apply (clarsimp simp: disj_imp) - apply (intro conjI) - apply (clarsimp simp: valid_queues_def) - apply (rule conjI, clarsimp) - apply (drule valid_queues_no_bitmap_objD, assumption) - apply (clarsimp simp: inQ_def comp_def) - apply (rule conjI) - apply (erule obj_at'_weaken) - apply (simp add: inQ_def) - apply (clarsimp simp: st_tcb_at'_def) - apply (erule obj_at'_weaken) - apply (simp add: inQ_def) - apply (simp add: valid_queues_no_bitmap_def) - apply clarsimp - apply (clarsimp simp: st_tcb_at'_def) - apply (drule obj_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def) - apply (clarsimp simp: valid_obj'_def valid_tcb'_def) - subgoal - by (fastforce simp: valid_tcb_state'_def - split: Structures_H.thread_state.splits) - apply (clarsimp dest!: st_tcb_at_state_refs_ofD' - elim!: rsubst[where P=sym_refs] - intro!: ext) - apply (fastforce simp: valid_queues_def inQ_def pred_tcb_at' pred_tcb_at'_def - elim!: st_tcb_ex_cap'' obj_at'_weakenE)+ - done - crunch ct_idle_or_in_cur_domain'[wp]: tcbSchedDequeue ct_idle_or_in_cur_domain' - -lemma tcbSchedDequeue_invs'_no_valid_queues: - "\\s. (\t' d p. - (t' \ set(ksReadyQueues s (d, p)) \ - (obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t' s - \ (t' \ t \ st_tcb_at' runnable' t' s))) - \ distinct (ksReadyQueues s (d, p)) \ (maxDomain < d \ maxPriority < p \ ksReadyQueues s (d, p) = [])) \ - valid_bitmapQ s \ - bitmapQ_no_L2_orphans s \ - bitmapQ_no_L1_orphans s \ - valid_pspace' s \ - sch_act_wf (ksSchedulerAction s) s \ - sym_refs (state_refs_of' s) \ - sym_refs (state_hyp_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 \ - valid_queues' s \ - ct_not_inQ s \ - ct_idle_or_in_cur_domain' s \ - pspace_domain_valid s \ - ksCurDomain s \ maxDomain \ - valid_dom_schedule' s \ - untyped_ranges_zero' s \ - cur_tcb' s \ - tcb_at' t s\ - tcbSchedDequeue t - \\_. invs' \" - apply (simp add: invs'_def valid_state'_def) - apply (wp tcbSchedDequeue_valid_queues_weak valid_irq_handlers_lift - valid_irq_node_lift valid_irq_handlers_lift' - tcbSchedDequeue_irq_states irqs_masked_lift cur_tcb_lift - untyped_ranges_zero_lift - | clarsimp simp add: cteCaps_of_def valid_queues_def o_def)+ - apply (rule conjI) - apply (fastforce simp: obj_at'_def inQ_def st_tcb_at'_def valid_queues_no_bitmap_except_def) - apply (rule conjI, clarsimp simp: correct_queue_def) - apply (fastforce simp: valid_pspace'_def intro: obj_at'_conjI - elim: valid_objs'_maxDomain valid_objs'_maxPriority) - done - -lemmas sts_tcbSchedDequeue_invs' = - sts_invs_minor'_no_valid_queues - tcbSchedDequeue_invs'_no_valid_queues + (wp: crunch_wps) lemma asUser_sch_act_simple[wp]: "\sch_act_simple\ asUser s t \\_. sch_act_simple\" @@ -1839,11 +1408,14 @@ lemma (in delete_one_conc) suspend_invs'[wp]: "\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 (wp sts_tcbSchedDequeue_invs') - apply (simp add: updateRestartPC_def | strengthen no_refs_simple_strg')+ - prefer 2 - apply (wpsimp wp: hoare_drop_imps hoare_vcg_imp_lift' - | strengthen no_refs_simple_strg')+ + 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]: @@ -1887,109 +1459,6 @@ lemma (in delete_one_conc_pre) suspend_st_tcb_at': lemmas (in delete_one_conc_pre) suspend_makes_simple' = suspend_st_tcb_at' [where P=simple', simplified] -lemma valid_queues_not_runnable'_not_ksQ: - assumes "Invariants_H.valid_queues s" and "st_tcb_at' (Not \ runnable') t s" - shows "\d p. t \ set (ksReadyQueues s (d, p))" - using assms - apply - - apply (clarsimp simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def pred_tcb_at'_def) - apply (erule_tac x=d in allE) - apply (erule_tac x=p in allE) - apply (clarsimp) - apply (drule(1) bspec) - apply (clarsimp simp: obj_at'_def) - done - -declare valid_queues_not_runnable'_not_ksQ[OF ByAssum, simp] - -lemma cancelSignal_queues[wp]: - "\Invariants_H.valid_queues and st_tcb_at' (Not \ runnable') t\ - cancelSignal t ae \\_. Invariants_H.valid_queues \" - apply (simp add: cancelSignal_def) - apply (wp sts_valid_queues) - apply (rule_tac Q="\_ s. \p. t \ set (ksReadyQueues s p)" in hoare_post_imp, simp) - apply (wp hoare_vcg_all_lift) - apply (wpc) - apply (wp)+ - apply (rule_tac Q="\_ s. Invariants_H.valid_queues s \ (\p. t \ set (ksReadyQueues s p))" in hoare_post_imp) - apply (clarsimp) - apply (wp) - apply (clarsimp) - done - -lemma (in delete_one_conc_pre) cancelIPC_queues[wp]: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - cancelIPC t \\rv. Invariants_H.valid_queues\" - apply (simp add: cancelIPC_def Let_def getThreadReplySlot_def - cong: Structures_H.thread_state.case_cong list.case_cong) - apply (rule hoare_seq_ext [OF _ gts_sp']) - apply (rule hoare_pre) - apply (wpc - | wp hoare_vcg_conj_lift delete_one_queues threadSet_valid_queues - threadSet_valid_objs' sts_valid_queues setEndpoint_ksQ - hoare_vcg_all_lift threadSet_sch_act threadSet_weak_sch_act_wf - | simp add: o_def if_apply_def2 inQ_def - | rule hoare_drop_imps - | clarsimp simp: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def - elim!: pred_tcb'_weakenE)+ - apply (fastforce dest: valid_queues_not_runnable'_not_ksQ elim: pred_tcb'_weakenE) - done - -(* FIXME: move to Schedule_R *) -lemma tcbSchedDequeue_nonq[wp]: - "\Invariants_H.valid_queues and tcb_at' t and K (t = t')\ - tcbSchedDequeue t \\_ s. \d p. t' \ set (ksReadyQueues s (d, p))\" - apply (rule hoare_gen_asm) - apply (simp add: tcbSchedDequeue_def) - apply (wp threadGet_wp|simp)+ - apply (fastforce simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def obj_at'_def inQ_def) - done - -lemma sts_ksQ_oaQ: - "\Invariants_H.valid_queues\ - setThreadState st t - \\_ s. t \ set (ksReadyQueues s (d, p)) \ - obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t s\" - (is "\_\ _ \\_. ?POST\") - proof - - have RR: "\sch_act_simple and ?POST\ rescheduleRequired \\_. ?POST\" - apply (simp add: rescheduleRequired_def) - apply (wp) - apply (clarsimp) - apply (rule_tac - Q="(\s. action = ResumeCurrentThread \ action = ChooseNewThread) and ?POST" - in hoare_pre_imp, assumption) - apply (case_tac action) - apply (clarsimp)+ - apply (wp) - apply (clarsimp simp: sch_act_simple_def) - done - show ?thesis - apply (simp add: setThreadState_def) - apply (wp RR) - apply (rule_tac Q="\_. ?POST" in hoare_post_imp) - apply (clarsimp simp add: sch_act_simple_def) - apply (wp hoare_convert_imp) - apply (clarsimp simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (fastforce dest: bspec elim!: obj_at'_weakenE simp: inQ_def) - done - qed - -lemma (in delete_one_conc_pre) suspend_nonq: - "\Invariants_H.valid_queues and valid_objs' and tcb_at' t - and (\s. weak_sch_act_wf (ksSchedulerAction s) s) - and (\s. t \ ksIdleThread s) and K (t = t')\ - suspend t - \\rv s. \d p. t' \ set (ksReadyQueues s (d, p))\" - apply (rule hoare_gen_asm) - apply (simp add: suspend_def) - unfolding updateRestartPC_def - apply (wp hoare_allI tcbSchedDequeue_t_notksQ sts_ksQ_oaQ) - apply wpsimp+ - done - lemma suspend_makes_inactive: "\K (t = t')\ suspend t \\rv. st_tcb_at' ((=) Inactive) t'\" apply (cases "t = t'", simp_all) @@ -2000,29 +1469,21 @@ lemma suspend_makes_inactive: declare threadSet_sch_act_sane [wp] declare sts_sch_act_sane [wp] -lemma tcbSchedEnqueue_ksQset_weak: - "\\s. t' \ set (ksReadyQueues s p)\ - tcbSchedEnqueue t - \\_ s. t' \ set (ksReadyQueues s p)\" (is "\?PRE\ _ \_\") - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wp hoare_vcg_conj_lift hoare_vcg_imp_lift hoare_vcg_if_lift) - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, ((wp | clarsimp)+))+ - done - 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 tcbSchedEnqueue_ct', wp, simp) + by (rule hoare_weaken_pre, wps, wp, simp) lemma sts_sch_act_not_ct[wp]: "\\s. sch_act_not (ksCurThread s) s\ setThreadState st t \\_ s. sch_act_not (ksCurThread s) s\" - by (rule hoare_weaken_pre, wps tcbSchedEnqueue_ct', wp, simp) + by (rule hoare_weaken_pre, wps, wp, simp) text \Cancelling all IPC in an endpoint or notification object\ lemma ep_cancel_corres_helper: - "corres dc ((\s. \t \ set list. tcb_at t s) and valid_etcbs and pspace_aligned and pspace_distinct) - (Invariants_H.valid_queues and valid_queues' and valid_objs') + "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 @@ -2031,28 +1492,34 @@ lemma ep_cancel_corres_helper: 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 (rule corres_guard_imp [OF setThreadState_corres]) - apply simp - apply (simp add: valid_tcb_state_def) - apply simp - apply (wp sts_valid_queues)+ - apply (force simp: tcb_at_is_etcb_at) - apply (fastforce elim: obj_at'_weakenE) - apply ((wp hoare_vcg_const_Ball_lift | simp)+)[1] - apply (rule hoare_pre) - apply (wp hoare_vcg_const_Ball_lift - weak_sch_act_wf_lift_linear sts_st_tcb' setThreadState_not_st - sts_valid_queues tcbSchedEnqueue_not_st - | simp)+ - apply (auto elim: obj_at'_weakenE simp: valid_tcb_state'_def) + 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 +crunches 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 ep_cancel_corres: "corres dc (invs and valid_sched and ep_at ep) (invs' and ep_at' ep) (cancel_all_ipc ep) (cancelAllIPC ep)" @@ -2060,10 +1527,10 @@ proof - have P: "\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_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 - \ Invariants_H.valid_queues s \ valid_queues' s \ valid_objs' 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; @@ -2085,22 +1552,23 @@ proof - 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 R="\_ s. \x\set list. tcb_at' x s \ valid_objs' s" + apply (rule_tac R="\_ 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 (rule hoare_name_pre_state) - apply ((wp hoare_vcg_const_Ball_lift mapM_x_wp' - sts_valid_queues setThreadState_not_st sts_st_tcb' tcbSchedEnqueue_not_st - | clarsimp - | fastforce elim: obj_at'_weakenE simp: valid_tcb_state'_def)+)[2] - apply (rule hoare_name_pre_state) + 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 elim!: valid_objs_valid_tcbE))+ + | (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 (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 @@ -2128,6 +1596,8 @@ lemma cancelAllSignals_corres: "corres dc (invs and valid_sched and ntfn_at ntfn) (invs' and ntfn_at' ntfn) (cancel_all_signals ntfn) (cancelAllSignals ntfn)" apply (simp add: cancel_all_signals_def cancelAllSignals_def) + 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+ @@ -2138,17 +1608,19 @@ lemma cancelAllSignals_corres: 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 setThreadState_not_st + weak_sch_act_wf_lift_linear set_thread_state_runnable_weak_valid_sched_action | simp)+ apply (rename_tac list) - apply (rule_tac R="\_ s. (\x\set list. tcb_at' x s) \ valid_objs' s" + apply (rule_tac R="\_ 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_queues setThreadState_not_st - simp: valid_tcb_state'_def) + 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)+ @@ -2195,6 +1667,11 @@ proof - done qed +lemma tcbSchedEnqueue_valid_pspace'[wp]: + "tcbSchedEnqueue tcbPtr \valid_pspace'\" + unfolding valid_pspace'_def + by wpsimp + lemma cancel_all_invs'_helper: "\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} @@ -2210,8 +1687,7 @@ lemma cancel_all_invs'_helper: apply clarsimp 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_valid_queues sts_st_tcb' setThreadState_not_st + 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 @@ -2220,7 +1696,7 @@ lemma cancel_all_invs'_helper: elim!: rsubst[where P=sym_refs] dest!: set_mono_suffix intro!: ext - | (drule (1) bspec, clarsimp simp: valid_pspace'_def valid_tcb'_def elim!: valid_objs_valid_tcbE))+ + | (drule (1) bspec, clarsimp simp: valid_pspace'_def valid_tcb'_def))+ done lemma ep_q_refs_max: @@ -2237,10 +1713,9 @@ lemma ep_q_refs_max: done lemma rescheduleRequired_invs'[wp]: - "\invs'\ rescheduleRequired \\rv. invs'\" + "rescheduleRequired \invs'\" apply (simp add: rescheduleRequired_def) apply (wpsimp wp: ssa_invs') - apply (clarsimp simp: invs'_def valid_state'_def) done lemma invs_rct_ct_activatable': @@ -2367,6 +1842,7 @@ lemma rescheduleRequired_all_invs_but_ct_not_inQ: lemma cancelAllIPC_invs'[wp]: "\invs'\ cancelAllIPC ep_ptr \\rv. invs'\" apply (simp add: cancelAllIPC_def ep'_Idle_case_helper cong del: if_cong) + apply (rule hoare_seq_ext[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' @@ -2395,6 +1871,7 @@ lemma cancelAllIPC_invs'[wp]: lemma cancelAllSignals_invs'[wp]: "\invs'\ cancelAllSignals ntfn \\rv. invs'\" apply (simp add: cancelAllSignals_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) apply (case_tac "ntfnObj ntfna", simp_all) apply (wp, simp) @@ -2426,12 +1903,14 @@ lemma cancelAllSignals_invs'[wp]: done lemma cancelAllIPC_valid_objs'[wp]: - "\valid_objs'\ cancelAllIPC ep \\rv. valid_objs'\" + "\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 hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ep_sp']) apply (rule hoare_pre) apply (wp set_ep_valid_objs' setSchedulerAction_valid_objs') - apply (rule_tac Q="\rv s. valid_objs' s \ (\x\set (epQueue ep). tcb_at' x s)" + 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) @@ -2448,8 +1927,9 @@ lemma cancelAllIPC_valid_objs'[wp]: done lemma cancelAllSignals_valid_objs'[wp]: - "\valid_objs'\ cancelAllSignals ntfn \\rv. valid_objs'\" + "\valid_objs' and pspace_aligned' and pspace_distinct'\ cancelAllSignals ntfn \\rv. valid_objs'\" apply (simp add: cancelAllSignals_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) apply (case_tac "ntfnObj ntfna", simp_all) apply (wp, simp) @@ -2502,19 +1982,17 @@ 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\" - apply (simp add: setThreadState_def setQueue_def - rescheduleRequired_def tcbSchedEnqueue_def - unless_def bitmap_fun_defs - cong: scheduler_action.case_cong cong del: if_cong - | wp | wpcw)+ - done + 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 unless_def) + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_def) apply (wp | simp add: setQueue_def bitmap_fun_defs)+ done @@ -2548,19 +2026,41 @@ lemma setObject_ko_wp_at': objBits_def[symmetric] ps_clear_upd in_magnitude_check v) -lemma rescheduleRequired_unlive: - "\\s. ko_wp_at' (Not \ live') p s \ ksSchedulerAction s \ SwitchToThread p\ - rescheduleRequired +lemma threadSet_unlive_other: + "\ko_wp_at' (Not \ live') p and K (p \ t)\ + threadSet f t \\rv. ko_wp_at' (Not \ live') p\" - apply (simp add: rescheduleRequired_def) - apply (wp | simp | wpc)+ - apply (simp add: tcbSchedEnqueue_def unless_def - threadSet_def setQueue_def threadGet_def) - apply (wp setObject_ko_wp_at getObject_tcb_wp - | simp add: objBits_simps' bitmap_fun_defs split del: if_split)+ - apply (clarsimp simp: o_def) - apply (drule obj_at_ko_at') - apply clarsimp + by (clarsimp simp: threadSet_def valid_def getObject_def + setObject_def in_monad loadObject_default_def + ko_wp_at'_def split_def in_magnitude_check + objBits_simps' updateObject_default_def + ps_clear_upd) + +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 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 live'_def + split: option.splits) + done + +lemma rescheduleRequired_unlive[wp]: + "\\s. ko_wp_at' (Not \ live') p s \ ksSchedulerAction s \ SwitchToThread p\ + rescheduleRequired + \\_. ko_wp_at' (Not \ live') p\" + supply comp_apply[simp del] + unfolding rescheduleRequired_def + apply (wpsimp wp: tcbSchedEnqueue_unlive_other) done lemmas setEndpoint_ko_wp_at' @@ -2570,6 +2070,7 @@ lemma cancelAllIPC_unlive: "\valid_objs' and (\s. sch_act_wf (ksSchedulerAction s) s)\ cancelAllIPC ep \\rv. ko_wp_at' (Not \ live') ep\" apply (simp add: cancelAllIPC_def ep'_Idle_case_helper) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ep_sp']) apply (rule hoare_pre) apply (wp cancelAll_unlive_helper setEndpoint_ko_wp_at' @@ -2589,6 +2090,7 @@ lemma cancelAllSignals_unlive: \ obj_at' (\ko. ntfnBoundTCB ko = None) ntfnptr s\ cancelAllSignals ntfnptr \\rv. ko_wp_at' (Not \ live') ntfnptr\" apply (simp add: cancelAllSignals_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) apply (case_tac "ntfnObj ntfn", simp_all add: setNotification_def) apply wp @@ -2655,25 +2157,20 @@ lemma cancelBadgedSends_filterM_helper': apply (rule hoare_pre) 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' sts_valid_queues setThreadState_not_st - tcbSchedEnqueue_not_st - untyped_ranges_zero_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 + apply (clarsimp simp: valid_pspace'_def cong: conj_cong) apply (intro conjI) - apply (clarsimp simp: valid_pspace'_def valid_tcb'_def elim!: valid_objs_valid_tcbE dest!: st_tcb_ex_cap'') - apply (fastforce dest!: 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) - apply (fastforce elim!: obj_atE' - simp: state_refs_of'_def tcb_bound_refs'_def - subsetD symreftype_inverse' - split: if_split_asm)+ - done + by (fastforce elim!: obj_atE' + simp: state_refs_of'_def tcb_bound_refs'_def subsetD symreftype_inverse' + split: if_split_asm)+ lemmas cancelBadgedSends_filterM_helper = spec [where x=Nil, OF cancelBadgedSends_filterM_helper', simplified] @@ -2683,7 +2180,8 @@ lemma cancelBadgedSends_invs[wp]: shows "\invs'\ cancelBadgedSends epptr badge \\rv. invs'\" apply (simp add: cancelBadgedSends_def) - apply (rule hoare_seq_ext [OF _ get_ep_sp']) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) + apply (rule hoare_seq_ext [OF _ get_ep_sp'], rename_tac ep) apply (case_tac ep, simp_all) apply ((wp | simp)+)[2] apply (subst bind_assoc [where g="\_. rescheduleRequired", @@ -2715,10 +2213,20 @@ lemma cancelBadgedSends_invs[wp]: crunch state_refs_of[wp]: tcb_sched_action "\s. P (state_refs_of s)" +lemma setEndpoint_valid_tcbs'[wp]: + "setEndpoint ePtr val \valid_tcbs'\" + unfolding setEndpoint_def + apply (wpsimp wp: setObject_valid_tcbs'[where P=\]) + apply (clarsimp simp: updateObject_default_def monad_simps) + apply fastforce + done + lemma cancelBadgedSends_corres: "corres dc (invs and valid_sched and ep_at epptr) (invs' and ep_at' epptr) (cancel_badged_sends epptr bdg) (cancelBadgedSends epptr bdg)" 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 Q'=invs']) @@ -2728,11 +2236,16 @@ lemma cancelBadgedSends_corres: apply (rule corres_guard_imp) apply (rule corres_split_nor[OF setEndpoint_corres]) apply (simp add: ep_relation_def) - apply (rule corres_split_eqr[OF _ _ _ hoare_post_add[where R="\_. valid_objs'"]]) + apply (rule corres_split_eqr[OF _ _ _ hoare_post_add + [where R="\_. 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 \ pspace_aligned s \ pspace_distinct s" - and Q'="\xs s. Invariants_H.valid_queues s \ valid_queues' s \ valid_objs' s" + 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) @@ -2743,57 +2256,53 @@ lemma cancelBadgedSends_corres: 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]) + apply (rule corres_split[OF tcbSchedEnqueue_corres], simp) apply (rule corres_trivial) apply simp apply wp+ apply simp - apply (wp sts_valid_queues gts_st_tcb_at)+ + 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: is_tcb_def) - apply simp + 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_queues + 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 (wp gts_st_tcb_at hoare_vcg_imp_lift mapM_wp' - sts_st_tcb' sts_valid_queues - set_thread_state_runnable_weak_valid_sched_action - | clarsimp simp: valid_tcb_state'_def)+ - apply (wp hoare_vcg_const_Ball_lift weak_sch_act_wf_lift_linear set_ep_valid_objs' - | simp)+ + 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 (drule ko_at_valid_objs', clarsimp) - apply simp - apply (clarsimp simp: valid_obj'_def valid_ep'_def invs_weak_sch_act_wf - invs'_def valid_state'_def) + apply (fastforce simp: valid_ep'_def) done +crunches 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 (simp add: threadGet_def| wp getObject_tcb_wp)+ - apply (rule hoare_strengthen_post, rule hoare_post_taut) - apply (fastforce simp: obj_at'_def) - apply (rule hoare_post_taut) - apply wp+ - done + unfolding suspend_def + by (wpsimp simp: comp_def wp: tcbSchedDequeue_not_tcbQueued) crunch no_vcpu[wp]: vcpuInvalidateActive "obj_at' (P::'a:: no_vcpu \ bool) t" @@ -2838,7 +2347,6 @@ lemma archThreadGet_wp: crunch unqueued: prepareThreadDelete "obj_at' (Not \ tcbQueued) t" (simp: o_def wp: dissociateVCPUTCB_unqueued[simplified o_def] archThreadGet_wp) crunch inactive: prepareThreadDelete "st_tcb_at' ((=) Inactive) t'" -crunch nonq: prepareThreadDelete " \s. \d p. t' \ set (ksReadyQueues s (d, p))" end end diff --git a/proof/refine/AARCH64/Ipc_R.thy b/proof/refine/AARCH64/Ipc_R.thy index b79babae31..b4d1cae884 100644 --- a/proof/refine/AARCH64/Ipc_R.thy +++ b/proof/refine/AARCH64/Ipc_R.thy @@ -765,14 +765,6 @@ lemma tcts_sch_act[wp]: \\rv s. sch_act_wf (ksSchedulerAction s) s\" by (wp sch_act_wf_lift tcb_in_cur_domain'_lift transferCapsToSlots_pres1) -lemma tcts_vq[wp]: - "\Invariants_H.valid_queues\ transferCapsToSlots ep buffer n caps slots mi \\rv. Invariants_H.valid_queues\" - by (wp valid_queues_lift transferCapsToSlots_pres1) - -lemma tcts_vq'[wp]: - "\valid_queues'\ transferCapsToSlots ep buffer n caps slots mi \\rv. valid_queues'\" - by (wp valid_queues_lift' transferCapsToSlots_pres1) - crunches setExtraBadge for state_refs_of'[wp]: "\s. P (state_refs_of' s)" and state_hyp_refs_of'[wp]: "\s. P (state_hyp_refs_of' s)" @@ -982,6 +974,11 @@ crunch ksDomScheduleIdx[wp]: setExtraBadge "\s. P (ksDomScheduleIdx s)" crunch ksDomSchedule[wp]: transferCapsToSlots "\s. P (ksDomSchedule s)" crunch ksDomScheduleIdx[wp]: transferCapsToSlots "\s. P (ksDomScheduleIdx s)" +crunches transferCapsToSlots + 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) lemma transferCapsToSlots_invs[wp]: "\\s. invs' s \ distinct slots @@ -1216,8 +1213,6 @@ lemma setMRs_invs_bits[wp]: setMRs t buf mrs \\rv s. sch_act_wf (ksSchedulerAction s) s\" "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ setMRs t buf mrs \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" - "\Invariants_H.valid_queues\ setMRs t buf mrs \\rv. Invariants_H.valid_queues\" - "\valid_queues'\ setMRs t buf mrs \\rv. valid_queues'\" "\P. setMRs t buf mrs \\s. P (state_refs_of' s)\" "\P. setMRs t buf mrs \\s. P (state_hyp_refs_of' s)\" "\if_live_then_nonz_cap'\ setMRs t buf mrs \\rv. if_live_then_nonz_cap'\" @@ -1233,8 +1228,6 @@ lemma copyMRs_invs_bits[wp]: "\valid_pspace'\ copyMRs s sb r rb n \\rv. valid_pspace'\" "\\s. sch_act_wf (ksSchedulerAction s) s\ copyMRs s sb r rb n \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\Invariants_H.valid_queues\ copyMRs s sb r rb n \\rv. Invariants_H.valid_queues\" - "\valid_queues'\ copyMRs s sb r rb n \\rv. valid_queues'\" "\P. copyMRs s sb r rb n \\s. P (state_refs_of' s)\" "\P. copyMRs s sb r rb n \\s. P (state_hyp_refs_of' s)\" "\if_live_then_nonz_cap'\ copyMRs s sb r rb n \\rv. if_live_then_nonz_cap'\" @@ -1710,10 +1703,6 @@ crunch vp[wp]: doIPCTransfer "valid_pspace'" (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' wp: transferCapsToSlots_vp simp:ball_conj_distrib ) crunch sch_act_wf[wp]: doIPCTransfer "\s. sch_act_wf (ksSchedulerAction s) s" (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch vq[wp]: doIPCTransfer "Invariants_H.valid_queues" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch vq'[wp]: doIPCTransfer "valid_queues'" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) crunch state_refs_of[wp]: doIPCTransfer "\s. P (state_refs_of' s)" (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) crunch state_hyp_refs_of[wp]: doIPCTransfer "\s. P (state_hyp_refs_of' s)" @@ -1871,16 +1860,6 @@ lemma getThreadCallerSlot_inv: "\P\ getThreadCallerSlot t \\_. P\" by (simp add: getThreadCallerSlot_def, wp) -lemma deleteCallerCap_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - deleteCallerCap t - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - apply (simp add: deleteCallerCap_def getSlotCap_def getThreadCallerSlot_def locateSlot_conv) - apply (wp getThreadCallerSlot_inv cteDeleteOne_ct_not_ksQ getCTE_wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - done - lemma finaliseCapTrue_standin_tcb_at' [wp]: "\tcb_at' x\ finaliseCapTrue_standin cap v2 \\_. tcb_at' x\" apply (simp add: finaliseCapTrue_standin_def Let_def) @@ -2034,39 +2013,11 @@ lemma cteDeleteOne_weak_sch_act[wp]: done crunch pred_tcb_at'[wp]: handleFaultReply "pred_tcb_at' proj P t" -crunch valid_queues[wp]: handleFaultReply "Invariants_H.valid_queues" -crunch valid_queues'[wp]: handleFaultReply "valid_queues'" crunch tcb_in_cur_domain'[wp]: handleFaultReply "tcb_in_cur_domain' t" crunch sch_act_wf[wp]: unbindNotification "\s. sch_act_wf (ksSchedulerAction s) s" (wp: sbn_sch_act') -crunch valid_queues'[wp]: cteDeleteOne valid_queues' - (simp: crunch_simps unless_def inQ_def - wp: crunch_wps sts_st_tcb' getObject_inv loadObject_default_inv - threadSet_valid_queues' rescheduleRequired_valid_queues'_weak) - -lemma cancelSignal_valid_queues'[wp]: - "\valid_queues'\ cancelSignal t ntfn \\rv. valid_queues'\" - apply (simp add: cancelSignal_def) - apply (rule hoare_pre) - apply (wp getNotification_wp| wpc | simp)+ - done - -lemma cancelIPC_valid_queues'[wp]: - "\valid_queues' and (\s. sch_act_wf (ksSchedulerAction s) s) \ cancelIPC t \\rv. valid_queues'\" - apply (simp add: cancelIPC_def Let_def getThreadReplySlot_def locateSlot_conv liftM_def) - apply (rule hoare_seq_ext[OF _ gts_sp']) - apply (case_tac state, simp_all) defer 2 - apply (rule hoare_pre) - apply ((wp getEndpoint_wp getCTE_wp | wpc | simp)+)[8] - apply (wp cteDeleteOne_valid_queues') - apply (rule_tac Q="\_. valid_queues' and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) - apply (clarsimp simp: capHasProperty_def cte_wp_at_ctes_of) - apply (wp threadSet_valid_queues' threadSet_sch_act| simp)+ - apply (clarsimp simp: inQ_def) - done - crunch valid_objs'[wp]: handleFaultReply valid_objs' lemma cte_wp_at_is_reply_cap_toI: @@ -2078,6 +2029,13 @@ crunches handle_fault_reply for pspace_alignedp[wp]: pspace_aligned and pspace_distinct[wp]: pspace_distinct +crunches cteDeleteOne, doIPCTransfer, handleFaultReply + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + and pspace_aligned'[wp]: pspace_aligned' + and pspace_distinct'[wp]: pspace_distinct' + (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) + lemma doReplyTransfer_corres: "corres dc (einvs and tcb_at receiver and tcb_at sender @@ -2123,8 +2081,12 @@ lemma doReplyTransfer_corres: apply (rule corres_split[OF setThreadState_corres]) apply simp apply (rule possibleSwitchTo_corres) - apply (wp set_thread_state_runnable_valid_sched set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' sts_st_tcb' sts_valid_queues sts_valid_objs' delete_one_tcbDomain_obj_at' - | simp add: valid_tcb_state'_def)+ + 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]) @@ -2133,7 +2095,11 @@ lemma doReplyTransfer_corres: apply (fastforce) apply (clarsimp simp:is_cap_simps) apply (wp weak_valid_sched_action_lift)+ - apply (rule_tac Q="\_. valid_queues' and valid_objs' and cur_tcb' and tcb_at' receiver and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp, simp add: sch_act_wf_weak) + 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) @@ -2165,7 +2131,9 @@ lemma doReplyTransfer_corres: 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 Invariants_H.valid_queues and valid_queues' and valid_objs'" + 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) @@ -2174,18 +2142,16 @@ lemma doReplyTransfer_corres: 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_queues + sts_st_tcb' sts_valid_objs' | force simp: valid_sched_def valid_sched_action_def valid_tcb_state'_def)+ apply (rule corres_guard_imp) apply (rule setThreadState_corres) apply (clarsimp simp: tcb_relation_def) apply (wp threadSet_cur weak_sch_act_wf_lift_linear threadSet_pred_tcb_no_state - thread_set_not_state_valid_sched threadSet_valid_queues threadSet_valid_queues' + 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 (wp threadSet_cur weak_sch_act_wf_lift_linear threadSet_pred_tcb_no_state - thread_set_not_state_valid_sched threadSet_valid_queues threadSet_valid_queues' - | simp add: runnable_def inQ_def valid_tcb'_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) @@ -2452,10 +2418,12 @@ proof - 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 setThreadState_valid_queues' sts_valid_queues sts_weak_sch_act_wf + 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) + 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) @@ -2520,11 +2488,13 @@ proof - 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 setThreadState_valid_queues' sts_valid_queues sts_weak_sch_act_wf + 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)+)[1] + | 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) @@ -2598,14 +2568,15 @@ lemma sendSignal_corres: apply (rule possibleSwitchTo_corres) apply wp apply (wp set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' - sts_valid_queues sts_st_tcb' hoare_disjI2 + 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 (clarsimp simp: invs'_def valid_state'_def sch_act_wf_weak - valid_tcb_state'_def) + 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)+ @@ -2631,23 +2602,23 @@ lemma sendSignal_corres: apply (rule corres_split[OF asUser_setRegister_corres]) apply (rule possibleSwitchTo_corres) apply ((wp | simp)+)[1] - apply (rule_tac Q="\_. Invariants_H.valid_queues and valid_queues' and - (\s. sch_act_wf (ksSchedulerAction s) s) and + apply (rule_tac Q="\_. (\s. sch_act_wf (ksSchedulerAction s) s) and cur_tcb' and - st_tcb_at' runnable' (hd list) and valid_objs'" + st_tcb_at' runnable' (hd list) and valid_objs' and + sym_heap_sched_pointers and valid_sched_pointers and + pspace_aligned' and pspace_distinct'" in hoare_post_imp, clarsimp simp: pred_tcb_at') apply (wp | simp)+ apply (wp sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action | simp)+ - apply (wp sts_st_tcb_at'_cases sts_valid_queues setThreadState_valid_queues' - setThreadState_st_tcb + 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 (clarsimp 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 (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) @@ -2665,16 +2636,14 @@ lemma sendSignal_corres: apply (wp cur_tcb_lift | 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_queues setThreadState_valid_queues' - setThreadState_st_tcb - | 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 (clarsimp 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 (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] @@ -2705,38 +2674,6 @@ lemma possibleSwitchTo_sch_act[wp]: apply (auto simp: obj_at'_def tcb_in_cur_domain'_def) done -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\" - apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs) - apply (wp hoare_drop_imps | wpc | simp)+ - apply (auto simp: valid_tcb'_def weak_sch_act_wf_def - dest: pred_tcb_at' - elim!: valid_objs_valid_tcbE) - done - -lemma possibleSwitchTo_ksQ': - "\(\s. t' \ set (ksReadyQueues s p) \ sch_act_not t' s) and K(t' \ t)\ - possibleSwitchTo t - \\_ s. t' \ set (ksReadyQueues s p)\" - apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs) - apply (wp hoare_weak_lift_imp rescheduleRequired_ksQ' tcbSchedEnqueue_ksQ threadGet_wp - | wpc - | simp split del: if_split)+ - apply (auto simp: obj_at'_def) - done - -lemma possibleSwitchTo_valid_queues'[wp]: - "\valid_queues' and (\s. sch_act_wf (ksSchedulerAction s) s) - and st_tcb_at' runnable' t\ - possibleSwitchTo t - \\rv. valid_queues'\" - apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs) - apply (wp hoare_weak_lift_imp threadGet_wp | wpc | simp)+ - apply (auto simp: obj_at'_def) - done - crunch st_refs_of'[wp]: possibleSwitchTo "\s. P (state_refs_of' s)" (wp: crunch_wps) crunch st_hyp_refs_of'[wp]: possibleSwitchTo "\s. P (state_hyp_refs_of' s)" @@ -2749,16 +2686,12 @@ crunch ct[wp]: possibleSwitchTo 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 + "\if_live_then_nonz_cap' and ex_nonz_cap_to' t and (\s. sch_act_wf (ksSchedulerAction s) s) + and pspace_aligned' and pspace_distinct'\ + possibleSwitchTo t \\rv. if_live_then_nonz_cap'\" - apply (simp add: possibleSwitchTo_def curDomain_def) - apply (wp | wpc | simp)+ - apply (simp only: imp_conv_disj, wp hoare_vcg_all_lift hoare_vcg_disj_lift) - apply (wp threadGet_wp)+ - apply (auto simp: obj_at'_def) - done + unfolding possibleSwitchTo_def curDomain_def + by (wpsimp wp: threadGet_wp) crunch ifunsafe[wp]: possibleSwitchTo if_unsafe_then_cap' (wp: crunch_wps) @@ -2789,10 +2722,6 @@ crunch irqs_masked'[wp]: sendSignal "irqs_masked'" simp: crunch_simps unless_def o_def rule: irqs_masked_lift) -lemma sts_running_valid_queues: - "runnable' st \ \ Invariants_H.valid_queues \ setThreadState st t \\_. Invariants_H.valid_queues \" - by (wp sts_valid_queues, clarsimp) - 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) @@ -2805,24 +2734,21 @@ lemma setThreadState_nonqueued_state_update: \ st \ {Inactive, Running, Restart, IdleThreadState} \ (st \ Inactive \ ex_nonz_cap_to' t s) \ (t = ksIdleThread s \ idle' st) - - \ (\ runnable' st \ sch_act_simple s) - \ (\ runnable' st \ (\p. t \ set (ksReadyQueues s p)))\ - setThreadState st t \\rv. invs'\" + \ (\ 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 - sts_valid_queues - setThreadState_ct_not_inQ) + 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 (drule simple_st_tcb_at_state_refs_ofD') apply (drule bound_tcb_at_state_refs_ofD') - apply (rule conjI, fastforce) - 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 (rule conjI) + apply clarsimp + apply (erule delta_sym_refs) + apply (fastforce split: if_split_asm) + apply (fastforce simp: symreftype_inverse' tcb_bound_refs'_def split: if_split_asm) + apply fastforce done lemma cteDeleteOne_reply_cap_to'[wp]: @@ -2890,16 +2816,14 @@ lemma cancelAllIPC_not_rct[wp]: \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" apply (simp add: cancelAllIPC_def) apply (wp | wpc)+ + apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) + apply simp + apply (rule mapM_x_wp_inv) + apply (wp)+ apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) apply simp apply (rule mapM_x_wp_inv) - apply (wp)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wp)+ - apply (wp hoare_vcg_all_lift hoare_drop_imp) - apply (simp_all) + apply (wpsimp wp: hoare_vcg_all_lift hoare_drop_imp)+ done lemma cancelAllSignals_not_rct[wp]: @@ -2908,12 +2832,10 @@ lemma cancelAllSignals_not_rct[wp]: \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" apply (simp add: cancelAllSignals_def) apply (wp | wpc)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wp)+ - apply (wp hoare_vcg_all_lift hoare_drop_imp) - apply (simp_all) + 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 not_rct[wp]: finaliseCapTrue_standin "\s. ksSchedulerAction s \ ResumeCurrentThread" @@ -2995,7 +2917,6 @@ lemma sai_invs'[wp]: 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 - sts_valid_queues [where st="Structures_H.thread_state.Running", simplified] set_ntfn_valid_objs' cur_tcb_lift sts_st_tcb' hoare_convert_imp [OF setNotification_nosch] | simp split del: if_split)+ @@ -3208,11 +3129,11 @@ lemma receiveIPC_corres: 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 Invariants_H.valid_queues - and valid_queues' and valid_pspace' and valid_objs' - and (\s. weak_sch_act_wf (ksSchedulerAction s) s)" + 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]) @@ -3221,17 +3142,18 @@ lemma receiveIPC_corres: apply (rule corres_split[OF setThreadState_corres]) apply simp apply (rule possibleSwitchTo_corres) - apply (wp sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action - | simp)+ - apply (wp sts_st_tcb_at'_cases sts_valid_queues setThreadState_valid_queues' - setThreadState_st_tcb + 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 (clarsimp simp: st_tcb_at_tcb_at st_tcb_def2 valid_sched_def - valid_sched_action_def) + 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" - in hoare_post_imp, erule sch_act_wf_weak) + 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 @@ -3456,30 +3378,6 @@ lemma setupCallerCap_state_hyp_refs_of[wp]: apply (wp hoare_drop_imps) done -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 vq[wp]: cteInsert "Invariants_H.valid_queues" - (wp: crunch_wps) - -crunch vq[wp]: getThreadCallerSlot "Invariants_H.valid_queues" - (wp: crunch_wps) - -crunch vq[wp]: getThreadReplySlot "Invariants_H.valid_queues" - (wp: crunch_wps) - -lemma setupCallerCap_vq[wp]: - "\Invariants_H.valid_queues and (\s. \p. send \ set (ksReadyQueues s p))\ - setupCallerCap send recv grant \\_. Invariants_H.valid_queues\" - apply (simp add: setupCallerCap_def) - apply (wp crunch_wps sts_valid_queues) - apply (fastforce simp: valid_queues_def obj_at'_def inQ_def) - done - -crunch vq'[wp]: setupCallerCap "valid_queues'" - (wp: crunch_wps) - 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)" @@ -3521,7 +3419,7 @@ lemma setupCallerCap_vp[wp]: declare haskell_assert_inv[wp del] lemma setupCallerCap_iflive[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' sender\ + "\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 @@ -3533,7 +3431,7 @@ lemma setupCallerCap_iflive[wp]: lemma setupCallerCap_ifunsafe[wp]: "\if_unsafe_then_cap' and valid_objs' and - ex_nonz_cap_to' rcvr and tcb_at' rcvr\ + 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 @@ -3555,13 +3453,11 @@ lemma setupCallerCap_global_refs'[wp]: \\rv. valid_global_refs'\" unfolding setupCallerCap_def getThreadCallerSlot_def getThreadReplySlot_def locateSlot_conv - apply (wp getSlotCap_cte_wp_at - | simp add: o_def unique_master_reply_cap' - | strengthen eq_imp_strg - | wp (once) getCTE_wp | clarsimp simp: cte_wp_at_ctes_of)+ - (* at setThreadState *) - apply (rule_tac Q="\_. valid_global_refs'" in hoare_post_imp, wpsimp+) - done + 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 valid_arch'[wp]: setupCallerCap "valid_arch_state'" (wp: hoare_drop_imps) @@ -3736,12 +3632,21 @@ crunches possibleSwitchTo for ksArch[wp]: "\s. P (ksArchState s)" (wp: possibleSwitchTo_ctes_of crunch_wps ignore: constOnFailure) +crunches asUser + for valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift wp: crunch_wps) + +crunches setupCallerCap, possibleSwitchTo, doIPCTransfer + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + and valid_bitmaps[wp]: valid_bitmaps + (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) + (* t = ksCurThread s *) lemma ri_invs' [wp]: "\invs' and sch_act_not t and ct_in_state' simple' and st_tcb_at' simple' t - and (\s. \p. t \ set (ksReadyQueues s p)) and ex_nonz_cap_to' t and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s)\ receiveIPC t cap isBlocking @@ -3759,7 +3664,7 @@ lemma ri_invs' [wp]: 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 - sts_valid_queues setThreadState_ct_not_inQ + 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) @@ -3786,7 +3691,7 @@ lemma ri_invs' [wp]: 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 - sts_valid_queues setThreadState_ct_not_inQ + 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) @@ -3810,9 +3715,8 @@ lemma ri_invs' [wp]: 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' sts_valid_queues - setThreadState_ct_not_inQ possibleSwitchTo_valid_queues - possibleSwitchTo_valid_queues' + 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 @@ -3829,8 +3733,6 @@ lemma ri_invs' [wp]: apply (clarsimp simp: valid_obj'_def valid_ep'_def st_tcb_at_refs_of_rev' conj_ac split del: if_split cong: if_cong) - apply (frule_tac t=sender in valid_queues_not_runnable'_not_ksQ) - apply (erule pred_tcb'_weakenE, clarsimp) apply (subgoal_tac "sch_act_not sender s") prefer 2 apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) @@ -3864,7 +3766,6 @@ lemma ri_invs' [wp]: lemma rai_invs'[wp]: "\invs' and sch_act_not t and st_tcb_at' simple' t - and (\s. \p. t \ set (ksReadyQueues s p)) and ex_nonz_cap_to' t and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s) and (\s. \ntfnptr. isNotificationCap cap @@ -3881,7 +3782,7 @@ lemma rai_invs'[wp]: apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) apply (wp valid_irq_node_lift sts_sch_act' typ_at_lifts - sts_valid_queues setThreadState_ct_not_inQ + setThreadState_ct_not_inQ asUser_urz | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def live'_def | wpc)+ apply (clarsimp simp: pred_tcb_at' valid_tcb_state'_def) @@ -3899,7 +3800,7 @@ lemma rai_invs'[wp]: apply (clarsimp split: if_split_asm) apply (fastforce simp: tcb_bound_refs'_def symreftype_inverse' split: if_split_asm) - apply (clarsimp dest!: global'_no_ex_cap) + apply (fastforce dest!: global'_no_ex_cap) apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) \ \ep = ActiveNtfn\ apply (simp add: invs'_def valid_state'_def) @@ -3919,7 +3820,7 @@ lemma rai_invs'[wp]: apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) apply (wp hoare_vcg_const_Ball_lift valid_irq_node_lift sts_sch_act' - sts_valid_queues setThreadState_ct_not_inQ typ_at_lifts + setThreadState_ct_not_inQ typ_at_lifts asUser_urz | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def live'_def | wpc)+ apply (clarsimp simp: valid_tcb_state'_def) @@ -3947,7 +3848,7 @@ lemma rai_invs'[wp]: 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 (clarsimp dest!: global'_no_ex_cap) + apply (fastforce dest!: global'_no_ex_cap) done lemma getCTE_cap_to_refs[wp]: @@ -3986,9 +3887,12 @@ crunch urz[wp]: possibleSwitchTo "untyped_ranges_zero'" declare zipWithM_x_mapM[simp] (* FIXME AARCH64: remove? *) +crunches possibleSwitchTo + for pspace_aligned'[wp]: pspace_aligned' + and pspace_distinct'[wp]: pspace_distinct' + lemma si_invs'[wp]: "\invs' and st_tcb_at' simple' t - and (\s. \p. t \ set (ksReadyQueues s p)) and sch_act_not t and ex_nonz_cap_to' ep and ex_nonz_cap_to' t\ sendIPC bl call ba cg cgr t ep @@ -4007,8 +3911,8 @@ lemma si_invs'[wp]: 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 sts_valid_queues setThreadState_ct_not_inQ - possibleSwitchTo_ksQ' possibleSwitchTo_ct_not_inQ hoare_vcg_all_lift sts_ksQ' + 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"] @@ -4059,8 +3963,7 @@ lemma si_invs'[wp]: 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' sts_valid_queues - setThreadState_ct_not_inQ) + 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") @@ -4079,8 +3982,7 @@ lemma si_invs'[wp]: 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' - sts_valid_queues setThreadState_ct_not_inQ) + 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) @@ -4106,19 +4008,15 @@ lemma si_invs'[wp]: lemma sfi_invs_plus': "\invs' and st_tcb_at' simple' t and sch_act_not t - and (\s. \p. t \ set (ksReadyQueues s p)) and ex_nonz_cap_to' t\ - sendFaultIPC t f - \\rv. invs'\, \\rv. invs' and st_tcb_at' simple' t - and (\s. \p. t \ set (ksReadyQueues s p)) - and sch_act_not t and (\s. ksIdleThread s \ t)\" + sendFaultIPC t f + \\_. invs'\, \\_. invs' and st_tcb_at' simple' t and sch_act_not t and (\s. ksIdleThread s \ t)\" apply (simp add: sendFaultIPC_def) apply (wp threadSet_invs_trivial threadSet_pred_tcb_no_state threadSet_cap_to' | wpc | simp)+ apply (rule_tac Q'="\rv s. invs' s \ sch_act_not t s \ st_tcb_at' simple' t s - \ (\p. t \ set (ksReadyQueues s p)) \ ex_nonz_cap_to' t s \ t \ ksIdleThread s \ (\r\zobj_refs' rv. ex_nonz_cap_to' r s)" @@ -4140,7 +4038,6 @@ lemma handleFault_corres: corres dc (einvs and st_tcb_at active thread and ex_nonz_cap_to thread and (\_. valid_fault f)) (invs' and sch_act_not thread - and (\s. \p. thread \ set(ksReadyQueues s p)) 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) @@ -4164,17 +4061,13 @@ lemma sts_invs_minor'': \ (st \ Inactive \ \ idle' st \ st' \ Inactive \ \ idle' st')) t and (\s. t = ksIdleThread s \ idle' st) - and (\s. (\p. t \ set (ksReadyQueues s p)) \ runnable' st) - and (\s. runnable' st \ obj_at' tcbQueued t s - \ st_tcb_at' runnable' t s) 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' sts_valid_queues - setThreadState_ct_not_inQ) + apply (wp valid_irq_node_lift sts_sch_act' setThreadState_ct_not_inQ) apply clarsimp apply (rule conjI) apply fastforce @@ -4189,12 +4082,11 @@ lemma sts_invs_minor'': apply (clarsimp dest!: st_tcb_at_state_refs_ofD' elim!: rsubst[where P=sym_refs] intro!: ext) - apply (clarsimp elim!: st_tcb_ex_cap'') + apply (fastforce elim!: st_tcb_ex_cap'') done lemma hf_invs' [wp]: "\invs' and sch_act_not t - and (\s. \p. t \ set(ksReadyQueues s p)) and st_tcb_at' simple' t and ex_nonz_cap_to' t and (\s. t \ ksIdleThread s)\ handleFault t f \\r. invs'\" diff --git a/proof/refine/AARCH64/KHeap_R.thy b/proof/refine/AARCH64/KHeap_R.thy index 0f62064b1a..67059315ff 100644 --- a/proof/refine/AARCH64/KHeap_R.thy +++ b/proof/refine/AARCH64/KHeap_R.thy @@ -14,8 +14,45 @@ lemma lookupAround2_known1: "m x = Some y \ fst (lookupAround2 x m) = Some (x, y)" by (fastforce simp: lookupAround2_char1) +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 + context begin interpretation Arch . (*FIXME: arch_split*) +lemma setObject_modify_variable_size: + fixes v :: "'a :: pspace_storable" shows + "\obj_at' (P :: 'a \ bool) p s; updateObject v = updateObject_default v; + (1 :: machine_word) < 2 ^ objBits v; obj_at' (\obj. objBits v = objBits obj) p s\ + \ setObject p v s = modify (ksPSpace_update (\ps. ps (p \ injectKO v))) s" + apply (clarsimp simp: setObject_def split_def exec_gets obj_at'_def lookupAround2_known1 + assert_opt_def updateObject_default_def bind_assoc) + apply (simp add: projectKO_def alignCheck_assert) + apply (simp add: project_inject objBits_def) + apply (clarsimp simp only: koTypeOf_injectKO) + apply (frule in_magnitude_check[where s'=s]) + apply blast + apply fastforce + apply (simp add: magnitudeCheck_assert in_monad bind_def gets_def oassert_opt_def + get_def return_def) + apply (simp add: simpler_modify_def) + done + +lemma setObject_modify: + fixes v :: "'a :: pspace_storable" shows + "\obj_at' (P :: 'a \ bool) p s; updateObject v = updateObject_default v; + (1 :: machine_word) < 2 ^ objBits v; \ko. P ko \ objBits ko = objBits v \ + \ setObject p v s = modify (ksPSpace_update (\ps. ps (p \ injectKO v))) s" + apply (rule setObject_modify_variable_size) + apply fastforce + apply fastforce + apply fastforce + unfolding obj_at'_def + by fastforce + lemma obj_at_getObject: assumes R: "\a b n ko s obj::'a::pspace_storable. @@ -137,8 +174,7 @@ lemma corres_get_tcb: apply (drule bspec) apply clarsimp apply blast - apply (clarsimp simp add: other_obj_relation_def - lookupAround2_known1) + apply (clarsimp simp: tcb_relation_cut_def lookupAround2_known1) done lemma lookupAround2_same1[simp]: @@ -436,6 +472,40 @@ lemma setObject_tcb_strongest: updateObject_default_def ps_clear_upd) done +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 opt_pred_def projectKO_opts_defs + split: if_split_asm + Structures_H.kernel_object.split_asm + +lemma setObject_endpoint_tcbs_of'[wp]: + "setObject c (endpoint :: endpoint) \\s. P' (tcbs_of' s)\" + by setObject_easy_cases + +lemma setObject_notification_tcbs_of'[wp]: + "setObject c (notification :: notification) \\s. P' (tcbs_of' s)\" + by setObject_easy_cases + +lemma setObject_cte_tcbSchedNexts_of[wp]: + "setObject c (cte :: cte) \\s. P' (tcbSchedNexts_of s)\" + by setObject_easy_cases + +lemma setObject_cte_tcbSchedPrevs_of[wp]: + "setObject c (cte :: cte) \\s. P' (tcbSchedPrevs_of s)\" + by setObject_easy_cases + +lemma setObject_cte_tcbQueued[wp]: + "setObject c (cte :: cte) \\s. P' (tcbQueued |< tcbs_of' s)\" + supply inQ_def[simp] + by setObject_easy_cases + +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 getObject_obj_at': assumes x: "\q n ko. loadObject p q n ko = (loadObject_default p q n ko :: ('a :: pspace_storable) kernel)" @@ -939,7 +1009,7 @@ lemma obj_relation_cut_same_type: \ (\pt_t pt_t'. a_type ko = AArch (APageTable pt_t) \ a_type ko' = AArch (APageTable pt_t'))" apply (rule ccontr) apply (simp add: obj_relation_cuts_def2 a_type_def) - apply (auto simp: other_obj_relation_def cte_relation_def pte_relation_def + apply (auto simp: other_obj_relation_def tcb_relation_cut_def cte_relation_def pte_relation_def split: Structures_A.kernel_object.split_asm if_split_asm Structures_H.kernel_object.split_asm arch_kernel_obj.split_asm arch_kernel_object.split_asm) @@ -956,6 +1026,16 @@ 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\ + \ tcbs_of' (s'\ksPSpace := (ksPSpace s')(ptr \ ko)\) = tcbs_of' s'" + by (fastforce simp: typ_at'_def ko_wp_at'_def opt_map_def projectKO_opts_defs + split: kernel_object.splits) + +lemma typ_at'_koTypeOf: + "ko_at' ob' ptr b \ typ_at' (koTypeOf (injectKO ob')) ptr b" + by (auto simp: typ_at'_def ko_wp_at'_def obj_at'_def project_inject) + lemma setObject_other_corres: fixes ob' :: "'a :: pspace_storable" assumes x: "updateObject ob' = updateObject_default ob'" @@ -985,7 +1065,7 @@ lemma setObject_other_corres: 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 (extract_conjunct \match conclusion in "ghost_relation _ _ _ _" \ -\) apply (clarsimp simp add: ghost_relation_def) apply (erule_tac x=ptr in allE)+ apply (clarsimp simp: obj_at_def a_type_def @@ -995,6 +1075,14 @@ lemma setObject_other_corres: apply (simp only: pspace_relation_def pspace_dom_update dom_fun_upd2 simp_thms) apply (elim conjE) apply (frule bspec, erule domI) + apply (prop_tac "typ_at' (koTypeOf (injectKO ob')) ptr b") + subgoal + by (clarsimp simp: typ_at'_def ko_wp_at'_def obj_at'_def projectKO_opts_defs + 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 clarsimp apply (rule conjI) apply (rule ballI, drule(1) bspec) apply (drule domD) @@ -1003,31 +1091,30 @@ lemma setObject_other_corres: apply clarsimp apply (frule_tac ko'=ko and x'=ptr in obj_relation_cut_same_type, (fastforce simp add: is_other_obj_relation_type t)+) - apply (erule disjE) - apply (simp add: is_other_obj_relation_type t) - apply (erule disjE) - apply (insert t, clarsimp simp: is_other_obj_relation_type_CapTable a_type_def) - apply (erule disjE) - apply (insert t, clarsimp simp: is_other_obj_relation_type_UserData a_type_def) - apply (erule disjE) - apply (insert t, clarsimp simp: is_other_obj_relation_type_DeviceData a_type_def) - apply (insert t, clarsimp simp: is_other_obj_relation_type_PageTable a_type_def) - 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) - (* FIXME AARCH64: slow due to multiple (too many?) splits *) - apply (case_tac ob; - simp 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)+ - done + apply (insert t) + apply ((erule disjE + | 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)[1] + 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 map_to_ctes_upd_other is_other_obj_relation_type_def @@ -1117,13 +1204,14 @@ lemma typ_at'_valid_obj'_lift: 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, + 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 valid_bound_ntfn'_def - split: option.splits, - wpsimp) + 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 wp done @@ -1404,32 +1492,6 @@ lemma set_ep_bitmapQ_no_L2_orphans[wp]: apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp add: bitmapQ_def)+ done -lemma set_ep_valid_queues[wp]: - "\Invariants_H.valid_queues\ setEndpoint epptr ep \\rv. Invariants_H.valid_queues\" - apply (simp add: Invariants_H.valid_queues_def) - apply (wp hoare_vcg_conj_lift) - apply (simp add: setEndpoint_def valid_queues_no_bitmap_def) - apply (wp hoare_Ball_helper hoare_vcg_all_lift) - apply (rule obj_at_setObject2) - apply (clarsimp simp: updateObject_default_def in_monad) - apply (wp updateObject_default_inv set_ep_valid_bitmapQ[unfolded setEndpoint_def] - | simp add: valid_queues_no_bitmap_def)+ - done - -lemma set_ep_valid_queues'[wp]: - "\valid_queues'\ setEndpoint epptr ep \\rv. valid_queues'\" - apply (unfold setEndpoint_def) - apply (simp only: valid_queues'_def imp_conv_disj - obj_at'_real_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - apply (rule setObject_ko_wp_at) - apply simp - apply (simp add: objBits_simps') - apply simp - apply (wp updateObject_default_inv | simp)+ - apply (clarsimp simp: ko_wp_at'_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\" @@ -1687,34 +1749,6 @@ lemma set_ntfn_bitmapQ_no_L2_orphans[wp]: apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp)+ done -lemma set_ntfn_valid_queues[wp]: - "\Invariants_H.valid_queues\ setNotification p ntfn \\rv. Invariants_H.valid_queues\" - apply (simp add: Invariants_H.valid_queues_def) - apply (rule hoare_pre) - apply (wp hoare_vcg_conj_lift) - apply (simp add: setNotification_def valid_queues_no_bitmap_def) - apply (wp hoare_Ball_helper hoare_vcg_all_lift) - apply (rule obj_at_setObject2) - apply (clarsimp simp: updateObject_default_def in_monad) - apply (wp updateObject_default_inv set_ep_valid_bitmapQ[unfolded setEndpoint_def] - | simp add: valid_queues_no_bitmap_def)+ - done - -lemma set_ntfn_valid_queues'[wp]: - "\valid_queues'\ setNotification p ntfn \\rv. valid_queues'\" - apply (unfold setNotification_def) - apply (rule setObject_ntfn_pre) - apply (simp only: valid_queues'_def imp_conv_disj - obj_at'_real_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - apply (rule setObject_ko_wp_at) - apply simp - apply (simp add: objBits_simps') - apply simp - apply (wp updateObject_default_inv | simp)+ - apply (clarsimp simp: ko_wp_at'_def) - 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)))\ @@ -2127,6 +2161,21 @@ lemma setNotification_ct_idle_or_in_cur_domain'[wp]: crunch gsUntypedZeroRanges[wp]: setNotification "\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)\" + assumes nexts: "\P. f \\s. P (tcbSchedNexts_of s)\" + shows "f \sym_heap_sched_pointers\" + by (rule_tac f=tcbSchedPrevs_of in hoare_lift_Pf2; wpsimp wp: assms) + +crunches setNotification + for tcbSchedNexts_of[wp]: "\s. P (tcbSchedNexts_of s)" + and tcbSchedPrevs_of[wp]: "\s. P (tcbSchedPrevs_of s)" + and valid_sched_pointers[wp]: valid_sched_pointers + and ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" + and ksReadyQueuesL1Bitmap[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" + and ksReadyQueuesL2Bitmap[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" + (simp: updateObject_default_def) + lemma set_ntfn_minor_invs': "\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)) @@ -2136,9 +2185,10 @@ lemma set_ntfn_minor_invs': and (\s. ptr \ ksIdleThread s) \ setNotification ptr val \\rv. invs'\" - apply (clarsimp simp add: invs'_def valid_state'_def cteCaps_of_def) - apply (wp irqs_masked_lift valid_irq_node_lift untyped_ranges_zero_lift, - simp_all add: o_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')+ @@ -2180,6 +2230,29 @@ lemma idle_is_global [intro!]: "ksIdleThread s \ global_refs' s" by (simp add: global_refs'_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 project_inject pspace_distinct'_def pspace_aligned'_def) + apply (drule bspec, erule domI)+ + apply (clarsimp simp: objBits_simps' word_bits_def + split: kernel_object.splits arch_kernel_object.splits) + done + +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 + +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) + lemma valid_globals_cte_wpD': "\ valid_global_refs' s; cte_wp_at' P p s \ \ \cte. P cte \ ksIdleThread s \ capRange (cteCap cte)" @@ -2223,19 +2296,17 @@ crunch typ_at'[wp]: doMachineOp "\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)\" - "\\s. P (state_hyp_refs_of' s)\ doMachineOp m \\rv s. P (state_hyp_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'\" - by (simp add: doMachineOp_def split_def - valid_pspace'_def valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs - | wp cur_tcb_lift sch_act_wf_lift tcb_in_cur_domain'_lift + "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 \\s. P (state_hyp_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 obj_at'[wp]: doMachineOp "\s. P (obj_at' P' p s)" diff --git a/proof/refine/AARCH64/Refine.thy b/proof/refine/AARCH64/Refine.thy index 3c6a30033a..798816a7ed 100644 --- a/proof/refine/AARCH64/Refine.thy +++ b/proof/refine/AARCH64/Refine.thy @@ -78,7 +78,7 @@ lemma typ_at_UserDataI: apply clarsimp apply (subst mask_lower_twice [where n = pageBits, OF pbfs_atleast_pageBits, symmetric]) apply (clarsimp simp: obj_relation_cuts_def2 pte_relation_def - cte_relation_def other_obj_relation_def + cte_relation_def other_obj_relation_def tcb_relation_cut_def split: Structures_A.kernel_object.split_asm Structures_H.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) @@ -107,7 +107,7 @@ lemma typ_at_DeviceDataI: apply clarsimp apply (subst mask_lower_twice [where n = pageBits, OF pbfs_atleast_pageBits, symmetric]) apply (clarsimp simp: obj_relation_cuts_def2 pte_relation_def - cte_relation_def other_obj_relation_def + cte_relation_def other_obj_relation_def tcb_relation_cut_def split: Structures_A.kernel_object.split_asm Structures_H.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) @@ -589,7 +589,7 @@ lemma kernel_corres': apply simp apply (rule handleInterrupt_corres[simplified dc_def]) apply simp - apply (wp hoare_drop_imps hoare_vcg_all_lift)[1] + 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' \ @@ -668,7 +668,7 @@ lemma entry_corres: apply (rule corres_split[OF getCurThread_corres]) apply (rule corres_split) apply simp - apply (rule threadset_corresT) + 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 cteSizeBits_def) diff --git a/proof/refine/AARCH64/Retype_R.thy b/proof/refine/AARCH64/Retype_R.thy index a0e7b99a12..990910c38f 100644 --- a/proof/refine/AARCH64/Retype_R.thy +++ b/proof/refine/AARCH64/Retype_R.thy @@ -309,7 +309,7 @@ lemma state_relation_null_filterE: null_filter (caps_of_state t) = null_filter (caps_of_state s); null_filter' (ctes_of t') = null_filter' (ctes_of s'); pspace_relation (kheap t) (ksPSpace t'); - ekheap_relation (ekheap t) (ksPSpace t'); + ekheap_relation (ekheap t) (ksPSpace t'); ready_queues_relation t t'; ghost_relation (kheap t) (gsUserPages t') (gsCNodes t') (gsPTTypes (ksArchState t')); valid_list s; pspace_aligned' s'; pspace_distinct' s'; valid_objs s; valid_mdb s; @@ -997,7 +997,7 @@ lemma retype_ekheap_relation: apply (intro impI conjI) apply clarsimp apply (drule_tac x=a in bspec,force) - apply (clarsimp simp add: other_obj_relation_def split: if_split_asm) + apply (clarsimp simp: 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 AARCH64_H.object_type.splits @@ -1179,6 +1179,11 @@ lemma ksMachineState_update_gs[simp]: by (simp add: update_gs_def split: aobject_type.splits Structures_A.apiobject_type.splits) +lemma ksReadyQueues_update_gs[simp]: + "ksReadyQueues (update_gs tp us addrs s) = ksReadyQueues s" + by (simp add: update_gs_def + split: aobject_type.splits Structures_A.apiobject_type.splits) + lemma update_gs_ksMachineState_update_swap: "update_gs tp us addrs (ksMachineState_update f s) = ksMachineState_update f (update_gs tp us addrs s)" @@ -1205,6 +1210,144 @@ lemma update_gs_simps[simp]: (\as. gsPTTypes_update (\pt_types x. if x \ ptrs then Some VSRootPT_T else pt_types x) as)" by (simp_all add: update_gs_def) +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 - + 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_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 "\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 (fastforce simp: ptr_add_def p_assoc_help) + done +qed + +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 + "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 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 + 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_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 + "tcbSchedNexts_of + (s'\ksPSpace := foldr (\addr. data_map_insert addr ko) (new_cap_addrs m ptr ko) (ksPSpace s')\) + = tcbSchedNexts_of s'" +proof - + 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 + 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 + 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 + by (cases ty; + fastforce simp add: makeObjectKO_def makeObject_tcb + 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" @@ -1233,7 +1376,7 @@ lemma retype_state_relation: \ state_relation" (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) + 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 ko] num_r]) @@ -1472,6 +1615,16 @@ lemma retype_state_relation: apply fastforce apply (rule_tac x=id in exI, simp)+ done + + have rdyqrel: "ready_queues_relation s s'" + using sr by (simp add: state_relation_def) + + thus "ready_queues_relation_2 (ready_queues s) (ksReadyQueues s') + (?ps' |> tcb_of' |> tcbSchedNext) (?ps' |> tcb_of' |> tcbSchedPrev) + (\d p. inQ d p |< (?ps' |> tcb_of'))" + using retype_ready_queues_relation[OF _ vs' pn' ko cover num_r] + by (clarsimp simp: ready_queues_relation_def Let_def) + qed lemma new_cap_addrs_fold': @@ -2491,7 +2644,6 @@ qed lemma other_objs_default_relation: "\ case ty of Structures_A.EndpointObject \ ko = injectKO (makeObject :: endpoint) | Structures_A.NotificationObject \ ko = injectKO (makeObject :: Structures_H.notification) - | Structures_A.TCBObject \ ko = injectKO (makeObject :: tcb) | _ \ False \ \ obj_relation_retype (default_object ty dev n) ko" apply (rule obj_relation_retype_other_obj) @@ -2512,6 +2664,14 @@ lemma other_objs_default_relation: split: Structures_A.apiobject_type.split_asm) done +lemma tcb_relation_retype: + "obj_relation_retype (default_object Structures_A.TCBObject dev n) (KOTCB makeObject)" + by (clarsimp simp: tcb_relation_cut_def default_object_def obj_relation_retype_def + tcb_relation_def default_tcb_def + makeObject_tcb makeObject_cte new_context_def newContext_def newFPUState_def + fault_rel_optionation_def initContext_def default_priority_def + default_arch_tcb_def newArchTCB_def arch_tcb_relation_def objBits_simps') + lemma captable_relation_retype: "n < word_bits \ obj_relation_retype (default_object Structures_A.CapTableObject dev n) (KOCTE makeObject)" @@ -3189,10 +3349,10 @@ proof (intro conjI impI) apply (rule_tac ptr="x + xa" in cte_wp_at_tcbI', assumption+) apply fastforce apply simp - apply (rename_tac thread_state mcp priority bool option nat cptr vptr bound user_context) - apply (case_tac thread_state, simp_all add: valid_tcb_state'_def - valid_bound_ntfn'_def obj_at_disj' - split: option.splits)[2] + 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 (clarsimp simp add: valid_arch_tcb'_def typ_at_to_obj_at_arches obj_at_disj') apply (simp add: valid_cte'_def) apply (frule pspace_alignedD' [OF _ ad(1)]) @@ -3458,12 +3618,12 @@ lemma createNewCaps_cte_wp_at2: \\rv s. P (cte_wp_at' P' p s)\" including classic_wp_pre apply (simp add: createNewCaps_def createObjects_def AARCH64_H.toAPIType_def - split del: if_split) + split del: if_split) apply (case_tac ty; simp add: createNewCaps_def createObjects_def Arch_createNewCaps_def 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) + apply (wp, simp add:createObjects_def) apply ((wp createObjects_orig_cte_wp_at2'[where sz = sz] mapM_x_wp' threadSet_cte_wp_at2')+ | assumption @@ -3925,16 +4085,6 @@ lemma sch_act_wf_lift_asm: apply auto done -lemma valid_queues_lift_asm': - assumes tat: "\d p t. \\s. \ obj_at' (inQ d p) t s \ Q d p s\ f \\_ s. \ obj_at' (inQ d p) t s\" - and prq: "\P. \\s. P (ksReadyQueues s)\ f \\_ s. P (ksReadyQueues s)\" - shows "\\s. valid_queues' s \ (\d p. Q d p s)\ f \\_. valid_queues'\" - apply (simp only: valid_queues'_def imp_conv_disj) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift - tat prq) - apply simp - done - lemma createObjects'_ct[wp]: "\\s. P (ksCurThread s)\ createObjects' p n v us \\rv s. P (ksCurThread s)\" by (rule createObjects_pspace_only, simp) @@ -4240,34 +4390,146 @@ crunch irq_states' [wp]: createNewCaps valid_irq_states' crunch ksMachine[wp]: createObjects "\s. P (ksMachineState s)" (simp: crunch_simps unless_def) -lemma createNewCaps_valid_queues': - "\valid_queues' and pspace_no_overlap' ptr sz - 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_queues'\" - apply (wp valid_queues_lift_asm' [OF createNewCaps_obj_at2]) - apply (clarsimp) - apply (simp add: makeObjectKO_def - split: object_type.split_asm - apiobject_type.split_asm) - apply (clarsimp simp: inQ_def) - apply (auto simp: makeObject_tcb - split: object_type.splits apiobject_type.splits) - done - -lemma createNewCaps_valid_queues: - "\valid_queues and pspace_no_overlap' ptr sz - 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_queues\" - apply (rule hoare_gen_asm) - apply (wpsimp wp: valid_queues_lift_asm createNewCaps_obj_at2[where sz=sz]) - apply (simp add: inQ_def) - apply (wp createNewCaps_pred_tcb_at'[where sz=sz] | simp)+ +lemma createObjects_valid_bitmaps: + "createObjects' ptr n val gbits \valid_bitmaps\" + apply (clarsimp simp: createObjects'_def alignError_def split_def) + apply (wp case_option_wp[where P="\_. P" and P'=P for P, simplified] assert_inv + | clarsimp simp del: fun_upd_apply)+ + apply (clarsimp simp: valid_bitmaps_def valid_bitmapQ_def bitmapQ_def bitmapQ_no_L2_orphans_def + bitmapQ_no_L1_orphans_def) + done + +lemma valid_bitmaps_gsCNodes_update[simp]: + "valid_bitmaps (gsCNodes_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) + +lemma valid_bitmaps_gsUserPages_update[simp]: + "valid_bitmaps (gsUserPages_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) + +crunches curDomain + for valid_bitmaps[wp]: valid_bitmaps + and sched_pointers[wp]: "\s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)" + and valid_sched_pointers[wp]: valid_sched_pointers + +lemma createNewCaps_valid_bitmaps: + "\\s. valid_pspace' s \ pspace_no_overlap' ptr sz s \ valid_bitmaps s\ + createNewCaps ty ptr n us dev + \\_. valid_bitmaps\" + unfolding createNewCaps_def + apply (clarsimp simp: 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 (wpsimp wp: createObjects_valid_bitmaps) + by (wpsimp wp: createObjects_valid_bitmaps[simplified o_def] mapM_x_wp + | simp add: makeObject_tcb objBits_def createObjects_def + | intro conjI impI)+ + +lemma createObjects_sched_queues: + "\\s. n \ 0 + \ range_cover ptr sz (objBitsKO val + gbits) n + \ P (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ (case val of KOTCB tcb \ tcbSchedNext tcb = None \ tcbSchedPrev tcb = None + | _ \ True) + \ pspace_aligned' s \ pspace_distinct' s + \ pspace_no_overlap' ptr sz s\ + createObjects' ptr n val gbits + \\_ s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" + (is "\ \s. _ \ _ \ ?Pre s \ _ \\_. _\") +proof (rule hoare_grab_asm)+ + 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 \\_ s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" + proof - + have shiftr_not_zero:" 1 \ ((of_nat n)::machine_word) << gbits" + using range_cover_not_zero_shift[OF not_0 cover,where gbits = gbits] + by (simp add:word_le_sub1) + show ?thesis + apply (clarsimp simp: createObjects'_def unless_def alignError_def split_def) + apply (wp | clarsimp simp del: fun_upd_apply)+ + 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 (clarsimp simp: foldr_upd_app_if) + apply (rule_tac a="tcbSchedNexts_of s" and b="tcbSchedPrevs_of s" + in rsubst2[rotated, OF sym sym, where P=P]) + apply (rule ext) + apply (clarsimp simp: opt_map_def) + apply (frule (3) retype_ksPSpace_None[simplified mult.commute]) + apply (fastforce intro: cover) + apply fastforce + apply (clarsimp split: kernel_object.splits option.splits) + apply (rule ext) + apply (clarsimp simp: opt_map_def) + apply (frule (3) retype_ksPSpace_None[simplified mult.commute]) + apply (fastforce intro: cover) + apply fastforce + apply (clarsimp split: kernel_object.splits option.splits) + apply simp + done + qed +qed + +lemma createNewCaps_sched_queues: + assumes cover: "range_cover ptr sz (APIType_capBits ty us) n" + assumes not_0: "n \ 0" + shows + "\\s. valid_pspace' s \ pspace_no_overlap' ptr sz s + \ P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\ + createNewCaps ty ptr n us dev + \\_ s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" + unfolding createNewCaps_def + apply (clarsimp simp: AARCH64_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 (wp, simp) + apply (insert cover not_0) + apply (wpsimp wp: mapM_x_wp' createObjects_sched_queues threadSet_sched_pointers + simp: curDomain_def createObjects_def) + apply (simp add: valid_pspace'_def objBits_simps APIType_capBits_def makeObject_tcb) + by (wpsimp wp: mapM_x_wp' createObjects_sched_queues threadSet_sched_pointers + simp: createObjects_def valid_pspace'_def objBits_simps APIType_capBits_def + split_del: if_split, + fastforce simp add: mult_2 add_ac)+ + +lemma createObjects_valid_sched_pointers: + "\\s. valid_sched_pointers s + \ (case val of KOTCB tcb \ tcbSchedNext tcb = None \ tcbSchedPrev tcb = None + | _ \ True)\ + createObjects' ptr n val gbits + \\_. valid_sched_pointers\" + apply (clarsimp simp: createObjects'_def unless_def alignError_def split_def) + apply (wp case_option_wp[where P="\_. P" and P'=P for P, simplified] assert_inv + | clarsimp simp del: fun_upd_apply)+ + apply (clarsimp simp: valid_sched_pointers_def foldr_upd_app_if opt_pred_def opt_map_def comp_def) + apply (cases "tcb_of' val"; clarsimp) done +lemma createNewCaps_valid_sched_pointers: + "\\s. valid_pspace' s \ pspace_no_overlap' ptr sz s \ valid_sched_pointers s\ + createNewCaps ty ptr n us dev + \\_. valid_sched_pointers\" + unfolding createNewCaps_def + apply (clarsimp simp: 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 (wpsimp wp: createObjects_valid_sched_pointers) + by (wpsimp wp: createObjects_valid_sched_pointers[simplified o_def] mapM_x_wp + threadSet_valid_sched_pointers + | simp add: makeObject_tcb objBits_def createObjects_def + | intro conjI impI)+ + lemma mapM_x_threadSet_valid_pspace: "\valid_pspace' and K (curdom \ maxDomain)\ mapM_x (threadSet (tcbDomain_update (\_. curdom))) addrs \\y. valid_pspace'\" @@ -4635,12 +4897,13 @@ proof (rule hoare_gen_asm, elim conjE) createNewCaps_valid_arch_state valid_irq_node_lift_asm [unfolded pred_conj_def, OF _ createNewCaps_obj_at'] createNewCaps_irq_handlers' createNewCaps_vms - createNewCaps_valid_queues - createNewCaps_valid_queues' createNewCaps_pred_tcb_at' cnc_ct_not_inQ createNewCaps_ct_idle_or_in_cur_domain' createNewCaps_sch_act_wf createNewCaps_urz[where sz=sz] + createNewCaps_sched_queues[OF cover not_0] + createNewCaps_valid_sched_pointers + createNewCaps_valid_bitmaps | simp)+ using not_0 apply (clarsimp simp: valid_pspace'_def) @@ -4713,35 +4976,6 @@ lemma createObjects_sch: apply (wp sch_act_wf_lift_asm createObjects_pred_tcb_at' createObjects_orig_obj_at3 | force)+ done -lemma createObjects_queues: - "\\s. valid_queues 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. valid_queues\" - apply (wpsimp wp: valid_queues_lift_asm [unfolded pred_conj_def, OF createObjects_orig_obj_at3] - createObjects_pred_tcb_at' [unfolded pred_conj_def]) - apply fastforce - apply wp+ - apply fastforce - done - -lemma createObjects_queues': - assumes no_tcb: "\t. projectKO_opt val \ Some (t::tcb)" - shows - "\\s. valid_queues' 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. valid_queues'\" - apply (simp add: createObjects_def) - apply (wp valid_queues_lift_asm') - apply (wp createObjects_orig_obj_at2') - apply clarsimp - apply assumption - apply wp - using no_tcb - apply fastforce - done - lemma createObjects_no_cte_ifunsafe': assumes no_cte: "\c. projectKO_opt val \ Some (c::cte)" assumes no_tcb: "\t. projectKO_opt val \ Some (t::tcb)" @@ -4972,50 +5206,61 @@ proof - apply (rule hoare_weaken_pre) apply (wps createObjects_ct) apply (wp createObjects_obj_at_other) - apply (simp)+ + apply (simp)+ done show ?thesis - 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 createObjects_queues) - 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_state_hyp_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' - createObjects_queues' [OF no_tcb] - 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' - createObjects_queues' [OF no_tcb] 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 - using no_cte no_tcb - apply ((intro conjI; assumption?); simp add: valid_pspace'_def objBits_def) - apply (fastforce simp add: split_def split: option.splits) - apply (clarsimp simp: invs'_def no_tcb valid_state'_def no_cte split: option.splits) - 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_state_hyp_refs_of'') + apply (rule hoare_vcg_conj_lift) + apply (simp add: createObjects_def) + apply (wp createObjects_iflive') + apply (wp createObjects_no_cte_ifunsafe' assms) + apply (rule hoare_vcg_conj_lift) + apply (simp add: createObjects_def) + apply (wp createObjects_idle') + apply (wpsimp wp: irqs_masked_lift createObjects_no_cte_valid_global + createObjects_valid_arch createObjects_irq_state + createObjects_no_cte_irq_handlers assms) + 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 (wp createObjects_idle') + 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' + createObjects_pspace_domain_valid co_ct_not_inQ + createObjects_ct_idle_or_in_cur_domain' + createObjects_untyped_ranges_zero'[OF moKO] + assms + createObjects_sched_queues + | simp)+ + using no_cte no_tcb + apply (clarsimp simp: valid_pspace'_def) + apply (extract_conjunct \match conclusion in "pspace_no_overlap' ptr ?x _" \ -\, assumption)+ + apply (extract_conjunct \match conclusion in "range_cover ptr ?x ?y _" \ -\, assumption) + apply simp + apply (rule conjI, fastforce simp add: split_def split: option.splits) + by (auto simp: invs'_def no_tcb valid_state'_def no_cte + split: option.splits kernel_object.splits) qed lemma corres_retype_update_gsI: @@ -5051,7 +5296,7 @@ lemma gcd_corres: "corres (=) \ \ (gets cur_domain) curDomain" 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. 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 @@ -5062,7 +5307,7 @@ lemma retype_region2_extra_ext_mapM_x_corres: 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. tcb_at' t s" + and P'="\s. \t \ set addrs. obj_at' (Not \ tcbQueued) t s" in corres_mapM_x) apply simp apply (rule corres_guard_imp) @@ -5070,8 +5315,10 @@ lemma retype_region2_extra_ext_mapM_x_corres: apply (case_tac tcb') apply simp apply fastforce - 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 @@ -5104,10 +5351,11 @@ lemma retype_region2_obj_at: apply (auto simp: obj_at_def default_object_def is_tcb_def) done -lemma createObjects_tcb_at': +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\ - createObjects ptr n (KOTCB makeObject) 0 \\ptrs s. \addr\set ptrs. tcb_at' addr 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 project_inject objBitsKO_def objBits_def makeObject_tcb) done @@ -5172,8 +5420,9 @@ lemma corres_retype_region_createNewCaps: apply (rule corres_retype[where 'a = tcb], simp_all add: obj_bits_api_def objBits_simps' pageBits_def APIType_map2_def makeObjectKO_def - other_objs_default_relation)[1] + tcb_relation_retype)[1] apply (fastforce simp: range_cover_def) + apply (simp add: tcb_relation_retype) apply (rule corres_split_nor) apply (simp add: APIType_map2_def) apply (rule retype_region2_extra_ext_mapM_x_corres) @@ -5183,7 +5432,7 @@ lemma corres_retype_region_createNewCaps: apply wp apply wp apply ((wp retype_region2_obj_at | simp add: APIType_map2_def)+)[1] - apply ((wp createObjects_tcb_at'[where sz=sz] + apply ((wp createObjects_Not_tcbQueued[where sz=sz] | simp add: APIType_map2_def objBits_simps' obj_bits_api_def)+)[1] apply simp apply simp diff --git a/proof/refine/AARCH64/Schedule_R.thy b/proof/refine/AARCH64/Schedule_R.thy index b8e0b34b28..8be19706b7 100644 --- a/proof/refine/AARCH64/Schedule_R.thy +++ b/proof/refine/AARCH64/Schedule_R.thy @@ -16,11 +16,6 @@ declare hoare_weak_lift_imp[wp_split del] (* Levity: added (20090713 10:04:12) *) declare sts_rel_idle [simp] -lemma invs_no_cicd'_queues: - "invs_no_cicd' s \ valid_queues s" - unfolding invs_no_cicd'_def - by simp - 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)" @@ -131,7 +126,7 @@ lemma ko_tcb_cross: apply normalise_obj_at' apply (clarsimp simp: state_relation_def pspace_relation_def obj_at_def) apply (drule bspec, fastforce) - apply (clarsimp simp: other_obj_relation_def obj_at'_def) + apply (clarsimp simp: tcb_relation_cut_def obj_at'_def) done (* FIXME AARCH64: move *) @@ -195,275 +190,259 @@ lemma schedule_choose_new_thread_sched_act_rct[wp]: unfolding schedule_choose_new_thread_def by wp +\ \This proof shares many similarities with the proof of @{thm tcbSchedEnqueue_corres}\ lemma tcbSchedAppend_corres: - notes trans_state_update'[symmetric, simp del] - shows - "corres dc (is_etcb_at t and tcb_at t and pspace_aligned and pspace_distinct) - (Invariants_H.valid_queues and valid_queues') - (tcb_sched_action (tcb_sched_append) t) (tcbSchedAppend t)" - apply (rule corres_cross_over_guard[where P'=Q and Q="tcb_at' t and Q" for Q]) - apply (fastforce simp: tcb_at_cross state_relation_def) - apply (simp only: tcbSchedAppend_def tcb_sched_action_def) - apply (rule corres_symb_exec_r [OF _ _ threadGet_inv, 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, simp) - apply (rule no_fail_pre, wp, simp) - apply (case_tac queued) - apply (simp add: unless_def when_def) - apply (rule corres_no_failI) - apply wp+ - apply (clarsimp simp: in_monad ethread_get_def gets_the_def bind_assoc - assert_opt_def exec_gets is_etcb_at_def get_etcb_def get_tcb_queue_def - set_tcb_queue_def simpler_modify_def) - - apply (subgoal_tac "tcb_sched_append t (ready_queues a (tcb_domain y) (tcb_priority y)) - = (ready_queues a (tcb_domain y) (tcb_priority y))") - apply (simp add: state_relation_def ready_queues_relation_def) - apply (clarsimp simp: tcb_sched_append_def state_relation_def - valid_queues'_def ready_queues_relation_def - ekheap_relation_def etcb_relation_def - obj_at'_def inQ_def project_inject) - apply (drule_tac x=t in bspec,clarsimp) + "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_append tcb_ptr) (tcbSchedAppend 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_append_def get_tcb_queue_def + tcbSchedAppend_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]; 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) + 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 (clarsimp simp: unless_def when_def cong: if_cong) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres) - apply (simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres) - apply (simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply simp - apply (rule getQueue_corres) - apply (rule corres_split_noop_rhs2) - apply (simp add: tcb_sched_append_def) - apply (intro conjI impI) - apply (rule corres_guard_imp) - apply (rule setQueue_corres) - prefer 3 - apply (rule_tac P=\ and Q="K (t \ set queuea)" in corres_assume_pre) - apply simp - apply simp - apply simp - apply (rule corres_split_noop_rhs2) - apply (rule addToBitmap_if_null_noop_corres) - apply (rule threadSet_corres_noop, simp_all add: tcb_relation_def exst_same_def)[1] - apply wp+ - apply (wp getObject_tcb_wp | simp add: threadGet_def)+ - apply (fastforce simp: valid_queues_def valid_queues_no_bitmap_def obj_at'_def inQ_def - project_inject) - done + apply (rule corres_symb_exec_r[OF _ threadGet_sp]; (solves wpsimp)?) + apply (rule corres_symb_exec_r[OF _ threadGet_sp]; (solves wpsimp)?) + apply (rule corres_symb_exec_r[OF _ gets_sp]; (solves wpsimp)?) + \ \break off the addToBitmap\ + apply (rule corres_add_noop_lhs) + apply (rule corres_underlying_split[rotated 2, + where Q="\_. P" and P=P and Q'="\_. P'" and P'=P' for P P']) -crunches tcbSchedEnqueue, tcbSchedAppend, tcbSchedDequeue - for valid_pspace'[wp]: valid_pspace' - and valid_arch_state'[wp]: valid_arch_state' - (simp: unless_def) + apply wpsimp + apply (wpsimp wp: hoare_vcg_if_lift hoare_vcg_ex_lift) + apply (corres corres: addToBitmap_if_null_noop_corres) + + apply (rule corres_from_valid_det) + apply (fastforce intro: det_wp_modify det_wp_pre simp: set_tcb_queue_def) + apply (wpsimp simp: tcbQueueAppend_def wp: hoare_vcg_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'_tcbQueueEnd_ksReadyQueues simp: obj_at'_def) + + apply (rename_tac s rv t) + apply (clarsimp simp: state_relation_def) + apply (intro hoare_vcg_conj_lift_pre_fix; + (solves \frule singleton_eqD, frule set_tcb_queue_projs_inv, wpsimp simp: swp_def\)?) + + \ \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 simp: setQueue_def tcbQueueAppend_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) + 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 obj_at'_tcbQueueEnd_ksReadyQueues) + apply fast + apply fast + apply fastforce + apply fastforce + apply (cut_tac xs="ready_queues s d p" in heap_path_head') + apply (force dest!: spec simp: list_queue_relation_def) + 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) + apply (metis inQ_def option.simps(5) tcb_of'_TCB) + apply (intro conjI impI; clarsimp) + + \ \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 (tcbQueueEnd (ksReadyQueues s' (tcb_domain etcb, tcb_priority etcb))) + \ set (ready_queues s d p)") + apply (erule orthD2) + apply (drule_tac x="tcb_domain etcb" in spec) + apply (drule_tac x="tcb_priority etcb" in spec) + apply clarsimp + apply (drule_tac x="the (tcbQueueEnd (ksReadyQueues s' (tcb_domain etcb, tcb_priority etcb)))" + in spec) + subgoal by (auto simp: in_opt_pred opt_map_red) + 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"; + clarsimp 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 split: if_splits) + apply (case_tac "t = the (tcbQueueEnd (ksReadyQueues s' (tcb_domain etcb, tcb_priority etcb)))") + apply (clarsimp simp: inQ_def opt_pred_def fun_upd_apply) + 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 tcb \ p = tcb_priority tcb\ + 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) + apply (frule valid_tcbs'_maxPriority[where t=tcbPtr], simp add: obj_at'_def) + 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) + apply (intro conjI; clarsimp) + + \ \the ready queue was originally empty\ + apply (force simp: inQ_def in_opt_pred fun_upd_apply opt_map_def obj_at'_def + queue_end_valid_def prev_queue_head_def + split: if_splits option.splits) + + \ \the ready queue was not originally empty\ + apply (drule (2) heap_ls_append[where new=tcbPtr]) + apply (rule conjI) + apply (clarsimp simp: fun_upd_apply queue_end_valid_def opt_map_def split: if_splits) + apply (rule conjI) + apply (clarsimp simp: fun_upd_apply queue_end_valid_def) + apply (rule conjI) + apply (subst opt_map_upd_triv) + apply (clarsimp simp: opt_map_def fun_upd_apply queue_end_valid_def split: if_splits) + apply (clarsimp simp: prev_queue_head_def fun_upd_apply split: if_splits) + by (clarsimp simp: inQ_def in_opt_pred fun_upd_apply queue_end_valid_def split: if_splits) + +lemma tcbQueueAppend_valid_objs'[wp]: + "\\s. valid_objs' s \ tcb_at' tcbPtr s \ (\end. tcbQueueEnd queue = Some end \ tcb_at' end s)\ + tcbQueueAppend queue tcbPtr + \\_. valid_objs'\" + unfolding tcbQueueAppend_def + apply (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') + apply (clarsimp simp: tcbQueueEmpty_def valid_bound_tcb'_def split: option.splits) + done + +lemma tcbSchedAppend_valid_objs'[wp]: + "\valid_objs' and pspace_aligned' and pspace_distinct'\ + tcbSchedAppend tcbPtr + \\_. valid_objs'\" + apply (clarsimp simp: tcbSchedAppend_def setQueue_def) + apply (wpsimp wp: threadSet_valid_objs' threadGet_wp hoare_vcg_all_lift) + apply (normalise_obj_at', rename_tac tcb "end") + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (frule tcbQueueHead_iff_tcbQueueEnd) + apply (force dest!: obj_at'_tcbQueueEnd_ksReadyQueues simp: tcbQueueEmpty_def obj_at'_def) + done crunches tcbSchedAppend, tcbSchedDequeue for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" (wp: threadSet_pred_tcb_no_state simp: unless_def tcb_to_itcb'_def) -lemma removeFromBitmap_valid_queues_no_bitmap_except[wp]: - "\ valid_queues_no_bitmap_except t \ - removeFromBitmap d p - \\_. valid_queues_no_bitmap_except t \" - unfolding bitmapQ_defs valid_queues_no_bitmap_except_def - by (wp| clarsimp simp: bitmap_fun_defs)+ - -lemma removeFromBitmap_bitmapQ: - "\ \s. True \ removeFromBitmap d p \\_ s. \ bitmapQ d p s \" - unfolding bitmapQ_defs bitmap_fun_defs - by (wp| clarsimp simp: bitmap_fun_defs)+ - -lemma removeFromBitmap_valid_bitmapQ[wp]: -" \ valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - (\s. ksReadyQueues s (d,p) = []) \ - removeFromBitmap d p - \\_. valid_bitmapQ \" -proof - - have "\ valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - (\s. ksReadyQueues s (d,p) = []) \ - removeFromBitmap d p - \\_. valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - (\s. \ bitmapQ d p s \ ksReadyQueues s (d,p) = []) \" - by (rule hoare_pre) - (wp removeFromBitmap_valid_queues_no_bitmap_except removeFromBitmap_valid_bitmapQ_except - removeFromBitmap_bitmapQ, simp) - thus ?thesis - by - (erule hoare_strengthen_post; fastforce elim: valid_bitmap_valid_bitmapQ_exceptE) -qed - -(* this should be the actual weakest precondition to establish valid_queues - under tagging a thread as not queued *) -lemma threadSet_valid_queues_dequeue_wp: - "\ valid_queues_no_bitmap_except t and - valid_bitmapQ and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - (\s. \d p. t \ set (ksReadyQueues s (d,p))) \ - threadSet (tcbQueued_update (\_. False)) t - \\rv. valid_queues \" - unfolding threadSet_def - apply (rule hoare_seq_ext[OF _ getObject_tcb_sp]) - apply (rule hoare_pre) - apply (simp add: valid_queues_def valid_queues_no_bitmap_except_def valid_queues_no_bitmap_def) - apply (wp setObject_queues_unchanged_tcb hoare_Ball_helper hoare_vcg_all_lift - setObject_tcb_strongest) - apply (clarsimp simp: valid_queues_no_bitmap_except_def obj_at'_def valid_queues_no_bitmap_def) - done - (* FIXME move *) lemmas obj_at'_conjI = obj_at_conj' -lemma setQueue_valid_queues_no_bitmap_except_dequeue_wp: - "\d p ts t. - \ \s. valid_queues_no_bitmap_except t s \ - (\t' \ set ts. obj_at' (inQ d p and runnable' \ tcbState) t' s) \ - t \ set ts \ distinct ts \ p \ maxPriority \ d \ maxDomain \ - setQueue d p ts - \\rv. valid_queues_no_bitmap_except t \" - unfolding setQueue_def valid_queues_no_bitmap_except_def null_def - by wp force - -definition (* if t is in a queue, it should be tagged with right priority and domain *) - "correct_queue t s \ \d p. t \ set(ksReadyQueues s (d, p)) \ - (obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t s)" - -lemma valid_queues_no_bitmap_correct_queueI[intro]: - "valid_queues_no_bitmap s \ correct_queue t s" - unfolding correct_queue_def valid_queues_no_bitmap_def - by (fastforce simp: obj_at'_def inQ_def) - - -lemma tcbSchedDequeue_valid_queues_weak: - "\ valid_queues_no_bitmap_except t and valid_bitmapQ and - bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - correct_queue t and - obj_at' (\tcb. tcbDomain tcb \ maxDomain \ tcbPriority tcb \ maxPriority) t \ - tcbSchedDequeue t - \\_. Invariants_H.valid_queues\" -proof - - show ?thesis - unfolding tcbSchedDequeue_def null_def valid_queues_def - apply wp (* stops on threadSet *) - apply (rule hoare_post_eq[OF _ threadSet_valid_queues_dequeue_wp], - simp add: valid_queues_def) - apply (wp hoare_vcg_if_lift hoare_vcg_conj_lift hoare_vcg_imp_lift)+ - apply (wp hoare_vcg_imp_lift setQueue_valid_queues_no_bitmap_except_dequeue_wp - setQueue_valid_bitmapQ threadGet_const_tcb_at hoare_vcg_if_lift)+ - (* wp done *) - apply (normalise_obj_at') - apply (clarsimp simp: correct_queue_def) - apply (normalise_obj_at') - apply (fastforce simp add: valid_queues_no_bitmap_except_def valid_queues_no_bitmap_def elim: obj_at'_weaken)+ - done -qed - -lemma tcbSchedDequeue_valid_queues: - "\Invariants_H.valid_queues - and obj_at' (\tcb. tcbDomain tcb \ maxDomain) t - and obj_at' (\tcb. tcbPriority tcb \ maxPriority) t\ - tcbSchedDequeue t - \\_. Invariants_H.valid_queues\" - apply (rule hoare_pre, rule tcbSchedDequeue_valid_queues_weak) - apply (fastforce simp: valid_queues_def valid_queues_no_bitmap_def obj_at'_def inQ_def) - done - -lemma tcbSchedAppend_valid_queues'[wp]: - (* most of this is identical to tcbSchedEnqueue_valid_queues' in TcbAcc_R *) - "\valid_queues' and tcb_at' t\ tcbSchedAppend t \\_. valid_queues'\" - apply (simp add: tcbSchedAppend_def) - apply (rule hoare_pre) - apply (rule_tac B="\rv. valid_queues' and obj_at' (\obj. tcbQueued obj = rv) t" - in hoare_seq_ext) - 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 inQ_def) - apply (wp setQueue_valid_queues' | simp | simp add: setQueue_def)+ - apply (wp getObject_tcb_wp | simp add: threadGet_def)+ - apply (clarsimp simp: obj_at'_def inQ_def valid_queues'_def) - apply (wp getObject_tcb_wp | simp add: threadGet_def)+ - apply (clarsimp simp: obj_at'_def) - done - -lemma threadSet_valid_queues'_dequeue: (* threadSet_valid_queues' is too weak for dequeue *) - "\\s. (\d p t'. obj_at' (inQ d p) t' s \ t' \ t \ t' \ set (ksReadyQueues s (d, p))) \ - obj_at' (inQ d p) t s \ - threadSet (tcbQueued_update (\_. False)) t - \\rv. valid_queues' \" - unfolding valid_queues'_def - apply (rule hoare_pre) - apply (wp hoare_vcg_all_lift) - apply (simp only: imp_conv_disj not_obj_at') - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - apply (simp add: not_obj_at') - apply (clarsimp simp: typ_at_tcb') - apply normalise_obj_at' - apply (fastforce elim: obj_at'_weaken simp: inQ_def) - done - -lemma setQueue_ksReadyQueues_lift: - "\ \s. P (s\ksReadyQueues := (ksReadyQueues s)((d, p) := ts)\) ts \ - setQueue d p ts - \ \_ s. P s (ksReadyQueues s (d,p))\" - unfolding setQueue_def - by (wp, clarsimp simp: fun_upd_def cong: if_cong) - -lemma tcbSchedDequeue_valid_queues'[wp]: - "\valid_queues' and tcb_at' t\ - tcbSchedDequeue t \\_. valid_queues'\" - unfolding tcbSchedDequeue_def - apply (rule_tac B="\rv. valid_queues' and obj_at' (\obj. tcbQueued obj = rv) t" - in hoare_seq_ext) - prefer 2 - apply (wp threadGet_const_tcb_at) - apply (fastforce simp: obj_at'_def) - apply clarsimp - apply (rename_tac queued) - apply (case_tac queued, simp_all) - apply wp - apply (rule_tac d=tdom and p=prio in threadSet_valid_queues'_dequeue) - apply (rule hoare_pre_post, assumption) - apply (wp | clarsimp simp: bitmap_fun_defs)+ - apply (wp hoare_vcg_all_lift setQueue_ksReadyQueues_lift) - apply clarsimp - apply (wp threadGet_obj_at' threadGet_const_tcb_at)+ - apply clarsimp - apply (rule context_conjI, clarsimp simp: obj_at'_def) - apply (clarsimp simp: valid_queues'_def obj_at'_def inQ_def|wp)+ - done +crunches tcbSchedAppend, tcbSchedDequeue, tcbSchedEnqueue + for tcb_at'[wp]: "tcb_at' t" + and cap_to'[wp]: "ex_nonz_cap_to' p" + and ifunsafe'[wp]: if_unsafe_then_cap' + (wp: crunch_wps simp: crunch_simps) lemma tcbSchedAppend_iflive'[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' tcb\ - tcbSchedAppend tcb \\_. if_live_then_nonz_cap'\" - apply (simp add: tcbSchedAppend_def unless_def) - apply (wp threadSet_iflive' hoare_drop_imps | simp add: crunch_simps)+ + "\if_live_then_nonz_cap' and pspace_aligned' and pspace_distinct'\ + tcbSchedAppend tcbPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbSchedAppend_def + apply (wpsimp wp: tcbQueueAppend_if_live_then_nonz_cap' threadGet_wp simp: bitmap_fun_defs) + apply (frule_tac p=tcbPtr in if_live_then_nonz_capE') + apply (fastforce simp: ko_wp_at'_def st_tcb_at'_def obj_at'_def runnable_eq_active' live'_def) + apply (clarsimp simp: tcbQueueEmpty_def) + apply (erule if_live_then_nonz_capE') + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (fastforce dest!: obj_at'_tcbQueueEnd_ksReadyQueues + simp: ko_wp_at'_def inQ_def obj_at'_def tcbQueueEmpty_def live'_def) done lemma tcbSchedDequeue_iflive'[wp]: - "\if_live_then_nonz_cap'\ tcbSchedDequeue tcb \\_. if_live_then_nonz_cap'\" + "\if_live_then_nonz_cap' and valid_objs' and sym_heap_sched_pointers\ + tcbSchedDequeue tcbPtr + \\_. if_live_then_nonz_cap'\" apply (simp add: tcbSchedDequeue_def) - apply (wp threadSet_iflive' hoare_when_weak_wp | simp add: crunch_simps)+ - apply ((wp | clarsimp simp: bitmap_fun_defs)+)[1] (* deal with removeFromBitmap *) - apply (wp threadSet_iflive' hoare_when_weak_wp | simp add: crunch_simps)+ - apply (rule_tac Q="\rv. \" in hoare_post_imp, fastforce) - apply (wp | simp add: crunch_simps)+ + apply (wpsimp wp: tcbQueueRemove_if_live_then_nonz_cap' threadGet_wp) + apply (fastforce elim: if_live_then_nonz_capE' simp: obj_at'_def ko_wp_at'_def live'_def) done crunches tcbSchedAppend, tcbSchedDequeue, tcbSchedEnqueue @@ -480,7 +459,7 @@ crunches tcbSchedAppend, tcbSchedDequeue, tcbSchedEnqueue and state_refs_of'[wp]: "\s. P (state_refs_of' s)" and state_hyp_refs_of'[wp]: "\s. P (state_hyp_refs_of' s)" and idle'[wp]: valid_idle' - (simp: unless_def crunch_simps) + (simp: unless_def crunch_simps obj_at'_def wp: getObject_tcb_wp) lemma tcbSchedEnqueue_vms'[wp]: "\valid_machine_state'\ tcbSchedEnqueue t \\_. valid_machine_state'\" @@ -510,19 +489,87 @@ lemma ct_idle_or_in_cur_domain'_lift2: apply simp+ done +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'\" + apply (wpsimp wp: setObject_tcb_mdb' getTCB_wp simp: threadSet_def obj_at'_def) + apply fastforce + done + +lemma tcbSchedNext_update_valid_mdb'[wp]: + "\valid_mdb' and tcb_at' tcbPtr\ threadSet (tcbSchedNext_update f) tcbPtr \\_. valid_mdb'\" + apply (wpsimp wp: threadSet_mdb') + apply (fastforce simp: obj_at'_def valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) + done + +lemma tcbSchedPrev_update_valid_mdb'[wp]: + "\valid_mdb' and tcb_at' tcbPtr\ threadSet (tcbSchedPrev_update f) tcbPtr \\_. valid_mdb'\" + apply (wpsimp wp: threadSet_mdb') + apply (fastforce simp: obj_at'_def valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) + done + +lemma tcbQueueRemove_valid_mdb': + "\\s. valid_mdb' s \ valid_objs' s\ tcbQueueRemove q tcbPtr \\_. valid_mdb'\" + unfolding tcbQueueRemove_def + apply (wpsimp wp: getTCB_wp) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (fastforce simp: valid_tcb'_def obj_at'_def) + done + +lemma tcbQueuePrepend_valid_mdb': + "\valid_mdb' and tcb_at' tcbPtr + and (\s. \ tcbQueueEmpty queue \ tcb_at' (the (tcbQueueHead queue)) s)\ + tcbQueuePrepend queue tcbPtr + \\_. valid_mdb'\" + unfolding tcbQueuePrepend_def + by (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') + +lemma tcbQueueAppend_valid_mdb': + "\\s. valid_mdb' s \ tcb_at' tcbPtr s + \ (\ tcbQueueEmpty queue \ tcb_at' (the (tcbQueueEnd queue)) s)\ + tcbQueueAppend queue tcbPtr + \\_. valid_mdb'\" + unfolding tcbQueueAppend_def + by (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') + +lemma tcbQueued_update_valid_mdb'[wp]: + "\valid_mdb' and tcb_at' tcbPtr\ threadSet (tcbQueued_update f) tcbPtr \\_. valid_mdb'\" + apply (wpsimp wp: threadSet_mdb') + apply (fastforce simp: obj_at'_def valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) + done + +lemma valid_mdb'_ksReadyQueuesL1Bitmap_update[simp]: + "valid_mdb' (ksReadyQueuesL1Bitmap_update f s) = valid_mdb' s" + by (simp add: valid_mdb'_def) + +lemma valid_mdb'_ksReadyQueuesL2Bitmap_update[simp]: + "valid_mdb' (ksReadyQueuesL2Bitmap_update f s) = valid_mdb' s" + by (simp add: valid_mdb'_def) + +lemma tcbSchedEnqueue_valid_mdb'[wp]: + "\valid_mdb' and valid_objs' and pspace_aligned' and pspace_distinct'\ + tcbSchedEnqueue tcbPtr + \\_. valid_mdb'\" + apply (clarsimp simp: tcbSchedEnqueue_def setQueue_def) + apply (wpsimp wp: tcbQueuePrepend_valid_mdb' threadGet_wp simp: bitmap_fun_defs) + apply normalise_obj_at' + apply (fastforce dest!: obj_at'_tcbQueueHead_ksReadyQueues + simp: ready_queue_relation_def ksReadyQueues_asrt_def obj_at'_def) + done + +crunches tcbSchedEnqueue + for cur_tcb'[wp]: cur_tcb' + (wp: threadSet_cur) + lemma tcbSchedEnqueue_invs'[wp]: - "\invs' - and st_tcb_at' runnable' t - and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ - tcbSchedEnqueue t + "\invs' and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ + tcbSchedEnqueue t \\_. invs'\" - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp tcbSchedEnqueue_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 tcbSchedEnqueue_ct_not_inQ + simp: cteCaps_of_def o_def) done crunch ksMachine[wp]: tcbSchedAppend "\s. P (ksMachineState s)" @@ -531,7 +578,7 @@ crunch ksMachine[wp]: tcbSchedAppend "\s. P (ksMachineState s)" lemma tcbSchedAppend_vms'[wp]: "\valid_machine_state'\ tcbSchedAppend t \\_. valid_machine_state'\" apply (simp add: valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift tcbSchedAppend_ksMachine) + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) done crunch pspace_domain_valid[wp]: tcbSchedAppend "pspace_domain_valid" @@ -546,21 +593,27 @@ crunch ksIdleThread[wp]: tcbSchedAppend "\s. P (ksIdleThread s)" crunch ksDomSchedule[wp]: tcbSchedAppend "\s. P (ksDomSchedule s)" (simp: unless_def) +lemma tcbQueueAppend_tcbPriority_obj_at'[wp]: + "tcbQueueAppend queue tptr \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + unfolding tcbQueueAppend_def + apply (wpsimp wp: threadSet_wp) + by (auto simp: obj_at'_def objBits_simps ps_clear_def split: if_splits) + +lemma tcbQueueAppend_tcbDomain_obj_at'[wp]: + "tcbQueueAppend queue tptr \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding tcbQueueAppend_def + apply (wpsimp wp: threadSet_wp) + by (auto simp: obj_at'_def objBits_simps ps_clear_def split: if_splits) + lemma tcbSchedAppend_tcbDomain[wp]: - "\ obj_at' (\tcb. P (tcbDomain tcb)) t' \ - tcbSchedAppend t - \ \_. obj_at' (\tcb. P (tcbDomain tcb)) t' \" + "tcbSchedAppend t \obj_at' (\tcb. P (tcbDomain tcb)) t'\" apply (clarsimp simp: tcbSchedAppend_def) - apply (wpsimp simp: unless_def)+ - done + by wpsimp lemma tcbSchedAppend_tcbPriority[wp]: - "\ obj_at' (\tcb. P (tcbPriority tcb)) t' \ - tcbSchedAppend t - \ \_. obj_at' (\tcb. P (tcbPriority tcb)) t' \" + "tcbSchedAppend t \obj_at' (\tcb. P (tcbPriority tcb)) t'\" apply (clarsimp simp: tcbSchedAppend_def) - apply (wpsimp simp: unless_def)+ - done + by wpsimp lemma tcbSchedAppend_tcb_in_cur_domain'[wp]: "\tcb_in_cur_domain' t'\ tcbSchedAppend t \\_. tcb_in_cur_domain' t' \" @@ -579,28 +632,59 @@ crunches tcbSchedDequeue, tcbSchedAppend for arch'[wp]: "\s. P (ksArchState s)" lemma tcbSchedAppend_sch_act_wf[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ tcbSchedAppend thread - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - apply (simp add:tcbSchedAppend_def bitmap_fun_defs) - apply (wp unless_wp setQueue_sch_act threadGet_wp|simp)+ - apply (fastforce simp:typ_at'_def obj_at'_def) + "tcbSchedAppend thread \\s. sch_act_wf (ksSchedulerAction s) s\" + by (wpsimp wp: sch_act_wf_lift) + +lemma tcbSchedAppend_valid_bitmapQ[wp]: + "\valid_bitmaps\ tcbSchedAppend tcbPtr \\_. valid_bitmapQ\" + supply if_split[split del] + unfolding tcbSchedAppend_def + apply (wpsimp simp: tcbQueueAppend_def + wp: setQueue_valid_bitmapQ' addToBitmap_valid_bitmapQ_except addToBitmap_bitmapQ + threadGet_wp hoare_vcg_if_lift2) + apply (clarsimp simp: ksReadyQueues_asrt_def split: if_splits) + apply normalise_obj_at' + apply (force dest: tcbQueueHead_iff_tcbQueueEnd + simp: valid_bitmaps_def valid_bitmapQ_def tcbQueueEmpty_def) + done + +lemma tcbSchedAppend_valid_mdb'[wp]: + "\valid_mdb' and valid_tcbs' and pspace_aligned' and pspace_distinct'\ + tcbSchedAppend tcbPtr + \\_. valid_mdb'\" + apply (clarsimp simp: tcbSchedAppend_def setQueue_def) + apply (wpsimp wp: tcbQueueAppend_valid_mdb' threadGet_wp simp: bitmap_fun_defs) + apply (fastforce dest: obj_at'_tcbQueueEnd_ksReadyQueues + simp: ready_queue_relation_def ksReadyQueues_asrt_def obj_at'_def) + done + +lemma tcbSchedAppend_valid_bitmaps[wp]: + "tcbSchedAppend tcbPtr \valid_bitmaps\" + unfolding valid_bitmaps_def + apply wpsimp + apply (clarsimp simp: valid_bitmaps_def) done lemma tcbSchedAppend_invs'[wp]: - "\invs' - and st_tcb_at' runnable' t - and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ - tcbSchedAppend t + "\invs' and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ + tcbSchedAppend t \\_. invs'\" - apply (simp add: invs'_def valid_state'_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: @@ -629,7 +713,7 @@ crunch ksMachine[wp]: tcbSchedDequeue "\s. P (ksMachineState s)" lemma tcbSchedDequeue_vms'[wp]: "\valid_machine_state'\ tcbSchedDequeue t \\_. valid_machine_state'\" apply (simp add: valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift tcbSchedDequeue_ksMachine) + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) done crunch pspace_domain_valid[wp]: tcbSchedDequeue "pspace_domain_valid" @@ -647,46 +731,89 @@ lemma tcbSchedDequeue_tcb_in_cur_domain'[wp]: "\tcb_in_cur_domain' t'\ tcbSchedDequeue t \\_. tcb_in_cur_domain' t' \" apply (rule tcb_in_cur_domain'_lift) apply wp - apply (clarsimp simp: tcbSchedDequeue_def) - apply (wp hoare_when_weak_wp | simp)+ - done - -lemma tcbSchedDequeue_tcbDomain[wp]: - "\ obj_at' (\tcb. P (tcbDomain tcb)) t' \ - tcbSchedDequeue t - \ \_. obj_at' (\tcb. P (tcbDomain tcb)) t' \" - apply (clarsimp simp: tcbSchedDequeue_def) - apply (wp hoare_when_weak_wp | simp)+ - done - -lemma tcbSchedDequeue_tcbPriority[wp]: - "\ obj_at' (\tcb. P (tcbPriority tcb)) t' \ - tcbSchedDequeue t - \ \_. obj_at' (\tcb. P (tcbPriority tcb)) t' \" - apply (clarsimp simp: tcbSchedDequeue_def) - apply (wp hoare_when_weak_wp | simp)+ + apply (clarsimp simp: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wpsimp wp: hoare_when_weak_wp getObject_tcb_wp threadGet_wp) done crunch ksDomScheduleIdx[wp]: tcbSchedDequeue "\s. P (ksDomScheduleIdx s)" (simp: unless_def) +lemma tcbSchedDequeue_valid_mdb'[wp]: + "\valid_mdb' and valid_objs'\ tcbSchedDequeue tcbPtr \\_. valid_mdb'\" + unfolding tcbSchedDequeue_def + apply (wpsimp simp: bitmap_fun_defs setQueue_def wp: threadSet_mdb' tcbQueueRemove_valid_mdb') + apply (rule_tac Q="\_. tcb_at' tcbPtr" in hoare_post_imp) + apply (fastforce simp: tcb_cte_cases_def cteSizeBits_def) + apply (wpsimp wp: threadGet_wp)+ + apply (fastforce simp: obj_at'_def) + done + lemma tcbSchedDequeue_invs'[wp]: - "\invs' and tcb_at' t\ - tcbSchedDequeue t - \\_. invs'\" - unfolding invs'_def valid_state'_def - apply (rule hoare_pre) - 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 - tcbSchedDequeue_valid_queues - untyped_ranges_zero_lift - | simp add: cteCaps_of_def o_def)+ - apply (fastforce elim: valid_objs'_maxDomain valid_objs'_maxPriority simp: valid_pspace'_def)+ + "tcbSchedDequeue t \invs'\" + 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: + "\(s, s') \ state_relation; pspace_aligned s; pspace_distinct s; valid_queues s\ + \ ready_qs_runnable s'" + apply (clarsimp simp: ready_qs_runnable_def) + apply normalise_obj_at' + apply (frule state_relation_ready_queues_relation) + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def + list_queue_relation_def) + apply (drule_tac x="tcbDomain ko" in spec) + apply (drule_tac x="tcbPriority ko" in spec) + apply (clarsimp simp: valid_queues_def) + apply (drule_tac x="tcbDomain ko" in spec) + apply (drule_tac x="tcbPriority ko" in spec) + apply clarsimp + apply (drule_tac x=t in bspec) + apply (fastforce simp: inQ_def in_opt_pred obj_at'_def opt_map_red) + apply (fastforce dest: st_tcb_at_runnable_cross simp: obj_at'_def st_tcb_at'_def) + done + +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_queues)?, (frule invs_psp_aligned)?, (frule invs_distinct)?, + fastforce dest: ready_qs_runnable_cross + +defs idleThreadNotQueued_def: + "idleThreadNotQueued s \ obj_at' (Not \ tcbQueued) (ksIdleThread s) s" + +lemma idle_thread_not_queued: + "\valid_idle s; valid_queues s; valid_etcbs s\ + \ \ (\d p. idle_thread s \ set (ready_queues s d p))" + apply (clarsimp simp: valid_queues_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply clarsimp + apply (drule_tac x="idle_thread s" in bspec) + apply fastforce + apply (clarsimp simp: valid_idle_def pred_tcb_at_def obj_at_def valid_etcbs_def) done +lemma valid_idle_tcb_at: + "valid_idle s \ tcb_at (idle_thread s) s" + by (clarsimp simp: valid_idle_def pred_tcb_at_def obj_at_def is_tcb_def) + lemma setCurThread_corres: - "corres dc \ \ (modify (cur_thread_update (\_. t))) (setCurThread t)" - apply (unfold setCurThread_def) + "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 opt_pred_def opt_map_def) apply (rule corres_modify) apply (simp add: state_relation_def swp_def) done @@ -709,10 +836,9 @@ lemma updateASIDPoolEntry_pred_tcb_at'[wp]: unfolding updateASIDPoolEntry_def getPoolPtr_def by (wpsimp wp: setASIDPool_pred_tcb_at' getASID_wp) -lemma updateASIDPoolEntry_valid_queues[wp]: - "updateASIDPoolEntry g asid \Invariants_H.valid_queues\" - unfolding updateASIDPoolEntry_def getPoolPtr_def - by (wpsimp wp: getASID_wp) +crunches updateASIDPoolEntry + for tcbs_of'[wp]: "\s. P (tcbs_of' s)" + (wp: getASID_wp crunch_wps) crunches setVMRoot for pred_tcb_at'[wp]: "pred_tcb_at' proj P t'" @@ -738,49 +864,60 @@ qed crunches storeWordUser, setVMRoot, asUser, storeWordUser, Arch.switchToThread for ksQ[wp]: "\s. P (ksReadyQueues s p)" and ksIdleThread[wp]: "\s. P (ksIdleThread s)" - and valid_queues[wp]: "Invariants_H.valid_queues" - (wp: crunch_wps simp: crunch_simps) + and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_objs'[wp]: valid_objs' + (wp: crunch_wps threadSet_sched_pointers getObject_tcb_wp getASID_wp + simp: crunch_simps obj_at'_def) -crunches arch_switch_to_thread +crunches arch_switch_to_thread, arch_switch_to_idle_thread for pspace_aligned[wp]: pspace_aligned and pspace_distinct[wp]: pspace_distinct + and ready_qs_distinct[wp]: ready_qs_distinct + and valid_idle[wp]: valid_idle + (wp: ready_qs_distinct_lift simp: crunch_simps) + +lemma valid_queues_in_correct_ready_q[elim!]: + "valid_queues s \ in_correct_ready_q s" + by (clarsimp simp: valid_queues_def in_correct_ready_q_def) + +lemma valid_queues_ready_qs_distinct[elim!]: + "valid_queues s \ ready_qs_distinct s" + by (clarsimp simp: valid_queues_def ready_qs_distinct_def) lemma switchToThread_corres: "corres dc (valid_arch_state and valid_objs and valid_vspace_objs and pspace_aligned and pspace_distinct and valid_vs_lookup and valid_global_objs and pspace_in_kernel_window and unique_table_refs - and st_tcb_at runnable t and valid_etcbs and (\s. sym_refs (state_hyp_refs_of s))) - (no_0_obj' and Invariants_H.valid_queues) + and st_tcb_at runnable t and valid_etcbs and (\s. sym_refs (state_hyp_refs_of s)) + and valid_queues and valid_idle) + (no_0_obj' and sym_heap_sched_pointers and valid_objs') (switch_to_thread t) (switchToThread t)" - (is "corres _ ?PA ?PH _ _") -proof - - have mainpart: "corres dc (?PA) (?PH) - (do y \ arch_switch_to_thread t; - y \ (tcb_sched_action tcb_sched_dequeue t); - modify (cur_thread_update (\_. t)) - od) - (do y \ Arch.switchToThread t; - y \ tcbSchedDequeue t; - setCurThread 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) + apply add_ready_qs_runnable + apply (simp add: switch_to_thread_def Thread_H.switchToThread_def) + apply (rule corres_symb_exec_l[OF _ _ get_sp]; (solves wpsimp)?) + apply (rule corres_symb_exec_l[OF _ _ assert_sp]; (solves wpsimp)?) + 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_stateAssert_ignore) + apply (fastforce dest!: state_relation_ready_queues_relation intro: ksReadyQueues_asrt_cross) + apply (rule corres_stateAssert_add_assertion[rotated]) + apply fastforce apply (rule corres_guard_imp) apply (rule corres_split[OF arch_switchToThread_corres]) apply (rule corres_split[OF tcbSchedDequeue_corres setCurThread_corres]) - apply (wp|clarsimp simp: tcb_at_is_etcb_at st_tcb_at_tcb_at)+ - done - - show ?thesis - apply - - apply (simp add: switch_to_thread_def Thread_H.switchToThread_def) - apply (rule corres_symb_exec_l [where Q = "\ s rv. (?PA and (=) rv) s", - OF corres_symb_exec_l [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 tcb_at_idle_thread_lift: assumes T: "\T' t. \typ_at T' t\ f \\rv. typ_at T' t\" @@ -824,15 +961,21 @@ lemma arch_switchToIdleThread_corres: done lemma switchToIdleThread_corres: - "corres dc invs invs_no_cicd' switch_to_idle_thread switchToIdleThread" + "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 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_trivial, rule corres_modify) - apply (simp add: state_relation_def cdt_relation_def) - apply (wp+, simp+) + 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) @@ -867,11 +1010,9 @@ proof - 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 Invariants_H.valid_queues_def - sch_act_wf ct_in_state'_def state_refs_of'_def - ps_clear_def valid_irq_node'_def valid_queues'_def ct_not_inQ_ct - ct_idle_or_in_cur_domain'_def - bitmapQ_defs valid_queues_no_bitmap_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 @@ -885,100 +1026,20 @@ lemma setCurThread_invs: by (rule hoare_pre, rule setCurThread_invs_no_cicd') (simp add: invs'_to_invs_no_cicd'_def) -lemma valid_queues_not_runnable_not_queued: - fixes s - assumes vq: "Invariants_H.valid_queues 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 - - with vq have "st_tcb_at' runnable' t s" - unfolding Invariants_H.valid_queues_def valid_queues_no_bitmap_def - apply - - apply clarsimp - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp simp add: st_tcb_at'_def) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE) - apply (clarsimp) - done - - with st show False - apply - - apply (drule(1) pred_tcb_at_conj') - apply (clarsimp) - done -qed - -(* - * The idle thread is not part of any ready queues. - *) -lemma idle'_not_tcbQueued': - assumes vq: "Invariants_H.valid_queues 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 add: valid_idle'_def pred_tcb_at'_def obj_at'_def idle_tcb'_def) - with vq vq' show ?thesis - by (rule valid_queues_not_runnable_not_queued) -qed - lemma setCurThread_invs_no_cicd'_idle_thread: - "\invs_no_cicd' and (\s. t = ksIdleThread s) \ 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 - have idle'_activatable': "\ s t. st_tcb_at' idle' t s \ st_tcb_at' activatable' t s" - apply (clarsimp simp: st_tcb_at'_def o_def obj_at'_def) + "\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 st_tcb_at'_def + idleThreadNotQueued_def) done - show ?thesis - apply (simp add: setCurThread_def) - apply wp - apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def) - apply (frule (2) idle'_not_tcbQueued'[simplified o_def]) - apply (clarsimp simp add: ct_not_inQ_ct idle'_activatable' - 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_queues_no_bitmap_def valid_queues'_def - pred_tcb_at'_def - cong: option.case_cong) - apply (clarsimp simp: obj_at'_def idle_tcb'_def ) - done -qed lemma setCurThread_invs_idle_thread: "\invs' and (\s. t = ksIdleThread s) \ setCurThread t \\rv. invs'\" @@ -1001,13 +1062,13 @@ lemma Arch_switchToThread_tcb_in_cur_domain'[wp]: by (wp tcb_in_cur_domain'_lift) lemma tcbSchedDequeue_not_tcbQueued: - "\ tcb_at' t \ tcbSchedDequeue t \ \_. obj_at' (\x. \ tcbQueued x) t \" + "\\\ tcbSchedDequeue t \\_. obj_at' (\x. \ tcbQueued x) t\" apply (simp add: tcbSchedDequeue_def) apply (wp|clarsimp)+ apply (rule_tac Q="\queued. obj_at' (\x. tcbQueued x = queued) t" in hoare_post_imp) - apply (clarsimp simp: obj_at'_def) - apply (wp threadGet_obj_at') - apply (simp) + apply (clarsimp simp: obj_at'_def) + apply (wpsimp wp: threadGet_wp)+ + apply (clarsimp simp: obj_at'_def) done lemma asUser_obj_at[wp]: @@ -1027,10 +1088,6 @@ crunch valid_irq_states'[wp]: asUser "valid_irq_states'" crunch valid_machine_state'[wp]: asUser "valid_machine_state'" (wp: crunch_wps simp: crunch_simps) -crunch valid_queues'[wp]: asUser "valid_queues'" -(wp: crunch_wps simp: crunch_simps) - - lemma asUser_valid_irq_node'[wp]: "asUser t (setRegister f r) \\s. valid_irq_node' (irq_node' s) s\" apply (rule_tac valid_irq_node_lift) @@ -1089,57 +1146,39 @@ lemma asUser_utr[wp]: done lemma threadSet_invs_no_cicd'_trivialT: - assumes x: "\tcb. \(getF,setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" - assumes z: "\tcb. tcbState (F tcb) = tcbState tcb \ tcbDomain (F tcb) = tcbDomain tcb" - assumes w: "\tcb. is_aligned (tcbIPCBuffer tcb) msg_align_bits \ is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits" - assumes a: "\tcb. tcbBoundNotification (F tcb) = tcbBoundNotification tcb" - assumes w: "\tcb. is_aligned (tcbIPCBuffer tcb) msg_align_bits \ is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits" - 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 v: "\tcb. atcbVCPUPtr (tcbArch (F tcb)) = atcbVCPUPtr (tcbArch tcb)" - shows - "\\s. invs_no_cicd' 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. \ tcbQueued tcb \ tcbQueued (F tcb)) \ ex_nonz_cap_to' t s \ t \ ksCurThread s) \ - (\tcb. tcbQueued (F tcb) \ ksSchedulerAction s = ResumeCurrentThread \ tcbQueued tcb \ t \ ksCurThread s)\ - threadSet F t - \\rv. invs_no_cicd'\" -proof - - from z have domains: "\tcb. tcbDomain (F tcb) = tcbDomain tcb" by blast - note threadSet_sch_actT_P[where P=False, simplified] - have y: "\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_no_cicd'_def valid_state'_def split del: if_split) - apply (rule hoare_pre) - apply (wp x w v u b - threadSet_valid_pspace'T - threadSet_sch_actT_P[where P=False, simplified] - threadSet_valid_queues - threadSet_state_refs_of'T[where f'=id] - threadSet_state_hyp_refs_of' - 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_cur - untyped_ranges_zero_lift - |clarsimp simp: y z a v domains cteCaps_of_def valid_arch_tcb'_def |rule refl)+ - apply (clarsimp simp: obj_at'_def pred_tcb_at'_def) - apply (clarsimp simp: cur_tcb'_def valid_irq_node'_def valid_queues'_def o_def) - by (fastforce simp: domains ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def z a) -qed + assumes + "\tcb. \(getF,setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" + "\tcb. tcbState (F tcb) = tcbState tcb \ tcbDomain (F tcb) = tcbDomain tcb" + "\tcb. is_aligned (tcbIPCBuffer tcb) msg_align_bits \ is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits" + "\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 tcb \ maxDomain \ tcbDomain (F tcb) \ maxDomain" + "\tcb. tcbPriority tcb \ maxPriority \ tcbPriority (F tcb) \ maxPriority" + "\tcb. tcbMCP tcb \ maxPriority \ tcbMCP (F tcb) \ maxPriority" + "\tcb. atcbVCPUPtr (tcbArch (F tcb)) = atcbVCPUPtr (tcbArch tcb)" + shows "threadSet F t \invs_no_cicd'\" + apply (simp add: invs_no_cicd'_def valid_state'_def) + apply (wp threadSet_valid_pspace'T + threadSet_sch_actT_P[where P=False, simplified] + threadSet_state_refs_of'T[where f'=id] + threadSet_state_hyp_refs_of' + 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_sched_pointers threadSet_valid_sched_pointers + threadSet_cur + untyped_ranges_zero_lift + | clarsimp simp: assms cteCaps_of_def valid_arch_tcb'_def | rule refl)+ + by (auto simp: o_def) lemmas threadSet_invs_no_cicd'_trivial = threadSet_invs_no_cicd'_trivialT [OF all_tcbI all_tcbI all_tcbI all_tcbI, OF ball_tcb_cte_casesI] @@ -1158,22 +1197,17 @@ lemma Arch_switchToThread_invs_no_cicd': by (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def) lemma tcbSchedDequeue_invs_no_cicd'[wp]: - "\invs_no_cicd' and tcb_at' t\ - tcbSchedDequeue t - \\_. invs_no_cicd'\" - unfolding all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def + "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 - tcbSchedDequeue_valid_queues_weak untyped_ranges_zero_lift | simp add: cteCaps_of_def o_def)+ apply clarsimp - apply (fastforce simp: valid_pspace'_def valid_queues_def - elim: valid_objs'_maxDomain valid_objs'_maxPriority intro: obj_at'_conjI) done lemma switchToThread_invs_no_cicd': - "\invs_no_cicd' and st_tcb_at' runnable' t and tcb_in_cur_domain' t \ ThreadDecls_H.switchToThread t \\rv. invs' \" + "\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') @@ -1181,7 +1215,7 @@ lemma switchToThread_invs_no_cicd': done lemma switchToThread_invs[wp]: - "\invs' and st_tcb_at' runnable' t and tcb_in_cur_domain' t \ switchToThread t \\rv. invs' \" + "\invs' and tcb_in_cur_domain' t \ switchToThread t \\rv. invs' \" apply (simp add: Thread_H.switchToThread_def ) apply (wp threadSet_timeslice_invs setCurThread_invs Arch_switchToThread_invs dmo_invs' @@ -1268,61 +1302,6 @@ lemma obj_tcb_at': "obj_at' (\tcb::tcb. P tcb) t s \ tcb_at' t s" by (clarsimp simp: obj_at'_def) -lemma invs'_not_runnable_not_queued: - fixes s - assumes inv: "invs' s" - and st: "st_tcb_at' (Not \ runnable') t s" - shows "obj_at' (Not \ tcbQueued) t s" - apply (insert assms) - apply (rule valid_queues_not_runnable_not_queued) - apply (clarsimp simp add: invs'_def valid_state'_def)+ - done - -lemma valid_queues_not_tcbQueued_not_ksQ: - fixes s - assumes vq: "Invariants_H.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" - unfolding Invariants_H.valid_queues_def valid_queues_no_bitmap_def - apply clarify - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE) - apply (simp) - done - 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 valid_state'_def) - apply (drule(1) valid_queues_not_tcbQueued_not_ksQ) - apply (clarsimp) - done - -lemma ct_not_ksQ: - "\ invs' s; ksSchedulerAction s = ResumeCurrentThread \ - \ \p. ksCurThread s \ set (ksReadyQueues s p)" - apply (clarsimp simp: invs'_def valid_state'_def ct_not_inQ_def) - apply (frule(1) valid_queues_not_tcbQueued_not_ksQ) - apply (fastforce) - done - lemma setThreadState_rct: "\\s. (runnable' st \ ksCurThread s \ t) \ ksSchedulerAction s = ResumeCurrentThread\ @@ -1394,21 +1373,24 @@ lemma bitmapQ_from_bitmap_lookup: done lemma lookupBitmapPriority_obj_at': - "\ksReadyQueuesL1Bitmap s (ksCurDomain s) \ 0; valid_queues_no_bitmap s; valid_bitmapQ s; - bitmapQ_no_L1_orphans s\ - \ obj_at' (inQ (ksCurDomain s) (lookupBitmapPriority (ksCurDomain s) s) and runnable' \ tcbState) - (hd (ksReadyQueues s (ksCurDomain s, lookupBitmapPriority (ksCurDomain s) s))) s" + "\ksReadyQueuesL1Bitmap s d \ 0; valid_bitmapQ s; bitmapQ_no_L1_orphans s; + ksReadyQueues_asrt s; ready_qs_runnable s; pspace_aligned' s; pspace_distinct' s\ + \ obj_at' (inQ d (lookupBitmapPriority d s) and runnable' \ tcbState) + (the (tcbQueueHead (ksReadyQueues s (d, lookupBitmapPriority d s)))) s" apply (drule (2) bitmapQ_from_bitmap_lookup) apply (simp add: valid_bitmapQ_bitmapQ_simp) - apply (case_tac "ksReadyQueues s (ksCurDomain s, lookupBitmapPriority (ksCurDomain s) s)", simp) - apply (clarsimp, rename_tac t ts) - apply (drule cons_set_intro) - apply (drule (2) valid_queues_no_bitmap_objD) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def tcbQueueEmpty_def) + apply (drule_tac x=d in spec) + apply (drule_tac x="lookupBitmapPriority d s" in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (fastforce simp: obj_at'_and ready_qs_runnable_def obj_at'_def st_tcb_at'_def inQ_def + tcbQueueEmpty_def) done lemma bitmapL1_zero_ksReadyQueues: "\ valid_bitmapQ s ; bitmapQ_no_L1_orphans s \ - \ (ksReadyQueuesL1Bitmap s d = 0) = (\p. ksReadyQueues s (d,p) = [])" + \ (ksReadyQueuesL1Bitmap s d = 0) = (\p. tcbQueueEmpty (ksReadyQueues s (d, p)))" apply (cases "ksReadyQueuesL1Bitmap s d = 0") apply (force simp add: bitmapQ_def valid_bitmapQ_def) apply (fastforce dest: bitmapQ_from_bitmap_lookup simp: valid_bitmapQ_bitmapQ_simp) @@ -1479,7 +1461,7 @@ lemma bitmapL1_highest_lookup: done lemma bitmapQ_ksReadyQueuesI: - "\ bitmapQ d p s ; valid_bitmapQ s \ \ ksReadyQueues s (d, p) \ []" + "\ bitmapQ d p s ; valid_bitmapQ s \ \ \ tcbQueueEmpty (ksReadyQueues s (d, p))" unfolding valid_bitmapQ_def by simp lemma getReadyQueuesL2Bitmap_inv[wp]: @@ -1488,24 +1470,22 @@ lemma getReadyQueuesL2Bitmap_inv[wp]: lemma switchToThread_lookupBitmapPriority_wp: "\\s. invs_no_cicd' s \ bitmapQ (ksCurDomain s) (lookupBitmapPriority (ksCurDomain s) s) s \ - t = hd (ksReadyQueues s (ksCurDomain s, lookupBitmapPriority (ksCurDomain 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 ; 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 elim: obj_at'_weaken simp: inQ_def tcb_in_cur_domain'_def st_tcb_at'_def) - done - thus ?thesis - by (wp switchToThread_invs_no_cicd') (fastforce dest: invs_no_cicd'_queues) -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_no_cicd': "\invs_no_cicd'\ switchToIdleThread \\rv. invs'\" @@ -1604,8 +1584,9 @@ lemma guarded_switch_to_corres: and valid_vspace_objs and pspace_aligned and pspace_distinct and valid_vs_lookup and valid_global_objs and pspace_in_kernel_window and unique_table_refs - and st_tcb_at runnable t and valid_etcbs and (\s. sym_refs (state_hyp_refs_of s))) - (no_0_obj' and Invariants_H.valid_queues) + and st_tcb_at runnable t and valid_etcbs and (\s. sym_refs (state_hyp_refs_of s)) + and valid_queues and valid_idle) + (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) @@ -1650,7 +1631,7 @@ lemma curDomain_corres: "corres (=) \ \ (gets cur_domain) (curDomain)" lemma curDomain_corres': "corres (=) \ (\s. ksCurDomain s \ maxDomain) - (gets cur_domain) (if 1 < numDomains then curDomain else return 0)" + (gets cur_domain) (if Suc 0 < numDomains then curDomain else return 0)" apply (case_tac "1 < numDomains"; simp) apply (rule corres_guard_imp[OF curDomain_corres]; solves simp) (* if we have only one domain, then we are in it *) @@ -1660,27 +1641,32 @@ lemma curDomain_corres': lemma lookupBitmapPriority_Max_eqI: "\ valid_bitmapQ s ; bitmapQ_no_L1_orphans s ; ksReadyQueuesL1Bitmap s d \ 0 \ - \ lookupBitmapPriority d s = (Max {prio. ksReadyQueues s (d, prio) \ []})" + \ lookupBitmapPriority d s = (Max {prio. \ tcbQueueEmpty (ksReadyQueues s (d, prio))})" apply (rule Max_eqI[simplified eq_commute]; simp) apply (fastforce simp: bitmapL1_highest_lookup valid_bitmapQ_bitmapQ_simp) apply (metis valid_bitmapQ_bitmapQ_simp bitmapQ_from_bitmap_lookup) done lemma corres_gets_queues_getReadyQueuesL1Bitmap: - "corres (\qs l1. ((l1 = 0) = (\p. qs p = []))) \ valid_queues + "corres (\qs l1. (l1 = 0) = (\p. qs p = [])) \ valid_bitmaps (gets (\s. ready_queues s d)) (getReadyQueuesL1Bitmap d)" - unfolding state_relation_def valid_queues_def getReadyQueuesL1Bitmap_def - by (clarsimp simp: bitmapL1_zero_ksReadyQueues ready_queues_relation_def) + unfolding state_relation_def valid_bitmaps_def getReadyQueuesL1Bitmap_def + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def) + apply (drule_tac x=d in spec) + apply (fastforce simp: bitmapL1_zero_ksReadyQueues list_queue_relation_def tcbQueueEmpty_def) + done lemma guarded_switch_to_chooseThread_fragment_corres: "corres dc (P and st_tcb_at runnable t and invs and valid_sched) - (P' and st_tcb_at' runnable' t and invs_no_cicd') - (guarded_switch_to t) - (do runnable \ isRunnable t; - y \ assert runnable; - ThreadDecls_H.switchToThread t - od)" + (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) @@ -1695,35 +1681,50 @@ lemma guarded_switch_to_chooseThread_fragment_corres: 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' + \ Max {prio. ready_queues s d prio \ []} + = Max {prio. \ tcbQueueEmpty (ksReadyQueues s' (d, prio))}" + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def + list_queue_relation_def tcbQueueEmpty_def) + apply (rule Max_eq_if) + apply fastforce + apply fastforce + apply (fastforce dest: heap_path_head) + apply clarsimp + apply (drule_tac x=d in spec) + apply (drule_tac x=b in spec) + apply force + done + lemma bitmap_lookup_queue_is_max_non_empty: - "\ valid_queues s'; (s, s') \ state_relation; invs s; + "\ 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 all_invs_but_ct_idle_or_in_cur_domain'_def 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 \ - \ 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 (simp add: valid_queues_no_bitmap_def) - apply (erule_tac x="ksCurDomain s" in allE) - apply (erule_tac x="lookupBitmapPriority (ksCurDomain s) s" in allE) - apply (clarsimp simp: st_tcb_at'_def) - apply (erule obj_at'_weaken) - apply simp - 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 \" @@ -1735,52 +1736,72 @@ lemma invs_no_cicd_ksCurDomain_maxDomain': "invs_no_cicd' s \ ksCurDomain s \ maxDomain" unfolding invs_no_cicd'_def by simp +crunches curDomain + for valid_bitmaps[wp]: valid_bitmaps + lemma chooseThread_corres: - "corres dc (invs and valid_sched) (invs_no_cicd') - choose_thread chooseThread" (is "corres _ ?PREI ?PREH _ _") + "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 - unfolding choose_thread_def chooseThread_def - 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 \ 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 dest!: invs_no_cicd'_queues simp: bitmap_lookup_queue_is_max_non_empty) - 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 (clarsimp simp: if_apply_def2) - apply (wp hoare_vcg_conj_lift hoare_vcg_imp_lift ksReadyQueuesL1Bitmap_return_wp) - apply (wpsimp wp: curDomain_or_return_0 simp: curDomain_def)+ - apply (fastforce simp: invs_no_cicd'_def) - apply (clarsimp simp: valid_sched_def DetSchedInvs_AI.valid_queues_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 (simp add: invs_no_cicd_ksCurDomain_maxDomain') - apply (clarsimp dest!: invs_no_cicd'_queues) - apply (fastforce intro: ksReadyQueuesL1Bitmap_st_tcb_at') - done + 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 (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 = @@ -1869,7 +1890,7 @@ lemma isHighestPrio_corres: assumes "d' = d" assumes "p' = p" shows - "corres ((=)) \ valid_queues + "corres ((=)) \ valid_bitmaps (gets (is_highest_prio d p)) (isHighestPrio d' p')" using assms @@ -1879,18 +1900,16 @@ lemma isHighestPrio_corres: apply (rule corres_split[OF corres_gets_queues_getReadyQueuesL1Bitmap]) apply (rule corres_if_r'[where P'="\_. True",rotated]) apply (rule_tac corres_symb_exec_r) - apply (rule_tac - P="\s. q = ready_queues s d - " and - P'="\s. valid_queues s \ - l1 = ksReadyQueuesL1Bitmap s d \ - l1 \ 0 \ hprio = lookupBitmapPriority d s" and - F="hprio = Max {prio. q prio \ []}" in corres_req) - apply (elim conjE) - apply (clarsimp simp: valid_queues_def) - apply (subst lookupBitmapPriority_Max_eqI; blast?) - apply (fastforce simp: ready_queues_relation_def dest!: state_relationD) - apply fastforce + apply (rule_tac P="\s. q = ready_queues s d" + and P'="\s. valid_bitmaps s \ l1 = ksReadyQueuesL1Bitmap s d \ + l1 \ 0 \ hprio = lookupBitmapPriority d s" + and F="hprio = Max {prio. q prio \ []}" in corres_req) + apply (elim conjE) + apply (clarsimp simp: valid_bitmaps_def) + apply (subst lookupBitmapPriority_Max_eqI; blast?) + apply (fastforce dest: state_relation_ready_queues_relation Max_prio_helper[where d=d] + simp: tcbQueueEmpty_def) + apply fastforce apply (wpsimp simp: if_apply_def2 wp: hoare_drop_imps ksReadyQueuesL1Bitmap_return_wp)+ done @@ -1901,9 +1920,8 @@ crunch inv[wp]: curDomain P crunch inv[wp]: scheduleSwitchThreadFastfail P lemma setSchedulerAction_invs': (* not in wp set, clobbered by ssa_wp *) - "\\s. invs' s \ setSchedulerAction ChooseNewThread \\_. invs' \" + "setSchedulerAction ChooseNewThread \invs' \" by (wpsimp simp: invs'_def cur_tcb'_def valid_state'_def valid_irq_node'_def ct_not_inQ_def - valid_queues_def valid_queues_no_bitmap_def valid_queues'_def ct_idle_or_in_cur_domain'_def) lemma scheduleChooseNewThread_corres: @@ -1933,6 +1951,46 @@ lemma ethread_get_when_corres: 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 + +crunches 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) + +crunches 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) + 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] @@ -1961,7 +2019,7 @@ lemma schedule_corres: apply (rule corres_split[OF thread_get_isRunnable_corres]) apply (rule corres_split) apply (rule corres_when, simp) - apply (rule tcbSchedEnqueue_corres) + 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)+ @@ -1970,7 +2028,7 @@ lemma schedule_corres: rename_tac was_running wasRunning) apply (rule corres_split) apply (rule corres_when, simp) - apply (rule tcbSchedEnqueue_corres) + 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) @@ -1986,7 +2044,7 @@ lemma schedule_corres: 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]) + apply (rule corres_split[OF tcbSchedEnqueue_corres], simp) apply (simp, fold dc_def) apply (rule corres_split) apply (rule setSchedulerAction_corres; simp) @@ -2000,7 +2058,7 @@ lemma schedule_corres: 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]) + apply (rule corres_split[OF tcbSchedAppend_corres], simp) apply (simp, fold dc_def) apply (rule corres_split) apply (rule setSchedulerAction_corres; simp) @@ -2032,7 +2090,8 @@ lemma schedule_corres: 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)+ + del: gets_wp + | strengthen valid_objs'_valid_tcbs')+ apply (clarsimp simp: conj_ac if_apply_def2 cong: imp_cong conj_cong del: hoare_gets) apply (wp gets_wp)+ @@ -2055,14 +2114,13 @@ lemma schedule_corres: 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 invs_hyp_sym_refs) - apply (clarsimp simp add: pred_tcb_at_def obj_at_def is_tcb valid_idle_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)+ - apply (simp add: valid_sched_def valid_blocked_def valid_blocked_except_def) done (* haskell final subgoal *) @@ -2080,11 +2138,8 @@ proof - apply (simp add: setSchedulerAction_def) apply wp apply (clarsimp simp add: invs'_def valid_state'_def cur_tcb'_def - Invariants_H.valid_queues_def - state_refs_of'_def ps_clear_def - valid_irq_node'_def valid_queues'_def - tcb_in_cur_domain'_def ct_idle_or_in_cur_domain'_def - bitmapQ_defs valid_queues_no_bitmap_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 @@ -2124,7 +2179,7 @@ lemma switchToThread_ct_not_queued_2: apply (simp add: Thread_H.switchToThread_def) apply (wp) apply (simp add: AARCH64_H.switchToThread_def setCurThread_def) - apply (wp tcbSchedDequeue_not_tcbQueued | simp )+ + apply (wp tcbSchedDequeue_not_tcbQueued hoare_drop_imp | simp)+ done lemma setCurThread_obj_at': @@ -2138,11 +2193,12 @@ proof - qed lemma switchToIdleThread_ct_not_queued_no_cicd': - "\ invs_no_cicd' \ switchToIdleThread \\rv s. obj_at' (Not \ tcbQueued) (ksCurThread s) s \" + "\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 (rule idle'_not_tcbQueued') - apply (simp add: invs_no_cicd'_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]: @@ -2159,7 +2215,7 @@ lemma switchToThread_tcb_in_cur_domain': ThreadDecls_H.switchToThread thread \\y s. tcb_in_cur_domain' (ksCurThread s) s\" apply (simp add: Thread_H.switchToThread_def setCurThread_def) - apply (wpsimp wp: tcbSchedDequeue_not_tcbQueued) + apply (wpsimp wp: tcbSchedDequeue_not_tcbQueued hoare_drop_imps) done lemma chooseThread_invs_no_cicd'_posts: (* generic version *) @@ -2181,11 +2237,14 @@ proof - by (simp add: all_invs_but_ct_idle_or_in_cur_domain'_def maxDomain_def) show ?thesis - unfolding chooseThread_def Let_def curDomain_def + apply (clarsimp simp: chooseThread_def Let_def curDomain_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp])+ apply (simp only: return_bind, simp) - apply (rule hoare_seq_ext[where B="\rv s. invs_no_cicd' s \ rv = ksCurDomain s"]) + apply (rule hoare_seq_ext[where B="\rv s. invs_no_cicd' s \ rv = ksCurDomain s + \ ksReadyQueues_asrt s \ ready_qs_runnable s"]) apply (rule_tac B="\rv s. invs_no_cicd' s \ curdom = ksCurDomain s \ - rv = ksReadyQueuesL1Bitmap s curdom" in hoare_seq_ext) + rv = ksReadyQueuesL1Bitmap s curdom \ + ksReadyQueues_asrt s \ ready_qs_runnable s" in hoare_seq_ext) apply (rename_tac l1) apply (case_tac "l1 = 0") (* switch to idle thread *) @@ -2199,12 +2258,10 @@ proof - 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 - apply (clarsimp dest!: invs_no_cicd'_queues - simp: valid_queues_def lookupBitmapPriority_def[symmetric]) - 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 (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 @@ -2243,11 +2300,14 @@ proof - (* FIXME this is almost identical to the chooseThread_invs_no_cicd'_posts proof, can generalise? *) show ?thesis - unfolding chooseThread_def Let_def curDomain_def + apply (clarsimp simp: chooseThread_def Let_def curDomain_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp])+ apply (simp only: return_bind, simp) - apply (rule hoare_seq_ext[where B="\rv s. invs_no_cicd' s \ rv = ksCurDomain s"]) + apply (rule hoare_seq_ext[where B="\rv s. invs_no_cicd' s \ rv = ksCurDomain s + \ ksReadyQueues_asrt s \ ready_qs_runnable s"]) apply (rule_tac B="\rv s. invs_no_cicd' s \ curdom = ksCurDomain s \ - rv = ksReadyQueuesL1Bitmap s curdom" in hoare_seq_ext) + rv = ksReadyQueuesL1Bitmap s curdom \ + ksReadyQueues_asrt s \ ready_qs_runnable s" in hoare_seq_ext) apply (rename_tac l1) apply (case_tac "l1 = 0") (* switch to idle thread *) @@ -2255,7 +2315,10 @@ proof - (* we have a thread to switch to *) apply (clarsimp simp: bitmap_fun_defs) apply (wp assert_inv) - apply (clarsimp dest!: invs_no_cicd'_queues simp: valid_queues_def) + 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 @@ -2405,12 +2468,15 @@ lemma sbn_sch_act_sane: lemma possibleSwitchTo_corres: "corres dc - (valid_etcbs and weak_valid_sched_action and cur_tcb and st_tcb_at runnable t - and pspace_aligned and pspace_distinct) - (valid_queues and valid_queues' and (\s. weak_sch_act_wf (ksSchedulerAction s) s) - and valid_objs') - (possible_switch_to t) - (possibleSwitchTo t)" + (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) @@ -2423,12 +2489,12 @@ lemma possibleSwitchTo_corres: apply (clarsimp simp: etcb_relation_def) apply (rule corres_split[OF getSchedulerAction_corres]) apply (rule corres_if, simp) - apply (rule tcbSchedEnqueue_corres) + 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) - apply (wp rescheduleRequired_valid_queues'_weak)+ + 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])+ @@ -2437,7 +2503,7 @@ lemma possibleSwitchTo_corres: 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 (simp add: tcb_at_is_etcb_at) + apply (fastforce simp: tcb_at_is_etcb_at) done end diff --git a/proof/refine/AARCH64/StateRelation.thy b/proof/refine/AARCH64/StateRelation.thy index 43a6fce143..e8f13fae54 100644 --- a/proof/refine/AARCH64/StateRelation.thy +++ b/proof/refine/AARCH64/StateRelation.thy @@ -184,13 +184,20 @@ definition tcb_relation :: "Structures_A.tcb \ Structures_H.tcb \ tcb_bound_notification tcb = tcbBoundNotification tcb' \ tcb_mcpriority tcb = tcbMCP tcb'" +\ \ + A pair of objects @{term "(obj, obj')"} should satisfy the following relation when, under further + mild assumptions, a @{term corres_underlying} lemma for @{term "set_object obj"} + and @{term "setObject obj'"} can be stated: see setObject_other_corres in KHeap_R. + + TCBs do not satisfy this relation because the tcbSchedPrev and tcbSchedNext fields of a TCB are + used to model the ready queues, and so an update to such a field would correspond to an update + to a ready queue (see ready_queues_relation below).\ definition other_obj_relation :: "Structures_A.kernel_object \ Structures_H.kernel_object \ bool" where "other_obj_relation obj obj' \ (case (obj, obj') of - (TCB tcb, KOTCB tcb') \ tcb_relation tcb tcb' - | (Endpoint ep, KOEndpoint ep') \ ep_relation ep ep' + (Endpoint ep, KOEndpoint ep') \ ep_relation ep ep' | (Notification ntfn, KONotification ntfn') \ ntfn_relation ntfn ntfn' | (ArchObj (AARCH64_A.ASIDPool ap), KOArch (KOASIDPool ap')) \ asid_pool_relation ap ap' | (ArchObj (AARCH64_A.VCPU vcpu), KOArch (KOVCPU vcpu')) \ vcpu_relation vcpu vcpu' @@ -221,22 +228,28 @@ primrec aobj_relation_cuts :: "AARCH64_A.arch_kernel_obj \ machine_w | "aobj_relation_cuts (AARCH64_A.VCPU v) x = {(x, other_obj_relation)}" +definition tcb_relation_cut :: "Structures_A.kernel_object \ kernel_object \ bool" where + "tcb_relation_cut obj obj' \ + case (obj, obj') of + (TCB t, KOTCB t') \ tcb_relation t t' + | _ \ False" + primrec obj_relation_cuts :: "Structures_A.kernel_object \ machine_word \ obj_relation_cuts" where "obj_relation_cuts (CNode sz cs) x = (if well_formed_cnode_n sz cs then {(cte_map (x, y), cte_relation y) | y. y \ dom cs} else {(x, \\)})" -| "obj_relation_cuts (TCB tcb) x = {(x, other_obj_relation)}" +| "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 (ArchObj ao) x = aobj_relation_cuts ao x" - lemma obj_relation_cuts_def2: "obj_relation_cuts ko x = (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, \\)} + | TCB tcb \ {(x, tcb_relation_cut)} | ArchObj (PageTable pt) \ (\y. (x + (y << pteBits), pte_relation y)) ` {0..mask (ptTranslationBits (pt_type pt))} | ArchObj (DataPage dev sz) \ @@ -250,6 +263,7 @@ lemma obj_relation_cuts_def3: "obj_relation_cuts ko x = (case a_type ko of ACapTable n \ {(cte_map (x, y), cte_relation y) | y. length y = n} + | ATCB \ {(x, tcb_relation_cut)} | AArch (APageTable pt_t) \ (\y. (x + (y << pteBits), pte_relation y)) ` {0..mask (ptTranslationBits pt_t)} | AArch (AUserData sz) \ {(x + (n << pageBits), \_ obj. obj = KOUserData) @@ -265,6 +279,7 @@ definition is_other_obj_relation_type :: "a_type \ bool" where "is_other_obj_relation_type tp \ case tp of ACapTable n \ False + | ATCB \ False | AArch (APageTable _) \ False | AArch (AUserData _) \ False | AArch (ADeviceData _) \ False @@ -279,6 +294,10 @@ lemma is_other_obj_relation_type_PageTable: "\ is_other_obj_relation_type (AArch (APageTable pt_t))" unfolding is_other_obj_relation_type_def by simp +lemma is_other_obj_relation_type_TCB: + "\ is_other_obj_relation_type ATCB" + by (simp add: is_other_obj_relation_type_def) + lemma is_other_obj_relation_type_UserData: "\ is_other_obj_relation_type (AArch (AUserData sz))" unfolding is_other_obj_relation_type_def by simp @@ -318,10 +337,55 @@ primrec sched_act_relation :: "Deterministic_A.scheduler_action \ sc "sched_act_relation choose_new_thread a' = (a' = ChooseNewThread)" | "sched_act_relation (switch_thread x) a' = (a' = SwitchToThread x)" -definition ready_queues_relation :: - "(Deterministic_A.domain \ Structures_A.priority \ Deterministic_A.ready_queue) \ - (domain \ priority \ KernelStateData_H.ready_queue) \ bool" where - "ready_queues_relation qs qs' \ \d p. (qs d p = qs' (d, p))" +definition queue_end_valid :: "obj_ref list \ tcb_queue \ bool" where + "queue_end_valid ts q \ + (ts = [] \ tcbQueueEnd q = None) \ (ts \ [] \ tcbQueueEnd q = Some (last ts))" + +definition prev_queue_head :: "tcb_queue \ (obj_ref \ 'a) \ bool" where + "prev_queue_head q prevs \ \head. tcbQueueHead q = Some head \ prevs head = None" + +lemma prev_queue_head_heap_upd: + "\prev_queue_head q prevs; Some r \ tcbQueueHead q\ \ prev_queue_head q (prevs(r := x))" + by (clarsimp simp: prev_queue_head_def) + +definition list_queue_relation :: + "obj_ref list \ tcb_queue \ (obj_ref \ obj_ref) \ (obj_ref \ obj_ref) \ bool" + where + "list_queue_relation ts q nexts prevs \ + heap_ls nexts (tcbQueueHead q) ts \ queue_end_valid ts q \ prev_queue_head q prevs" + +lemma list_queue_relation_nil: + "list_queue_relation ts q nexts prevs \ ts = [] \ tcbQueueEmpty q" + by (fastforce dest: heap_path_head simp: tcbQueueEmpty_def list_queue_relation_def) + +definition ready_queue_relation :: + "Deterministic_A.domain \ Structures_A.priority + \ Deterministic_A.ready_queue \ ready_queue + \ (obj_ref \ obj_ref) \ (obj_ref \ obj_ref) + \ (obj_ref \ bool) \ bool" + where + "ready_queue_relation d p q q' nexts prevs flag \ + list_queue_relation q q' nexts prevs + \ (\t. flag t \ t \ set q) + \ (d > maxDomain \ p > maxPriority \ tcbQueueEmpty q')" + +definition ready_queues_relation_2 :: + "(Deterministic_A.domain \ Structures_A.priority \ Deterministic_A.ready_queue) + \ (domain \ priority \ ready_queue) + \ (obj_ref \ obj_ref) \ (obj_ref \ obj_ref) + \ (domain \ priority \ obj_ref \ bool) \ bool" + where + "ready_queues_relation_2 qs qs' nexts prevs inQs \ + \d p. let q = qs d p; q' = qs' (d, p); flag = inQs d p in + ready_queue_relation d p q q' nexts prevs flag" + +abbreviation ready_queues_relation :: "det_state \ kernel_state \ bool" where + "ready_queues_relation s s' \ + ready_queues_relation_2 + (ready_queues s) (ksReadyQueues s') (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + (\d p. inQ d p |< tcbs_of' s')" + +lemmas ready_queues_relation_def = ready_queues_relation_2_def definition ghost_relation :: "Structures_A.kheap \ (machine_word \ vmpage_size) \ (machine_word \ nat) \ (machine_word \ pt_type) \ bool" where @@ -381,6 +445,8 @@ lemma obj_relation_cutsE: \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; + \tcb tcb'. \ y = x; ko = TCB tcb; ko' = KOTCB tcb'; tcb_relation tcb tcb' \ + \ R; \pt z pte'. \ ko = ArchObj (PageTable pt); y = x + (z << pteBits); z \ mask (ptTranslationBits (pt_type pt)); ko' = KOArch (KOPTE pte'); pte_relation' (pt_apply pt z) pte' \ @@ -391,8 +457,9 @@ lemma obj_relation_cutsE: \ y = x; other_obj_relation ko ko'; is_other_obj_relation_type (a_type ko) \ \ R \ \ R" by (force simp: obj_relation_cuts_def2 is_other_obj_relation_type_def a_type_def - cte_relation_def pte_relation_def - split: Structures_A.kernel_object.splits if_splits AARCH64_A.arch_kernel_obj.splits) + cte_relation_def pte_relation_def tcb_relation_cut_def + split: Structures_A.kernel_object.splits kernel_object.splits if_splits + AARCH64_A.arch_kernel_obj.splits) lemma eq_trans_helper: "\ x = y; P y = Q \ \ P x = Q" @@ -460,7 +527,7 @@ definition state_relation :: "(det_state \ kernel_state) set" where pspace_relation (kheap s) (ksPSpace s') \ ekheap_relation (ekheap s) (ksPSpace s') \ sched_act_relation (scheduler_action s) (ksSchedulerAction s') - \ ready_queues_relation (ready_queues s) (ksReadyQueues s') + \ ready_queues_relation s s' \ ghost_relation (kheap s) (gsUserPages s') (gsCNodes s') (gsPTTypes (ksArchState s')) \ cdt_relation (swp cte_at s) (cdt s) (ctes_of s') \ cdt_list_relation (cdt_list s) (cdt s) (ctes_of s') @@ -482,6 +549,10 @@ lemma curthread_relation: "(a, b) \ state_relation \ ksCurThread b = cur_thread a" by (simp add: state_relation_def) +lemma curdomain_relation[elim!]: + "(s, s') \ state_relation \ cur_domain s = ksCurDomain s'" + by (clarsimp simp: state_relation_def) + lemma state_relation_pspace_relation[elim!]: "(s,s') \ state_relation \ pspace_relation (kheap s) (ksPSpace s')" by (simp add: state_relation_def) @@ -490,12 +561,24 @@ 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')" + by (clarsimp simp: state_relation_def) + +lemma state_relation_ready_queues_relation[elim!]: + "(s, s') \ state_relation \ ready_queues_relation s s'" + by (simp add: state_relation_def) + +lemma state_relation_idle_thread[elim!]: + "(s, s') \ state_relation \ idle_thread s = ksIdleThread s'" + by (clarsimp simp: state_relation_def) + lemma state_relationD: "(s, s') \ state_relation \ pspace_relation (kheap s) (ksPSpace s') \ ekheap_relation (ekheap s) (ksPSpace s') \ sched_act_relation (scheduler_action s) (ksSchedulerAction s') \ - ready_queues_relation (ready_queues s) (ksReadyQueues s') \ + ready_queues_relation s s' \ ghost_relation (kheap s) (gsUserPages s') (gsCNodes s') (gsPTTypes (ksArchState s')) \ cdt_relation (swp cte_at s) (cdt s) (ctes_of s') \ cdt_list_relation (cdt_list s) (cdt s) (ctes_of s') \ @@ -517,7 +600,7 @@ lemma state_relationE [elim?]: and rl: "\ pspace_relation (kheap s) (ksPSpace s'); ekheap_relation (ekheap s) (ksPSpace s'); sched_act_relation (scheduler_action s) (ksSchedulerAction s'); - ready_queues_relation (ready_queues s) (ksReadyQueues s'); + ready_queues_relation s s'; ghost_relation (kheap s) (gsUserPages s') (gsCNodes s') (gsPTTypes (ksArchState 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'); diff --git a/proof/refine/AARCH64/Syscall_R.thy b/proof/refine/AARCH64/Syscall_R.thy index f64f361d95..3fa35533cd 100644 --- a/proof/refine/AARCH64/Syscall_R.thy +++ b/proof/refine/AARCH64/Syscall_R.thy @@ -352,15 +352,13 @@ lemma threadSet_tcbDomain_update_sch_act_wf[wp]: lemma setDomain_corres: "corres dc (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)" + (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 corres_guard_imp) apply (rule corres_split[OF getCurThread_corres]) - apply (rule corres_split[OF tcbSchedDequeue_corres]) + apply (rule corres_split[OF tcbSchedDequeue_corres], simp) apply (rule corres_split) apply (rule ethread_set_corres; simp) apply (clarsimp simp: etcb_relation_def) @@ -369,26 +367,38 @@ lemma setDomain_corres: apply (rule corres_split) apply clarsimp apply (rule corres_when[OF refl]) - apply (rule tcbSchedEnqueue_corres) + apply (rule tcbSchedEnqueue_corres, simp) apply (rule corres_when[OF refl]) apply (rule rescheduleRequired_corres) - apply ((wp hoare_drop_imps hoare_vcg_conj_lift | clarsimp| assumption)+)[5] - apply clarsimp - apply (rule_tac Q="\_. valid_objs' and valid_queues' and valid_queues and - (\s. sch_act_wf (ksSchedulerAction s) s) and tcb_at' tptr" - in hoare_strengthen_post[rotated]) - apply (auto simp: invs'_def valid_state'_def sch_act_wf_weak st_tcb_at'_def o_def)[1] - apply (wp threadSet_valid_objs' threadSet_valid_queues'_no_state - threadSet_valid_queues_no_state - threadSet_pred_tcb_no_state | simp)+ - apply (rule_tac Q = "\r s. invs' s \ (\p. tptr \ set (ksReadyQueues s p)) \ 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) - apply (drule(1) bspec) - apply (clarsimp simp:tcb_cte_cases_def cteSizeBits_def) + 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 Tcb_R.tcbSchedDequeue_not_in_queue)+ + apply (wp hoare_vcg_all_lift tcbSchedDequeue_not_queued)+ apply clarsimp apply (frule tcb_at_is_etcb_at) apply simp+ @@ -396,7 +406,6 @@ lemma setDomain_corres: simp: valid_sched_def valid_sched_action_def) done - lemma performInvocation_corres: "\ inv_relation i i'; call \ block \ \ corres (dc \ (=)) @@ -761,90 +770,71 @@ 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 - \\rv. invs'\" + doReplyTransfer t' t slot grant + \\_. invs'\" apply (simp add: doReplyTransfer_def liftM_def) apply (rule hoare_seq_ext [OF _ gts_sp']) apply (rule hoare_seq_ext [OF _ assert_sp]) apply (rule hoare_seq_ext [OF _ getCTE_sp]) apply (wp, wpc) - apply (wp) + apply wp apply (wp (once) sts_invs_minor'') - apply (simp) + apply simp apply (wp (once) sts_st_tcb') - apply (wp)[1] - apply (rule_tac Q="\rv s. invs' s - \ t \ ksIdleThread s - \ st_tcb_at' awaiting_reply' t s" + 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 (frule_tac t=t in invs'_not_runnable_not_queued) - apply (erule pred_tcb'_weakenE, case_tac st, clarsimp+) + apply clarsimp apply (rule conjI, erule pred_tcb'_weakenE, case_tac st, clarsimp+) - apply (rule conjI, rule impI, erule pred_tcb'_weakenE, case_tac st) - apply (clarsimp | drule(1) obj_at_conj')+ 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 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 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]) + 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 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="\rv s. invs' s \ sch_act_simple s - \ st_tcb_at' awaiting_reply' t s - \ t \ ksIdleThread s" - in hoare_post_imp) - apply (clarsimp) - apply (frule_tac t=t in invs'_not_runnable_not_queued) - apply (erule pred_tcb'_weakenE, case_tac st, clarsimp+) + 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 (rule conjI, rule impI, erule pred_tcb'_weakenE, case_tac st) - apply (clarsimp | drule(1) obj_at_conj')+ 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 clarsimp apply (erule_tac P="\st. awaiting_reply' st \ activatable' st" - in pred_tcb'_weakenE) + 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 clarsimp apply (rule conjI) - apply (clarsimp simp: invs'_def valid_state'_def valid_idle'_def) - apply (rule conjI) - apply clarsimp - apply (clarsimp simp: obj_at'_def idle_tcb'_def pred_tcb_at'_def) + 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 (rule conjI) apply (clarsimp simp : invs'_def valid_state'_def valid_idle'_def pred_tcb_at'_def obj_at'_def idle_tcb'_def) - apply (rule conjI) - apply clarsimp - apply (frule invs'_not_runnable_not_queued) - apply (erule pred_tcb'_weakenE, clarsimp) - apply (frule (1) not_tcbQueued_not_ksQ) - apply simp - apply clarsimp 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) @@ -854,35 +844,9 @@ lemma ct_active_runnable' [simp]: "ct_active' s \ ct_in_state' runnable' s" by (fastforce simp: ct_in_state'_def elim!: pred_tcb'_weakenE) -lemma valid_irq_node_tcbSchedEnqueue[wp]: - "\\s. valid_irq_node' (irq_node' s) s \ tcbSchedEnqueue ptr - \\rv s'. valid_irq_node' (irq_node' s') s'\" - apply (rule hoare_pre) - apply (simp add:valid_irq_node'_def ) - apply (wp unless_wp hoare_vcg_all_lift | wps)+ - apply (simp add:tcbSchedEnqueue_def) - apply (wp unless_wp| simp)+ - apply (simp add:valid_irq_node'_def) - done - -lemma rescheduleRequired_valid_queues_but_ct_domain: - "\\s. Invariants_H.valid_queues s \ valid_objs' s - \ (\x. ksSchedulerAction s = SwitchToThread x \ st_tcb_at' runnable' x s) \ - rescheduleRequired - \\_. Invariants_H.valid_queues\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp)+ - done - -lemma rescheduleRequired_valid_queues'_but_ct_domain: - "\\s. valid_queues' s - \ (\x. ksSchedulerAction s = SwitchToThread x \ st_tcb_at' runnable' x s) - \ - rescheduleRequired - \\_. valid_queues'\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp | fastforce simp: valid_queues'_def)+ - done +crunches tcbSchedEnqueue + for valid_irq_node[wp]: "\s. valid_irq_node' (irq_node' s) s" + (rule: valid_irq_node_lift) lemma tcbSchedEnqueue_valid_action: "\\s. \x. ksSchedulerAction s = SwitchToThread x \ st_tcb_at' runnable' x s\ @@ -893,10 +857,11 @@ lemma tcbSchedEnqueue_valid_action: done abbreviation (input) "all_invs_but_sch_extra \ - \s. valid_pspace' s \ Invariants_H.valid_queues s \ + \s. valid_pspace' s \ sym_refs (state_refs_of' s) \ sym_refs (state_hyp_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 \ @@ -908,7 +873,7 @@ abbreviation (input) "all_invs_but_sch_extra \ valid_machine_state' s \ cur_tcb' s \ untyped_ranges_zero' s \ - valid_queues' s \ pspace_domain_valid s \ + pspace_domain_valid s \ ksCurDomain s \ maxDomain \ valid_dom_schedule' s \ (\x. ksSchedulerAction s = SwitchToThread x \ st_tcb_at' runnable' x s)" @@ -919,15 +884,13 @@ lemma rescheduleRequired_all_invs_but_extra: apply (simp add: invs'_def valid_state'_def) apply (wp add: rescheduleRequired_ct_not_inQ rescheduleRequired_sch_act' - rescheduleRequired_valid_queues_but_ct_domain - rescheduleRequired_valid_queues'_but_ct_domain valid_irq_node_lift valid_irq_handlers_lift'' irqs_masked_lift cur_tcb_lift) apply auto done lemma threadSet_all_invs_but_sch_extra: - shows "\ tcb_at' t and (\s. (\p. t \ set (ksReadyQueues s p))) and + shows "\ tcb_at' t and all_invs_but_sch_extra and sch_act_simple and K (ds \ maxDomain) \ threadSet (tcbDomain_update (\_. ds)) t @@ -948,13 +911,11 @@ lemma threadSet_all_invs_but_sch_extra: valid_irq_handlers_lift'' threadSet_ctes_ofT threadSet_not_inQ - threadSet_valid_queues'_no_state threadSet_tcbDomain_update_ct_idle_or_in_cur_domain' - threadSet_valid_queues threadSet_valid_dom_schedule' threadSet_iflive'T threadSet_ifunsafe'T - untyped_ranges_zero_lift + 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) @@ -982,9 +943,7 @@ lemma setDomain_invs': \ (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 (erule st_tcb_ex_cap'') apply simp - apply (case_tac st,simp_all)[1] apply (rule hoare_strengthen_post[OF hoare_vcg_conj_lift]) apply (rule threadSet_all_invs_but_sch_extra) prefer 2 @@ -1002,17 +961,14 @@ lemma setDomain_invs': done lemma performInv_invs'[wp]: - "\invs' and sch_act_simple - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p)) - and ct_active' and valid_invocation' i\ - RetypeDecls_H.performInvocation block call i \\rv. invs'\" + "\invs' and sch_act_simple and ct_active' and valid_invocation' i\ + RetypeDecls_H.performInvocation block call i + \\_. invs'\" unfolding performInvocation_def apply (cases i) - apply ((clarsimp simp: simple_sane_strg sch_act_simple_def - ct_not_ksQ sch_act_sane_def - | wp tcbinv_invs' arch_performInvocation_invs' - setDomain_invs' - | rule conjI | erule active_ex_cap')+) + 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]: @@ -1240,7 +1196,6 @@ lemma handleInvocation_corres: and (\s. ksSchedulerAction s = ResumeCurrentThread)" in hoare_post_imp) apply (clarsimp simp: ct_in_state'_def) - apply (frule(1) ct_not_ksQ) apply (clarsimp) apply (wp setThreadState_nonqueued_state_update setThreadState_st_tcb setThreadState_rct)[1] @@ -1252,14 +1207,13 @@ lemma handleInvocation_corres: 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) + 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) apply (frule tcb_at_invs') apply (clarsimp simp: invs'_def valid_state'_def ct_in_state'_def ct_not_inQ_def) - apply (frule(1) valid_queues_not_tcbQueued_not_ksQ) 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) @@ -1319,11 +1273,8 @@ lemma hinv_invs'[wp]: and st_tcb_at' active' thread" in hoare_post_imp) apply (clarsimp simp: ct_in_state'_def) - apply (frule(1) ct_not_ksQ) - apply (clarsimp) apply (wp sts_invs_minor' setThreadState_st_tcb setThreadState_rct | simp)+ apply (clarsimp) - apply (frule(1) ct_not_ksQ) apply (fastforce simp add: tcb_at_invs' ct_in_state'_def simple_sane_strg sch_act_simple_def @@ -1467,7 +1418,6 @@ lemma handleRecv_isBlocking_corres': and (\s. ex_nonz_cap_to (cur_thread s) s)) (invs' and ct_in_state' simple' and sch_act_sane - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p)) and (\s. ex_nonz_cap_to' (ksCurThread s) s)) (handle_recv isBlocking) (handleRecv isBlocking)" (is "corres dc (?pre1) (?pre2) (handle_recv _) (handleRecv _)") @@ -1530,8 +1480,7 @@ lemma handleRecv_isBlocking_corres': lemma handleRecv_isBlocking_corres: "corres dc (einvs and ct_active) - (invs' and ct_active' and sch_act_sane and - (\s. \p. ksCurThread s \ set (ksReadyQueues s p))) + (invs' and ct_active' and sch_act_sane) (handle_recv isBlocking) (handleRecv isBlocking)" apply (rule corres_guard_imp) apply (rule handleRecv_isBlocking_corres') @@ -1546,42 +1495,27 @@ lemma lookupCap_refs[wp]: "\invs'\ lookupCap t ref \\rv s. \r\zobj_refs' rv. ex_nonz_cap_to' r s\,-" by (simp add: lookupCap_def split_def | wp | simp add: o_def)+ -lemma deleteCallerCap_ksQ_ct': - "\invs' and ct_in_state' simple' and sch_act_sane and - (\s. ksCurThread s \ set (ksReadyQueues s p) \ thread = ksCurThread s)\ - deleteCallerCap thread - \\rv s. thread \ set (ksReadyQueues s p)\" - apply (rule_tac Q="\rv s. thread = ksCurThread s \ ksCurThread s \ set (ksReadyQueues s p)" - in hoare_strengthen_post) - apply (wp deleteCallerCap_ct_not_ksQ) - apply auto - done - lemma hw_invs'[wp]: "\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) - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p))\ + 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 - deleteCallerCap_ksQ_ct' hoare_lift_Pf2[OF deleteCallerCap_simple deleteCallerCap_ct'] | wpc | simp)+)[1] apply simp apply (wp deleteCallerCap_nonz_cap hoare_vcg_all_lift - deleteCallerCap_ksQ_ct' 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 - \ (\p. ksCurThread s \ set (ksReadyQueues s p)) \ thread = ksCurThread s \ ct_in_state' simple' s \ ex_nonz_cap_to' thread s @@ -1605,34 +1539,45 @@ lemma setSchedulerAction_obj_at'[wp]: by (wp, clarsimp elim!: obj_at'_pspaceI) lemma handleYield_corres: - "corres dc einvs (invs' and ct_active' and (\s. ksSchedulerAction s = ResumeCurrentThread)) handle_yield handleYield" + "corres dc + (einvs and ct_active) + (invs' and (\s. ksSchedulerAction s = ResumeCurrentThread)) + handle_yield handleYield" apply (clarsimp simp: handle_yield_def handleYield_def) apply (rule corres_guard_imp) apply (rule corres_split[OF getCurThread_corres]) apply simp - apply (rule corres_split[OF tcbSchedDequeue_corres]) - apply (rule corres_split[OF tcbSchedAppend_corres]) + apply (rule corres_split[OF tcbSchedDequeue_corres], simp) + apply (rule corres_split[OF tcbSchedAppend_corres], simp) apply (rule rescheduleRequired_corres) - apply (wp weak_sch_act_wf_lift_linear tcbSchedDequeue_valid_queues | simp add: )+ + 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) - apply clarsimp - apply (frule ct_active_runnable') - apply (clarsimp simp: invs'_def valid_state'_def ct_in_state'_def sch_act_wf_weak 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) - apply (erule(1) valid_objs_valid_tcbE[OF valid_pspace_valid_objs']) - apply (simp add:valid_tcb'_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 hy_invs': "\invs' and ct_active'\ handleYield \\r. invs' and ct_active'\" apply (simp add: handleYield_def) - apply (wp ct_in_state_thread_state_lift' - rescheduleRequired_all_invs_but_ct_not_inQ - tcbSchedAppend_invs_but_ct_not_inQ' | simp)+ - apply (clarsimp simp add: 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 - ) + 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 @@ -1834,7 +1779,7 @@ 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 haskell_assert_wp doReplyTransfer_sane getCTE_wp'| wpc)+ + apply (wp doReplyTransfer_sane getCTE_wp'| wpc)+ apply (clarsimp simp: cte_wp_at_ctes_of) done @@ -1850,74 +1795,6 @@ lemma handleReply_nonz_cap_to_ct: crunch ksQ[wp]: handleFaultReply "\s. P (ksReadyQueues s p)" -lemma doReplyTransfer_ct_not_ksQ: - "\ invs' and sch_act_simple - and tcb_at' thread and tcb_at' word - and ct_in_state' simple' - and (\s. ksCurThread s \ word) - and (\s. \p. ksCurThread s \ set(ksReadyQueues s p))\ - doReplyTransfer thread word callerSlot g - \\rv s. \p. ksCurThread s \ set(ksReadyQueues s p)\" -proof - - have astct: "\t p. - \(\s. ksCurThread s \ set(ksReadyQueues s p) \ sch_act_sane s) - and (\s. ksCurThread s \ t)\ - possibleSwitchTo t \\rv s. ksCurThread s \ set(ksReadyQueues s p)\" - apply (rule hoare_weaken_pre) - apply (wps possibleSwitchTo_ct') - apply (wp possibleSwitchTo_ksQ') - apply (clarsimp simp: sch_act_sane_def) - done - have stsct: "\t st p. - \(\s. ksCurThread s \ set(ksReadyQueues s p)) and sch_act_simple\ - setThreadState st t - \\rv s. ksCurThread s \ set(ksReadyQueues s p)\" - apply (rule hoare_weaken_pre) - apply (wps setThreadState_ct') - apply (wp hoare_vcg_all_lift sts_ksQ) - apply (clarsimp) - done - show ?thesis - apply (simp add: doReplyTransfer_def) - apply (wp, wpc) - apply (wp astct stsct hoare_vcg_all_lift - cteDeleteOne_ct_not_ksQ hoare_drop_imp - hoare_lift_Pf2 [OF cteDeleteOne_sch_act_not cteDeleteOne_ct'] - hoare_lift_Pf2 [OF doIPCTransfer_pred_tcb_at' doIPCTransfer_ct'] - hoare_lift_Pf2 [OF doIPCTransfer_ksQ doIPCTransfer_ct'] - hoare_lift_Pf2 [OF threadSet_ksQ threadSet_ct] - hoare_lift_Pf2 [OF handleFaultReply_ksQ handleFaultReply_ct'] - | simp add: ct_in_state'_def)+ - apply (fastforce simp: sch_act_simple_def sch_act_sane_def ct_in_state'_def)+ - done -qed - -lemma handleReply_ct_not_ksQ: - "\invs' and sch_act_simple - and ct_in_state' simple' - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p))\ - handleReply - \\rv s. \p. ksCurThread s \ set (ksReadyQueues s p)\" - apply (simp add: handleReply_def del: split_paired_All) - apply (subst haskell_assert_def) - apply (wp | wpc)+ - apply (wp doReplyTransfer_ct_not_ksQ getThreadCallerSlot_inv)+ - apply (rule_tac Q="\cap. - (\s. \p. ksCurThread s \ set(ksReadyQueues s p)) - and invs' - and sch_act_simple - and (\s. thread = ksCurThread s) - and tcb_at' thread - and ct_in_state' simple' - and cte_wp_at' (\c. cteCap c = cap) callerSlot" - in hoare_post_imp) - apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def - cte_wp_at_ctes_of valid_cap'_def - dest!: ctes_of_valid') - apply (wp getSlotCap_cte_wp_at getThreadCallerSlot_inv)+ - apply (clarsimp) - done - crunch valid_etcbs[wp]: handle_recv "valid_etcbs" (wp: crunch_wps simp: crunch_simps) @@ -1930,18 +1807,16 @@ lemma handleReply_handleRecv_corres: 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 handleReply_ct_not_ksQ handle_reply_valid_sched)+ + 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 (frule(1) ct_not_ksQ) 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) (invs' and sch_act_not thread - and (\s. \p. thread \ set(ksReadyQueues s p)) and st_tcb_at' simple' thread and ex_nonz_cap_to' thread) (handle_hypervisor_fault thread fault) (handleHypervisorFault thread fault)" apply (cases fault; clarsimp simp: handleHypervisorFault_def isFpuEnable_def split del: if_split) @@ -1964,12 +1839,11 @@ lemma hvmf_invs_lift: curVCPUActive_def doMachineOp_bind getRestartPC_def getRegister_def) lemma hvmf_invs_etc: - "\invs' and sch_act_not t and (\s. \p. t \ set (ksReadyQueues s p)) and st_tcb_at' simple' t and + "\invs' and sch_act_not t and st_tcb_at' simple' t and ex_nonz_cap_to' t\ handleVMFault t f \\_ _. True\, - \\_. invs' and sch_act_not t and (\s. \p. t \ set (ksReadyQueues s p)) and - st_tcb_at' simple' t and ex_nonz_cap_to' t\" + \\_. invs' and sch_act_not t and st_tcb_at' simple' t and ex_nonz_cap_to' t\" apply (rule hvmf_invs_lift) apply (clarsimp simp: invs'_def valid_state'_def valid_machine_state'_def) done @@ -1982,14 +1856,13 @@ lemma handleEvent_corres: (handle_event event) (handleEvent event)" proof - have hw: - "\isBlocking. corres dc (einvs and ct_running and (\s. scheduler_action s = resume_cur_thread)) + "\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 - dest!: ct_not_ksQ)+ + elim!: st_tcb_weakenE pred_tcb'_weakenE)+ done show ?thesis apply (case_tac event) @@ -2015,7 +1888,6 @@ proof - simp: ct_in_state_def) apply wp apply (clarsimp) - apply (frule(1) ct_not_ksQ) apply (auto simp: ct_in_state'_def sch_act_simple_def sch_act_sane_def elim: pred_tcb'_weakenE st_tcb_ex_cap'')[1] @@ -2028,12 +1900,11 @@ proof - simp: ct_in_state_def valid_fault_def) apply wp apply clarsimp - apply (frule(1) ct_not_ksQ) 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="\rv. einvs" + 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) @@ -2044,8 +1915,7 @@ proof - doMachineOp_getActiveIRQ_IRQ_active' | simp | simp add: imp_conjR | wp (once) hoare_drop_imps)+ - apply (clarsimp simp: invs'_def valid_state'_def ct_not_inQ_def valid_queues_def - valid_queues_no_bitmap_def) + apply (clarsimp simp: invs'_def valid_state'_def ct_not_inQ_def valid_queues_def) apply (rule_tac corres_underlying_split) apply (rule corres_guard_imp, rule getCurThread_corres, simp+) apply (rule corres_split_catch) @@ -2058,7 +1928,6 @@ proof - apply (fastforce elim!: st_tcb_ex_cap st_tcb_weakenE simp: ct_in_state_def) apply wp apply (clarsimp) - apply (frule(1) ct_not_ksQ) 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) @@ -2069,7 +1938,6 @@ proof - simp: ct_in_state_def) apply wp apply (clarsimp) - apply (frule(1) ct_not_ksQ) apply (auto simp: ct_in_state'_def sch_act_simple_def sch_act_sane_def elim: pred_tcb'_weakenE st_tcb_ex_cap'')[1] @@ -2087,9 +1955,9 @@ crunches handleHypervisorFault (wp: undefined_valid haskell_assert_inv simp: isFpuEnable_def) lemma hh_invs'[wp]: - "\invs' and sch_act_not p and (\s. \a b. p \ set (ksReadyQueues s (a, b))) and - st_tcb_at' simple' p and ex_nonz_cap_to' p and (\s. p \ ksIdleThread s)\ - handleHypervisorFault p t \\_. invs'\" + "\invs' and sch_act_not p and st_tcb_at' simple' p and ex_nonz_cap_to' p and (\s. p \ ksIdleThread s)\ + handleHypervisorFault p t + \\_. invs'\" supply if_split[split del] by (cases t; wpsimp simp: AARCH64_H.handleHypervisorFault_def isFpuEnable_def) @@ -2153,10 +2021,8 @@ proof - apply (rename_tac syscall) apply (case_tac syscall, (wp handleReply_sane handleReply_nonz_cap_to_ct handleReply_ksCurThread - handleReply_ct_not_ksQ | clarsimp simp: active_from_running' simple_from_running' simple_sane_strg simp del: split_paired_All | rule conjI active_ex_cap' - | drule ct_not_ksQ[rotated] | strengthen nidle)+) apply (rule hoare_strengthen_post, rule hoare_weaken_pre, @@ -2169,7 +2035,6 @@ proof - | 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' - | drule ct_not_ksQ[rotated] | wpc | wp (once) hoare_drop_imps hoare_vcg_all_lift)+ done qed diff --git a/proof/refine/AARCH64/TcbAcc_R.thy b/proof/refine/AARCH64/TcbAcc_R.thy index 5d1f8f2d2f..6382800cb1 100644 --- a/proof/refine/AARCH64/TcbAcc_R.thy +++ b/proof/refine/AARCH64/TcbAcc_R.thy @@ -59,10 +59,8 @@ lemma getHighestPrio_inv[wp]: unfolding bitmap_fun_defs by simp lemma valid_bitmapQ_bitmapQ_simp: - "\ valid_bitmapQ s \ \ - bitmapQ d p s = (ksReadyQueues s (d, p) \ [])" - unfolding valid_bitmapQ_def - by simp + "valid_bitmapQ s \ bitmapQ d p s = (\ tcbQueueEmpty (ksReadyQueues s (d, p)))" + by (simp add: valid_bitmapQ_def) lemma prioToL1Index_l1IndexToPrio_or_id: "\ unat (w'::priority) < 2 ^ wordRadix ; w < 2^(size w' - wordRadix) \ @@ -85,20 +83,6 @@ 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 :: "machine_word \ 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 and runnable' \ tcbState) t s) - \ distinct (ksReadyQueues s (d, p)) - \ (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 - lemma st_tcb_at_coerce_abstract: assumes t: "st_tcb_at' P t c" assumes sr: "(a, c) \ state_relation" @@ -107,11 +91,10 @@ lemma st_tcb_at_coerce_abstract: apply (clarsimp simp: state_relation_def pred_tcb_at'_def obj_at'_def objBits_simps) apply (erule(1) pspace_dom_relatedE) apply (erule(1) obj_relation_cutsE, simp_all) - apply (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 - AARCH64_A.arch_kernel_obj.split_asm)+ - apply fastforce + apply (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 + AARCH64_A.arch_kernel_obj.split_asm)+ done lemma st_tcb_at_runnable_coerce_concrete: @@ -133,10 +116,11 @@ lemma pspace_relation_tcb_at': assumes t: "tcb_at t a" assumes aligned: "pspace_aligned' c" assumes distinct: "pspace_distinct' c" - shows "tcb_at' t c" using assms + shows "tcb_at' t c" + using assms apply (clarsimp simp: obj_at_def) apply (drule(1) pspace_relation_absD) - apply (clarsimp simp: is_tcb other_obj_relation_def) + 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) @@ -144,13 +128,24 @@ lemma pspace_relation_tcb_at': 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'" + "\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 is_tcb_def + 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'" @@ -167,24 +162,83 @@ lemma cur_tcb_cross: 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" +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" + using assms apply (clarsimp simp add: 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) done -lemma valid_objs'_maxDomain: - "\s t. \ valid_objs' s; tcb_at' t s \ \ obj_at' (\tcb. tcbDomain tcb \ maxDomain) t s" - apply (erule (1) valid_objs_valid_tcbE) - apply (clarsimp simp: valid_tcb'_def) +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 + 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 objBits_simps') + done + +definition valid_tcbs' :: "kernel_state \ bool" where + "valid_tcbs' s' \ \ptr tcb. ksPSpace s' ptr = Some (KOTCB tcb) \ valid_tcb' tcb s'" + +lemma valid_objs'_valid_tcbs'[elim!]: + "valid_objs' s \ valid_tcbs' s" + by (auto simp: valid_objs'_def valid_tcbs'_def valid_obj'_def split: kernel_object.splits) + +lemma invs'_valid_tcbs'[elim!]: + "invs' s \ valid_tcbs' s" + by (fastforce intro: valid_objs'_valid_tcbs') + +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 valid_tcb'_def) + 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 valid_tcb'_def) done -lemma valid_objs'_maxPriority: - "\s t. \ valid_objs' s; tcb_at' t s \ \ obj_at' (\tcb. tcbPriority tcb \ maxPriority) t s" - apply (erule (1) valid_objs_valid_tcbE) - apply (clarsimp simp: valid_tcb'_def) +lemmas valid_objs'_maxPriority = valid_tcbs'_maxPriority[OF valid_objs'_valid_tcbs'] + +lemma valid_tcbs'_obj_at': + assumes "valid_tcbs' 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" + using assms + 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) done +lemma update_valid_tcb'[simp]: + "\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" + "\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 + opt_tcb_at'_def valid_arch_tcb'_def + split: option.splits thread_state.splits) + +lemma update_valid_tcbs'[simp]: + "\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': assumes masks: "\P. \\s. P (irq_masks s)\ f \\_ s. P (irq_masks s)\" shows "\valid_irq_states'\ doMachineOp f \\rv. valid_irq_states'\" @@ -282,49 +336,109 @@ lemma updateObject_tcb_inv: by simp (rule updateObject_default_inv) lemma setObject_update_TCB_corres': - assumes tcbs: "tcb_relation tcb tcb' \ tcb_relation tcbu tcbu'" - assumes tables: "\(getF, v) \ ran tcb_cap_cases. getF tcbu = getF tcb" - assumes tables': "\(getF, v) \ ran tcb_cte_cases. getF tcbu' = getF tcb'" + 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" + assumes tables': "\(getF, v) \ ran tcb_cte_cases. getF new_tcb' = getF tcb'" + assumes sched_pointers: "tcbSchedPrev new_tcb' = tcbSchedPrev tcb'" + "tcbSchedNext new_tcb' = tcbSchedNext tcb'" + assumes flag: "tcbQueued new_tcb' = tcbQueued tcb'" assumes r: "r () ()" - assumes exst: "exst_same tcb' tcbu'" - 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' \ exst_same tcb' tcbu'" 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: other_obj_relation_def exst) - 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 - 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: 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) + 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 project_inject 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 + 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 () (); exst_same tcb' tcbu'\ - \ 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 fastforce - apply (clarsimp simp: getObject_def in_monad split_def obj_at'_def - loadObject_default_def objBits_simps' in_magnitude_check) + apply (erule (7) setObject_update_TCB_corres') + apply (clarsimp simp: getObject_def in_monad split_def obj_at'_def + loadObject_default_def objBits_simps' in_magnitude_check)+ done lemma getObject_TCB_corres: @@ -364,7 +478,8 @@ lemma ball_tcb_cte_casesI: by (simp add: tcb_cte_cases_def cteSizeBits_def) lemma all_tcbI: - "\ \a b c d e f g h i j k l m n p q. P (Thread a b c d e f g h i j k l m n p q) \ \ \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: @@ -373,6 +488,9 @@ 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" + 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) \ @@ -381,10 +499,13 @@ lemma threadset_corresT: 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 (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+ @@ -414,6 +535,9 @@ lemma threadSet_corres_noopT: tcb_relation tcb (fn tcb')" assumes y: "\tcb. \(getF, setF) \ ran tcb_cte_cases. getF (fn tcb) = getF tcb" + 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)" @@ -432,9 +556,12 @@ proof - defer apply (subst bind_return [symmetric], rule corres_underlying_split [OF threadset_corresT]) - apply (simp add: x) - apply simp - apply (rule y) + 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 @@ -453,14 +580,20 @@ 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'\" + 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)+ @@ -689,7 +822,12 @@ lemma threadSet_valid_pspace'T_P: assumes v: "\tcb. (P \ Q' (tcbBoundNotification tcb)) \ (\s. valid_bound_ntfn' (tcbBoundNotification tcb) s \ valid_bound_ntfn' (tcbBoundNotification (F tcb)) s)" - + assumes p: "\tcb. (P \ Q'' (tcbSchedPrev tcb)) \ + (\s. opt_tcb_at' (tcbSchedPrev tcb) s + \ opt_tcb_at' (tcbSchedPrev (F tcb)) s)" + assumes n: "\tcb. (P \ Q''' (tcbSchedNext tcb)) \ + (\s. opt_tcb_at' (tcbSchedNext tcb) s + \ opt_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" @@ -697,9 +835,11 @@ lemma threadSet_valid_pspace'T_P: assumes w': "\tcb. tcbMCP tcb \ maxPriority \ tcbMCP (F tcb) \ maxPriority" assumes v': "\tcb s. valid_arch_tcb' (tcbArch tcb) s \ valid_arch_tcb' (tcbArch (F tcb)) s" shows - "\valid_pspace' and (\s. P \ st_tcb_at' Q t s \ bound_tcb_at' Q' t s)\ - threadSet F t - \\rv. valid_pspace'\" + "\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 + \\_. valid_pspace'\" apply (simp add: valid_pspace'_def threadSet_def) apply (rule hoare_pre, wp setObject_tcb_valid_objs getObject_tcb_wp) @@ -707,7 +847,7 @@ lemma threadSet_valid_pspace'T_P: 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 v w' v') + split_paired_Ball y u w v w' v' p n) done lemmas threadSet_valid_pspace'T = @@ -791,6 +931,10 @@ lemma threadSet_iflive'T: \ tcbState (F tcb) \ Inactive \ tcbState (F tcb) \ IdleThreadState \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) + \ ((\tcb. tcbSchedNext tcb = None \ tcbSchedNext (F tcb) \ None + \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) + \ ((\tcb. tcbSchedPrev tcb = None \ tcbSchedPrev (F tcb) \ None + \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) \ ((\tcb. \ tcbQueued tcb \ tcbQueued (F tcb) \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) \ ((\tcb. \ bound (atcbVCPUPtr (tcbArch tcb)) \ bound (atcbVCPUPtr (tcbArch (F tcb))) @@ -846,6 +990,12 @@ lemmas threadSet_ctes_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) + \ 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 objBits_simps') + lemma threadSet_idle'T: assumes x: "\tcb. \(getF, setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" shows @@ -883,30 +1033,6 @@ lemma set_tcb_bitmapQ_no_L2_orphans[wp]: apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp add: bitmapQ_def)+ done -lemma threadSet_valid_queues_no_bitmap: - "\ valid_queues_no_bitmap and - (\s. \d p. (\tcb. (inQ d p tcb \ runnable' (tcbState tcb)) \ - \(inQ d p (f tcb) \ runnable' (tcbState (f tcb)))) - \ obj_at' (\tcb. (inQ d p tcb \ runnable' (tcbState tcb)) \ - \(inQ d p (f tcb) \ runnable' (tcbState (f tcb)))) t s - \ t \ set (ksReadyQueues s (d, p)) - )\ - threadSet f t - \\rv. valid_queues_no_bitmap \" - apply (simp add: threadSet_def) - apply wp - apply (simp add: Invariants_H.valid_queues_no_bitmap_def' pred_tcb_at'_def) - - apply (wp setObject_queues_unchanged_tcb - hoare_Ball_helper - hoare_vcg_all_lift - setObject_tcb_strongest)[1] - apply (wp getObject_tcb_wp) - apply (clarsimp simp: valid_queues_no_bitmap_def' pred_tcb_at'_def) - apply (clarsimp simp: obj_at'_def) - apply (fastforce) - done - lemma threadSet_valid_bitmapQ[wp]: "\ valid_bitmapQ \ threadSet f t \ \rv. valid_bitmapQ \" unfolding bitmapQ_defs threadSet_def @@ -925,72 +1051,6 @@ lemma threadSet_valid_bitmapQ_no_L2_orphans[wp]: by (clarsimp simp: setObject_def split_def) (wp | simp add: updateObject_default_def)+ -lemma threadSet_valid_queues: - "\Invariants_H.valid_queues and - (\s. \d p. (\tcb. (inQ d p tcb \ runnable' (tcbState tcb)) \ - \(inQ d p (f tcb) \ runnable' (tcbState (f tcb)))) - \ obj_at' (\tcb. (inQ d p tcb \ runnable' (tcbState tcb)) \ - \(inQ d p (f tcb) \ runnable' (tcbState (f tcb)))) t s - \ t \ set (ksReadyQueues s (d, p)) - )\ - threadSet f t - \\rv. Invariants_H.valid_queues\" - unfolding valid_queues_def - by (wp threadSet_valid_queues_no_bitmap;simp) - -definition - addToQs :: "(Structures_H.tcb \ Structures_H.tcb) - \ machine_word \ (domain \ priority \ machine_word list) - \ (domain \ priority \ machine_word list)" -where - "addToQs F t \ \qs (qdom, prio). if (\ko. \ inQ qdom prio (F ko)) - then t # qs (qdom, prio) - else qs (qdom, prio)" - -lemma addToQs_set_def: - "(t' \ set (addToQs F t qs (qdom, prio))) = (t' \ set (qs (qdom, prio)) - \ (t' = t \ (\ko. \ inQ qdom prio (F ko))))" - by (auto simp add: addToQs_def) - -lemma threadSet_valid_queues_addToQs: - "\\s. (\ko qdom prio. ko_at' ko t s \ inQ qdom prio (F ko) \ \ inQ qdom prio ko - \ t \ set (ksReadyQueues s (qdom, prio))) - \ valid_queues' (ksReadyQueues_update (addToQs F t) s)\ - threadSet F t - \\rv. 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 objBits_simps addToQs_set_def - split del: if_split cong: if_cong) - apply (fastforce split: if_split_asm) - done - -lemma threadSet_valid_queues_Qf: - "\\s. (\ko qdom prio. ko_at' ko t s \ inQ qdom prio (F ko) \ \ inQ qdom prio ko - \ t \ set (ksReadyQueues s (qdom, prio))) - \ valid_queues' (ksReadyQueues_update Qf s) - \ (\prio. set (Qf (ksReadyQueues s) prio) - \ set (addToQs F t (ksReadyQueues s) prio))\ - threadSet F t - \\rv. valid_queues'\" - apply (wp threadSet_valid_queues_addToQs) - apply (clarsimp simp: valid_queues'_def subset_iff) - done - -lemma addToQs_subset: - "set (qs p) \ set (addToQs F t qs p)" -by (clarsimp simp: addToQs_def split_def) - -lemmas threadSet_valid_queues' - = threadSet_valid_queues_Qf - [where Qf=id, simplified ksReadyQueues_update_id - id_apply addToQs_subset simp_thms] - lemma threadSet_cur: "\\s. cur_tcb' s\ threadSet f t \\rv s. cur_tcb' s\" apply (simp add: threadSet_def cur_tcb'_def) @@ -1006,7 +1066,7 @@ lemma modifyReadyQueuesL1Bitmap_obj_at[wp]: crunches setThreadState, setBoundNotification for valid_arch' [wp]: valid_arch_state' - (simp: unless_def crunch_simps) + (simp: unless_def crunch_simps wp: crunch_wps) crunch ksInterrupt'[wp]: threadSet "\s. P (ksInterruptState s)" (wp: setObject_ksInterrupt updateObject_default_inv) @@ -1259,58 +1319,103 @@ lemma threadSet_valid_dom_schedule': unfolding threadSet_def by (wp setObject_ksDomSchedule_inv hoare_Ball_helper) +lemma threadSet_wp: + "\\s. \tcb. ko_at' tcb t s \ P (s\ksPSpace := (ksPSpace s)(t \ injectKO (f tcb))\)\ + threadSet f t + \\_. P\" + unfolding threadSet_def setObject_def + apply (wpsimp wp: getObject_tcb_wp simp: updateObject_default_def) + apply (auto simp: obj_at'_def split: if_splits) + apply (erule rsubst[where P=P]) + apply (clarsimp simp: fun_upd_def) + apply (prop_tac "\ptr. psMap (ksPSpace s) ptr = ksPSpace s ptr") + apply fastforce + apply metis + done + +lemma threadSet_sched_pointers: + "\\tcb. tcbSchedNext (F tcb) = tcbSchedNext tcb; \tcb. tcbSchedPrev (F tcb) = tcbSchedPrev tcb\ + \ threadSet F tcbPtr \\s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + apply (fastforce simp: opt_map_def obj_at'_def elim: rsubst2[where P=P]) + done + +lemma threadSet_valid_sched_pointers: + "\\tcb. tcbSchedNext (F tcb) = tcbSchedNext tcb; \tcb. tcbSchedPrev (F tcb) = tcbSchedPrev tcb; + \tcb. tcbQueued (F tcb) = tcbQueued tcb\ + \ threadSet F tcbPtr \valid_sched_pointers\" + unfolding valid_sched_pointers_def + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + by (fastforce simp: opt_pred_def opt_map_def obj_at'_def split: option.splits if_splits) + +lemma threadSet_tcbSchedNexts_of: + "(\tcb. tcbSchedNext (F tcb) = tcbSchedNext tcb) \ + threadSet F t \\s. P (tcbSchedNexts_of s)\" + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + apply (erule rsubst[where P=P]) + apply (fastforce simp: opt_map_def obj_at'_def) + done + +lemma threadSet_tcbSchedPrevs_of: + "(\tcb. tcbSchedPrev (F tcb) = tcbSchedPrev tcb) \ + threadSet F t \\s. P (tcbSchedPrevs_of s)\" + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + apply (erule rsubst[where P=P]) + apply (fastforce simp: opt_map_def obj_at'_def) + done + +lemma threadSet_tcbQueued: + "(\tcb. tcbQueued (F tcb) = tcbQueued tcb) \ + threadSet F t \\s. P (tcbQueued |< tcbs_of' s)\" + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + apply (erule rsubst[where P=P]) + apply (fastforce simp: opt_pred_def opt_map_def obj_at'_def) + done + +crunches threadSet + for ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" + and ksReadyQueuesL1Bitmap[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" + and ksReadyQueuesL2Bitmap[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" + lemma threadSet_invs_trivialT: - assumes x: "\tcb. \(getF,setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" - assumes z: "\tcb. tcbState (F tcb) = tcbState tcb \ tcbDomain (F tcb) = tcbDomain tcb" - assumes w: "\tcb. is_aligned (tcbIPCBuffer tcb) msg_align_bits \ is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits" - assumes a: "\tcb. tcbBoundNotification (F tcb) = tcbBoundNotification tcb" - assumes w: "\tcb. is_aligned (tcbIPCBuffer tcb) msg_align_bits \ is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits" - 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 r: "\tcb. atcbVCPUPtr (tcbArch (F tcb)) = atcbVCPUPtr (tcbArch tcb)" - shows - "\\s. invs' 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. \ tcbQueued tcb \ tcbQueued (F tcb)) \ ex_nonz_cap_to' t s \ t \ ksCurThread s) \ - (\tcb. tcbQueued (F tcb) \ ksSchedulerAction s = ResumeCurrentThread \ tcbQueued tcb \ t \ ksCurThread s)\ - threadSet F t - \\rv. invs'\" -proof - - from z have domains: "\tcb. tcbDomain (F tcb) = tcbDomain tcb" by blast - note threadSet_sch_actT_P[where P=False, simplified] - have y: "\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 valid_state'_def split del: if_split) - apply (rule hoare_pre) - apply (wp x w v u b - threadSet_valid_pspace'T - threadSet_sch_actT_P[where P=False, simplified] - threadSet_valid_queues - threadSet_state_refs_of'T[where f'=id] - threadSet_state_hyp_refs_of' - 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_cur - untyped_ranges_zero_lift - |clarsimp simp: y z a r domains cteCaps_of_def valid_arch_tcb'_def | rule refl)+ - apply (clarsimp simp: obj_at'_def pred_tcb_at'_def) - apply (clarsimp simp: cur_tcb'_def valid_irq_node'_def valid_queues'_def o_def) - by (fastforce simp: domains ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def z a) -qed + assumes + "\tcb. \(getF,setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" + "\tcb. tcbState (F tcb) = tcbState tcb" + "\tcb. is_aligned (tcbIPCBuffer tcb) msg_align_bits + \ is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits" + "\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. tcbMCP tcb \ maxPriority \ tcbMCP (F tcb) \ maxPriority" + "\tcb. atcbVCPUPtr (tcbArch (F tcb)) = atcbVCPUPtr (tcbArch tcb)" + shows "threadSet F t \invs'\" + apply (simp add: invs'_def valid_state'_def split del: if_split) + apply (wp threadSet_valid_pspace'T + threadSet_sch_actT_P[where P=False, simplified] + threadSet_state_refs_of'T[where f'=id] + threadSet_state_hyp_refs_of' + 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_cur + untyped_ranges_zero_lift + sym_heap_sched_pointers_lift threadSet_valid_sched_pointers + threadSet_tcbQueued + threadSet_tcbSchedPrevs_of threadSet_tcbSchedNexts_of valid_bitmaps_lift + | clarsimp simp: assms cteCaps_of_def valid_arch_tcb'_def | rule refl)+ + apply (clarsimp simp: o_def) + by (auto simp: assms obj_at'_def) lemmas threadSet_invs_trivial = threadSet_invs_trivialT [OF all_tcbI all_tcbI all_tcbI all_tcbI, OF ball_tcb_cte_casesI] @@ -1357,6 +1462,70 @@ lemma atcbVCPUPtr_atcbContextSet_id[simp]: "atcbVCPUPtr (atcbContextSet f (tcbArch tcb)) = atcbVCPUPtr (tcbArch tcb)" by (simp add: atcbContextSet_def) +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'] + +lemma setObject_valid_tcbs': + assumes preserve_valid_tcb': "\s s' ko ko' x n tcb tcb'. + \ (ko', s') \ fst (updateObject val ko ptr x n s); P s; + lookupAround2 ptr (ksPSpace s) = (Some (x, ko), n); + projectKO_opt ko = Some tcb; projectKO_opt ko' = Some tcb'; + valid_tcb' tcb s \ \ valid_tcb' tcb' s" + shows "\valid_tcbs' and P\ setObject ptr val \\rv. valid_tcbs'\" + unfolding valid_tcbs'_def + apply (clarsimp simp: valid_def) + apply (rename_tac s s' ptr' tcb) + apply (prop_tac "\tcb'. valid_tcb' tcb s \ valid_tcb' tcb s'") + apply clarsimp + apply (erule (1) use_valid[OF _ setObject_valid_tcb']) + apply (drule spec, erule mp) + apply (clarsimp simp: setObject_def in_monad split_def lookupAround2_char1) + apply (rename_tac s ptr' new_tcb' ptr'' old_tcb_ko' s' f) + apply (case_tac "ptr'' = ptr'"; clarsimp) + apply (prop_tac "\old_tcb' :: tcb. projectKO_opt old_tcb_ko' = Some old_tcb'") + apply (frule updateObject_type) + apply (case_tac old_tcb_ko'; clarsimp simp: project_inject) + apply (erule exE) + apply (rule preserve_valid_tcb', assumption+) + apply (simp add: prod_eqI lookupAround2_char1) + apply force + apply (clarsimp simp: project_inject) + apply (clarsimp simp: project_inject) + done + +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 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 + \\_. valid_tcb' tcb\" + apply (simp add: threadSet_def) + apply (wpsimp wp: setObject_valid_tcb') + done + +lemma threadSet_valid_tcbs': + "\valid_tcbs' and (\s. \tcb. valid_tcb' tcb s \ valid_tcb' (f tcb) s)\ + threadSet f t + \\_. valid_tcbs'\" + apply (simp add: threadSet_def) + apply (rule hoare_seq_ext[OF _ getObject_tcb_sp]) + apply (wpsimp wp: setObject_tcb_valid_tcbs') + apply (clarsimp simp: obj_at'_def valid_tcbs'_def) + 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 valid_arch_tcb'_def tcb_cte_cases_def objBits_simps') + done + lemma asUser_corres': assumes y: "corres_underlying Id False True r \ \ f g" shows "corres r (tcb_at t and pspace_aligned and pspace_distinct) \ @@ -1496,13 +1665,6 @@ lemma asUser_valid_pspace'[wp]: simp: atcbContextSet_def valid_arch_tcb'_def)+ done -lemma asUser_valid_queues[wp]: - "\Invariants_H.valid_queues\ asUser t m \\rv. Invariants_H.valid_queues\" - apply (simp add: asUser_def split_def) - apply (wp hoare_drop_imps | simp)+ - apply (wp threadSet_valid_queues hoare_drop_imps | simp)+ - done - lemma asUser_ifunsafe'[wp]: "\if_unsafe_then_cap'\ asUser t m \\rv. if_unsafe_then_cap'\" apply (simp add: asUser_def split_def) @@ -1787,19 +1949,22 @@ lemma ethreadget_corres: apply (simp add: x) done -lemma setQueue_corres: - "corres dc \ \ (set_tcb_queue d p q) (setQueue d p q)" - apply (rule corres_no_failI) - apply wp - apply (clarsimp simp: setQueue_def in_monad set_tcb_queue_def return_def simpler_modify_def) - apply (fastforce simp: state_relation_def ready_queues_relation_def) - done - - -lemma getQueue_corres: "corres (=) \ \ (get_tcb_queue qdom prio) (getQueue qdom prio)" - apply (clarsimp simp add: getQueue_def state_relation_def ready_queues_relation_def get_tcb_queue_def gets_def) - apply (fold gets_def) - apply simp +lemma getQueue_corres: + "corres (\ls q. (ls = [] \ tcbQueueEmpty q) \ (ls \ [] \ tcbQueueHead q = Some (hd ls)) + \ queue_end_valid ls q) + \ \ (get_tcb_queue qdom prio) (getQueue qdom prio)" + apply (clarsimp simp: get_tcb_queue_def getQueue_def tcbQueueEmpty_def) + apply (rule corres_bind_return2) + apply (rule corres_symb_exec_l[OF _ _ gets_sp]) + apply (rule corres_symb_exec_r[OF _ gets_sp]) + apply clarsimp + apply (drule state_relation_ready_queues_relation) + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def + list_queue_relation_def) + apply (drule_tac x=qdom in spec) + apply (drule_tac x=prio in spec) + apply (fastforce dest: heap_path_head) + apply wpsimp+ done lemma no_fail_return: @@ -1814,8 +1979,8 @@ lemma addToBitmap_noop_corres: (wp | simp add: state_relation_def | rule no_fail_pre)+ lemma addToBitmap_if_null_noop_corres: (* used this way in Haskell code *) - "corres dc \ \ (return ()) (if null queue then addToBitmap d p else return ())" - by (cases "null queue", simp_all add: addToBitmap_noop_corres) + "corres dc \ \ (return ()) (if tcbQueueEmpty queue then addToBitmap d p else return ())" + by (cases "tcbQueueHead queue", simp_all add: addToBitmap_noop_corres) lemma removeFromBitmap_corres_noop: "corres dc \ \ (return ()) (removeFromBitmap tdom prioa)" @@ -1832,56 +1997,701 @@ crunch typ_at'[wp]: removeFromBitmap "\s. P (typ_at' T p s)" 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 ekheap_relation_tcb_domain_priority: + "\ekheap_relation (ekheap s) (ksPSpace s'); ekheap s t = Some (tcb); + ksPSpace s' t = Some (KOTCB tcb')\ + \ 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 (clarsimp simp: other_obj_relation_def etcb_relation_def) + done + +lemma no_fail_thread_get[wp]: + "no_fail (tcb_at tcb_ptr) (thread_get f tcb_ptr)" + unfolding thread_get_def + apply wpsimp + apply (clarsimp simp: tcb_at_def) + done + +lemma pspace_relation_tcb_relation: + "\pspace_relation (kheap s) (ksPSpace s'); kheap s ptr = Some (TCB tcb); + ksPSpace s' ptr = Some (KOTCB tcb')\ + \ 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: obj_at_def obj_at'_def tcb_relation_cut_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) + apply (frule (1) pspace_relation_tcb_relation) + apply (fastforce simp: obj_at'_def) + 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) + apply (frule (1) ekheap_relation_etcb_relation) + apply (fastforce simp: obj_at'_def) + apply (fastforce dest!: etcb_rel) + done + +lemma tcbQueued_update_pspace_relation[wp]: + fixes s :: det_state + shows "threadSet (tcbQueued_update f) tcbPtr \\s'. pspace_relation (kheap s) (ksPSpace s')\" + by (wpsimp wp: threadSet_pspace_relation simp: tcb_relation_def) + +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 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 threadSet_ghost_relation[wp]: + "threadSet f tcbPtr \\s'. ghost_relation (kheap s) (gsUserPages s') (gsCNodes s') (gsPTTypes (ksArchState 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 removeFromBitmap_ghost_relation[wp]: + "removeFromBitmap tdom prio + \\s'. ghost_relation (kheap s) (gsUserPages s') (gsCNodes s') (gsPTTypes (ksArchState 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) + +crunches tcbQueueRemove, tcbQueuePrepend, tcbQueueAppend, tcbQueueInsert, + setQueue, removeFromBitmap + for ghost_relation_projs[wp]: "\s. P (gsUserPages s) (gsCNodes s) (gsPTTypes (ksArchState 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) + +crunches 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 + +crunches 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) + +crunches 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 pspace_canonical'[wp]: pspace_canonical' + 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 ready_queue_relation_def Let_def) + apply (wpsimp wp: threadSet_wp) + apply (clarsimp simp: list_queue_relation_def obj_at'_def) + apply (rename_tac tcb' d p) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: list_queue_relation_def) + apply (rule conjI) + apply (drule_tac x=tcbPtr in spec) + apply (fastforce intro: heap_path_heap_upd_not_in + simp: inQ_def opt_map_def opt_pred_def obj_at'_def) + apply (rule conjI) + apply (drule_tac x=tcbPtr in spec) + apply (clarsimp simp: prev_queue_head_def) + apply (prop_tac "ready_queues s d p \ []", fastforce) + apply (fastforce dest: heap_path_head simp: inQ_def opt_pred_def opt_map_def fun_upd_apply) + apply (auto simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + done + +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\ + isRunnable tcb_ptr + \\rv s. \tcb'. ko_at' tcb' tcb_ptr s + \ (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_def) + apply (fastforce simp: obj_at'_def split: Structures_H.thread_state.splits) + done + +crunch (no_fail) no_fail[wp]: isRunnable + +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) + +crunches 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 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 in_set_ready_queues_inQ_eq: + "ready_queues_relation s s' \ t \ set (ready_queues s d p) \ (inQ d p |< tcbs_of' s') t" + by (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def) + +lemma in_ready_q_tcbQueued_eq: + "ready_queues_relation s s' + \ (\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_queues_relation_def ready_queue_relation_def Let_def inQ_def + opt_pred_def + split: option.splits) + done + lemma tcbSchedEnqueue_corres: - "corres dc (tcb_at t and is_etcb_at t and pspace_aligned and pspace_distinct) - (Invariants_H.valid_queues and valid_queues') - (tcb_sched_action (tcb_sched_enqueue) t) (tcbSchedEnqueue t)" -proof - - have ready_queues_helper: - "\t tcb a b. \ ekheap a t = Some tcb; obj_at' tcbQueued t b ; valid_queues' b ; - ekheap_relation (ekheap a) (ksPSpace b) \ - \ t \ set (ksReadyQueues b (tcb_domain tcb, tcb_priority tcb))" - unfolding valid_queues'_def - by (fastforce dest: ekheap_relation_absD simp: obj_at'_def inQ_def etcb_relation_def) - - show ?thesis unfolding tcbSchedEnqueue_def tcb_sched_action_def - apply (rule corres_cross_over_guard[where P'=Q and Q="tcb_at' t and Q" for Q]) - apply (fastforce simp: tcb_at_cross state_relation_def) - apply (rule corres_symb_exec_r [OF _ _ threadGet_inv, - 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 (rule no_fail_pre, wp, blast) - apply (case_tac queued; simp_all) - apply (rule corres_no_failI; simp add: no_fail_return) - apply (clarsimp simp: in_monad ethread_get_def gets_the_def bind_assoc - assert_opt_def exec_gets is_etcb_at_def get_etcb_def get_tcb_queue_def - set_tcb_queue_def simpler_modify_def ready_queues_relation_def - state_relation_def tcb_sched_enqueue_def) - apply (rule ready_queues_helper; auto) - apply (clarsimp simp: when_def) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split[where r'="(=)", OF ethreadget_corres]) - apply (simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)", OF ethreadget_corres]) - apply (simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply simp - apply (rule getQueue_corres) - apply (rule corres_split_noop_rhs2) - apply simp - 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 - apply (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 exst_same_def) - apply (wp getObject_tcb_wp | simp add: threadGet_def)+ - apply (fastforce simp: valid_queues_def valid_queues_no_bitmap_def obj_at'_def inQ_def - project_inject) - done -qed + "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) + 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)?) + + \ \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) + + 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) + + 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) + 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) + 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 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 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) + apply (frule valid_tcbs'_maxPriority[where t=tcbPtr], simp add: obj_at'_def) + 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) + 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 + 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 fun_upd_apply split: if_splits) + apply (clarsimp simp: fun_upd_apply 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 + split: if_splits option.splits) definition weak_sch_act_wf :: "scheduler_action \ kernel_state \ bool" @@ -1908,8 +2718,10 @@ lemma getSchedulerAction_corres: done lemma rescheduleRequired_corres: - "corres dc (weak_valid_sched_action and valid_etcbs and pspace_aligned and pspace_distinct) - (Invariants_H.valid_queues and valid_queues') + "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) @@ -1920,7 +2732,7 @@ lemma rescheduleRequired_corres: apply (case_tac action) apply simp apply simp - apply (rule tcbSchedEnqueue_corres) + apply (rule tcbSchedEnqueue_corres, simp) apply simp apply (rule setSchedulerAction_corres) apply simp @@ -1995,20 +2807,18 @@ lemmas addToBitmap_weak_sch_act_wf[wp] = weak_sch_act_wf_lift[OF addToBitmap_nosch] crunch st_tcb_at'[wp]: removeFromBitmap "st_tcb_at' P t" -crunch pred_tcb_at'[wp]: removeFromBitmap "pred_tcb_at' proj P t" +crunch pred_tcb_at'[wp]: removeFromBitmap "\s. Q (pred_tcb_at' proj P t s)" crunch not_st_tcb_at'[wp]: removeFromBitmap "\s. \ (st_tcb_at' P' t) s" -crunch not_pred_tcb_at'[wp]: removeFromBitmap "\s. \ (pred_tcb_at' proj P' t) s" crunch st_tcb_at'[wp]: addToBitmap "st_tcb_at' P' t" -crunch pred_tcb_at'[wp]: addToBitmap "pred_tcb_at' proj P' t" +crunch pred_tcb_at'[wp]: addToBitmap "\s. Q (pred_tcb_at' proj P t s)" crunch not_st_tcb_at'[wp]: addToBitmap "\s. \ (st_tcb_at' P' t) s" -crunch not_pred_tcb_at'[wp]: addToBitmap "\s. \ (pred_tcb_at' proj P' t) s" -crunch obj_at'[wp]: removeFromBitmap "obj_at' P t" +crunch obj_at'[wp]: removeFromBitmap "\s. Q (obj_at' P t s)" -crunch obj_at'[wp]: addToBitmap "obj_at' P t" +crunch obj_at'[wp]: addToBitmap "\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\" @@ -2025,9 +2835,11 @@ lemma addToBitmap_tcb_in_cur_domain'[wp]: done lemma tcbSchedDequeue_weak_sch_act_wf[wp]: - "\ \s. weak_sch_act_wf (ksSchedulerAction s) s \ tcbSchedDequeue a \ \_ s. weak_sch_act_wf (ksSchedulerAction s) s \" - apply (simp add: tcbSchedDequeue_def) - apply (wp threadSet_weak_sch_act_wf removeFromBitmap_weak_sch_act_wf | simp add: crunch_simps)+ + "tcbSchedDequeue tcbPtr \\s. weak_sch_act_wf (ksSchedulerAction s) s\" + apply (simp add: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wp threadSet_weak_sch_act_wf getObject_tcb_wp removeFromBitmap_weak_sch_act_wf + | simp add: crunch_simps threadGet_def)+ + apply (clarsimp simp: obj_at'_def) done lemma dequeue_nothing_eq[simp]: @@ -2043,47 +2855,342 @@ lemma gets_the_exec: "f s \ None \ (do x \ ge return_def assert_opt_def) done +lemma tcbQueueRemove_no_fail: + "no_fail (\s. tcb_at' tcbPtr s + \ (\ts. list_queue_relation ts queue (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ tcbPtr \ set ts) + \ sym_heap_sched_pointers s \ valid_objs' s) + (tcbQueueRemove queue tcbPtr)" + unfolding tcbQueueRemove_def + apply (wpsimp wp: getObject_tcb_wp) + apply normalise_obj_at' + apply (frule (1) ko_at_valid_objs') + apply fastforce + apply (clarsimp simp: list_queue_relation_def) + apply (prop_tac "tcbQueueHead queue \ Some tcbPtr \ tcbSchedPrevs_of s tcbPtr \ None") + apply (rule impI) + apply (frule not_head_prev_not_None[where p=tcbPtr]) + apply (fastforce simp: inQ_def opt_pred_def opt_map_def obj_at'_def) + apply (fastforce dest: heap_path_head) + apply fastforce + apply (fastforce simp: opt_map_def obj_at'_def valid_tcb'_def valid_bound_tcb'_def) + by (fastforce dest!: not_last_next_not_None[where p=tcbPtr] + simp: queue_end_valid_def opt_map_def obj_at'_def valid_obj'_def valid_tcb'_def) + +crunch (no_fail) no_fail[wp]: removeFromBitmap + +crunches removeFromBitmap + for ready_queues_relation[wp]: "ready_queues_relation s" + and list_queue_relation[wp]: + "\s'. list_queue_relation ts (P (ksReadyQueues s')) + (tcbSchedNexts_of s') (tcbSchedPrevs_of s')" + (simp: bitmap_fun_defs ready_queues_relation_def) + +\ \ + A direct analogue of tcbQueueRemove, used in tcb_sched_dequeue' below, so that within the proof of + tcbQueueRemove_corres, we may reason in terms of the list operations used within this function + rather than @{term filter}.\ +definition tcb_queue_remove :: "'a \ 'a list \ 'a list" where + "tcb_queue_remove a ls \ + if ls = [a] + then [] + else if a = hd ls + then tl ls + else if a = last ls + then butlast ls + else list_remove ls a" + +definition tcb_sched_dequeue' :: "obj_ref \ unit det_ext_monad" where + "tcb_sched_dequeue' tcb_ptr \ do + d \ ethread_get tcb_domain tcb_ptr; + prio \ ethread_get tcb_priority tcb_ptr; + queue \ get_tcb_queue d prio; + when (tcb_ptr \ set queue) $ set_tcb_queue d prio (tcb_queue_remove tcb_ptr queue) + od" + +lemma filter_tcb_queue_remove: + "\a \ set ls; distinct ls \ \ filter ((\) a) ls = tcb_queue_remove a ls" + apply (clarsimp simp: tcb_queue_remove_def) + apply (intro conjI impI) + apply (fastforce elim: filter_hd_equals_tl) + apply (fastforce elim: filter_last_equals_butlast) + apply (fastforce elim: filter_hd_equals_tl) + apply (frule split_list) + apply (clarsimp simp: list_remove_middle_distinct) + apply (subst filter_True | clarsimp simp: list_remove_none)+ + done + +lemma tcb_sched_dequeue_monadic_rewrite: + "monadic_rewrite False True (is_etcb_at t and (\s. \d p. distinct (ready_queues s d p))) + (tcb_sched_action tcb_sched_dequeue t) (tcb_sched_dequeue' t)" + supply if_split[split del] + apply (clarsimp simp: tcb_sched_dequeue'_def tcb_sched_dequeue_def tcb_sched_action_def + set_tcb_queue_def) + apply (rule monadic_rewrite_bind_tail)+ + apply (clarsimp simp: when_def) + apply (rule monadic_rewrite_if_r) + apply (rule_tac P="\_. distinct queue" in monadic_rewrite_guard_arg_cong) + apply (frule (1) filter_tcb_queue_remove) + apply (metis (mono_tags, lifting) filter_cong) + apply (rule monadic_rewrite_modify_noop) + apply (wpsimp wp: thread_get_wp)+ + apply (clarsimp simp: etcb_at_def split: option.splits) + apply (prop_tac "(\d' p. if d' = tcb_domain x2 \ p = tcb_priority x2 + then filter (\x. x \ t) (ready_queues s (tcb_domain x2) (tcb_priority x2)) + else ready_queues s d' p) + = ready_queues s") + apply (subst filter_True) + apply fastforce + apply (clarsimp intro!: ext split: if_splits) + apply fastforce + done + +crunches removeFromBitmap + for ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" + +lemma list_queue_relation_neighbour_in_set: + "\list_queue_relation ls q hp hp'; sym_heap hp hp'; p \ set ls\ + \ \nbr. (hp p = Some nbr \ nbr \ set ls) \ (hp' p = Some nbr \ nbr \ set ls)" + apply (rule heap_ls_neighbour_in_set) + apply (fastforce simp: list_queue_relation_def) + apply fastforce + apply (clarsimp simp: list_queue_relation_def prev_queue_head_def) + apply fastforce + done + +lemma in_queue_not_head_or_not_tail_length_gt_1: + "\tcbPtr \ set ls; tcbQueueHead q \ Some tcbPtr \ tcbQueueEnd q \ Some tcbPtr; + list_queue_relation ls q nexts prevs\ + \ Suc 0 < length ls" + apply (clarsimp simp: list_queue_relation_def) + apply (cases ls; fastforce simp: queue_end_valid_def) + done + lemma tcbSchedDequeue_corres: - "corres dc (is_etcb_at t and tcb_at t and pspace_aligned and pspace_distinct) - (Invariants_H.valid_queues) - (tcb_sched_action tcb_sched_dequeue t) (tcbSchedDequeue t)" - apply (rule corres_cross_over_guard[where P'=Q and Q="tcb_at' t and Q" for Q]) - apply (fastforce simp: tcb_at_cross state_relation_def) - apply (simp only: tcbSchedDequeue_def tcb_sched_action_def) - apply (rule corres_symb_exec_r[OF _ _ threadGet_inv, where Q'="\rv. tcb_at' t and Invariants_H.valid_queues and obj_at' (\obj. tcbQueued obj = rv) t"]) - defer - apply (wp threadGet_obj_at', simp, simp) - apply (rule no_fail_pre, wp, simp) - apply (case_tac queued) - defer - apply (simp add: when_def) - apply (rule corres_no_failI) - apply (wp) - apply (clarsimp simp: in_monad ethread_get_def set_tcb_queue_def is_etcb_at_def state_relation_def) - apply (subgoal_tac "t \ set (ready_queues a (tcb_domain y) (tcb_priority y))") - prefer 2 - subgoal by (force simp: tcb_sched_dequeue_def Invariants_H.valid_queues_def valid_queues_no_bitmap_def - ready_queues_relation_def obj_at'_def inQ_def project_inject) - apply (subst gets_the_exec) - apply (simp add: get_etcb_def) - apply (subst gets_the_exec) - apply (simp add: get_etcb_def) - apply (simp add: exec_gets simpler_modify_def get_etcb_def ready_queues_relation_def cong: if_cong get_tcb_queue_def) - apply (simp add: when_def) - apply (rule corres_guard_imp) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres, simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres, simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply (simp, rule getQueue_corres) - apply (rule corres_split_noop_rhs2) - apply (simp add: tcb_sched_dequeue_def) - apply (rule setQueue_corres) - apply (rule corres_split_noop_rhs) - apply (clarsimp, rule removeFromBitmap_corres_noop) - apply (rule threadSet_corres_noop; simp_all add: tcb_relation_def exst_same_def) - apply (wp | simp)+ + "tcb_ptr = tcbPtr \ + corres dc + (in_correct_ready_q and ready_qs_distinct and valid_etcbs and tcb_at tcb_ptr + and pspace_aligned and pspace_distinct) + (sym_heap_sched_pointers and valid_objs') + (tcb_sched_action tcb_sched_dequeue tcb_ptr) (tcbSchedDequeue tcbPtr)" + supply heap_path_append[simp del] fun_upd_apply[simp del] distinct_append[simp del] + list_remove_append[simp del] + apply (rule_tac Q'="tcb_at' tcbPtr" in corres_cross_add_guard) + apply (fastforce intro!: tcb_at_cross simp: obj_at_def is_tcb_def) + apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) + apply (fastforce dest: pspace_aligned_cross) + apply (rule_tac Q'=pspace_distinct' in corres_cross_add_guard) + apply (fastforce dest: pspace_distinct_cross) + apply (rule monadic_rewrite_corres_l[where P=P and Q=P for P, simplified]) + apply (rule monadic_rewrite_guard_imp[OF tcb_sched_dequeue_monadic_rewrite]) + apply (fastforce dest: tcb_at_is_etcb_at simp: in_correct_ready_q_def ready_qs_distinct_def) + apply (clarsimp simp: tcb_sched_dequeue'_def get_tcb_queue_def tcbSchedDequeue_def getQueue_def + unless_def when_def) + apply (rule corres_symb_exec_l[OF _ _ ethread_get_sp]; wpsimp?) + apply (rename_tac dom) + apply (rule corres_symb_exec_l[OF _ _ ethread_get_sp]; wpsimp?) + apply (rename_tac prio) + 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 _ threadGet_sp]; (solves wpsimp)?) + apply (rule corres_if_strong'; fastforce?) + apply (frule state_relation_ready_queues_relation) + apply (frule in_ready_q_tcbQueued_eq[where t=tcbPtr]) + apply (fastforce 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) + apply (rule corres_symb_exec_r[OF _ threadGet_sp]; wpsimp?) + apply (rule corres_symb_exec_r[OF _ threadGet_sp]; wpsimp?) + apply (rule corres_symb_exec_r[OF _ gets_sp]; wpsimp?) + apply (rule corres_from_valid_det) + apply (fastforce intro: det_wp_modify det_wp_pre simp: set_tcb_queue_def) + apply (wpsimp wp: tcbQueueRemove_no_fail) + apply (fastforce dest: state_relation_ready_queues_relation + simp: ex_abs_underlying_def ready_queues_relation_def ready_queue_relation_def + Let_def inQ_def opt_pred_def opt_map_def obj_at'_def) + apply (clarsimp simp: state_relation_def) + apply (intro hoare_vcg_conj_lift_pre_fix; + (solves \frule singleton_eqD, frule set_tcb_queue_projs_inv, wpsimp simp: swp_def\)?) + + \ \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 tcbQueueRemove_def + split_del: if_split) + apply (frule (1) tcb_at_is_etcb_at) + apply (clarsimp simp: obj_at_def is_etcb_at_def etcb_at_def) + apply normalise_obj_at' + 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) + + apply (case_tac "d \ tcb_domain etcb \ p \ tcb_priority etcb") + apply clarsimp + apply (cut_tac p=tcbPtr and ls="ready_queues s (tcb_domain etcb) (tcb_priority etcb)" + in list_queue_relation_neighbour_in_set) + apply (fastforce dest!: spec) + apply fastforce + apply fastforce + apply (cut_tac xs="ready_queues s d p" in heap_path_head') + apply (force dest!: spec simp: ready_queues_relation_def Let_def list_queue_relation_def) + 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 (cut_tac ts="ready_queues s d p" in list_queue_relation_nil) + apply fast + apply (clarsimp simp: tcbQueueEmpty_def) + apply (prop_tac "Some tcbPtr \ tcbQueueHead (ksReadyQueues s' (d, p))") + apply (metis hd_in_set not_emptyI option.sel option.simps(2)) + apply (prop_tac "tcbPtr \ set (ready_queues s d p)") + apply blast + apply (clarsimp simp: list_queue_relation_def) + apply (intro conjI; clarsimp) + + \ \the ready queue is the singleton consisting of tcbPtr\ + apply (intro conjI) + apply (force intro!: heap_path_heap_upd_not_in simp: fun_upd_apply) + apply (clarsimp simp: queue_end_valid_def fun_upd_apply) + apply (force simp: prev_queue_head_heap_upd fun_upd_apply) + apply (clarsimp simp: inQ_def in_opt_pred fun_upd_apply) + apply (clarsimp simp: fun_upd_apply) + apply (clarsimp simp: fun_upd_apply) + + apply (clarsimp simp: etcb_at_def obj_at'_def) + apply (intro conjI; clarsimp) + + \ \tcbPtr is the head of the ready queue\ + apply (intro conjI) + apply (intro heap_path_heap_upd_not_in) + apply (force simp: fun_upd_apply) + apply (force simp: not_emptyI opt_map_red) + apply assumption + apply (clarsimp simp: queue_end_valid_def fun_upd_apply) + apply (clarsimp simp: prev_queue_head_def fun_upd_apply) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + apply (clarsimp simp: fun_upd_apply) + apply (clarsimp simp: fun_upd_apply) + apply (intro conjI; clarsimp) + + \ \tcbPtr is the end of the ready queue\ + apply (intro conjI) + apply (intro heap_path_heap_upd_not_in) + apply (simp add: fun_upd_apply split: if_splits) + apply (force simp: not_emptyI opt_map_red) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + apply (clarsimp simp: queue_end_valid_def fun_upd_apply) + apply (force simp: prev_queue_head_def fun_upd_apply opt_map_red opt_map_upd_triv) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + apply (clarsimp simp: fun_upd_apply) + apply (clarsimp simp: fun_upd_apply) + + \ \tcbPtr is in the middle of the ready queue\ + apply (intro conjI) + apply (intro heap_path_heap_upd_not_in) + apply (simp add: fun_upd_apply) + apply (force simp: not_emptyI opt_map_red) + apply (force simp: not_emptyI opt_map_red) + apply fastforce + apply (clarsimp simp: opt_map_red opt_map_upd_triv) + apply (intro prev_queue_head_heap_upd) + apply (force dest!: spec) + apply (metis hd_in_set not_emptyI option.sel option.simps(2)) + apply fastforce + subgoal + by (clarsimp simp: inQ_def opt_map_def opt_pred_def fun_upd_apply + split: if_splits option.splits) + + \ \d = tcb_domain tcb \ p = tcb_priority tcb\ + apply clarsimp + apply (drule_tac x="tcb_domain etcb" in spec) + apply (drule_tac x="tcb_priority etcb" in spec) + apply (clarsimp simp: list_queue_relation_def) + apply (frule heap_path_head') + apply (frule heap_ls_distinct) + apply (intro conjI; clarsimp simp: tcbQueueEmpty_def) + + \ \the ready queue is the singleton consisting of tcbPtr\ + apply (intro conjI) + apply (simp add: fun_upd_apply tcb_queue_remove_def queue_end_valid_def heap_ls_unique + heap_path_last_end) + apply (simp add: fun_upd_apply tcb_queue_remove_def queue_end_valid_def heap_ls_unique + heap_path_last_end) + apply (simp add: fun_upd_apply prev_queue_head_def) + apply (case_tac "ready_queues s (tcb_domain etcb) (tcb_priority etcb)"; + clarsimp simp: tcb_queue_remove_def inQ_def opt_pred_def fun_upd_apply) + apply (intro conjI; clarsimp) + + \ \tcbPtr is the head of the ready queue\ + apply (frule set_list_mem_nonempty) + apply (frule in_queue_not_head_or_not_tail_length_gt_1) + apply fastforce + apply (fastforce simp: list_queue_relation_def) + apply (frule list_not_head) + apply (clarsimp simp: tcb_queue_remove_def) + apply (frule length_tail_nonempty) + apply (frule (2) heap_ls_next_of_hd) + apply (clarsimp simp: obj_at'_def) + apply (intro conjI impI allI) + apply (drule (1) heap_ls_remove_head_not_singleton) + apply (clarsimp simp: opt_map_red opt_map_upd_triv fun_upd_apply) + apply (clarsimp simp: queue_end_valid_def fun_upd_apply last_tl) + apply (clarsimp simp: prev_queue_head_def fun_upd_apply) + apply (case_tac "ready_queues s (tcb_domain etcb) (tcb_priority etcb)"; + clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + apply (intro conjI; clarsimp) + + \ \tcbPtr is the end of the ready queue\ + apply (frule set_list_mem_nonempty) + apply (frule in_queue_not_head_or_not_tail_length_gt_1) + apply fast + apply (force dest!: spec simp: list_queue_relation_def) + apply (clarsimp simp: queue_end_valid_def) + apply (frule list_not_last) + apply (clarsimp simp: tcb_queue_remove_def) + apply (frule length_gt_1_imp_butlast_nonempty) + apply (frule (3) heap_ls_prev_of_last) + apply (clarsimp simp: obj_at'_def) + apply (intro conjI impI; clarsimp?) + apply (drule (1) heap_ls_remove_last_not_singleton) + apply (force elim!: rsubst3[where P=heap_ls] simp: opt_map_def fun_upd_apply) + apply (clarsimp simp: opt_map_def fun_upd_apply) + apply (clarsimp simp: prev_queue_head_def fun_upd_apply opt_map_def) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + apply (meson distinct_in_butlast_not_last in_set_butlastD last_in_set not_last_in_set_butlast) + + \ \tcbPtr is in the middle of the ready queue\ + apply (clarsimp simp: obj_at'_def) + apply (frule set_list_mem_nonempty) + apply (frule split_list) + apply clarsimp + apply (rename_tac xs ys) + apply (prop_tac "xs \ [] \ ys \ []", fastforce simp: queue_end_valid_def) + apply clarsimp + apply (frule (2) ptr_in_middle_prev_next) + apply fastforce + apply (clarsimp simp: tcb_queue_remove_def) + apply (prop_tac "tcbPtr \ last xs") + apply (clarsimp simp: distinct_append) + apply (prop_tac "tcbPtr \ hd ys") + apply (fastforce dest: hd_in_set simp: distinct_append) + apply (prop_tac "last xs \ hd ys") + apply (metis distinct_decompose2 hd_Cons_tl last_in_set) + apply (prop_tac "list_remove (xs @ tcbPtr # ys) tcbPtr = xs @ ys") + apply (simp add: list_remove_middle_distinct del: list_remove_append) + apply (intro conjI impI allI; (solves \clarsimp simp: distinct_append\)?) + apply (fastforce elim!: rsubst3[where P=heap_ls] + dest!: heap_ls_remove_middle hd_in_set last_in_set + simp: distinct_append not_emptyI opt_map_def fun_upd_apply) + apply (clarsimp simp: queue_end_valid_def fun_upd_apply) + apply (case_tac xs; + fastforce simp: prev_queue_head_def opt_map_def fun_upd_apply distinct_append) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply distinct_append + split: option.splits) done lemma thread_get_test: "do cur_ts \ get_thread_state cur; g (test cur_ts) od = @@ -2143,30 +3250,84 @@ lemma setBoundNotification_corres: crunches rescheduleRequired, tcbSchedDequeue, setThreadState, setBoundNotification for tcb'[wp]: "tcb_at' addr" +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 + +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 + +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) + +crunches addToBitmap + for valid_objs'[wp]: valid_objs' + (simp: unless_def crunch_simps wp: crunch_wps) + +lemma tcbSchedEnqueue_valid_objs'[wp]: + "\valid_objs' and pspace_aligned' and pspace_distinct'\ + tcbSchedEnqueue tcbPtr + \\_. valid_objs'\" + 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 + crunches rescheduleRequired, removeFromBitmap for valid_objs'[wp]: valid_objs' - (simp: unless_def crunch_simps) + (simp: crunch_simps) +lemmas ko_at_valid_objs'_pre = + ko_at_valid_objs'[simplified project_inject, atomized, simplified, rule_format] -lemma tcbSchedDequeue_valid_objs' [wp]: "\ valid_objs' \ tcbSchedDequeue t \\_. valid_objs' \" - unfolding tcbSchedDequeue_def - apply (wp threadSet_valid_objs') - apply (clarsimp simp add: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) - apply wp - apply (simp add: if_apply_def2) - apply (wp hoare_drop_imps) - apply (wp | simp cong: if_cong add: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def if_apply_def2)+ +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] + +lemma tcbQueueRemove_valid_objs'[wp]: + "tcbQueueRemove queue tcbPtr \valid_objs'\" + unfolding tcbQueueRemove_def + apply (wpsimp wp: getObject_tcb_wp) + apply normalise_obj_at' + apply (fastforce dest!: tcb_ko_at_valid_objs_valid_tcb' + simp: valid_tcb'_def valid_bound_tcb'_def obj_at'_def) done +lemma tcbSchedDequeue_valid_objs'[wp]: + "tcbSchedDequeue t \valid_objs'\" + unfolding tcbSchedDequeue_def setQueue_def + by (wpsimp wp: threadSet_valid_objs') + lemma sts_valid_objs': - "\valid_objs' and valid_tcb_state' st\ - setThreadState st t - \\rv. valid_objs'\" - apply (simp add: setThreadState_def setQueue_def isRunnable_def isStopped_def) - apply (wp threadSet_valid_objs') - apply (simp add: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) - apply (wp threadSet_valid_objs' | simp)+ - apply (clarsimp simp: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) + "\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') + 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': @@ -2251,18 +3412,6 @@ lemma setQueue_valid_bitmapQ_except[wp]: unfolding setQueue_def bitmapQ_defs by (wp, clarsimp simp: bitmapQ_def) -lemma setQueue_valid_bitmapQ: (* enqueue only *) - "\ valid_bitmapQ and (\s. (ksReadyQueues s (d, p) = []) = (ts = [])) \ - setQueue d p ts - \\_. valid_bitmapQ \" - unfolding setQueue_def bitmapQ_defs - by (wp, clarsimp simp: bitmapQ_def) - -lemma setQueue_valid_queues': - "\valid_queues' and (\s. \t. obj_at' (inQ d p) t s \ t \ set ts)\ - setQueue d p ts \\_. valid_queues'\" - by (wp | simp add: valid_queues'_def setQueue_def)+ - lemma setQueue_cur: "\\s. cur_tcb' s\ setQueue d p ts \\rv s. cur_tcb' s\" unfolding setQueue_def cur_tcb'_def @@ -2400,9 +3549,17 @@ lemma threadSet_queued_sch_act_wf[wp]: apply (wp tcb_in_cur_domain'_lift | simp add: obj_at'_def)+ done +lemma tcbSchedNext_update_pred_tcb_at'[wp]: + "threadSet (tcbSchedNext_update f) t \\s. P (pred_tcb_at' proj P' t' s)\" + by (wp threadSet_pred_tcb_no_state crunch_wps | clarsimp simp: tcb_to_itcb'_def)+ + +lemma tcbSchedPrev_update_pred_tcb_at'[wp]: + "threadSet (tcbSchedPrev_update f) t \\s. P (pred_tcb_at' proj P' t' s)\" + by (wp threadSet_pred_tcb_no_state crunch_wps | clarsimp simp: tcb_to_itcb'_def)+ + lemma tcbSchedEnqueue_pred_tcb_at'[wp]: "\\s. pred_tcb_at' proj P' t' s \ tcbSchedEnqueue t \\_ s. pred_tcb_at' proj P' t' s\" - apply (simp add: tcbSchedEnqueue_def when_def unless_def) + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def when_def unless_def) apply (wp threadSet_pred_tcb_no_state crunch_wps | clarsimp simp: tcb_to_itcb'_def)+ done @@ -2410,8 +3567,9 @@ lemma tcbSchedDequeue_sch_act_wf[wp]: "\\s. sch_act_wf (ksSchedulerAction s) s\ tcbSchedDequeue t \\_ s. sch_act_wf (ksSchedulerAction s) s\" - unfolding tcbSchedDequeue_def - by (wp setQueue_sch_act | wp sch_act_wf_lift | simp add: if_apply_def2)+ + unfolding tcbSchedDequeue_def tcbQueueRemove_def + by (wp setQueue_sch_act threadSet_tcbDomain_triv hoare_drop_imps + | wp sch_act_wf_lift | simp add: if_apply_def2)+ crunch nosch: tcbSchedDequeue "\s. P (ksSchedulerAction s)" @@ -2507,21 +3665,22 @@ lemma tcbSchedEnqueue_sch_act[wp]: "\\s. sch_act_wf (ksSchedulerAction s) s\ tcbSchedEnqueue t \\_ s. sch_act_wf (ksSchedulerAction s) s\" - by (simp add: tcbSchedEnqueue_def unless_def) - (wp setQueue_sch_act | wp sch_act_wf_lift | clarsimp)+ + by (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_def) + (wp setQueue_sch_act threadSet_tcbDomain_triv | wp sch_act_wf_lift | clarsimp)+ lemma tcbSchedEnqueue_weak_sch_act[wp]: "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ tcbSchedEnqueue t \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: tcbSchedEnqueue_def unless_def) + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_def) apply (wp setQueue_sch_act threadSet_weak_sch_act_wf | clarsimp)+ done -lemma threadGet_wp: "\\s. tcb_at' t s \ (\tcb. ko_at' tcb t s \ P (f tcb) s)\ threadGet f t \P\" +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 + apply (clarsimp simp: obj_at'_def) done lemma threadGet_const: @@ -2567,14 +3726,6 @@ lemma addToBitmap_bitmapQ: by (wpsimp simp: bitmap_fun_defs bitmapQ_def prioToL1Index_bit_set prioL2Index_bit_set simp_del: bit_exp_iff) -lemma addToBitmap_valid_queues_no_bitmap_except: -" \ valid_queues_no_bitmap_except t \ - addToBitmap d p - \\_. valid_queues_no_bitmap_except t \" - unfolding addToBitmap_def modifyReadyQueuesL1Bitmap_def modifyReadyQueuesL2Bitmap_def - getReadyQueuesL1Bitmap_def getReadyQueuesL2Bitmap_def valid_queues_no_bitmap_except_def - by (wp, clarsimp) - crunch norq[wp]: addToBitmap "\s. P (ksReadyQueues s)" (wp: updateObject_cte_inv hoare_drop_imps) crunch norq[wp]: removeFromBitmap "\s. P (ksReadyQueues s)" @@ -2606,9 +3757,8 @@ lemma prioToL1Index_complement_nth_w2p: lemma valid_bitmapQ_exceptE: "\ valid_bitmapQ_except d' p' s ; d \ d' \ p \ p' \ - \ bitmapQ d p s = (ksReadyQueues s (d, p) \ [])" - unfolding valid_bitmapQ_except_def - by blast + \ bitmapQ d p s = (\ tcbQueueEmpty (ksReadyQueues s (d, p)))" + by (fastforce simp: valid_bitmapQ_except_def) lemma invertL1Index_eq_cancelD: "\ invertL1Index i = invertL1Index j ; i < l2BitmapSize ; j < l2BitmapSize \ @@ -2723,22 +3873,15 @@ lemma addToBitmap_valid_bitmapQ_except: done lemma addToBitmap_valid_bitmapQ: -" \ valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and - (\s. ksReadyQueues s (d,p) \ []) \ - addToBitmap d p - \\_. valid_bitmapQ \" -proof - - have "\ valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and - (\s. ksReadyQueues s (d,p) \ []) \ - addToBitmap d p - \\_. valid_bitmapQ_except d p and - bitmapQ_no_L2_orphans and (\s. bitmapQ d p s \ ksReadyQueues s (d,p) \ []) \" - by (wp addToBitmap_valid_queues_no_bitmap_except addToBitmap_valid_bitmapQ_except - addToBitmap_bitmapQ_no_L2_orphans addToBitmap_bitmapQ; simp) - - thus ?thesis - by - (erule hoare_strengthen_post; fastforce elim: valid_bitmap_valid_bitmapQ_exceptE) -qed + "\valid_bitmapQ_except d p and bitmapQ_no_L2_orphans + and (\s. \ tcbQueueEmpty (ksReadyQueues s (d,p)))\ + addToBitmap d p + \\_. valid_bitmapQ\" + (is "\?pre\ _ \_\") + apply (rule_tac Q="\_ s. ?pre s \ bitmapQ d p s" in hoare_strengthen_post) + apply (wpsimp wp: addToBitmap_valid_bitmapQ_except addToBitmap_bitmapQ) + apply (fastforce elim: valid_bitmap_valid_bitmapQ_exceptE) + done 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 \" @@ -2756,12 +3899,6 @@ lemma threadGet_const_tcb_at_imp_lift: apply (clarsimp simp: obj_at'_def) done -lemma valid_queues_no_bitmap_objD: - "\ valid_queues_no_bitmap s; t \ set (ksReadyQueues s (d, p))\ - \ obj_at' (inQ d p and runnable' \ tcbState) t s" - unfolding valid_queues_no_bitmap_def - by metis - lemma setQueue_bitmapQ_no_L1_orphans[wp]: "\ bitmapQ_no_L1_orphans \ setQueue d p ts @@ -2781,126 +3918,6 @@ lemma setQueue_sets_queue[wp]: unfolding setQueue_def by (wp, simp) -lemma tcbSchedEnqueueOrAppend_valid_queues: - (* f is either (t#ts) or (ts @ [t]), so we define its properties generally *) - assumes f_set[simp]: "\ts. t \ set (f ts)" - assumes f_set_insert[simp]: "\ts. set (f ts) = insert t (set ts)" - assumes f_not_empty[simp]: "\ts. f ts \ []" - assumes f_distinct: "\ts. \ distinct ts ; t \ set ts \ \ distinct (f ts)" - shows "\Invariants_H.valid_queues and st_tcb_at' runnable' t and valid_objs' \ - do queued \ threadGet tcbQueued t; - unless queued $ - do tdom \ threadGet tcbDomain t; - prio \ threadGet tcbPriority t; - queue \ getQueue tdom prio; - setQueue tdom prio $ f queue; - when (null queue) $ addToBitmap tdom prio; - threadSet (tcbQueued_update (\_. True)) t - od - od - \\_. Invariants_H.valid_queues\" -proof - - - define could_run where "could_run == - \d p t. obj_at' (\tcb. inQ d p (tcbQueued_update (\_. True) tcb) \ runnable' (tcbState tcb)) t" - - have addToBitmap_could_run: - "\d p. \\s. \d p. t \ set (ksReadyQueues s (d, p)) \ could_run d p t s\ - addToBitmap d p - \\_ s. \d p. t \ set (ksReadyQueues s (d, p)) \ could_run d p t s\" - unfolding bitmap_fun_defs - by (wp, clarsimp simp: could_run_def) - - have setQueue_valid_queues_no_bitmap_except: - "\d p ts. - \ valid_queues_no_bitmap_except t and - (\s. ksReadyQueues s (d, p) = ts \ p \ maxPriority \ d \ maxDomain \ t \ set ts) \ - setQueue d p (f ts) - \\rv. valid_queues_no_bitmap_except t\" - unfolding setQueue_def valid_queues_no_bitmap_except_def null_def - by (wp, auto intro: f_distinct) - - have threadSet_valid_queues_could_run: - "\f. \ valid_queues_no_bitmap_except t and - (\s. \d p. t \ set (ksReadyQueues s (d,p)) \ could_run d p t s) and - valid_bitmapQ and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans \ - threadSet (tcbQueued_update (\_. True)) t - \\rv. Invariants_H.valid_queues \" - unfolding threadSet_def could_run_def - apply (rule hoare_seq_ext[OF _ getObject_tcb_sp]) - apply (rule hoare_pre) - apply (simp add: valid_queues_def valid_queues_no_bitmap_def) - apply (wp setObject_queues_unchanged_tcb hoare_Ball_helper hoare_vcg_all_lift - setObject_tcb_strongest) - apply (clarsimp simp: valid_queues_no_bitmap_except_def obj_at'_def) - done - - have setQueue_could_run: "\d p ts. - \ valid_queues and (\_. t \ set ts) and - (\s. could_run d p t s) \ - setQueue d p ts - \\rv s. (\d p. t \ set (ksReadyQueues s (d, p)) \ could_run d p t s)\" - unfolding setQueue_def valid_queues_def could_run_def - by wp (fastforce dest: valid_queues_no_bitmap_objD simp: obj_at'_def inQ_def) - - note hoare_vcg_if_lift[wp] hoare_vcg_conj_lift[wp] hoare_vcg_const_imp_lift[wp] - - show ?thesis - unfolding tcbSchedEnqueue_def null_def - apply (rule hoare_pre) - apply (rule hoare_seq_ext) - apply (simp add: unless_def) - apply (wp threadSet_valid_queues_could_run) - apply (wp addToBitmap_could_run addToBitmap_valid_bitmapQ - addToBitmap_valid_queues_no_bitmap_except addToBitmap_bitmapQ_no_L2_orphans)+ - apply (wp setQueue_valid_queues_no_bitmap_except setQueue_could_run - setQueue_valid_bitmapQ_except setQueue_sets_queue setQueue_valid_bitmapQ)+ - apply (wp threadGet_const_tcb_at_imp_lift | simp add: if_apply_def2)+ - apply clarsimp - apply (frule pred_tcb_at') - apply (frule (1) valid_objs'_maxDomain) - apply (frule (1) valid_objs'_maxPriority) - apply (clarsimp simp: valid_queues_def st_tcb_at'_def obj_at'_def valid_queues_no_bitmap_exceptI) - apply (fastforce dest!: valid_queues_no_bitmap_objD simp: obj_at'_def inQ_def could_run_def) - done -qed - -lemma tcbSchedEnqueue_valid_queues[wp]: - "\Invariants_H.valid_queues - and st_tcb_at' runnable' t - and valid_objs' \ - tcbSchedEnqueue t - \\_. Invariants_H.valid_queues\" - unfolding tcbSchedEnqueue_def - by (fastforce intro: tcbSchedEnqueueOrAppend_valid_queues) - -lemma tcbSchedAppend_valid_queues[wp]: - "\Invariants_H.valid_queues - and st_tcb_at' runnable' t - and valid_objs' \ - tcbSchedAppend t - \\_. Invariants_H.valid_queues\" - unfolding tcbSchedAppend_def - by (fastforce intro: tcbSchedEnqueueOrAppend_valid_queues) - -lemma rescheduleRequired_valid_queues[wp]: - "\\s. Invariants_H.valid_queues s \ valid_objs' s \ - weak_sch_act_wf (ksSchedulerAction s) s\ - rescheduleRequired - \\_. Invariants_H.valid_queues\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp)+ - apply (fastforce simp: weak_sch_act_wf_def elim: valid_objs'_maxDomain valid_objs'_maxPriority) - done - -lemma rescheduleRequired_valid_queues_sch_act_simple: - "\Invariants_H.valid_queues and sch_act_simple\ - rescheduleRequired - \\_. Invariants_H.valid_queues\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp | fastforce simp: Invariants_H.valid_queues_def sch_act_simple_def)+ - done - lemma rescheduleRequired_valid_bitmapQ_sch_act_simple: "\ valid_bitmapQ and sch_act_simple\ rescheduleRequired @@ -2942,151 +3959,32 @@ lemma rescheduleRequired_bitmapQ_no_L2_orphans_sch_act_simple: lemma sts_valid_bitmapQ_sch_act_simple: "\valid_bitmapQ and sch_act_simple\ - setThreadState st t + setThreadState st t \\_. valid_bitmapQ \" 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 Invariants_H.valid_queues_def inQ_def)+ + 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 \" + "\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 Invariants_H.valid_queues_def inQ_def)+ + 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 \" + "\bitmapQ_no_L1_orphans and sch_act_simple\ + setThreadState st t + \\_. bitmapQ_no_L1_orphans\" 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 Invariants_H.valid_queues_def inQ_def)+ - done - -lemma sts_valid_queues: - "\\s. Invariants_H.valid_queues s \ - ((\p. t \ set(ksReadyQueues s p)) \ runnable' st)\ - setThreadState st t \\rv. Invariants_H.valid_queues\" - apply (simp add: setThreadState_def) - apply (wp rescheduleRequired_valid_queues_sch_act_simple - threadSet_valid_queues [THEN hoare_strengthen_post]) - apply (clarsimp simp: sch_act_simple_def Invariants_H.valid_queues_def inQ_def)+ - done - -lemma sbn_valid_queues: - "\\s. Invariants_H.valid_queues s\ - setBoundNotification ntfn t \\rv. Invariants_H.valid_queues\" - apply (simp add: setBoundNotification_def) - apply (wp threadSet_valid_queues [THEN hoare_strengthen_post]) - apply (clarsimp simp: sch_act_simple_def Invariants_H.valid_queues_def inQ_def)+ - done - - - -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]: - "\valid_queues' and st_tcb_at' runnable' t \ - tcbSchedEnqueue t - \\_. valid_queues'\" - apply (simp add: tcbSchedEnqueue_def) - apply (rule hoare_pre) - apply (rule_tac B="\rv. valid_queues' and obj_at' (\obj. tcbQueued obj = rv) t" - in hoare_seq_ext) - 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 inQ_def) - apply (wp setQueue_valid_queues' | simp | simp add: setQueue_def)+ - apply (wp getObject_tcb_wp | simp add: threadGet_def)+ - apply (clarsimp simp: obj_at'_def inQ_def valid_queues'_def) - apply (wp getObject_tcb_wp | simp add: threadGet_def)+ - apply (clarsimp simp: obj_at'_def) - done - -lemma rescheduleRequired_valid_queues'_weak[wp]: - "\\s. valid_queues' s \ weak_sch_act_wf (ksSchedulerAction s) s\ - rescheduleRequired - \\_. valid_queues'\" - apply (simp add: rescheduleRequired_def) - apply wpsimp - apply (clarsimp simp: weak_sch_act_wf_def) - done - -lemma rescheduleRequired_valid_queues'_sch_act_simple: - "\valid_queues' and sch_act_simple\ - rescheduleRequired - \\_. valid_queues'\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp | fastforce simp: valid_queues'_def sch_act_simple_def)+ - done - -lemma setThreadState_valid_queues'[wp]: - "\\s. valid_queues' s\ setThreadState st t \\rv. valid_queues'\" - apply (simp add: setThreadState_def) - apply (wp rescheduleRequired_valid_queues'_sch_act_simple) - apply (rule_tac Q="\_. valid_queues'" in hoare_post_imp) - apply (clarsimp simp: sch_act_simple_def) - apply (wp threadSet_valid_queues') - apply (fastforce simp: inQ_def obj_at'_def pred_tcb_at'_def) - 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 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 cteSizeBits_def valid_tcb_state'_def) - done - -lemma setThreadState_valid_objs'[wp]: - "\ valid_tcb_state' st and valid_objs' \ setThreadState st t \ \_. valid_objs' \" - apply (simp add: setThreadState_def) - apply (wp threadSet_valid_objs' | clarsimp simp: valid_tcb'_tcbState_update)+ - done - -lemma rescheduleRequired_ksQ: - "\\s. sch_act_simple s \ P (ksReadyQueues s p)\ - rescheduleRequired - \\_ s. P (ksReadyQueues s p)\" - including no_pre - apply (simp add: rescheduleRequired_def sch_act_simple_def) - apply (rule_tac B="\rv s. (rv = ResumeCurrentThread \ rv = ChooseNewThread) - \ P (ksReadyQueues s p)" in hoare_seq_ext) - apply wpsimp - apply (case_tac x; simp) - apply wp + apply (clarsimp simp: sch_act_simple_def inQ_def)+ done lemma setSchedulerAction_ksQ[wp]: @@ -3101,17 +3999,6 @@ lemma sbn_ksQ: "\\s. P (ksReadyQueues s p)\ setBoundNotification ntfn t \\rv s. P (ksReadyQueues s p)\" by (simp add: setBoundNotification_def, wp) -lemma sts_ksQ: - "\\s. sch_act_simple s \ P (ksReadyQueues s p)\ - setThreadState st t - \\_ s. P (ksReadyQueues s p)\" - apply (simp add: setThreadState_def) - apply (wp rescheduleRequired_ksQ) - apply (rule_tac Q="\_ s. P (ksReadyQueues s p)" in hoare_post_imp) - apply (clarsimp simp: sch_act_simple_def)+ - apply (wp, simp) - done - lemma setQueue_ksQ[wp]: "\\s. P ((ksReadyQueues s)((d, p) := q))\ setQueue d p q @@ -3119,22 +4006,6 @@ lemma setQueue_ksQ[wp]: by (simp add: setQueue_def fun_upd_def[symmetric] | wp)+ -lemma tcbSchedEnqueue_ksQ: - "\\s. t' \ set (ksReadyQueues s p) \ t' \ t \ - tcbSchedEnqueue t \\_ s. t' \ set (ksReadyQueues s p)\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wpsimp wp: hoare_vcg_imp_lift threadGet_wp) - apply (drule obj_at_ko_at') - apply fastforce - done - -lemma rescheduleRequired_ksQ': - "\\s. t \ set (ksReadyQueues s p) \ sch_act_not t s \ - rescheduleRequired \\_ s. t \ set (ksReadyQueues s p)\" - apply (simp add: rescheduleRequired_def) - apply (wpsimp wp: tcbSchedEnqueue_ksQ) - done - lemma threadSet_tcbState_st_tcb_at': "\\s. P st \ threadSet (tcbState_update (\_. st)) t \\_. st_tcb_at' P t\" apply (simp add: threadSet_def pred_tcb_at'_def) @@ -3145,36 +4016,6 @@ lemma isRunnable_const: "\st_tcb_at' runnable' t\ isRunnable t \\runnable _. runnable \" by (rule isRunnable_wp) -lemma sts_ksQ': - "\\s. (runnable' st \ ksCurThread s \ t) \ P (ksReadyQueues s p)\ - setThreadState st t - \\_ s. P (ksReadyQueues s p)\" - apply (simp add: setThreadState_def) - apply (rule hoare_pre_disj') - apply (rule hoare_seq_ext [OF _ - hoare_vcg_conj_lift - [OF threadSet_tcbState_st_tcb_at' [where P=runnable'] - threadSet_ksQ]]) - apply (rule hoare_seq_ext [OF _ - hoare_vcg_conj_lift [OF isRunnable_const isRunnable_inv]]) - apply (clarsimp simp: when_def) - apply (case_tac x) - apply (clarsimp, wp)[1] - apply (clarsimp) - apply (rule hoare_seq_ext [OF _ - hoare_vcg_conj_lift - [OF threadSet_ct threadSet_ksQ]]) - apply (rule hoare_seq_ext [OF _ isRunnable_inv]) - apply (rule hoare_seq_ext [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 valid_ipc_buffer_ptr'D: assumes yv: "y < unat max_ipc_words" and buf: "valid_ipc_buffer_ptr' a s" @@ -3635,11 +4476,11 @@ qed lemmas valid_ipc_buffer_cap_simps = valid_ipc_buffer_cap_def [split_simps cap.split arch_cap.split] lemma lookupIPCBuffer_corres': - "corres (=) (tcb_at t and valid_objs and pspace_aligned and pspace_distinct) - (no_0_obj') - (lookup_ipc_buffer w t) (lookupIPCBuffer w t)" - apply (rule corres_cross_over_guard[where P'=Q and - Q="pspace_aligned' and pspace_distinct' and Q" for Q]) + "corres (=) + (tcb_at t and valid_objs and pspace_aligned and pspace_distinct) + (valid_objs' and no_0_obj') + (lookup_ipc_buffer w t) (lookupIPCBuffer w t)" + apply (rule corres_cross_add_guard[where Q'="pspace_aligned' and pspace_distinct'"]) apply (fastforce simp: pspace_aligned_cross pspace_distinct_cross state_relation_def) apply (simp add: lookup_ipc_buffer_def AARCH64_H.lookupIPCBuffer_def) apply (rule corres_guard_imp) @@ -3684,11 +4525,11 @@ lemma lookupIPCBuffer_corres': done lemma lookupIPCBuffer_corres: - "corres (=) (tcb_at t and invs) (no_0_obj') (lookup_ipc_buffer w t) (lookupIPCBuffer w t)" + "corres (=) (tcb_at t and invs) (valid_objs' and no_0_obj') + (lookup_ipc_buffer w t) (lookupIPCBuffer w t)" using lookupIPCBuffer_corres' by (rule corres_guard_imp, auto simp: invs'_def valid_state'_def) - crunch inv[wp]: lookupIPCBuffer P (wp: crunch_wps simp: crunch_simps) @@ -3749,7 +4590,7 @@ lemma ct_in_state'_set: crunches setQueue, rescheduleRequired, tcbSchedDequeue for idle'[wp]: "valid_idle'" - (simp: crunch_simps) + (simp: crunch_simps wp: crunch_wps) lemma sts_valid_idle'[wp]: "\valid_idle' and valid_pspace' and @@ -3789,8 +4630,9 @@ lemma gbn_sp': lemma tcbSchedDequeue_tcbState_obj_at'[wp]: "\obj_at' (P \ tcbState) t'\ tcbSchedDequeue t \\rv. obj_at' (P \ tcbState) t'\" - apply (simp add: tcbSchedDequeue_def) - apply (wp | simp add: o_def split del: if_split cong: if_cong)+ + apply (simp add: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wpsimp wp: getObject_tcb_wp simp: o_def threadGet_def) + apply (clarsimp simp: obj_at'_def) done crunch typ_at'[wp]: setQueue "\s. P' (typ_at' P t s)" @@ -3809,10 +4651,14 @@ lemma setQueue_pred_tcb_at[wp]: lemma tcbSchedDequeue_pred_tcb_at'[wp]: "\\s. P' (pred_tcb_at' proj P t' s)\ tcbSchedDequeue t \\_ s. P' (pred_tcb_at' proj P t' s)\" apply (rule_tac P=P' in P_bool_lift) - apply (simp add: tcbSchedDequeue_def) - apply (wp threadSet_pred_tcb_no_state | clarsimp simp: tcb_to_itcb'_def)+ - apply (simp add: tcbSchedDequeue_def) - apply (wp threadSet_pred_tcb_no_state | clarsimp simp: tcb_to_itcb'_def)+ + apply (simp add: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wpsimp wp: threadSet_pred_tcb_no_state getObject_tcb_wp + simp: threadGet_def tcb_to_itcb'_def) + apply (clarsimp simp: obj_at'_def) + apply (simp add: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wpsimp wp: threadSet_pred_tcb_no_state getObject_tcb_wp + simp: threadGet_def tcb_to_itcb'_def) + apply (clarsimp simp: obj_at'_def) done lemma sts_st_tcb': @@ -3926,39 +4772,153 @@ crunch nonz_cap[wp]: addToBitmap "ex_nonz_cap_to' t" crunch iflive'[wp]: removeFromBitmap if_live_then_nonz_cap' crunch nonz_cap[wp]: removeFromBitmap "ex_nonz_cap_to' t" -lemma tcbSchedEnqueue_iflive'[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' tcb\ - tcbSchedEnqueue tcb \\_. if_live_then_nonz_cap'\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wp threadSet_iflive' hoare_drop_imps | simp add: crunch_simps)+ +crunches rescheduleRequired + for cap_to'[wp]: "ex_nonz_cap_to' p" + +lemma tcbQueued_update_tcb_cte_cases: + "(getF, setF) \ ran tcb_cte_cases \ getF (tcbQueued_update f tcb) = getF tcb" + unfolding tcb_cte_cases_def + by (case_tac tcb; fastforce simp: objBits_simps') + +lemma tcbSchedNext_update_tcb_cte_cases: + "(getF, setF) \ ran tcb_cte_cases \ getF (tcbSchedNext_update f tcb) = getF tcb" + unfolding tcb_cte_cases_def + by (case_tac tcb; fastforce simp: objBits_simps') + +lemma tcbSchedPrev_update_tcb_cte_cases: + "(getF, setF) \ ran tcb_cte_cases \ getF (tcbSchedPrev_update f tcb) = getF tcb" + unfolding tcb_cte_cases_def + by (case_tac tcb; fastforce simp: objBits_simps') + +lemma tcbSchedNext_update_ctes_of[wp]: + "threadSet (tcbSchedNext_update f) tptr \\s. P (ctes_of s)\" + by (wpsimp wp: threadSet_ctes_ofT simp: tcbSchedNext_update_tcb_cte_cases) + +lemma tcbSchedPrev_update_ctes_of[wp]: + "threadSet (tcbSchedPrev_update f) tptr \\s. P (ctes_of s)\" + by (wpsimp wp: threadSet_ctes_ofT simp: tcbSchedPrev_update_tcb_cte_cases) + +lemma tcbSchedNext_ex_nonz_cap_to'[wp]: + "threadSet (tcbSchedNext_update f) tptr \ex_nonz_cap_to' p\" + by (wpsimp wp: threadSet_cap_to simp: tcbSchedNext_update_tcb_cte_cases) + +lemma tcbSchedPrev_ex_nonz_cap_to'[wp]: + "threadSet (tcbSchedPrev_update f) tptr \ex_nonz_cap_to' p\" + by (wpsimp wp: threadSet_cap_to simp: tcbSchedPrev_update_tcb_cte_cases) + +lemma tcbSchedNext_update_iflive': + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' t s\ + threadSet (tcbSchedNext_update f) t + \\_. if_live_then_nonz_cap'\" + by (wpsimp wp: threadSet_iflive'T simp: tcbSchedNext_update_tcb_cte_cases) + +lemma tcbSchedPrev_update_iflive': + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' t s\ + threadSet (tcbSchedPrev_update f) t + \\_. if_live_then_nonz_cap'\" + by (wpsimp wp: threadSet_iflive'T simp: tcbSchedPrev_update_tcb_cte_cases) + +lemma tcbQueued_update_iflive'[wp]: + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' t s\ + threadSet (tcbQueued_update f) t + \\_. if_live_then_nonz_cap'\" + by (wpsimp wp: threadSet_iflive'T simp: tcbQueued_update_tcb_cte_cases) + +lemma getTCB_wp: + "\\s. \ko :: tcb. ko_at' ko p s \ Q ko s\ getObject p \Q\" + apply (wpsimp wp: getObject_tcb_wp) + apply (clarsimp simp: obj_at'_def) done -lemma rescheduleRequired_iflive'[wp]: - "\if_live_then_nonz_cap' - and (\s. \t. ksSchedulerAction s = SwitchToThread t - \ st_tcb_at' runnable' t s)\ - rescheduleRequired - \\rv. if_live_then_nonz_cap'\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp)+ - apply (clarsimp simp: pred_tcb_at'_def obj_at'_real_def) - apply (erule(1) if_live_then_nonz_capD') - apply (fastforce simp: live'_def) +lemma tcbQueueRemove_if_live_then_nonz_cap': + "\if_live_then_nonz_cap' and valid_objs' and sym_heap_sched_pointers and ex_nonz_cap_to' tcbPtr\ + tcbQueueRemove q tcbPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbQueueRemove_def + apply (wpsimp wp: tcbSchedPrev_update_iflive' tcbSchedNext_update_iflive' + hoare_vcg_imp_lift' getTCB_wp) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + by (force dest: sym_heapD2[where p'=tcbPtr] sym_heapD1[where p=tcbPtr] + elim: if_live_then_nonz_capE' + simp: valid_tcb'_def opt_map_def obj_at'_def ko_wp_at'_def opt_tcb_at'_def live'_def) + +lemma tcbQueueRemove_ex_nonz_cap_to'[wp]: + "tcbQueueRemove q tcbPtr \ex_nonz_cap_to' tcbPtr'\" + unfolding tcbQueueRemove_def + by (wpsimp wp: threadSet_cap_to' hoare_drop_imps getTCB_wp) + +(* We could write this one as "\t. tcbQueueHead t \ ..." instead, but we can't do the same in + tcbQueueAppend_if_live_then_nonz_cap', and it's nicer if the two lemmas are symmetric *) +lemma tcbQueuePrepend_if_live_then_nonz_cap': + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' tcbPtr s + \ (\ tcbQueueEmpty q \ ex_nonz_cap_to' (the (tcbQueueHead q)) s)\ + tcbQueuePrepend q tcbPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbQueuePrepend_def + by (wpsimp wp: tcbSchedPrev_update_iflive' tcbSchedNext_update_iflive' + hoare_vcg_if_lift2 hoare_vcg_imp_lift') + +lemma tcbQueueAppend_if_live_then_nonz_cap': + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' tcbPtr s + \ (\ tcbQueueEmpty q \ ex_nonz_cap_to' (the (tcbQueueEnd q)) s)\ + tcbQueueAppend q tcbPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbQueueAppend_def + by (wpsimp wp: tcbSchedPrev_update_iflive' tcbSchedNext_update_iflive') + +lemma tcbQueueInsert_if_live_then_nonz_cap': + "\if_live_then_nonz_cap' and ex_nonz_cap_to' tcbPtr and valid_objs' and sym_heap_sched_pointers\ + tcbQueueInsert tcbPtr afterPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbQueueInsert_def + apply (wpsimp wp: tcbSchedPrev_update_iflive' tcbSchedNext_update_iflive' getTCB_wp) + apply (intro conjI) + apply (erule if_live_then_nonz_capE') + apply (clarsimp simp: ko_wp_at'_def obj_at'_def live'_def) + apply (erule if_live_then_nonz_capE') + apply (frule_tac p'=afterPtr in sym_heapD2) + apply (fastforce simp: opt_map_def obj_at'_def) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (clarsimp simp: valid_tcb'_def ko_wp_at'_def obj_at'_def opt_map_def live'_def) done +lemma tcbSchedEnqueue_iflive'[wp]: + "\if_live_then_nonz_cap' and pspace_aligned' and pspace_distinct'\ + tcbSchedEnqueue tcbPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbSchedEnqueue_def + apply (wpsimp wp: tcbQueuePrepend_if_live_then_nonz_cap' threadGet_wp) + apply normalise_obj_at' + apply (rename_tac tcb) + apply (frule_tac p=tcbPtr in if_live_then_nonz_capE') + apply (fastforce simp: ko_wp_at'_def obj_at'_def live'_def) + apply clarsimp + apply (erule if_live_then_nonz_capE') + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (fastforce dest!: obj_at'_tcbQueueHead_ksReadyQueues + simp: ko_wp_at'_def inQ_def opt_pred_def opt_map_def obj_at'_def live'_def + split: option.splits) + done + +crunches rescheduleRequired + for iflive'[wp]: if_live_then_nonz_cap' + lemma sts_iflive'[wp]: "\\s. if_live_then_nonz_cap' s - \ (st \ Inactive \ \ idle' st \ ex_nonz_cap_to' t s)\ + \ (st \ Inactive \ \ idle' st \ ex_nonz_cap_to' t s) + \ pspace_aligned' s \ pspace_distinct' s\ setThreadState st t \\rv. if_live_then_nonz_cap'\" apply (simp add: setThreadState_def setQueue_def) - apply (rule hoare_pre) - apply (wp | simp)+ - apply (rule_tac Q="\rv. if_live_then_nonz_cap'" in hoare_post_imp) - apply clarsimp - apply (wp threadSet_iflive' | simp)+ - apply auto - done + 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 + done lemma sbn_iflive'[wp]: "\\s. if_live_then_nonz_cap' s @@ -4077,6 +5037,18 @@ lemma setBoundNotification_vms'[wp]: apply (intro hoare_vcg_all_lift hoare_vcg_disj_lift; wp) done +lemma threadSet_ct_not_inQ: + "(\tcb. tcbQueued tcb = tcbQueued (F tcb)) + \ threadSet F tcbPtr \\s. P (ct_not_inQ s)\" + unfolding threadSet_def + apply (wpsimp wp: getTCB_wp simp: setObject_def updateObject_default_def) + apply (erule rsubst[where P=P]) + by (fastforce simp: ct_not_inQ_def obj_at'_def objBits_simps ps_clear_def split: if_splits) + +crunches tcbQueuePrepend, tcbQueueAppend, tcbQueueInsert, tcbQueueRemove, addToBitmap + for ct_not_inQ[wp]: ct_not_inQ + (wp: threadSet_ct_not_inQ crunch_wps) + lemma tcbSchedEnqueue_ct_not_inQ: "\ct_not_inQ and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ tcbSchedEnqueue t \\_. ct_not_inQ\" @@ -4100,12 +5072,7 @@ lemma tcbSchedEnqueue_ct_not_inQ: done show ?thesis apply (simp add: tcbSchedEnqueue_def unless_def null_def) - apply (wp ts sq hoare_convert_imp [OF addToBitmap_nosch addToBitmap_ct'])+ - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, clarsimp) - apply (wp sq hoare_convert_imp [OF setQueue_nosch setQueue_ct])+ - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, clarsimp) - apply wp - apply assumption + apply (wpsimp wp: ts sq hoare_vcg_imp_lift' getTCB_wp simp: threadGet_def)+ done qed @@ -4132,12 +5099,7 @@ lemma tcbSchedAppend_ct_not_inQ: done show ?thesis apply (simp add: tcbSchedAppend_def unless_def null_def) - apply (wp ts sq hoare_convert_imp [OF addToBitmap_nosch addToBitmap_ct'])+ - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, clarsimp) - apply (wp sq hoare_convert_imp [OF setQueue_nosch setQueue_ct])+ - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, clarsimp) - apply wp - apply assumption + apply (wpsimp wp: ts sq hoare_vcg_imp_lift' getTCB_wp simp: threadGet_def)+ done qed @@ -4166,12 +5128,10 @@ lemma rescheduleRequired_sa_cnt[wp]: lemma possibleSwitchTo_ct_not_inQ: "\ct_not_inQ and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ possibleSwitchTo t \\_. ct_not_inQ\" - (is "\?PRE\ _ \_\") apply (simp add: possibleSwitchTo_def curDomain_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) + | (rule hoare_post_imp[OF _ rescheduleRequired_sa_cnt], fastforce))+ done lemma threadSet_tcbState_update_ct_not_inQ[wp]: @@ -4251,29 +5211,6 @@ lemma tcbSchedDequeue_ct_not_inQ[wp]: done qed -lemma tcbSchedEnqueue_not_st: - "(\tcb st qd. P (tcb\tcbState := st, tcbQueued := qd\) \ P tcb) - \ \obj_at' P t'\ tcbSchedEnqueue t \\_. obj_at' P t'\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wp threadGet_wp | simp)+ - apply (clarsimp simp: obj_at'_def) - apply (case_tac obja) - apply fastforce - done - -lemma setThreadState_not_st: - "(\tcb st qd. P (tcb\tcbState := st, tcbQueued := qd\) \ P tcb) - \ \obj_at' P t'\ setThreadState st t \\_. obj_at' P t'\" - apply (simp add: setThreadState_def rescheduleRequired_def) - apply (wp hoare_vcg_conj_lift tcbSchedEnqueue_not_st - | wpc - | rule hoare_drop_imps - | simp)+ - apply (clarsimp simp: obj_at'_def) - apply (case_tac obj) - apply fastforce - done - crunch ct_idle_or_in_cur_domain'[wp]: setQueue ct_idle_or_in_cur_domain' (simp: ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) @@ -4302,17 +5239,8 @@ lemma removeFromBitmap_ct_idle_or_in_cur_domain'[wp]: | clarsimp simp: updateObject_default_def in_monad setNotification_def)+ done -lemma tcbSchedEnqueue_ksCurDomain[wp]: - "\ \s. P (ksCurDomain s)\ tcbSchedEnqueue tptr \\_ s. P (ksCurDomain s)\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply wpsimp - done - -lemma tcbSchedEnqueue_ksDomSchedule[wp]: - "\ \s. P (ksDomSchedule s)\ tcbSchedEnqueue tptr \\_ s. P (ksDomSchedule s)\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply wpsimp - done +crunches tcbQueuePrepend + for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' lemma tcbSchedEnqueue_ct_idle_or_in_cur_domain'[wp]: "\ct_idle_or_in_cur_domain'\ tcbSchedEnqueue tptr \\_. ct_idle_or_in_cur_domain'\" @@ -4390,12 +5318,375 @@ lemma sts_utr[wp]: apply (wp untyped_ranges_zero_lift) done +lemma removeFromBitmap_bitmapQ: + "\\\ removeFromBitmap d p \\_ s. \ bitmapQ d p s \" + unfolding bitmapQ_defs bitmap_fun_defs + by (wpsimp simp: bitmap_fun_defs) + +lemma removeFromBitmap_valid_bitmapQ[wp]: + "\valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans + and (\s. tcbQueueEmpty (ksReadyQueues s (d,p)))\ + removeFromBitmap d p + \\_. valid_bitmapQ\" + (is "\?pre\ _ \_\") + apply (rule_tac Q="\_ s. ?pre s \ \ bitmapQ d p s" in hoare_strengthen_post) + apply (wpsimp wp: removeFromBitmap_valid_bitmapQ_except removeFromBitmap_bitmapQ) + apply (fastforce elim: valid_bitmap_valid_bitmapQ_exceptE) + done + +crunches tcbSchedDequeue + for bitmapQ_no_L1_orphans[wp]: bitmapQ_no_L1_orphans + and bitmapQ_no_L2_orphans[wp]: bitmapQ_no_L2_orphans + (wp: crunch_wps simp: crunch_simps) + +lemma setQueue_nonempty_valid_bitmapQ': + "\\s. valid_bitmapQ s \ \ tcbQueueEmpty (ksReadyQueues s (d, p))\ + setQueue d p queue + \\_ s. \ tcbQueueEmpty queue \ valid_bitmapQ s\" + apply (wpsimp simp: setQueue_def) + apply (fastforce simp: valid_bitmapQ_def bitmapQ_def) + done + +lemma threadSet_valid_bitmapQ_except[wp]: + "threadSet f tcbPtr \valid_bitmapQ_except d p\" + unfolding threadSet_def + apply (wpsimp wp: getTCB_wp simp: setObject_def updateObject_default_def) + apply (clarsimp simp: valid_bitmapQ_except_def bitmapQ_def) + done + +lemma threadSet_bitmapQ: + "threadSet F t \bitmapQ domain priority\" + unfolding threadSet_def + apply (wpsimp wp: getTCB_wp simp: setObject_def updateObject_default_def) + by (clarsimp simp: bitmapQ_def) + +crunches tcbQueueRemove, tcbQueuePrepend, tcbQueueAppend + for valid_bitmapQ_except[wp]: "valid_bitmapQ_except d p" + and valid_bitmapQ[wp]: valid_bitmapQ + and bitmapQ[wp]: "bitmapQ tdom prio" + (wp: crunch_wps) + +lemma tcbQueued_imp_queue_nonempty: + "\list_queue_relation ts (ksReadyQueues s (tcbDomain tcb, tcbPriority tcb)) nexts prevs; + \t. t \ set ts \ (inQ (tcbDomain tcb) (tcbPriority tcb) |< tcbs_of' s) t; + ko_at' tcb tcbPtr s; tcbQueued tcb\ + \ \ tcbQueueEmpty (ksReadyQueues s (tcbDomain tcb, tcbPriority tcb))" + apply (clarsimp simp: list_queue_relation_def tcbQueueEmpty_def) + apply (drule_tac x=tcbPtr in spec) + apply (fastforce dest: heap_path_head simp: inQ_def opt_map_def opt_pred_def obj_at'_def) + done + +lemma tcbSchedDequeue_valid_bitmapQ[wp]: + "\valid_bitmaps\ tcbSchedDequeue tcbPtr \\_. valid_bitmapQ\" + unfolding tcbSchedDequeue_def tcbQueueRemove_def + apply (wpsimp wp: setQueue_nonempty_valid_bitmapQ' hoare_vcg_conj_lift + hoare_vcg_if_lift2 hoare_vcg_const_imp_lift threadGet_wp + | wp (once) hoare_drop_imps)+ + by (fastforce dest!: tcbQueued_imp_queue_nonempty + simp: ready_queue_relation_def ksReadyQueues_asrt_def obj_at'_def) + +lemma tcbSchedDequeue_valid_bitmaps[wp]: + "tcbSchedDequeue tcbPtr \valid_bitmaps\" + by (wpsimp simp: valid_bitmaps_def) + +lemma setQueue_valid_bitmapQ': (* enqueue only *) + "\valid_bitmapQ_except d p and bitmapQ d p and K (\ tcbQueueEmpty q)\ + setQueue d p q + \\_. valid_bitmapQ\" + unfolding setQueue_def bitmapQ_defs + by (wpsimp simp: bitmapQ_def) + +lemma tcbSchedEnqueue_valid_bitmapQ[wp]: + "\valid_bitmaps\ tcbSchedEnqueue tcbPtr \\_. valid_bitmapQ\" + supply if_split[split del] + unfolding tcbSchedEnqueue_def + apply (wpsimp simp: tcbQueuePrepend_def + wp: setQueue_valid_bitmapQ' addToBitmap_valid_bitmapQ_except addToBitmap_bitmapQ + threadGet_wp) + apply (fastforce simp: valid_bitmaps_def valid_bitmapQ_def tcbQueueEmpty_def split: if_splits) + done + +crunches tcbSchedEnqueue, tcbSchedAppend + for bitmapQ_no_L1_orphans[wp]: bitmapQ_no_L1_orphans + and bitmapQ_no_L2_orphans[wp]: bitmapQ_no_L2_orphans + +lemma tcbSchedEnqueue_valid_bitmaps[wp]: + "tcbSchedEnqueue tcbPtr \valid_bitmaps\" + unfolding valid_bitmaps_def + apply wpsimp + apply (clarsimp simp: valid_bitmaps_def) + done + +crunches rescheduleRequired, threadSet, setThreadState + for valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift) + +lemma tcbSchedEnqueue_valid_sched_pointers[wp]: + "tcbSchedEnqueue tcbPtr \valid_sched_pointers\" + apply (clarsimp simp: tcbSchedEnqueue_def getQueue_def unless_def) + \ \we step forwards until we can step over the addToBitmap in order to avoid state blow-up\ + apply (intro hoare_seq_ext[OF _ stateAssert_sp] hoare_seq_ext[OF _ isRunnable_inv] + hoare_seq_ext[OF _ assert_sp] hoare_seq_ext[OF _ threadGet_sp] + hoare_seq_ext[OF _ gets_sp] + | rule hoare_when_cases, fastforce)+ + apply (forward_inv_step wp: hoare_vcg_ex_lift) + supply if_split[split del] + apply (wpsimp wp: getTCB_wp + simp: threadSet_def setObject_def updateObject_default_def tcbQueuePrepend_def + setQueue_def) + apply (clarsimp simp: valid_sched_pointers_def) + apply (intro conjI impI) + apply (fastforce simp: opt_pred_def opt_map_def split: if_splits) + apply normalise_obj_at' + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (clarsimp simp: valid_sched_pointers_def list_queue_relation_def) + apply (case_tac "ts = []", fastforce simp: tcbQueueEmpty_def) + by (intro conjI impI; + force dest!: hd_in_set heap_path_head + simp: inQ_def opt_pred_def opt_map_def obj_at'_def split: if_splits) + +lemma tcbSchedAppend_valid_sched_pointers[wp]: + "tcbSchedAppend tcbPtr \valid_sched_pointers\" + apply (clarsimp simp: tcbSchedAppend_def getQueue_def unless_def) + \ \we step forwards until we can step over the addToBitmap in order to avoid state blow-up\ + apply (intro hoare_seq_ext[OF _ stateAssert_sp] hoare_seq_ext[OF _ isRunnable_inv] + hoare_seq_ext[OF _ assert_sp] hoare_seq_ext[OF _ threadGet_sp] + hoare_seq_ext[OF _ gets_sp] + | rule hoare_when_cases, fastforce)+ + apply (forward_inv_step wp: hoare_vcg_ex_lift) + supply if_split[split del] + apply (wpsimp wp: getTCB_wp + simp: threadSet_def setObject_def updateObject_default_def tcbQueueAppend_def + setQueue_def) + apply (clarsimp simp: valid_sched_pointers_def) + apply (intro conjI impI) + apply (fastforce simp: opt_pred_def opt_map_def split: if_splits) + apply normalise_obj_at' + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + by (intro conjI impI; + clarsimp dest: last_in_set + simp: valid_sched_pointers_def opt_map_def list_queue_relation_def tcbQueueEmpty_def + queue_end_valid_def inQ_def opt_pred_def obj_at'_def + split: if_splits option.splits; + fastforce) + +lemma tcbSchedDequeue_valid_sched_pointers[wp]: + "\valid_sched_pointers and sym_heap_sched_pointers\ + tcbSchedDequeue tcbPtr + \\_. valid_sched_pointers\" + supply if_split[split del] fun_upd_apply[simp del] + apply (clarsimp simp: tcbSchedDequeue_def getQueue_def setQueue_def) + apply (wpsimp wp: threadSet_wp getTCB_wp threadGet_wp simp: tcbQueueRemove_def) + apply normalise_obj_at' + apply (rename_tac tcb) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (clarsimp split: if_splits) + apply (frule (1) list_queue_relation_neighbour_in_set[where p=tcbPtr]) + apply (fastforce simp: inQ_def opt_pred_def opt_map_def obj_at'_def) + apply (clarsimp simp: list_queue_relation_def) + apply (intro conjI impI) + \ \the ready queue is the singleton consisting of tcbPtr\ + apply (clarsimp simp: valid_sched_pointers_def) + apply (case_tac "ptr = tcbPtr") + apply (force dest!: heap_ls_last_None + simp: prev_queue_head_def queue_end_valid_def inQ_def opt_map_def obj_at'_def) + apply (simp add: fun_upd_def opt_pred_def) + \ \tcbPtr is the head of the ready queue\ + subgoal + by (auto dest!: heap_ls_last_None + simp: valid_sched_pointers_def fun_upd_apply prev_queue_head_def + inQ_def opt_pred_def opt_map_def obj_at'_def + split: if_splits option.splits) + \ \tcbPtr is the end of the ready queue\ + subgoal + by (auto dest!: heap_ls_last_None + simp: valid_sched_pointers_def queue_end_valid_def inQ_def opt_pred_def + opt_map_def fun_upd_apply obj_at'_def + split: if_splits option.splits) + \ \tcbPtr is in the middle of the ready queue\ + apply (intro conjI impI allI) + by (clarsimp simp: valid_sched_pointers_def inQ_def opt_pred_def opt_map_def fun_upd_apply obj_at'_def + split: if_splits option.splits; + auto) + +lemma tcbQueueRemove_sym_heap_sched_pointers: + "\\s. sym_heap_sched_pointers s + \ (\ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ tcbPtr \ set ts)\ + tcbQueueRemove q tcbPtr + \\_. sym_heap_sched_pointers\" + supply heap_path_append[simp del] + apply (clarsimp simp: tcbQueueRemove_def) + apply (wpsimp wp: threadSet_wp getTCB_wp) + apply (rename_tac tcb ts) + + \ \tcbPtr is the head of q, which is not a singleton\ + apply (rule conjI) + apply clarsimp + apply (clarsimp simp: list_queue_relation_def Let_def) + apply (prop_tac "tcbSchedNext tcb \ Some tcbPtr") + apply (fastforce dest: heap_ls_no_loops[where p=tcbPtr] simp: opt_map_def obj_at'_def) + apply (fastforce intro: sym_heap_remove_only' + simp: prev_queue_head_def opt_map_red opt_map_upd_triv obj_at'_def) + + \ \tcbPtr is the end of q, which is not a singleton\ + apply (intro impI) + apply (rule conjI) + apply clarsimp + apply (prop_tac "tcbSchedPrev tcb \ Some tcbPtr") + apply (fastforce dest!: heap_ls_prev_no_loops[where p=tcbPtr] + simp: list_queue_relation_def opt_map_def obj_at'_def) + apply (subst fun_upd_swap, fastforce) + apply (fastforce intro: sym_heap_remove_only simp: opt_map_red opt_map_upd_triv obj_at'_def) + + \ \tcbPtr is in the middle of q\ + apply (intro conjI impI allI) + apply (frule (2) list_queue_relation_neighbour_in_set[where p=tcbPtr]) + apply (frule split_list) + apply clarsimp + apply (rename_tac xs ys) + apply (prop_tac "xs \ [] \ ys \ []") + apply (fastforce simp: list_queue_relation_def queue_end_valid_def) + apply (clarsimp simp: list_queue_relation_def) + apply (frule (3) ptr_in_middle_prev_next) + apply (frule heap_ls_distinct) + apply (rename_tac afterPtr beforePtr xs ys) + apply (frule_tac before=beforePtr and middle=tcbPtr and after=afterPtr + in sym_heap_remove_middle_from_chain) + apply (fastforce dest: last_in_set simp: opt_map_def obj_at'_def) + apply (fastforce dest: hd_in_set simp: opt_map_def obj_at'_def) + apply (rule_tac hp="tcbSchedNexts_of s" in sym_heapD2) + apply fastforce + apply (fastforce simp: opt_map_def obj_at'_def) + apply (fastforce simp: opt_map_def obj_at'_def) + apply (fastforce simp: fun_upd_swap opt_map_red opt_map_upd_triv obj_at'_def split: if_splits) + done + +lemma tcbQueuePrepend_sym_heap_sched_pointers: + "\\s. sym_heap_sched_pointers s + \ (\ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ tcbPtr \ set ts) + \ tcbSchedNexts_of s tcbPtr = None \ tcbSchedPrevs_of s tcbPtr = None\ + tcbQueuePrepend q tcbPtr + \\_. sym_heap_sched_pointers\" + supply if_split[split del] + apply (clarsimp simp: tcbQueuePrepend_def) + apply (wpsimp wp: threadSet_wp) + apply (prop_tac "tcbPtr \ the (tcbQueueHead q)") + apply (case_tac "ts = []"; + fastforce dest: heap_path_head simp: list_queue_relation_def tcbQueueEmpty_def) + apply (drule_tac a=tcbPtr and b="the (tcbQueueHead q)" in sym_heap_connect) + apply assumption + apply (clarsimp simp: list_queue_relation_def prev_queue_head_def tcbQueueEmpty_def) + apply (fastforce simp: fun_upd_swap opt_map_red opt_map_upd_triv obj_at'_def tcbQueueEmpty_def) + done + +lemma tcbQueueInsert_sym_heap_sched_pointers: + "\\s. sym_heap_sched_pointers s + \ tcbSchedNexts_of s tcbPtr = None \ tcbSchedPrevs_of s tcbPtr = None\ + tcbQueueInsert tcbPtr afterPtr + \\_. sym_heap_sched_pointers\" + apply (clarsimp simp: tcbQueueInsert_def) + \ \forwards step in order to name beforePtr below\ + apply (rule hoare_seq_ext[OF _ getObject_tcb_sp]) + apply (rule hoare_seq_ext[OF _ assert_sp]) + apply (rule hoare_ex_pre_conj[simplified conj_commute], rename_tac beforePtr) + apply (rule hoare_seq_ext[OF _ assert_sp]) + apply (wpsimp wp: threadSet_wp) + apply normalise_obj_at' + apply (prop_tac "tcbPtr \ afterPtr") + apply (clarsimp simp: list_queue_relation_def opt_map_red obj_at'_def) + apply (prop_tac "tcbPtr \ beforePtr") + apply (fastforce dest: sym_heap_None simp: opt_map_def obj_at'_def split: option.splits) + apply (prop_tac "tcbSchedNexts_of s beforePtr = Some afterPtr") + apply (fastforce intro: sym_heapD2 simp: opt_map_def obj_at'_def) + apply (fastforce dest: sym_heap_insert_into_middle_of_chain + simp: fun_upd_swap opt_map_red opt_map_upd_triv obj_at'_def) + done + +lemma tcbQueueAppend_sym_heap_sched_pointers: + "\\s. sym_heap_sched_pointers s + \ (\ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ tcbPtr \ set ts) + \ tcbSchedNexts_of s tcbPtr = None \ tcbSchedPrevs_of s tcbPtr = None\ + tcbQueueAppend q tcbPtr + \\_. sym_heap_sched_pointers\" + supply if_split[split del] + apply (clarsimp simp: tcbQueueAppend_def) + apply (wpsimp wp: threadSet_wp) + apply (clarsimp simp: tcbQueueEmpty_def list_queue_relation_def queue_end_valid_def obj_at'_def + split: if_splits) + apply fastforce + apply (drule_tac a="last ts" and b=tcbPtr in sym_heap_connect) + apply (fastforce dest: heap_ls_last_None) + apply assumption + apply (simp add: opt_map_red tcbQueueEmpty_def) + apply (subst fun_upd_swap, simp) + apply (fastforce simp: opt_map_red opt_map_upd_triv) + done + +lemma tcbQueued_update_sym_heap_sched_pointers[wp]: + "threadSet (tcbQueued_update f) tcbPtr \sym_heap_sched_pointers\" + by (rule sym_heap_sched_pointers_lift; + wpsimp wp: threadSet_tcbSchedPrevs_of threadSet_tcbSchedNexts_of) + +lemma tcbSchedEnqueue_sym_heap_sched_pointers[wp]: + "\sym_heap_sched_pointers and valid_sched_pointers\ + tcbSchedEnqueue tcbPtr + \\_. sym_heap_sched_pointers\" + unfolding tcbSchedEnqueue_def + apply (wpsimp wp: tcbQueuePrepend_sym_heap_sched_pointers threadGet_wp + simp: addToBitmap_def bitmap_fun_defs) + apply (normalise_obj_at', rename_tac tcb) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (fastforce dest!: spec[where x=tcbPtr] inQ_implies_tcbQueueds_of + simp: valid_sched_pointers_def opt_pred_def opt_map_def obj_at'_def) + done + +lemma tcbSchedAppend_sym_heap_sched_pointers[wp]: + "\sym_heap_sched_pointers and valid_sched_pointers\ + tcbSchedAppend tcbPtr + \\_. sym_heap_sched_pointers\" + unfolding tcbSchedAppend_def + apply (wpsimp wp: tcbQueueAppend_sym_heap_sched_pointers threadGet_wp + simp: addToBitmap_def bitmap_fun_defs) + apply (normalise_obj_at', rename_tac tcb) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (fastforce dest!: spec[where x=tcbPtr] inQ_implies_tcbQueueds_of + simp: valid_sched_pointers_def opt_pred_def opt_map_def obj_at'_def) + done + +lemma tcbSchedDequeue_sym_heap_sched_pointers[wp]: + "\sym_heap_sched_pointers and valid_sched_pointers\ + tcbSchedDequeue tcbPtr + \\_. sym_heap_sched_pointers\" + unfolding tcbSchedDequeue_def + apply (wpsimp wp: tcbQueueRemove_sym_heap_sched_pointers hoare_vcg_if_lift2 threadGet_wp + simp: bitmap_fun_defs) + apply (fastforce simp: ready_queue_relation_def ksReadyQueues_asrt_def inQ_def opt_pred_def + opt_map_def obj_at'_def) + done + +crunches setThreadState + for valid_sched_pointers[wp]: valid_sched_pointers + and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + (simp: crunch_simps wp: crunch_wps threadSet_valid_sched_pointers threadSet_sched_pointers) + 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. (\p. t \ set(ksReadyQueues s p)) \ runnable' st) and (\s. runnable' st \ obj_at' tcbQueued t s \ st_tcb_at' runnable' t s) and sch_act_simple and invs'\ @@ -4404,21 +5695,21 @@ lemma sts_invs_minor': including no_pre apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) - apply (wp sts_valid_queues valid_irq_node_lift irqs_masked_lift - setThreadState_ct_not_inQ + apply (wp valid_irq_node_lift irqs_masked_lift + setThreadState_ct_not_inQ | simp add: cteCaps_of_def o_def)+ apply (clarsimp simp: sch_act_simple_def) apply (intro conjI) - apply clarsimp - defer - apply (clarsimp dest!: st_tcb_at_state_refs_ofD' - elim!: rsubst[where P=sym_refs] - intro!: ext) - apply (clarsimp elim!: st_tcb_ex_cap'') + apply clarsimp + defer + apply (clarsimp dest!: st_tcb_at_state_refs_ofD' + elim!: rsubst[where P=sym_refs] + intro!: ext) + apply (clarsimp elim!: st_tcb_ex_cap'') + apply fastforce + apply fastforce apply (frule tcb_in_valid_state', clarsimp+) - apply (cases st, simp_all add: valid_tcb_state'_def - split: Structures_H.thread_state.split_asm) - done + by (cases st; simp add: valid_tcb_state'_def split: Structures_H.thread_state.split_asm) lemma sts_cap_to'[wp]: "\ex_nonz_cap_to' p\ setThreadState st t \\rv. ex_nonz_cap_to' p\" @@ -4463,12 +5754,56 @@ lemma threadSet_ct_running': apply wp done +lemma tcbQueuePrepend_tcbPriority_obj_at'[wp]: + "tcbQueuePrepend queue tptr \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + unfolding tcbQueuePrepend_def + apply (wpsimp wp: threadSet_wp) + by (auto simp: obj_at'_def objBits_simps ps_clear_def split: if_splits) + +lemma tcbQueuePrepend_tcbDomain_obj_at'[wp]: + "tcbQueuePrepend queue tptr \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding tcbQueuePrepend_def + apply (wpsimp wp: threadSet_wp) + by (auto simp: obj_at'_def objBits_simps ps_clear_def split: if_splits) + +lemma tcbSchedDequeue_tcbPriority[wp]: + "tcbSchedDequeue t \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + unfolding tcbSchedDequeue_def tcbQueueRemove_def + by (wpsimp wp: hoare_when_weak_wp hoare_drop_imps) + +lemma tcbSchedDequeue_tcbDomain[wp]: + "tcbSchedDequeue t \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding tcbSchedDequeue_def tcbQueueRemove_def + by (wpsimp wp: hoare_when_weak_wp hoare_drop_imps) + +lemma tcbSchedEnqueue_tcbPriority_obj_at'[wp]: + "tcbSchedEnqueue tcbPtr \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + unfolding tcbSchedEnqueue_def setQueue_def + by wpsimp + +lemma tcbSchedEnqueue_tcbDomain_obj_at'[wp]: + "tcbSchedEnqueue tcbPtr \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding tcbSchedEnqueue_def setQueue_def + by wpsimp + +crunches rescheduleRequired + for tcbPriority_obj_at'[wp]: "obj_at' (\tcb. P (tcbPriority tcb)) t'" + and tcbDomain_obj_at'[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t'" + +lemma setThreadState_tcbPriority_obj_at'[wp]: + "setThreadState ts tptr \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + unfolding setThreadState_def + apply (wpsimp wp: threadSet_wp) + apply (fastforce simp: obj_at'_def objBits_simps ps_clear_def) + done + lemma setThreadState_tcb_in_cur_domain'[wp]: "\tcb_in_cur_domain' t'\ setThreadState st t \\_. tcb_in_cur_domain' t'\" apply (simp add: tcb_in_cur_domain'_def) apply (rule hoare_pre) apply wps - apply (wp setThreadState_not_st | simp)+ + apply (simp add: setThreadState_def) + apply (wpsimp wp: threadSet_ct_idle_or_in_cur_domain' hoare_drop_imps)+ done lemma asUser_global_refs': "\valid_global_refs'\ asUser t f \\rv. valid_global_refs'\" @@ -4614,10 +5949,13 @@ 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) - (set_eobject ptr etcb) (setObject ptr tcb')" + 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 @@ -4638,21 +5976,34 @@ lemma set_eobject_corres': 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 cte_relation_def tcb_relation_def + apply (clarsimp simp: obj_at'_def other_obj_relation_def tcb_relation_cut_def + cte_relation_def tcb_relation_def split: if_split_asm)+ apply (clarsimp simp: aobj_relation_cuts_def split: AARCH64_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 is_tcb_def split: if_split_asm)+ - 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 + 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 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 non_exst_same_def split: option.splits) + apply (clarsimp simp: ready_queue_relation_def opt_map_def opt_pred_def obj_at'_def inQ_def + non_exst_same_def + split: option.splits) + apply metis done lemma set_eobject_corres: @@ -4660,9 +6011,13 @@ lemma set_eobject_corres: 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) - (set_eobject add etcbu) (setObject add tcbu')" + 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) @@ -4689,24 +6044,27 @@ lemma set_eobject_corres: 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) - (ethread_set f t) (threadSet f' t)" + 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+ + 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 simp + apply (clarsimp simp: obj_at'_def) done lemmas ethread_set_corres = diff --git a/proof/refine/AARCH64/Tcb_R.thy b/proof/refine/AARCH64/Tcb_R.thy index f9f1c3c180..dff355d085 100644 --- a/proof/refine/AARCH64/Tcb_R.thy +++ b/proof/refine/AARCH64/Tcb_R.thy @@ -192,18 +192,13 @@ lemma setupReplyMaster_weak_sch_act_wf[wp]: apply assumption done -crunches setupReplyMaster - for valid_queues[wp]: "Invariants_H.valid_queues" - and valid_queues'[wp]: "valid_queues'" - (wp: crunch_wps simp: crunch_simps) - crunches 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) (invs' and tcb_at' t) + "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) @@ -214,19 +209,20 @@ lemma restart_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_valid_queues sts_st_tcb' - | clarsimp simp: valid_tcb_state'_def)+ - apply (rule_tac Q="\rv. valid_sched and cur_tcb and pspace_aligned and pspace_distinct" - in hoare_strengthen_post) - apply wp - apply (simp add: valid_sched_def valid_sched_action_def) - apply (rule_tac Q="\rv. invs' and tcb_at' t" in hoare_strengthen_post) - apply wp - apply (clarsimp simp: invs'_def valid_state'_def sch_act_wf_weak valid_pspace'_def) - apply wp+ + 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 simp add: invs'_def valid_state'_def sch_act_wf_weak) + apply clarsimp done lemma restart_invs': @@ -313,6 +309,11 @@ lemma asUser_postModifyRegisters_corres: apply (rule corres_stateAssert_assume) by simp+ +crunches restart + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + (simp: crunch_simps wp: crunch_wps threadSet_sched_pointers threadSet_valid_sched_pointers) + lemma invokeTCB_WriteRegisters_corres: "corres (dc \ (=)) (einvs and tcb_at dest and ex_nonz_cap_to dest) (invs' and sch_act_simple and tcb_at' dest and ex_nonz_cap_to' dest) @@ -341,10 +342,12 @@ lemma invokeTCB_WriteRegisters_corres: apply simp apply (wp+)[2] apply ((wp hoare_weak_lift_imp restart_invs' - | strengthen valid_sched_weak_strg einvs_valid_etcbs invs_valid_queues' invs_queues - invs_weak_sch_act_wf - | 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] + | 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_post_imp) apply (fastforce simp: invs_def valid_sched_weak_strg valid_sched_def valid_state_def dest!: idle_no_ex_cap) @@ -376,6 +379,10 @@ lemma suspend_ResumeCurrentThread_imp_notct[wp]: \\rv s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" by (wpsimp simp: suspend_def) +crunches restart, suspend + for cur_tcb'[wp]: cur_tcb' + (wp: crunch_wps threadSet_cur ignore: threadSet) + 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 @@ -403,7 +410,7 @@ proof - apply (rule corres_modify') apply simp apply simp - apply (simp add: invs_distinct invs_psp_aligned| wp)+ + apply (simp add: invs_distinct invs_psp_aligned | wp)+ done have R: "\src src' des des' xs ys. \ src = src'; des = des'; xs = ys \ \ corres dc (tcb_at src and tcb_at des and invs) @@ -452,11 +459,11 @@ proof - apply simp apply (solves \wp hoare_weak_lift_imp\)+ apply (rule_tac Q="\_. einvs and tcb_at dest" in hoare_post_imp) - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def valid_sched_weak_strg valid_sched_def) + 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_post_imp) - apply (clarsimp simp: invs'_def valid_state'_def invs_weak_sch_act_wf cur_tcb'_def) - apply ((wp mapM_x_wp' hoare_weak_lift_imp | simp+)+)[4] + 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 @@ -504,38 +511,6 @@ lemma copyreg_invs': \\rv. invs'\" by (rule hoare_strengthen_post, rule copyreg_invs'', simp) -lemma threadSet_valid_queues_no_state: - "\Invariants_H.valid_queues and (\s. \p. t \ set (ksReadyQueues s p))\ - threadSet f t \\_. Invariants_H.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 setObject_queues_unchanged_tcb - 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 - objBits_simps addToQs_def - split del: if_split cong: if_cong) - apply (fastforce simp: inQ_def split: if_split_asm) - done - lemma isRunnable_corres: "corres (\ts runn. runnable ts = runn) (tcb_at t and pspace_aligned and pspace_distinct) \ @@ -560,16 +535,6 @@ lemma tcbSchedDequeue_not_queued: apply (wp tg_sp' [where P=\, simplified] | simp)+ done -lemma tcbSchedDequeue_not_in_queue: - "\p. \Invariants_H.valid_queues and tcb_at' t and valid_objs'\ tcbSchedDequeue t - \\rv s. t \ set (ksReadyQueues s p)\" - apply (rule_tac Q="\rv. Invariants_H.valid_queues and obj_at' (Not \ tcbQueued) t" - in hoare_post_imp) - apply (fastforce simp: valid_queues_def valid_queues_no_bitmap_def obj_at'_def inQ_def ) - apply (wp tcbSchedDequeue_not_queued tcbSchedDequeue_valid_queues | - simp add: valid_objs'_maxDomain valid_objs'_maxPriority)+ - done - lemma threadSet_ct_in_state': "(\tcb. tcbState (f tcb) = tcbState tcb) \ \ct_in_state' test\ threadSet f t \\rv. ct_in_state' test\" @@ -615,14 +580,19 @@ lemma tcbSchedDequeue_ct_in_state'[wp]: crunch cur[wp]: tcbSchedDequeue cur_tcb' +crunches tcbSchedDequeue + for st_tcb_at'[wp]: "\s. P (st_tcb_at' st tcbPtr s)" + lemma sp_corres2: - "corres dc (valid_etcbs and weak_valid_sched_action and cur_tcb and pspace_aligned and pspace_distinct) - (Invariants_H.valid_queues and valid_queues' and tcb_at' t and - (\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_objs' and (\_. x \ maxPriority)) - (set_priority t x) (setPriority t x)" + "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]) + 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]) @@ -634,25 +604,28 @@ lemma sp_corres2: 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) - apply clarsimp - apply ((wp hoare_drop_imps hoare_vcg_if_lift hoare_vcg_all_lift - isRunnable_wp threadSet_pred_tcb_no_state threadSet_valid_queues_no_state - threadSet_valid_queues'_no_state threadSet_cur threadSet_valid_objs_tcbPriority_update - threadSet_weak_sch_act_wf threadSet_ct_in_state'[simplified ct_in_state'_def] - | simp add: etcb_relation_def)+)[1] - apply ((wp hoare_vcg_imp_lift' hoare_vcg_if_lift hoare_vcg_all_lift hoare_vcg_disj_lift - tcbSchedDequeue_not_in_queue tcbSchedDequeue_valid_queues - tcbSchedDequeue_ct_in_state'[simplified ct_in_state'_def] - | simp add: etcb_relation_def)+)[2] + 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 (force simp: state_relation_def elim: valid_objs'_maxDomain valid_objs'_maxPriority) + apply clarsimp done 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)" + "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) @@ -678,6 +651,9 @@ 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' \ @@ -685,10 +661,8 @@ lemma out_corresT: \ (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 - apply (clarsimp simp add: threadset_corresT [OF _ x y e]) + 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] @@ -697,32 +671,41 @@ lemma tcbSchedDequeue_sch_act_simple[wp]: "tcbSchedDequeue t \sch_act_simple\" by (wpsimp simp: sch_act_simple_def) +lemma tcbSchedNext_update_tcb_cte_cases: + "(a, b) \ ran tcb_cte_cases \ a (tcbPriority_update f tcb) = a tcb" + unfolding tcb_cte_cases_def + by (case_tac tcb; fastforce simp: objBits_simps') + +lemma threadSet_priority_invs': + "\invs' and tcb_at' t and K (p \ maxPriority)\ + threadSet (tcbPriority_update (\_. p)) t + \\_. invs'\" + apply (rule hoare_gen_asm) + apply (simp add: invs'_def valid_state'_def split del: if_split) + apply (wp threadSet_valid_pspace' + threadSet_sch_actT_P[where P=False, simplified] + threadSet_state_refs_of'T[where f'=id] + threadSet_state_hyp_refs_of' + threadSet_iflive'T + threadSet_ifunsafe'T + threadSet_idle'T + valid_irq_node_lift + valid_irq_handlers_lift'' + threadSet_ctes_ofT + threadSet_not_inQ + threadSet_ct_idle_or_in_cur_domain' + threadSet_cur + untyped_ranges_zero_lift + sym_heap_sched_pointers_lift threadSet_valid_sched_pointers + threadSet_tcbSchedPrevs_of threadSet_tcbSchedNexts_of + | clarsimp simp: cteCaps_of_def tcbSchedNext_update_tcb_cte_cases | rule refl)+ + apply (clarsimp simp: o_def) + by (auto simp: obj_at'_def) + lemma setP_invs': "\invs' and tcb_at' t and K (p \ maxPriority)\ setPriority t p \\rv. invs'\" - apply (rule hoare_gen_asm) - apply (simp add: setPriority_def) - apply (wp rescheduleRequired_all_invs_but_ct_not_inQ) - apply simp - apply (wp hoare_vcg_conj_lift hoare_vcg_imp_lift') - unfolding st_tcb_at'_def - apply (strengthen not_obj_at'_strengthen, wp) - apply (wp hoare_vcg_imp_lift') - apply (rule_tac Q="\rv s. invs' s" in hoare_post_imp) - apply (clarsimp simp: invs_sch_act_wf' invs'_def invs_queues) - apply (clarsimp simp: valid_state'_def) - apply (wp hoare_drop_imps threadSet_invs_trivial, - simp_all add: inQ_def cong: conj_cong)[1] - apply (wp hoare_drop_imps threadSet_invs_trivial, - simp_all add: inQ_def cong: conj_cong)[1] - apply (wp hoare_drop_imps threadSet_invs_trivial, - simp_all add: inQ_def cong: conj_cong)[1] - apply (rule_tac Q="\_. invs' and obj_at' (Not \ tcbQueued) t - and (\s. \d p. t \ set (ksReadyQueues s (d,p)))" - in hoare_post_imp) - apply (clarsimp simp: obj_at'_def inQ_def) - apply (wp tcbSchedDequeue_not_queued)+ - apply clarsimp - done + unfolding setPriority_def + by (wpsimp wp: rescheduleRequired_invs' threadSet_priority_invs') crunches setPriority, setMCPriority for typ_at'[wp]: "\s. P (typ_at' T p s)" @@ -989,13 +972,6 @@ lemma setMCPriority_valid_objs'[wp]: crunch sch_act_simple[wp]: setMCPriority sch_act_simple (wp: ssa_sch_act_simple crunch_wps rule: sch_act_simple_lift simp: crunch_simps) -(* For some reason, when this was embedded in a larger expression clarsimp wouldn't remove it. - Adding it as a simp rule does *) -lemma inQ_tc_corres_helper: - "(\d p. (\tcb. tcbQueued tcb \ tcbPriority tcb = p \ tcbDomain tcb = d \ - (tcbQueued tcb \ tcbDomain tcb \ d)) \ a \ set (ksReadyQueues s (d, p)))" - by clarsimp - abbreviation "valid_option_prio \ case_option True (\(p, auth). p \ maxPriority)" definition valid_tcb_invocation :: "tcbinvocation \ bool" where @@ -1017,35 +993,29 @@ lemma thread_set_ipc_weak_valid_sched_action: 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_helper2: - "is_aligned a msg_align_bits \ - \invs' and tcb_at' t\ - threadSet (tcbIPCBuffer_update (\_. a)) t - \\x s. Invariants_H.valid_queues s \ valid_queues' s\" - by (wp threadSet_invs_trivial - | strengthen invs_valid_queues' invs_queues invs_weak_sch_act_wf - | clarsimp simp: inQ_def )+ - lemma threadcontrol_corres_helper3: - "\ einvs and simple_sched_action\ + "\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))) - \\x. weak_valid_sched_action and valid_etcbs \" - apply (rule hoare_pre) - apply (wp check_cap_inv | simp add:)+ - by (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) + \\_ 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 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))))) - \\x. Invariants_H.valid_queues and valid_queues'\" - apply (wp - | strengthen invs_valid_queues' invs_queues invs_weak_sch_act_wf - | clarsimp simp: )+ + 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))))) + \\_ 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) @@ -1065,75 +1035,45 @@ lemma is_valid_vtable_root_simp: split: cap.splits arch_cap.splits option.splits pt_type.splits) 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 \ tcbDomain (F tcb) = tcbDomain tcb" - assumes a: "\tcb. tcbBoundNotification (F tcb) = tcbBoundNotification 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 r: "\tcb. atcbVCPUPtr (tcbArch (F tcb)) = atcbVCPUPtr (tcbArch tcb)" + assumes + "\tcb. \(getF,setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" + "\tcb. tcbState (F tcb) = tcbState tcb \ tcbDomain (F tcb) = tcbDomain 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 tcb \ maxDomain \ tcbDomain (F tcb) \ maxDomain" + "\tcb. tcbPriority tcb \ maxPriority \ tcbPriority (F tcb) \ maxPriority" + "\tcb. tcbMCP tcb \ maxPriority \ tcbMCP (F tcb) \ maxPriority" + "\tcb. atcbVCPUPtr (tcbArch (F tcb)) = atcbVCPUPtr (tcbArch tcb)" shows - "\\s. invs' s - \ tcb_at' t s \ (\tcb. is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits) - \ (\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. \ tcbQueued tcb \ tcbQueued (F tcb)) \ ex_nonz_cap_to' t s \ t \ ksCurThread s) - \ (\tcb. tcbQueued (F tcb) \ ksSchedulerAction s = ResumeCurrentThread \ tcbQueued tcb \ t \ ksCurThread s)\ - threadSet F t - \\rv. invs'\" -proof - - from z have domains: "\tcb. tcbDomain (F tcb) = tcbDomain tcb" by blast - note threadSet_sch_actT_P[where P=False, simplified] - have y: "\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 valid_state'_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_state_refs_of'T[where f'=id] - threadSet_state_hyp_refs_of' - 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_cur - untyped_ranges_zero_lift - |clarsimp simp: y z a r domains cteCaps_of_def valid_arch_tcb'_def|rule refl)+ - apply (clarsimp simp: obj_at'_def pred_tcb_at'_def) - apply (clarsimp simp: cur_tcb'_def valid_irq_node'_def valid_queues'_def o_def) - by (fastforce simp: domains ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def z a) -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 objBits_simps addToQs_def - split del: if_split cong: if_cong) - apply (fastforce simp: 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_state_hyp_refs_of' + threadSet_idle'T + threadSet_not_inQ + threadSet_ct_idle_or_in_cur_domain' + threadSet_cur + | clarsimp simp: assms cteCaps_of_def valid_arch_tcb'_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\" @@ -1144,10 +1084,6 @@ 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) @@ -1187,6 +1123,12 @@ crunches option_update_thread for aligned[wp]: "pspace_aligned" and distinct[wp]: "pspace_distinct" +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'" and y: "newroot_rel f f'" and z: "(case g of None \ g' = None @@ -1378,10 +1320,20 @@ proof - apply (rule corres_split[OF getCurThread_corres], clarsimp) apply (rule corres_when[OF refl rescheduleRequired_corres]) apply (wpsimp wp: gct_wp)+ - apply (wp thread_set_ipc_weak_valid_sched_action|wp (once) hoare_drop_imp)+ - apply simp - apply (wp threadcontrol_corres_helper2 | wpc | simp)+ - apply (wp|strengthen einvs_valid_etcbs)+ + 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)+ + 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 @@ -1410,7 +1362,7 @@ proof - cap_delete_valid_cap cteDelete_deletes cteDelete_invs' | strengthen use_no_cap_to_obj_asid_strg - | clarsimp simp: inQ_def inQ_tc_corres_helper)+ + | 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) @@ -1493,36 +1445,16 @@ proof - 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 - cap_delete_deletes + check_cap_inv[where P=simple_sched_action] + cap_delete_deletes hoare_drop_imps cap_delete_valid_cap - simp: ran_tcb_cap_cases) + 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_drop_imps) - apply ((wpsimp wp: hoare_vcg_const_imp_lift hoare_vcg_imp_lift' hoare_vcg_all_lift - threadSet_cte_wp_at' threadSet_invs_trivialT2 cteDelete_invs' - simp: tcb_cte_cases_def cteSizeBits_def), (fastforce+)[6]) - apply wpsimp - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - threadSet_invs_trivialT2 threadSet_cte_wp_at' - simp: tcb_cte_cases_def cteSizeBits_def, (fastforce+)[6]) - apply wpsimp - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - rescheduleRequired_invs' threadSet_cte_wp_at' - simp: tcb_cte_cases_def) - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - rescheduleRequired_invs' threadSet_invs_trivialT2 threadSet_cte_wp_at' - simp: tcb_cte_cases_def cteSizeBits_def, (fastforce+)[6]) - apply wpsimp - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - rescheduleRequired_invs' threadSet_invs_trivialT2 threadSet_cte_wp_at' - simp: tcb_cte_cases_def cteSizeBits_def, (fastforce+)[6]) - apply wpsimp - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - rescheduleRequired_invs' threadSet_cap_to' threadSet_invs_trivialT2 - threadSet_cte_wp_at' hoare_drop_imps - simp: tcb_cte_cases_def cteSizeBits_def) - apply (clarsimp) + 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_lift_R hoare_vcg_all_lift hoare_vcg_const_imp_lift_R hoare_vcg_const_imp_lift threadSet_valid_objs' thread_set_not_state_valid_sched @@ -1535,9 +1467,9 @@ proof - | strengthen tcb_cap_always_valid_strg tcb_at_invs use_no_cap_to_obj_asid_strg - | (erule exE, clarsimp simp: word_bits_def))+) + | (erule exE, clarsimp simp: word_bits_def) | wp (once) hoare_drop_imps)+) apply (strengthen valid_tcb_ipc_buffer_update) - apply (strengthen invs_valid_objs') + 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 @@ -1661,7 +1593,7 @@ lemma setSchedulerAction_invs'[wp]: apply (simp add: setSchedulerAction_def) apply wp apply (clarsimp simp add: invs'_def valid_state'_def valid_irq_node'_def - valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs cur_tcb'_def + valid_queues_def bitmapQ_defs cur_tcb'_def ct_not_inQ_def) apply (simp add: ct_idle_or_in_cur_domain'_def) done @@ -1791,8 +1723,8 @@ lemma invokeTCB_corres: apply (rule TcbAcc_R.rescheduleRequired_corres) apply (rule corres_trivial, simp) apply (wpsimp wp: hoare_drop_imp)+ - apply (clarsimp simp: valid_sched_weak_strg einvs_valid_etcbs invs_distinct) - apply (clarsimp simp: invs_valid_queues' invs_queues) + apply (fastforce dest: valid_sched_valid_queues simp: valid_sched_weak_strg einvs_valid_etcbs) + apply fastforce done lemma tcbBoundNotification_caps_safe[simp]: @@ -1807,6 +1739,10 @@ lemma valid_bound_ntfn_lift: apply (wp typ_at_lifts[OF P])+ done +crunches 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 @@ -1819,7 +1755,7 @@ lemma bindNotification_invs': apply (simp add: bindNotification_def invs'_def valid_state'_def) apply (rule hoare_seq_ext[OF _ get_ntfn_sp']) apply (rule hoare_pre) - apply (wp set_ntfn_valid_pspace' sbn_sch_act' sbn_valid_queues valid_irq_node_lift + 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)+ @@ -2045,12 +1981,6 @@ lemma decodeSetMCPriority_corres: apply (clarsimp simp: newroot_rel_def elim!: is_thread_cap.elims(2)) by (wpsimp simp: valid_cap_def valid_cap'_def)+ -lemma valid_objs'_maxPriority': - "\s t. \ valid_objs' s; tcb_at' t s \ \ obj_at' (\tcb. tcbMCP tcb \ maxPriority) t s" - apply (erule (1) valid_objs_valid_tcbE) - apply (clarsimp simp: valid_tcb'_def) - done - lemma getMCP_sp: "\P\ threadGet tcbMCP t \\rv. mcpriority_tcb_at' (\st. st = rv) t and P\" apply (simp add: threadGet_def) diff --git a/proof/refine/AARCH64/Untyped_R.thy b/proof/refine/AARCH64/Untyped_R.thy index a781e18568..2b28c833b2 100644 --- a/proof/refine/AARCH64/Untyped_R.thy +++ b/proof/refine/AARCH64/Untyped_R.thy @@ -1348,16 +1348,6 @@ crunches insertNewCaps crunch exst[wp]: set_cdt "\s. P (exst s)" -(*FIXME: Move to StateRelation*) -lemma state_relation_schact[elim!]: - "(s,s') \ state_relation \ sched_act_relation (scheduler_action s) (ksSchedulerAction s')" - apply (simp add: state_relation_def) - done - -lemma state_relation_queues[elim!]: "(s,s') \ state_relation \ ready_queues_relation (ready_queues s) (ksReadyQueues s')" - apply (simp add: state_relation_def) - done - lemma set_original_symb_exec_l: "corres_underlying {(s, s'). f (kheap s) (exst s) s'} nf 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) @@ -1384,6 +1374,10 @@ lemma updateNewFreeIndex_noop_psp_corres: | simp add: updateTrackedFreeIndex_def getSlotCap_def)+ done +crunches updateMDB, updateNewFreeIndex, setCTE + for rdyq_projs[wp]: + "\s. P (ksReadyQueues s) (tcbSchedNexts_of s) (tcbSchedPrevs_of s) (\d p. inQ d p |< tcbs_of' s)" + lemma insertNewCap_corres: notes if_cong[cong del] if_weak_cong[cong] shows @@ -3613,8 +3607,8 @@ lemma updateFreeIndex_clear_invs': apply (simp add:updateCap_def) apply (wp setCTE_irq_handlers' getCTE_wp) apply (simp add:updateCap_def) - apply (wp irqs_masked_lift valid_queues_lift' cur_tcb_lift ct_idle_or_in_cur_domain'_lift - hoare_vcg_disj_lift untyped_ranges_zero_lift getCTE_wp + apply (wp irqs_masked_lift cur_tcb_lift ct_idle_or_in_cur_domain'_lift + hoare_vcg_disj_lift untyped_ranges_zero_lift getCTE_wp valid_bitmaps_lift | wp (once) hoare_use_eq[where f="gsUntypedZeroRanges"] | simp add: getSlotCap_def | simp add: cte_wp_at_ctes_of)+ @@ -4226,14 +4220,12 @@ context begin interpretation Arch . (*FIXME: arch_split*) lemma resetUntypedCap_corres: "untypinv_relation ui ui' \ corres (dc \ dc) - (invs 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) apply (rule corres_guard_imp) @@ -5077,7 +5069,7 @@ lemma inv_untyped_corres': apply (clarsimp simp only: pred_conj_def invs ui) apply (strengthen vui) apply (cut_tac vui invs invs') - apply (clarsimp simp: cte_wp_at_caps_of_state valid_sched_etcbs) + 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 @@ -5128,7 +5120,6 @@ crunches insertNewCap and global_refs': "\s. P (global_refs' s)" and gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" and irq_states' [wp]: valid_irq_states' - and vq'[wp]: valid_queues' and irqs_masked' [wp]: irqs_masked' and valid_machine_state'[wp]: valid_machine_state' and pspace_domain_valid[wp]: pspace_domain_valid @@ -5136,6 +5127,9 @@ crunches insertNewCap and tcbState_inv[wp]: "obj_at' (\tcb. P (tcbState tcb)) t" and tcbDomain_inv[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t" and tcbPriority_inv[wp]: "obj_at' (\tcb. P (tcbPriority tcb)) t" + and sched_queues_projs[wp]: "\s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)" + and tcbQueueds_of[wp]: "\s. P (tcbQueued |< tcbs_of' s)" + and valid_sched_pointers[wp]: valid_sched_pointers (wp: crunch_wps) crunch if_unsafe_then_cap'[wp]: updateNewFreeIndex "if_unsafe_then_cap'" @@ -5296,8 +5290,8 @@ lemma insertNewCap_invs': apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) apply (wp insertNewCap_valid_pspace' sch_act_wf_lift - valid_queues_lift cur_tcb_lift tcb_in_cur_domain'_lift - insertNewCap_valid_global_refs' + cur_tcb_lift tcb_in_cur_domain'_lift valid_bitmaps_lift + insertNewCap_valid_global_refs' sym_heap_sched_pointers_lift valid_irq_node_lift insertNewCap_valid_irq_handlers) apply (clarsimp simp: cte_wp_at_ctes_of) apply (frule ctes_of_valid[rotated, where p=parent, OF valid_pspace_valid_objs']) diff --git a/proof/refine/AARCH64/VSpace_R.thy b/proof/refine/AARCH64/VSpace_R.thy index 32bce50440..4532ab82b8 100644 --- a/proof/refine/AARCH64/VSpace_R.thy +++ b/proof/refine/AARCH64/VSpace_R.thy @@ -316,11 +316,6 @@ lemma setVCPU_ksQ[wp]: "\\s. P (ksReadyQueues s)\ setObject p (v::vcpu) \\rv s. P (ksReadyQueues s)\" by (wp setObject_qs updateObject_default_inv | simp)+ -lemma setVCPU_valid_queues'[wp]: - "setObject v (vcpu::vcpu) \valid_queues'\" - unfolding valid_queues'_def - by (rule hoare_lift_Pf[where f=ksReadyQueues]; wp hoare_vcg_all_lift updateObject_default_inv) - lemma setVCPU_ct_not_inQ[wp]: "setObject v (vcpu::vcpu) \ct_not_inQ\" apply (wp ct_not_inQ_lift) @@ -906,23 +901,6 @@ lemma setVCPU_valid_arch': apply (clarsimp simp: is_vcpu'_def ko_wp_at'_def) done -lemma setVCPU_valid_queues [wp]: - "\valid_queues\ setObject p (v::vcpu) \\_. valid_queues\" - by (wp valid_queues_lift | simp add: pred_tcb_at'_def)+ - -crunches - vcpuDisable, vcpuRestore, vcpuEnable, vcpuUpdate, vcpuSaveRegRange, vgicUpdateLR - for valid_queues[wp]: valid_queues - (ignore: doMachineOp wp: mapM_x_wp) - -lemma vcpuSave_valid_queues[wp]: - "\Invariants_H.valid_queues\ vcpuSave param_a \\_. Invariants_H.valid_queues\" - by (wpsimp simp: vcpuSave_def armvVCPUSave_def wp: mapM_x_wp cong: option.case_cong_weak | simp)+ - -lemma vcpuSwitch_valid_queues[wp]: - "\Invariants_H.valid_queues\ vcpuSwitch param_a \\_. Invariants_H.valid_queues\" - by (wpsimp simp: vcpuSwitch_def modifyArchState_def | simp)+ - lemma setObject_vcpu_no_tcb_update: "\ vcpuTCBPtr (f vcpu) = vcpuTCBPtr vcpu \ \ \ valid_objs' and ko_at' (vcpu :: vcpu) p\ setObject p (f vcpu) \ \_. valid_objs' \" @@ -952,6 +930,10 @@ crunches and ksCurDomain[wp]: "\s. P (ksCurDomain s)" (wp: mapM_wp_inv simp: mapM_x_mapM) +lemma setVCPU_tcbs_of'[wp]: + "setObject v (vcpu :: vcpu) \\s. P' (tcbs_of' s)\" + by setObject_easy_cases + lemma setVCPU_regs_r_invs_cicd': "\invs_no_cicd' and ko_at' vcpu v\ setObject v (vcpuRegs_update (\_. (vcpuRegs vcpu)(r:=rval)) vcpu) \\_. invs_no_cicd'\" @@ -965,7 +947,7 @@ lemma setVCPU_regs_r_invs_cicd': valid_irq_node_lift_asm [where Q=\] valid_irq_handlers_lift' cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift - setObject_typ_at' cur_tcb_lift + setObject_typ_at' cur_tcb_lift valid_bitmaps_lift setVCPU_regs_valid_arch' setVCPU_regs_vcpu_live simp: objBits_simps archObjSize_def vcpuBits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) @@ -987,7 +969,7 @@ lemma setVCPU_vgic_invs_cicd': valid_irq_node_lift_asm [where Q=\] valid_irq_handlers_lift' cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift - setObject_typ_at' cur_tcb_lift + setObject_typ_at' cur_tcb_lift valid_bitmaps_lift setVCPU_vgic_valid_arch' simp: objBits_simps archObjSize_def vcpuBits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) @@ -1009,7 +991,7 @@ lemma setVCPU_VPPIMasked_invs_cicd': valid_irq_node_lift_asm [where Q=\] valid_irq_handlers_lift' cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift - setObject_typ_at' cur_tcb_lift + setObject_typ_at' cur_tcb_lift valid_bitmaps_lift setVCPU_VPPIMasked_valid_arch' simp: objBits_simps archObjSize_def vcpuBits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) @@ -1031,7 +1013,7 @@ lemma setVCPU_VTimer_invs_cicd': valid_irq_node_lift_asm [where Q=\] valid_irq_handlers_lift' cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift - setObject_typ_at' cur_tcb_lift + setObject_typ_at' cur_tcb_lift valid_bitmaps_lift setVCPU_VTimer_valid_arch' simp: objBits_simps archObjSize_def vcpuBits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) @@ -1111,13 +1093,12 @@ lemma vcpuSave_invs_no_cicd'[wp]: by (wpsimp simp: vcpuSave_def armvVCPUSave_def wp: mapM_x_wp cong: option.case_cong_weak | assumption)+ lemma valid_arch_state'_armHSCurVCPU_update[simp]: - "ko_wp_at' (is_vcpu' and hyp_live') v s \ - valid_arch_state' s \ valid_arch_state' (s\ksArchState := armHSCurVCPU_update (\_. Some (v, b)) (ksArchState s)\)" - by (clarsimp simp: invs'_def valid_state'_def valid_queues_def valid_queues_no_bitmap_def - bitmapQ_defs valid_global_refs'_def valid_arch_state'_def global_refs'_def - valid_queues'_def valid_irq_node'_def valid_irq_handlers'_def - irq_issued'_def irqs_masked'_def valid_machine_state'_def - cur_tcb'_def) + "\ ko_wp_at' (is_vcpu' and hyp_live') v s; valid_arch_state' s \ \ + valid_arch_state' (s\ksArchState := armHSCurVCPU_update (\_. Some (v, b)) (ksArchState s)\)" + by (clarsimp simp: invs'_def valid_state'_def + bitmapQ_defs valid_global_refs'_def valid_arch_state'_def global_refs'_def + valid_irq_node'_def valid_irq_handlers'_def + irq_issued'_def irqs_masked'_def valid_machine_state'_def cur_tcb'_def) lemma dmo_vcpu_hyp: "\ko_wp_at' (is_vcpu' and hyp_live') v\ doMachineOp f \\_. ko_wp_at' (is_vcpu' and hyp_live') v\" @@ -1210,20 +1191,18 @@ lemma vcpuSwitch_valid_arch_state'[wp]: lemma invs_no_cicd'_armHSCurVCPU_update[simp]: "ko_wp_at' (is_vcpu' and hyp_live') v s \ invs_no_cicd' s \ invs_no_cicd' (s\ksArchState := armHSCurVCPU_update (\_. Some (v, b)) (ksArchState s)\)" - by (clarsimp simp: invs_no_cicd'_def valid_state'_def valid_queues_def valid_queues_no_bitmap_def - bitmapQ_defs valid_global_refs'_def valid_arch_state'_def global_refs'_def - valid_queues'_def valid_irq_node'_def valid_irq_handlers'_def - irq_issued'_def irqs_masked'_def valid_machine_state'_def - cur_tcb'_def) + by (clarsimp simp: invs_no_cicd'_def valid_state'_def + bitmapQ_defs valid_global_refs'_def valid_arch_state'_def global_refs'_def + valid_irq_node'_def valid_irq_handlers'_def + irq_issued'_def irqs_masked'_def valid_machine_state'_def cur_tcb'_def) lemma invs'_armHSCurVCPU_update[simp]: "ko_wp_at' (is_vcpu' and hyp_live') v s \ invs' s \ invs' (s\ksArchState := armHSCurVCPU_update (\_. Some (v, b)) (ksArchState s)\)" - apply (clarsimp simp: invs'_def valid_state'_def valid_queues_def valid_queues_no_bitmap_def - bitmapQ_defs valid_global_refs'_def valid_arch_state'_def global_refs'_def - valid_queues'_def valid_irq_node'_def valid_irq_handlers'_def - irq_issued'_def irqs_masked'_def valid_machine_state'_def - cur_tcb'_def) + apply (clarsimp simp: invs'_def valid_state'_def + bitmapQ_defs valid_global_refs'_def valid_arch_state'_def global_refs'_def + valid_irq_node'_def valid_irq_handlers'_def + irq_issued'_def irqs_masked'_def valid_machine_state'_def cur_tcb'_def) done lemma armHSCurVCPU_None_invs'[wp]: @@ -1246,7 +1225,7 @@ lemma setVCPU_vgic_invs': valid_irq_node_lift_asm [where Q=\] valid_irq_handlers_lift' cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift - setObject_typ_at' cur_tcb_lift + setObject_typ_at' cur_tcb_lift valid_bitmaps_lift setVCPU_vgic_valid_arch' simp: objBits_simps archObjSize_def vcpuBits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) @@ -1266,7 +1245,7 @@ lemma setVCPU_regs_invs': valid_irq_node_lift_asm [where Q=\] valid_irq_handlers_lift' cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift - setObject_typ_at' cur_tcb_lift + setObject_typ_at' cur_tcb_lift valid_bitmaps_lift setVCPU_regs_valid_arch' simp: objBits_simps archObjSize_def vcpuBits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) @@ -1286,7 +1265,7 @@ lemma setVCPU_VPPIMasked_invs': valid_irq_node_lift_asm [where Q=\] valid_irq_handlers_lift' cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift - setObject_typ_at' cur_tcb_lift + setObject_typ_at' cur_tcb_lift valid_bitmaps_lift setVCPU_VPPIMasked_valid_arch' simp: objBits_simps archObjSize_def vcpuBits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) @@ -1306,7 +1285,7 @@ lemma setVCPU_VTimer_invs': valid_irq_node_lift_asm [where Q=\] valid_irq_handlers_lift' cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift - setObject_typ_at' cur_tcb_lift + setObject_typ_at' cur_tcb_lift valid_bitmaps_lift setVCPU_VTimer_valid_arch' simp: objBits_simps archObjSize_def vcpuBits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) @@ -2530,14 +2509,6 @@ lemma setASIDPool_tcb_obj_at'[wp]: apply (clarsimp simp add: updateObject_default_def in_monad) done -lemma setASIDPool_valid_queues[wp]: - "setObject p (ap::asidpool) \valid_queues\" - by (wp valid_queues_lift | simp add: pred_tcb_at'_def)+ - -lemma setASIDPool_valid_queues'[wp]: - "setObject p (ap::asidpool) \valid_queues'\" - by (wp valid_queues_lift') - lemma setASIDPool_state_refs'[wp]: "setObject p (ap::asidpool) \\s. P (state_refs_of' s)\" apply (clarsimp simp: setObject_def valid_def in_monad split_def @@ -2648,6 +2619,10 @@ lemma setObject_ap_ksDomScheduleIdx[wp]: "setObject p (ap::asidpool) \\s. P (ksDomScheduleIdx s)\" by (wpsimp wp: updateObject_default_inv simp: setObject_def) +lemma setObject_ap_tcbs_of'[wp]: + "setObject p (ap::asidpool) \\s. P' (tcbs_of' s)\" + by setObject_easy_cases + lemma setASIDPool_invs[wp]: "setObject p (ap::asidpool) \invs'\" apply (simp add: invs'_def valid_state'_def valid_pspace'_def) @@ -2655,10 +2630,10 @@ lemma setASIDPool_invs[wp]: valid_irq_node_lift cur_tcb_lift valid_irq_handlers_lift'' untyped_ranges_zero_lift - updateObject_default_inv + updateObject_default_inv valid_bitmaps_lift | simp add: cteCaps_of_def | rule setObject_ksPSpace_only)+ - apply (clarsimp simp: o_def) + apply (clarsimp simp: o_def) done lemma doMachineOp_invalidateTranslationASID_invs'[wp]: @@ -2710,7 +2685,7 @@ lemma setASIDPool_invs_no_cicd'[wp]: valid_irq_node_lift cur_tcb_lift valid_irq_handlers_lift'' untyped_ranges_zero_lift - updateObject_default_inv + updateObject_default_inv valid_bitmaps_lift | simp add: cteCaps_of_def | rule setObject_ksPSpace_only)+ apply (clarsimp simp: o_def) @@ -2820,10 +2795,6 @@ crunch norqL1[wp]: storePTE "\s. P (ksReadyQueuesL1Bitmap s)" crunch norqL2[wp]: storePTE "\s. P (ksReadyQueuesL2Bitmap s)" (simp: updateObject_default_def) -lemma storePTE_valid_queues' [wp]: - "\valid_queues'\ storePTE p pte \\_. valid_queues'\" - by (wp valid_queues_lift') - lemma storePTE_iflive [wp]: "\if_live_then_nonz_cap'\ storePTE p pte \\rv. if_live_then_nonz_cap'\" apply (simp add: storePTE_def) @@ -2942,10 +2913,6 @@ lemma storePTE_valid_objs[wp]: apply simp done -lemma storePTE_valid_queues [wp]: - "\Invariants_H.valid_queues\ storePTE p pde \\_. Invariants_H.valid_queues\" - by (wp valid_queues_lift | simp add: pred_tcb_at'_def)+ - lemma storePTE_ko_wp_vcpu_at'[wp]: "storePTE p pde \\s. P (ko_wp_at' (is_vcpu' and hyp_live') p' s)\" apply (clarsimp simp: storePTE_def) @@ -2953,11 +2920,19 @@ lemma storePTE_ko_wp_vcpu_at'[wp]: apply (auto simp: bit_simps ko_wp_at'_def obj_at'_def is_vcpu'_def)+ done +lemma setObject_pte_tcb_of'[wp]: + "setObject slote (pte::pte) \\s. P' (tcbs_of' s)\" + by setObject_easy_cases + +crunches storePTE + for tcbs_of'[wp]: "\s. P (tcbs_of' s)" + lemma storePTE_invs[wp]: "\invs' and K (ppn_bounded pte)\ storePTE p pte \\_. invs'\" unfolding invs'_def valid_state'_def valid_pspace'_def by (wpsimp wp: sch_act_wf_lift valid_global_refs_lift' irqs_masked_lift valid_arch_state_lift' valid_irq_node_lift cur_tcb_lift valid_irq_handlers_lift'' untyped_ranges_zero_lift + valid_bitmaps_lift simp: cteCaps_of_def o_def) crunch cte_wp_at'[wp]: unmapPageTable "\s. P (cte_wp_at' P' p s)" diff --git a/proof/refine/AARCH64/orphanage/Orphanage.thy b/proof/refine/AARCH64/orphanage/Orphanage.thy index 7e56a739c6..7196a28156 100644 --- a/proof/refine/AARCH64/orphanage/Orphanage.thy +++ b/proof/refine/AARCH64/orphanage/Orphanage.thy @@ -59,8 +59,7 @@ where definition all_queued_tcb_ptrs :: "kernel_state \ machine_word set" where - "all_queued_tcb_ptrs s \ - { tcb_ptr. \ priority. tcb_ptr : set ((ksReadyQueues s) priority) }" + "all_queued_tcb_ptrs s \ { tcb_ptr. obj_at' tcbQueued tcb_ptr s }" lemma st_tcb_at_neg': "(st_tcb_at' (\ ts. \ P ts) t s) = (tcb_at' t s \ \ st_tcb_at' P t s)" @@ -107,8 +106,8 @@ lemma no_orphans_lift: "\ tcb_ptr. \ \s. tcb_ptr = ksCurThread s \ f \ \_ s. tcb_ptr = ksCurThread s \" assumes st_tcb_at'_is_lifted: "\P p. \ \s. st_tcb_at' P p s\ f \ \_ s. st_tcb_at' P p s \" - assumes ksReadyQueues_is_lifted: - "\P. \ \s. P (ksReadyQueues s)\ f \ \_ s. P (ksReadyQueues s) \" + assumes tcbQueued_is_lifted: + "\P tcb_ptr. f \ \s. obj_at' (\tcb. P (tcbQueued tcb)) tcb_ptr s \" assumes ksSchedulerAction_is_lifted: "\P. \ \s. P (ksSchedulerAction s)\ f \ \_ s. P (ksSchedulerAction s) \" shows @@ -119,7 +118,7 @@ lemma no_orphans_lift: apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) apply (rule ksCurThread_is_lifted) apply (wp hoare_vcg_disj_lift) - apply (rule ksReadyQueues_is_lifted) + apply (wpsimp wp: tcbQueued_is_lifted) apply (wp hoare_vcg_disj_lift) apply (rule typ_at'_is_lifted) apply (wp hoare_vcg_disj_lift) @@ -139,13 +138,12 @@ lemma st_tcb_at'_all_active_tcb_ptrs_lift: by (clarsimp simp: all_active_tcb_ptrs_def) (rule st_tcb_at'_is_active_tcb_ptr_lift [OF assms]) -lemma ksQ_all_queued_tcb_ptrs_lift: - assumes "\P p. \\s. P (ksReadyQueues s p)\ f \\rv s. P (ksReadyQueues s p)\" +lemma tcbQueued_all_queued_tcb_ptrs_lift: + assumes "\Q P tcb_ptr. f \\s. Q (obj_at' (\tcb. P (tcbQueued tcb)) tcb_ptr s)\" shows "\\s. P (t \ all_queued_tcb_ptrs s)\ f \\_ s. P (t \ all_queued_tcb_ptrs s)\" apply (clarsimp simp: all_queued_tcb_ptrs_def) apply (rule_tac P=P in P_bool_lift) apply (wp hoare_vcg_ex_lift assms) - apply (clarsimp) apply (wp hoare_vcg_all_lift assms) done @@ -180,6 +178,11 @@ lemma almost_no_orphans_disj: apply (auto del: pred_tcb_at' intro: pred_tcb_at') done +lemma all_queued_tcb_ptrs_ksReadyQueues_update[simp]: + "tcb_ptr \ all_queued_tcb_ptrs (ksReadyQueues_update f s) = (tcb_ptr \ all_queued_tcb_ptrs s)" + unfolding all_queued_tcb_ptrs_def + by (clarsimp simp: obj_at'_def) + lemma no_orphans_update_simps[simp]: "no_orphans (gsCNodes_update f s) = no_orphans s" "no_orphans (gsUserPages_update g s) = no_orphans s" @@ -240,6 +243,12 @@ crunch no_orphans [wp]: removeFromBitmap "no_orphans" crunch almost_no_orphans [wp]: addToBitmap "almost_no_orphans x" crunch almost_no_orphans [wp]: removeFromBitmap "almost_no_orphans x" +lemma setCTE_tcbQueued[wp]: + "setCTE ptr v \\s. Q (obj_at' (\tcb. P (tcbQueued tcb)) t s)\" + apply (simp add: setCTE_def) + apply (rule setObject_cte_obj_at_tcb', simp_all) + done + lemma setCTE_no_orphans [wp]: "\ \s. no_orphans s \ setCTE p cte @@ -253,7 +262,7 @@ lemma setCTE_almost_no_orphans [wp]: setCTE p cte \ \rv s. almost_no_orphans tcb_ptr s \" unfolding almost_no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift setCTE_typ_at' setCTE_pred_tcb_at') + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift setCTE_typ_at' setCTE_pred_tcb_at') done crunch no_orphans [wp]: activateIdleThread "no_orphans" @@ -263,128 +272,131 @@ lemma asUser_no_orphans [wp]: asUser thread f \ \rv s. no_orphans s \" unfolding no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift) + done + +lemma threadSet_all_queued_tcb_ptrs: + "\tcb. tcbQueued (F tcb) = tcbQueued tcb \ threadSet F tptr \\s. P (t \ all_queued_tcb_ptrs s)\" + unfolding almost_no_orphans_disj all_queued_tcb_ptrs_def + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_st_tcb_at2 threadSet_wp) + apply (erule rsubst[where P=P]) + apply (clarsimp simp: obj_at'_def ps_clear_upd objBits_simps) + done + +crunches removeFromBitmap, addToBitmap, setQueue + for all_queued_tcb_ptrs[wp]: "\s. P (t \ all_queued_tcb_ptrs s)" + (wp: tcbQueued_all_queued_tcb_ptrs_lift) + +crunches tcbQueuePrepend, tcbQueueAppend + for all_queued_tcb_ptrs[wp]: "\s. P (t \ all_queued_tcb_ptrs s)" + (wp: threadSet_all_queued_tcb_ptrs ignore: threadSet) + +lemma tcbQueued_update_True_all_queued_tcb_ptrs[wp]: + "\\s. tcb_ptr \ tcb_ptr' \ tcb_ptr' \ all_queued_tcb_ptrs s\ + threadSet (tcbQueued_update (\_. True)) tcb_ptr + \\_ s. tcb_ptr' \ all_queued_tcb_ptrs s\" + apply (wpsimp wp: threadSet_wp) + apply (fastforce simp: all_queued_tcb_ptrs_def obj_at'_def ps_clear_upd objBits_simps) + done + +lemma tcbSchedEnqueue_all_queued_tcb_ptrs[wp]: + "\\s. tcb_ptr \ tcb_ptr' \ tcb_ptr \ all_queued_tcb_ptrs s\ + tcbSchedEnqueue tcb_ptr' + \\_ s. tcb_ptr \ all_queued_tcb_ptrs s\" + unfolding tcbSchedEnqueue_def tcbQueuePrepend_def + apply (wpsimp wp: hoare_vcg_imp_lift' threadGet_wp + | wpsimp wp: threadSet_all_queued_tcb_ptrs)+ + apply (clarsimp simp: all_queued_tcb_ptrs_def obj_at'_def) + done + +lemmas tcbSchedEnqueue_all_queued_tcb_ptrs'[wp] = + tcbSchedEnqueue_all_queued_tcb_ptrs[simplified all_queued_tcb_ptrs_def, simplified] + +lemma tcbSchedAppend_all_queued_tcb_ptrs[wp]: + "\\s. tcb_ptr \ tcb_ptr' \ tcb_ptr \ all_queued_tcb_ptrs s\ + tcbSchedAppend tcb_ptr' + \\_ s. tcb_ptr \ all_queued_tcb_ptrs s\" + unfolding tcbSchedAppend_def tcbQueueAppend_def + apply (wpsimp wp: hoare_vcg_imp_lift' threadGet_wp + | wpsimp wp: threadSet_all_queued_tcb_ptrs)+ + apply (clarsimp simp: all_queued_tcb_ptrs_def obj_at'_def) done +lemmas tcbSchedAppend_all_queued_tcb_ptrs'[wp] = + tcbSchedAppend_all_queued_tcb_ptrs[simplified all_queued_tcb_ptrs_def, simplified] + lemma threadSet_no_orphans: - "\tcb. \ is_active_thread_state (tcbState tcb) \ \ is_active_thread_state (tcbState (F tcb)) \ - \ \s. no_orphans s \ - threadSet F tptr - \ \rv s. no_orphans s \" + "\\tcb. \ is_active_thread_state (tcbState tcb) \ \ is_active_thread_state (tcbState (F tcb)); + \tcb. tcbQueued (F tcb) = tcbQueued tcb\ + \ threadSet F tptr \no_orphans\" unfolding no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_st_tcb_at2 | clarsimp)+ - done + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_st_tcb_at2) -lemma threadSet_almost_no_orphans: - "\tcb. \ is_active_thread_state (tcbState tcb) \ \ is_active_thread_state (tcbState (F tcb)) \ - \ \s. almost_no_orphans ptr s \ - threadSet F tptr - \ \rv s. almost_no_orphans ptr s \" - unfolding almost_no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_st_tcb_at2 | clarsimp)+ +lemma tcbQueued_update_True_no_orphans: + "\almost_no_orphans tptr and tcb_at' tptr\ + threadSet (tcbQueued_update (\_. True)) tptr + \\_. no_orphans\" + unfolding no_orphans_disj + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_st_tcb_at2) + apply (fastforce simp: almost_no_orphans_def all_active_tcb_ptrs_def + tcb_at_typ_at' st_tcb_at_neg' is_active_tcb_ptr_def) done -lemma setQueue_no_orphans_enq: - "\ \s. no_orphans s \ set (ksReadyQueues s (d, prio)) \ set qs \ - setQueue d prio qs - \ \_ s. no_orphans s \" - unfolding setQueue_def - apply wp - apply (clarsimp simp: no_orphans_def all_queued_tcb_ptrs_def - split: if_split_asm) +lemma tcbQueued_update_True_almost_no_orphans: + "threadSet (tcbQueued_update (\_. True)) tptr' \almost_no_orphans tptr\" + unfolding almost_no_orphans_disj + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift threadSet_st_tcb_at2) apply fastforce done -lemma setQueue_almost_no_orphans_enq: - "\ \s. almost_no_orphans tcb_ptr s \ set (ksReadyQueues s (d, prio)) \ set qs \ tcb_ptr \ set qs \ - setQueue d prio qs - \ \_ s. no_orphans s \" +lemma threadSet_almost_no_orphans: + "\\tcb. \ is_active_thread_state (tcbState tcb) \ \ is_active_thread_state (tcbState (F tcb)); + \tcb. tcbQueued (F tcb) = tcbQueued tcb\ + \ threadSet F tptr \almost_no_orphans ptr\" + unfolding almost_no_orphans_disj all_queued_tcb_ptrs_def + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_st_tcb_at2) + +lemma setQueue_no_orphans[wp]: + "setQueue d prio qs \no_orphans\" unfolding setQueue_def apply wp - apply (clarsimp simp: no_orphans_def almost_no_orphans_def all_queued_tcb_ptrs_def - split: if_split_asm) - apply fastforce + apply (clarsimp simp: no_orphans_def) done -lemma setQueue_almost_no_orphans_enq_lift: - "\ \s. almost_no_orphans tcb_ptr s \ set (ksReadyQueues s (d, prio)) \ set qs \ - setQueue d prio qs - \ \_ s. almost_no_orphans tcb_ptr s \" +lemma setQueue_almost_no_orphans[wp]: + "setQueue d prio qs \almost_no_orphans tptr\" unfolding setQueue_def apply wp - apply (clarsimp simp: almost_no_orphans_def all_queued_tcb_ptrs_def - split: if_split_asm) - apply fastforce + apply (clarsimp simp: almost_no_orphans_def) done lemma tcbSchedEnqueue_no_orphans[wp]: - "\ \s. no_orphans s \ - tcbSchedEnqueue tcb_ptr - \ \rv s. no_orphans s \" - unfolding tcbSchedEnqueue_def - apply (wp setQueue_no_orphans_enq threadSet_no_orphans | clarsimp simp: unless_def)+ - apply (wp getObject_tcb_wp | clarsimp simp: threadGet_def)+ - apply (drule obj_at_ko_at') - apply auto + "tcbSchedEnqueue tcb_ptr \no_orphans\" + unfolding tcbSchedEnqueue_def tcbQueuePrepend_def + apply (wpsimp wp: tcbQueued_update_True_no_orphans threadSet_almost_no_orphans threadGet_wp) + apply (fastforce simp: no_orphans_strg_almost) done lemma tcbSchedAppend_no_orphans[wp]: - "\ \s. no_orphans s \ - tcbSchedAppend tcb_ptr - \ \rv s. no_orphans s \" - unfolding tcbSchedAppend_def - apply (wp setQueue_no_orphans_enq threadSet_no_orphans | clarsimp simp: unless_def)+ - apply (wp getObject_tcb_wp | clarsimp simp: threadGet_def)+ - apply (drule obj_at_ko_at') - apply auto - done - -lemma ko_at_obj_at': - "ko_at' ko p s \ P ko \ obj_at' P p s" - unfolding obj_at'_def - apply clarsimp - done - -lemma queued_in_queue: - "\valid_queues' s; ko_at' tcb tcb_ptr s; tcbQueued tcb\ \ - \ p. tcb_ptr \ set (ksReadyQueues s p)" - unfolding valid_queues'_def - apply (drule_tac x="tcbDomain tcb" in spec) - apply (drule_tac x="tcbPriority tcb" in spec) - apply (drule_tac x="tcb_ptr" in spec) - apply (drule mp) - apply (rule ko_at_obj_at') - apply (auto simp: inQ_def) + "tcbSchedAppend tcb_ptr \no_orphans\" + unfolding tcbSchedAppend_def tcbQueueAppend_def + apply (wpsimp wp: tcbQueued_update_True_no_orphans threadSet_almost_no_orphans threadGet_wp) + apply (fastforce simp: no_orphans_strg_almost) done lemma tcbSchedEnqueue_almost_no_orphans: - "\ \s. almost_no_orphans tcb_ptr s \ valid_queues' s \ + "\almost_no_orphans tcb_ptr\ tcbSchedEnqueue tcb_ptr - \ \rv s. no_orphans s \" - unfolding tcbSchedEnqueue_def - apply simp - apply (wp setQueue_almost_no_orphans_enq[where tcb_ptr=tcb_ptr] threadSet_no_orphans - | clarsimp)+ - apply (wp getObject_tcb_wp | clarsimp simp: threadGet_def)+ - apply normalise_obj_at' - apply (rule_tac x=ko in exI) - apply (clarsimp simp: subset_insertI) - apply (unfold no_orphans_def almost_no_orphans_def) - apply clarsimp - apply (drule(2) queued_in_queue) - apply (fastforce simp: all_queued_tcb_ptrs_def) + \\_. no_orphans\" + unfolding tcbSchedEnqueue_def tcbQueuePrepend_def + apply (wpsimp wp: tcbQueued_update_True_no_orphans threadSet_almost_no_orphans threadGet_wp) + apply (fastforce simp: no_orphans_def almost_no_orphans_def all_queued_tcb_ptrs_def obj_at'_def) done lemma tcbSchedEnqueue_almost_no_orphans_lift: - "\ \s. almost_no_orphans ptr s \ - tcbSchedEnqueue tcb_ptr - \ \rv s. almost_no_orphans ptr s \" - unfolding tcbSchedEnqueue_def - apply (wp setQueue_almost_no_orphans_enq_lift threadSet_almost_no_orphans | clarsimp simp: unless_def)+ - apply (wp getObject_tcb_wp | clarsimp simp: threadGet_def)+ - apply (drule obj_at_ko_at') - apply auto - done + "tcbSchedEnqueue tcb_ptr \almost_no_orphans ptr\" + unfolding tcbSchedEnqueue_def tcbQueuePrepend_def + by (wpsimp wp: tcbQueued_update_True_almost_no_orphans threadSet_almost_no_orphans) lemma ssa_no_orphans: "\ \s. no_orphans s \ @@ -416,124 +428,70 @@ lemma ssa_almost_no_orphans_lift [wp]: apply auto done -lemma tcbSchedEnqueue_inQueue [wp]: - "\ \s. valid_queues' s \ - tcbSchedEnqueue tcb_ptr - \ \rv s. tcb_ptr \ all_queued_tcb_ptrs s \" - unfolding tcbSchedEnqueue_def all_queued_tcb_ptrs_def - apply (wp | clarsimp simp: unless_def)+ - apply (rule_tac Q="\rv. \" in hoare_post_imp) - apply fastforce - apply (wp getObject_tcb_wp | clarsimp simp: threadGet_def)+ - apply (fastforce simp: obj_at'_def valid_queues'_def inQ_def) - done - -lemma tcbSchedAppend_inQueue [wp]: - "\ \s. valid_queues' s \ - tcbSchedAppend tcb_ptr - \ \rv s. tcb_ptr \ all_queued_tcb_ptrs s \" - unfolding tcbSchedAppend_def all_queued_tcb_ptrs_def - apply (wp | clarsimp simp: unless_def)+ - apply (rule_tac Q="\rv. \" in hoare_post_imp) - apply fastforce - apply (wp getObject_tcb_wp | clarsimp simp: threadGet_def)+ - apply (fastforce simp: obj_at'_def valid_queues'_def inQ_def) - done - lemma rescheduleRequired_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ - rescheduleRequired - \ \rv s. no_orphans s \" + "rescheduleRequired \no_orphans\" unfolding rescheduleRequired_def - apply (wp tcbSchedEnqueue_no_orphans hoare_vcg_all_lift ssa_no_orphans | wpc | clarsimp)+ - apply (wps tcbSchedEnqueue_nosch, wp hoare_weak_lift_imp) - apply (rename_tac word t p) - apply (rule_tac P="word = t" in hoare_gen_asm) - apply (wp hoare_disjI1 | clarsimp)+ - done + by (wpsimp wp: ssa_no_orphans hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift | wpc)+ lemma rescheduleRequired_almost_no_orphans [wp]: - "\ \s. almost_no_orphans tcb_ptr s \ valid_queues' s \ - rescheduleRequired - \ \rv s. almost_no_orphans tcb_ptr s \" + "rescheduleRequired \almost_no_orphans tcb_ptr\" unfolding rescheduleRequired_def - apply (wp tcbSchedEnqueue_almost_no_orphans_lift hoare_vcg_all_lift | wpc | clarsimp)+ - apply (wps tcbSchedEnqueue_nosch, wp hoare_weak_lift_imp) - apply (rename_tac word t p) - apply (rule_tac P="word = t" in hoare_gen_asm) - apply (wp hoare_disjI1 | clarsimp)+ - done + by (wpsimp wp: ssa_almost_no_orphans_lift hoare_vcg_all_lift tcbSchedEnqueue_almost_no_orphans_lift + hoare_vcg_imp_lift' hoare_vcg_disj_lift) lemma setThreadState_current_no_orphans: - "\ \s. no_orphans s \ ksCurThread s = tcb_ptr \ valid_queues' s \ + "\\s. no_orphans s \ ksCurThread s = tcb_ptr\ setThreadState state tcb_ptr - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding setThreadState_def - apply (wp | clarsimp)+ - apply (rule_tac Q="\rv s. valid_queues' s \ no_orphans s" in hoare_post_imp) - apply clarsimp - apply (wp threadSet_valid_queues') - apply (unfold no_orphans_disj all_queued_tcb_ptrs_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state) - apply (auto simp: inQ_def) + apply wpsimp + unfolding no_orphans_disj + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state + threadSet_all_queued_tcb_ptrs + | fastforce)+ done lemma setThreadState_isRestart_no_orphans: - "\ \s. no_orphans s \ st_tcb_at' isRestart tcb_ptr s \ valid_queues' s\ + "\no_orphans and st_tcb_at' isRestart tcb_ptr\ setThreadState state tcb_ptr - \ \rv s. no_orphans s \" + \\_ . no_orphans\" unfolding setThreadState_def - apply (wp | clarsimp)+ - apply (rule_tac Q="\rv s. valid_queues' s \ no_orphans s" in hoare_post_imp) - apply clarsimp - apply (wp threadSet_valid_queues') - apply (unfold no_orphans_disj all_queued_tcb_ptrs_def is_active_thread_state_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state) - apply (auto simp: st_tcb_at_double_neg' st_tcb_at_neg' inQ_def) + apply wpsimp + unfolding no_orphans_disj + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state + threadSet_all_queued_tcb_ptrs + | fastforce)+ + apply (auto simp: is_active_thread_state_def st_tcb_at_double_neg' st_tcb_at_neg') done lemma setThreadState_almost_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s\ - setThreadState state tcb_ptr - \ \rv s. almost_no_orphans tcb_ptr s \" + "\no_orphans\ setThreadState state tcb_ptr \\_. almost_no_orphans tcb_ptr\" unfolding setThreadState_def - apply (wp | clarsimp)+ - apply (rule_tac Q="\rv s. valid_queues' s \ almost_no_orphans tcb_ptr s" in hoare_post_imp) - apply clarsimp - apply (wp threadSet_valid_queues') - apply (unfold no_orphans_disj almost_no_orphans_disj all_queued_tcb_ptrs_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state) - apply (auto simp: inQ_def) + apply wpsimp + apply (unfold no_orphans_disj almost_no_orphans_disj) + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state + threadSet_all_queued_tcb_ptrs + | fastforce)+ done lemma setThreadState_not_active_no_orphans: - "\ is_active_thread_state state \ - \ \s. no_orphans s \ valid_queues' s \ - setThreadState state tcb_ptr - \ \rv s. no_orphans s \" + "\ is_active_thread_state state \ setThreadState state tcb_ptr \no_orphans\" unfolding setThreadState_def - apply (wp | clarsimp)+ - apply (rule_tac Q="\rv s. valid_queues' s \ no_orphans s" in hoare_post_imp) - apply clarsimp - apply (wp threadSet_valid_queues') - apply (unfold no_orphans_disj all_queued_tcb_ptrs_def is_active_thread_state_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state) - apply (auto simp: isRunning_def isRestart_def inQ_def) + apply wpsimp + apply (unfold no_orphans_disj) + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state + threadSet_all_queued_tcb_ptrs + | fastforce)+ done lemma setThreadState_not_active_almost_no_orphans: - "\ is_active_thread_state state \ - \ \s. almost_no_orphans thread s \ valid_queues' s \ - setThreadState state tcb_ptr - \ \rv s. almost_no_orphans thread s \" + "\ is_active_thread_state state \ setThreadState state tcb_ptr \almost_no_orphans thread\" unfolding setThreadState_def - apply (wp | clarsimp)+ - apply (rule_tac Q="\rv s. valid_queues' s \ almost_no_orphans thread s" in hoare_post_imp) - apply clarsimp - apply (wp threadSet_valid_queues') - apply (unfold almost_no_orphans_disj all_queued_tcb_ptrs_def is_active_thread_state_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state) - apply (auto simp: isRunning_def isRestart_def inQ_def) + apply wpsimp + apply (unfold almost_no_orphans_disj) + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state + threadSet_all_queued_tcb_ptrs + | fastforce)+ done lemma activateThread_no_orphans [wp]: @@ -545,60 +503,75 @@ lemma activateThread_no_orphans [wp]: apply (auto simp: ct_in_state'_def pred_tcb_at'_def obj_at'_def isRestart_def) done -lemma setQueue_no_orphans_deq: - "\ \s. \ tcb_ptr. no_orphans s \ \ is_active_tcb_ptr tcb_ptr s \ - queue = [x\((ksReadyQueues s) (d, priority)). x \ tcb_ptr] \ - setQueue d priority queue - \ \rv s. no_orphans s \" - unfolding setQueue_def - apply (wp | clarsimp)+ - apply (fastforce simp: no_orphans_def all_queued_tcb_ptrs_def - all_active_tcb_ptrs_def is_active_tcb_ptr_def) +crunches removeFromBitmap, tcbQueueRemove, setQueue + for almost_no_orphans[wp]: "almost_no_orphans thread" + and no_orphans[wp]: no_orphans + and all_queued_tcb_ptrs[wp]: "\s. tcb_ptr \ all_queued_tcb_ptrs s" + (wp: crunch_wps) + +lemma tcbQueued_update_False_all_queued_tcb_ptrs: + "\\s. tcb_ptr \ tcb_ptr' \ tcb_ptr' \ all_queued_tcb_ptrs s\ + threadSet (tcbQueued_update (\_. False)) tcb_ptr + \\_ s. tcb_ptr' \ all_queued_tcb_ptrs s\" + apply (wpsimp wp: threadSet_wp) + apply (clarsimp simp: all_queued_tcb_ptrs_def obj_at'_def ps_clear_upd) done -lemma setQueue_almost_no_orphans_deq [wp]: - "\ \s. almost_no_orphans tcb_ptr s \ - queue = [x\((ksReadyQueues s) (d, priority)). x \ tcb_ptr] \ - setQueue d priority queue - \ \rv s. almost_no_orphans tcb_ptr s \" - unfolding setQueue_def - apply (wp | clarsimp)+ - apply (fastforce simp: almost_no_orphans_def all_queued_tcb_ptrs_def - all_active_tcb_ptrs_def is_active_tcb_ptr_def) +lemma tcbSchedDequeue_all_queued_tcb_ptrs_other: + "\\s. tcb_ptr \ tcb_ptr' \ tcb_ptr' \ all_queued_tcb_ptrs s\ + tcbSchedDequeue tcb_ptr + \\_ s. tcb_ptr' \ all_queued_tcb_ptrs s\" + unfolding tcbSchedDequeue_def + by (wpsimp wp: tcbQueued_update_False_all_queued_tcb_ptrs threadGet_wp) + +lemma tcbQueued_update_False_almost_no_orphans: + "\no_orphans\ + threadSet (tcbQueued_update (\_. False)) tptr + \\_. almost_no_orphans tptr\" + apply (wpsimp wp: threadSet_wp) + apply (clarsimp simp: no_orphans_def almost_no_orphans_def) + apply (rename_tac tcb_ptr) + apply (case_tac "tcb_ptr = tptr") + apply fastforce + apply (fastforce simp: all_queued_tcb_ptrs_def obj_at'_def all_active_tcb_ptrs_def + is_active_tcb_ptr_def st_tcb_at'_def ps_clear_upd) done lemma tcbSchedDequeue_almost_no_orphans [wp]: - "\ \s. no_orphans s \ - tcbSchedDequeue thread - \ \rv s. almost_no_orphans thread s \" + "\no_orphans\ tcbSchedDequeue thread \\_. almost_no_orphans thread\" unfolding tcbSchedDequeue_def - apply (wp threadSet_almost_no_orphans | simp cong: if_cong)+ - apply (simp add:no_orphans_strg_almost cong: if_cong) + apply (wpsimp wp: tcbQueued_update_False_almost_no_orphans threadGet_wp) + apply (simp add: no_orphans_strg_almost) done -lemma tcbSchedDequeue_no_orphans [wp]: - "\ \s. no_orphans s \ \ is_active_tcb_ptr tcb_ptr s \ - tcbSchedDequeue tcb_ptr - \ \rv s. no_orphans s \" - unfolding tcbSchedDequeue_def - apply (wp setQueue_no_orphans_deq threadSet_no_orphans | clarsimp)+ - apply (wp getObject_tcb_wp | clarsimp simp: threadGet_def)+ - apply (drule obj_at_ko_at') - apply auto +lemma tcbSchedDequeue_no_orphans[wp]: + "\\s. no_orphans s \ \ is_active_tcb_ptr tcbPtr s \ tcb_at' tcbPtr s\ + tcbSchedDequeue tcbPtr + \\_. no_orphans\" + supply disj_not1[simp del] + unfolding no_orphans_disj almost_no_orphans_disj + apply (rule hoare_allI) + apply (rename_tac tcb_ptr) + apply (case_tac "tcb_ptr = tcbPtr") + apply (rule_tac Q="\_ s. st_tcb_at' (\state. \ is_active_thread_state state) tcbPtr s" + in hoare_post_imp) + apply fastforce + apply wpsimp + apply (clarsimp simp: st_tcb_at'_def obj_at'_def is_active_tcb_ptr_def disj_not1) + apply (wpsimp wp: tcbQueued_update_False_all_queued_tcb_ptrs hoare_vcg_disj_lift + simp: tcbSchedDequeue_def) done lemma switchToIdleThread_no_orphans' [wp]: - "\ \s. no_orphans s \ - (is_active_tcb_ptr (ksCurThread s) s - \ ksCurThread s \ all_queued_tcb_ptrs s) \ + "\\s. no_orphans s + \ (is_active_tcb_ptr (ksCurThread s) s \ ksCurThread s \ all_queued_tcb_ptrs s)\ switchToIdleThread - \ \rv s. no_orphans s \" - unfolding switchToIdleThread_def setCurThread_def AARCH64_H.switchToIdleThread_def + \\_. no_orphans\" + apply (clarsimp simp: switchToIdleThread_def setCurThread_def AARCH64_H.switchToIdleThread_def) apply (simp add: no_orphans_disj all_queued_tcb_ptrs_def) - apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift hoare_vcg_disj_lift - | clarsimp)+ - apply (auto simp: no_orphans_disj all_queued_tcb_ptrs_def is_active_tcb_ptr_def - st_tcb_at_neg' tcb_at_typ_at') + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift + hoare_drop_imp[where R="\_. idleThreadNotQueued"] hoare_vcg_imp_lift') + apply (force simp: is_active_tcb_ptr_def st_tcb_at_neg' typ_at_tcb') done crunches getVMID, Arch.switchToThread @@ -610,14 +583,33 @@ crunches updateASIDPoolEntry, Arch.switchToThread for no_orphans[wp]: "no_orphans" (wp: no_orphans_lift crunch_wps) -lemma ArchThreadDecls_H_switchToThread_all_queued_tcb_ptrs [wp]: - "\ \s. P (all_queued_tcb_ptrs s) \ - Arch.switchToThread tcb_ptr - \ \rv s. P (all_queued_tcb_ptrs s) \" - unfolding AARCH64_H.switchToThread_def all_queued_tcb_ptrs_def - apply (wp | clarsimp)+ +lemma all_queued_tcb_ptrs_machine_state[simp]: + "all_queued_tcb_ptrs (s\ksMachineState := m\) = all_queued_tcb_ptrs s" + by (simp add: all_queued_tcb_ptrs_def) + +lemma all_queued_tcb_ptrs_arch_state[simp]: + "all_queued_tcb_ptrs (s\ksArchState := as\) = all_queued_tcb_ptrs s" + by (simp add: all_queued_tcb_ptrs_def) + +lemma setObject_vcpu_all_queued_tcb_ptrs[wp]: + "setObject ptr (vcpu::vcpu) \\s. P (t \ all_queued_tcb_ptrs s)\" + apply (simp add: all_queued_tcb_ptrs_def) + apply (rule setObject_vcpu_obj_at'_no_vcpu) + done + +lemma setASID_all_queued_tcb_ptrs[wp]: + "setObject ptr (ap::asidpool) \\s. P (t \ all_queued_tcb_ptrs s)\" + apply (simp add: all_queued_tcb_ptrs_def obj_at'_real_def) + apply (wpsimp wp: setObject_ko_wp_at simp: objBits_simps) + apply (simp add: pageBits_def) + apply simp + apply (clarsimp simp: obj_at'_def ko_wp_at'_def) done +crunches Arch.switchToThread + for all_queued_tcb_ptrs[wp]: "\s. P (t \ all_queued_tcb_ptrs s)" + (wp: getASID_wp crunch_wps simp: crunch_simps) + crunch ksSchedulerAction [wp]: "Arch.switchToThread" "\s. P (ksSchedulerAction s)" lemma setCurThread_no_orphans [wp]: @@ -632,22 +624,6 @@ lemma setCurThread_no_orphans [wp]: apply auto done -lemma tcbSchedDequeue_all_queued_tcb_ptrs: - "\\s. x \ all_queued_tcb_ptrs s \ x \ t \ - tcbSchedDequeue t \\_ s. x \ all_queued_tcb_ptrs s\" - apply (rule_tac Q="(\s. x \ all_queued_tcb_ptrs s) and K (x \ t)" - in hoare_pre_imp, clarsimp) - apply (rule hoare_gen_asm) - apply (clarsimp simp: tcbSchedDequeue_def all_queued_tcb_ptrs_def) - apply (rule hoare_pre) - apply (wp, clarsimp) - apply (wp hoare_vcg_ex_lift)+ - apply (rename_tac d p) - apply (rule_tac Q="\_ s. x \ set (ksReadyQueues s (d, p))" - in hoare_post_imp, clarsimp) - apply (wp hoare_vcg_all_lift | simp)+ - done - lemma tcbSchedDequeue_all_active_tcb_ptrs[wp]: "\\s. P (t' \ all_active_tcb_ptrs s)\ tcbSchedDequeue t \\_ s. P (t' \ all_active_tcb_ptrs s)\" by (clarsimp simp: all_active_tcb_ptrs_def is_active_tcb_ptr_def) wp @@ -670,9 +646,6 @@ lemma setCurThread_almost_no_orphans: lemmas ArchThreadDecls_H_switchToThread_all_active_tcb_ptrs[wp] = st_tcb_at'_all_active_tcb_ptrs_lift [OF Arch_switchToThread_pred_tcb'] -lemmas ArchThreadDecls_H_switchToThread_all_queued_tcb_ptrs_lift[wp] = - ksQ_all_queued_tcb_ptrs_lift [OF ArchThreadDecls_H_AARCH64_H_switchToThread_ksQ] - lemma ThreadDecls_H_switchToThread_no_orphans: "\ \s. no_orphans s \ st_tcb_at' runnable' tcb_ptr s \ @@ -681,16 +654,9 @@ lemma ThreadDecls_H_switchToThread_no_orphans: ThreadDecls_H.switchToThread tcb_ptr \ \rv s. no_orphans s \" unfolding Thread_H.switchToThread_def - apply (wp setCurThread_almost_no_orphans - tcbSchedDequeue_almost_no_orphans) - apply (wps tcbSchedDequeue_ct') - apply (wp tcbSchedDequeue_all_queued_tcb_ptrs hoare_convert_imp)+ - apply (wps) - apply (wp)+ - apply (wps) - apply (wp) - apply (clarsimp) - done + by (wpsimp wp: setCurThread_almost_no_orphans hoare_vcg_imp_lift' + tcbSchedDequeue_all_queued_tcb_ptrs_other + | wps)+ lemma findM_failure': "\ \x S. \ \s. P S s \ f x \ \rv s. \ rv \ P (insert x S) s \ \ \ @@ -708,22 +674,6 @@ lemma findM_failure': lemmas findM_failure = findM_failure'[where S="{}", simplified] -lemma tcbSchedEnqueue_inQueue_eq: - "\ valid_queues' and K (tcb_ptr = tcb_ptr') \ - tcbSchedEnqueue tcb_ptr - \ \rv s. tcb_ptr' \ all_queued_tcb_ptrs s \" - apply (rule hoare_gen_asm, simp) - apply wp - done - -lemma tcbSchedAppend_inQueue_eq: - "\ valid_queues' and K (tcb_ptr = tcb_ptr') \ - tcbSchedAppend tcb_ptr - \ \rv s. tcb_ptr' \ all_queued_tcb_ptrs s \" - apply (rule hoare_gen_asm, simp) - apply wp - done - lemma findM_on_success: "\ \x. \ P x \ f x \ \rv s. rv \; \x y. \ P x \ f y \ \rv. P x \ \ \ \ \s. \x \ set xs. P x s \ findM f xs \ \rv s. \ y. rv = Some y \" @@ -735,66 +685,32 @@ lemma findM_on_success: crunch st_tcb' [wp]: switchToThread "\s. P' (st_tcb_at' P t s)" -lemma setQueue_deq_not_empty: - "\ \s. (\tcb. tcb \ set (ksReadyQueues s p) \ st_tcb_at' P tcb s) \ - (\tcb_ptr. \ st_tcb_at' P tcb_ptr s \ - queue = [x\((ksReadyQueues s) (d, priority)). x \ tcb_ptr]) \ - setQueue d priority queue - \ \rv s. \tcb. tcb \ set (ksReadyQueues s p) \ st_tcb_at' P tcb s \" - unfolding setQueue_def - apply wp - apply auto - done - -lemma tcbSchedDequeue_not_empty: - "\ \s. (\tcb. tcb \ set (ksReadyQueues s p) \ st_tcb_at' P tcb s) \ \ st_tcb_at' P thread s \ - tcbSchedDequeue thread - \ \rv s. \tcb. tcb \ set (ksReadyQueues s p) \ st_tcb_at' P tcb s \" - unfolding tcbSchedDequeue_def - apply wp - apply (wp hoare_vcg_ex_lift threadSet_pred_tcb_no_state) - apply clarsimp - apply (wp setQueue_deq_not_empty) - apply clarsimp - apply (rule hoare_pre_post, assumption) - apply (clarsimp simp: bitmap_fun_defs) - apply wp - apply clarsimp - apply clarsimp - apply (wp setQueue_deq_not_empty)+ - apply (rule_tac Q="\rv s. \ st_tcb_at' P thread s" in hoare_post_imp) - apply fastforce - apply (wp weak_if_wp | clarsimp)+ - done - lemmas switchToThread_all_active_tcb_ptrs[wp] = st_tcb_at'_all_active_tcb_ptrs_lift [OF switchToThread_st_tcb'] (* ksSchedulerAction s = ChooseNewThread *) lemma chooseThread_no_orphans [wp]: - notes hoare_TrueI[simp] - shows - "\\s. no_orphans s \ all_invs_but_ct_idle_or_in_cur_domain' s \ - (is_active_tcb_ptr (ksCurThread s) s - \ ksCurThread s \ all_queued_tcb_ptrs s)\ + "\\s. no_orphans s \ all_invs_but_ct_idle_or_in_cur_domain' s + \ (is_active_tcb_ptr (ksCurThread s) s \ ksCurThread s \ all_queued_tcb_ptrs s)\ chooseThread - \ \rv s. no_orphans s \" + \\_. no_orphans\" (is "\?PRE\ _ \_\") unfolding chooseThread_def Let_def supply if_split[split del] apply (simp only: return_bind, simp) - apply (rule hoare_seq_ext[where B="\rv s. ?PRE s \ rv = ksCurDomain s"]) - apply (rule_tac B="\rv s. ?PRE s \ curdom = ksCurDomain s \ - rv = ksReadyQueuesL1Bitmap s curdom" in hoare_seq_ext) + apply (intro hoare_seq_ext[OF _ stateAssert_sp]) + apply (rule hoare_seq_ext[where B="\rv s. ?PRE s \ ksReadyQueues_asrt s \ ready_qs_runnable s + \ rv = ksCurDomain s"]) + apply (rule_tac B="\rv s. ?PRE s \ ksReadyQueues_asrt s \ ready_qs_runnable s + \ curdom = ksCurDomain s \ rv = ksReadyQueuesL1Bitmap s curdom" + in hoare_seq_ext) apply (rename_tac l1) apply (case_tac "l1 = 0") (* switch to idle thread *) apply (simp, wp, simp) (* we have a thread to switch to *) - apply (clarsimp simp: bitmap_fun_defs) apply (wp assert_inv ThreadDecls_H_switchToThread_no_orphans) - apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def - valid_queues_def st_tcb_at'_def) + apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def st_tcb_at'_def) apply (fastforce dest!: lookupBitmapPriority_obj_at' elim: obj_at'_weaken simp: all_active_tcb_ptrs_def) apply (wpsimp simp: bitmap_fun_defs) @@ -802,42 +718,6 @@ lemma chooseThread_no_orphans [wp]: apply (wpsimp simp: curDomain_def simp: invs_no_cicd_ksCurDomain_maxDomain')+ done -lemma valid_queues'_ko_atD: - "valid_queues' s \ ko_at' tcb t s \ tcbQueued tcb - \ t \ set (ksReadyQueues s (tcbDomain tcb, tcbPriority tcb))" - apply (simp add: valid_queues'_def) - apply (elim allE, erule mp) - apply normalise_obj_at' - apply (simp add: inQ_def) - done - -lemma tcbSchedAppend_in_ksQ: - "\valid_queues' and tcb_at' t\ tcbSchedAppend t - \\r s. \domain priority. t \ set (ksReadyQueues s (domain, priority))\" - apply (rule_tac Q="\s. \d p. valid_queues' s \ - obj_at' (\tcb. tcbPriority tcb = p) t s \ - obj_at' (\tcb. tcbDomain tcb = d) t s" - in hoare_pre_imp) - apply (clarsimp simp: tcb_at'_has_tcbPriority tcb_at'_has_tcbDomain) - apply (rule hoare_vcg_ex_lift)+ - apply (simp add: tcbSchedAppend_def unless_def) - apply wpsimp - apply (rule_tac Q="\rv s. tdom = d \ rv = p \ obj_at' (\tcb. tcbPriority tcb = p) t s - \ obj_at' (\tcb. tcbDomain tcb = d) t s" - in hoare_post_imp, clarsimp) - apply (wp, (wp threadGet_const)+) - apply (rule_tac Q="\rv s. - obj_at' (\tcb. tcbPriority tcb = p) t s \ - obj_at' (\tcb. tcbDomain tcb = d) t s \ - obj_at' (\tcb. tcbQueued tcb = rv) t s \ - (rv \ t \ set (ksReadyQueues s (d, p)))" in hoare_post_imp) - apply (clarsimp simp: o_def elim!: obj_at'_weakenE) - apply (wp threadGet_obj_at' hoare_vcg_imp_lift threadGet_const) - apply clarsimp - apply normalise_obj_at' - apply (drule(1) valid_queues'_ko_atD, simp+) - done - lemma hoare_neg_imps: "\P\ f \\ rv s. \ R rv s\ \ \P\ f \\r s. R r s \ Q r s\" by (auto simp: valid_def) @@ -861,7 +741,7 @@ lemma ThreadDecls_H_switchToThread_ct [wp]: crunch no_orphans [wp]: nextDomain no_orphans (wp: no_orphans_lift simp: Let_def) -crunch ksQ [wp]: nextDomain "\s. P (ksReadyQueues s p)" +crunch tcbQueued[wp]: nextDomain "\s. Q (obj_at' (\tcb. P (tcbQueued tcb)) tcb_ptr s)" (simp: Let_def) crunch st_tcb_at' [wp]: nextDomain "\s. P (st_tcb_at' P' p s)" @@ -873,41 +753,6 @@ crunch ct' [wp]: nextDomain "\s. P (ksCurThread s)" crunch sch_act_not [wp]: nextDomain "sch_act_not t" (simp: Let_def) -lemma tcbSchedEnqueue_in_ksQ: - "\valid_queues' and tcb_at' t\ tcbSchedEnqueue t - \\r s. \domain priority. t \ set (ksReadyQueues s (domain, priority))\" - apply (rule_tac Q="\s. \d p. valid_queues' s \ - obj_at' (\tcb. tcbPriority tcb = p) t s \ - obj_at' (\tcb. tcbDomain tcb = d) t s" - in hoare_pre_imp) - apply (clarsimp simp: tcb_at'_has_tcbPriority tcb_at'_has_tcbDomain) - apply (rule hoare_vcg_ex_lift)+ - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wpsimp simp: if_apply_def2) - apply (rule_tac Q="\rv s. tdom = d \ rv = p \ obj_at' (\tcb. tcbPriority tcb = p) t s - \ obj_at' (\tcb. tcbDomain tcb = d) t s" - in hoare_post_imp, clarsimp) - apply (wp, (wp threadGet_const)+) - apply (rule_tac Q="\rv s. - obj_at' (\tcb. tcbPriority tcb = p) t s \ - obj_at' (\tcb. tcbDomain tcb = d) t s \ - obj_at' (\tcb. tcbQueued tcb = rv) t s \ - (rv \ t \ set (ksReadyQueues s (d, p)))" in hoare_post_imp) - apply (clarsimp simp: o_def elim!: obj_at'_weakenE) - apply (wp threadGet_obj_at' hoare_vcg_imp_lift threadGet_const) - apply clarsimp - apply normalise_obj_at' - apply (frule(1) valid_queues'_ko_atD, simp+) - done - -lemma tcbSchedEnqueue_in_ksQ': - "\valid_queues' and tcb_at' t and K (t = t')\ - tcbSchedEnqueue t' - \\r s. \domain priority. t \ set (ksReadyQueues s (domain, priority))\" - apply (rule hoare_gen_asm) - apply (wp tcbSchedEnqueue_in_ksQ | clarsimp)+ - done - lemma all_invs_but_ct_idle_or_in_cur_domain'_strg: "invs' s \ all_invs_but_ct_idle_or_in_cur_domain' s" by (clarsimp simp: invs'_to_invs_no_cicd'_def) @@ -916,67 +761,6 @@ lemma setSchedulerAction_cnt_sch_act_not[wp]: "\ \ \ setSchedulerAction ChooseNewThread \\rv s. sch_act_not x s\" by (rule hoare_pre, rule hoare_strengthen_post[OF setSchedulerAction_direct]) auto -lemma tcbSchedEnqueue_in_ksQ_aqtp[wp]: - "\valid_queues' and tcb_at' t\ tcbSchedEnqueue t - \\r s. t \ all_queued_tcb_ptrs s\" - apply (clarsimp simp: all_queued_tcb_ptrs_def) - apply (rule tcbSchedEnqueue_in_ksQ) - done - -lemma tcbSchedEnqueue_in_ksQ_already_queued: - "\\s. valid_queues' s \ tcb_at' t s \ - (\domain priority. t' \ set (ksReadyQueues s (domain, priority))) \ - tcbSchedEnqueue t - \\r s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))\" - apply (case_tac "t'=t", wpsimp wp: tcbSchedEnqueue_in_ksQ) - apply (wpsimp simp: tcbSchedEnqueue_def unless_def) - apply (rule_tac Q="\_ s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))" - in hoare_post_imp) - apply metis - apply wpsimp+ - done - -lemma tcbSchedAppend_in_ksQ_already_queued: - "\\s. valid_queues' s \ tcb_at' t s \ - (\domain priority. t' \ set (ksReadyQueues s (domain, priority))) \ - tcbSchedAppend t - \\r s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))\" - apply (case_tac "t'=t", wpsimp wp: tcbSchedAppend_in_ksQ) - apply (wpsimp simp: tcbSchedAppend_def unless_def) - apply (rule_tac Q="\_ s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))" - in hoare_post_imp) - apply metis - apply wpsimp+ - done - -lemma tcbSchedEnqueue_in_ksQ'': - "\\s. valid_queues' s \ tcb_at' t s \ - (t' \ t \ (\domain priority. t' \ set (ksReadyQueues s (domain, priority)))) \ - tcbSchedEnqueue t - \\r s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))\" - apply (case_tac "t'=t", wpsimp wp: tcbSchedEnqueue_in_ksQ) - apply clarsimp - apply (wpsimp simp: tcbSchedEnqueue_def unless_def) - apply (rule_tac Q="\_ s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))" - in hoare_post_imp) - apply metis - apply wpsimp+ - done - -lemma tcbSchedAppend_in_ksQ'': - "\\s. valid_queues' s \ tcb_at' t s \ - (t' \ t \ (\domain priority. t' \ set (ksReadyQueues s (domain, priority)))) \ - tcbSchedAppend t - \\r s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))\" - apply (case_tac "t'=t", wpsimp wp: tcbSchedAppend_in_ksQ) - apply clarsimp - apply (wpsimp simp: tcbSchedAppend_def unless_def) - apply (rule_tac Q="\_ s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))" - in hoare_post_imp) - apply metis - apply wpsimp+ - done - crunches setSchedulerAction for pred_tcb_at': "\s. P (pred_tcb_at' proj Q t s)" and ct': "\s. P (ksCurThread s)" @@ -995,12 +779,6 @@ lemma ct_active_st_tcb_at': apply (case_tac st, auto) done -lemma tcbSchedEnqueue_in_ksQ_already_queued_aqtp: - "\\s. valid_queues' s \ tcb_at' t s \ - t' \ all_queued_tcb_ptrs s \ tcbSchedEnqueue t - \\r s. t' \ all_queued_tcb_ptrs s \" - by (clarsimp simp: all_queued_tcb_ptrs_def tcbSchedEnqueue_in_ksQ_already_queued) - (* FIXME move *) lemma invs_switchToThread_runnable': "\ invs' s ; ksSchedulerAction s = SwitchToThread t \ \ st_tcb_at' runnable' t s" @@ -1033,17 +811,16 @@ lemma chooseThread_nosch: done lemma scheduleChooseNewThread_no_orphans: - "\ invs' and no_orphans - and (\s. ksSchedulerAction s = ChooseNewThread - \ (st_tcb_at' runnable' (ksCurThread s) s - \ (\d p. ksCurThread s \ set (ksReadyQueues s (d, p))))) \ + "\invs' and no_orphans + and (\s. ksSchedulerAction s = ChooseNewThread + \ (st_tcb_at' runnable' (ksCurThread s) s \ ksCurThread s \ all_queued_tcb_ptrs s))\ scheduleChooseNewThread - \\_. no_orphans \" + \\_. no_orphans\" unfolding scheduleChooseNewThread_def apply (wp add: ssa_no_orphans hoare_vcg_all_lift) apply (wp hoare_disjI1 chooseThread_nosch)+ apply (wp nextDomain_invs_no_cicd' hoare_vcg_imp_lift - hoare_lift_Pf2 [OF ksQ_all_queued_tcb_ptrs_lift[OF nextDomain_ksQ] + hoare_lift_Pf2 [OF tcbQueued_all_queued_tcb_ptrs_lift[OF nextDomain_tcbQueued] nextDomain_ct'] hoare_lift_Pf2 [OF st_tcb_at'_is_active_tcb_ptr_lift[OF nextDomain_st_tcb_at'] nextDomain_ct'] @@ -1052,24 +829,25 @@ lemma scheduleChooseNewThread_no_orphans: is_active_tcb_ptr_runnable')+ done +lemma setSchedulerAction_tcbQueued[wp]: + "setSchedulerAction sa \\s. Q (obj_at' (\tcb. P (tcbQueued tcb)) tcb_ptr s)\" + by wpsimp + lemma schedule_no_orphans[wp]: notes ssa_wp[wp del] shows - "\ \s. no_orphans s \ invs' s \ - schedule - \ \rv s. no_orphans s \" + "\no_orphans and invs'\ schedule \\_. no_orphans\" proof - have do_switch_to: "\candidate. \\s. no_orphans s \ ksSchedulerAction s = SwitchToThread candidate \ st_tcb_at' runnable' candidate s - \ (st_tcb_at' runnable' (ksCurThread s) s - \ (\d p. ksCurThread s \ set (ksReadyQueues s (d, p)))) \ - do ThreadDecls_H.switchToThread candidate; - setSchedulerAction ResumeCurrentThread - od - \\rv. no_orphans\" + \ (st_tcb_at' runnable' (ksCurThread s) s \ ksCurThread s \ all_queued_tcb_ptrs s) \ + do ThreadDecls_H.switchToThread candidate; + setSchedulerAction ResumeCurrentThread + od + \\_. no_orphans\" apply (wpsimp wp: scheduleChooseNewThread_no_orphans ssa_no_orphans hoare_vcg_all_lift ThreadDecls_H_switchToThread_no_orphans)+ apply (rule_tac Q="\_ s. (t = candidate \ ksCurThread s = candidate) \ @@ -1081,56 +859,43 @@ proof - have abort_switch_to_enq: "\candidate. - \\s. no_orphans s \ invs' s \ valid_queues' s + \\s. no_orphans s \ invs' s \ ksSchedulerAction s = SwitchToThread candidate - \ (st_tcb_at' runnable' (ksCurThread s) s - \ (\d p. ksCurThread s \ set (ksReadyQueues s (d, p)))) \ - do tcbSchedEnqueue candidate; - setSchedulerAction ChooseNewThread; - scheduleChooseNewThread - od - \\rv. no_orphans\" - apply (rule hoare_pre) - apply (wp scheduleChooseNewThread_no_orphans ssa_no_orphans setSchedulerAction_direct) + \ (st_tcb_at' runnable' (ksCurThread s) s \ ksCurThread s \ all_queued_tcb_ptrs s) \ + do tcbSchedEnqueue candidate; + setSchedulerAction ChooseNewThread; + scheduleChooseNewThread + od + \\_. no_orphans\" + apply (wpsimp wp: scheduleChooseNewThread_no_orphans ssa_no_orphans setSchedulerAction_direct) apply (wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_ex_lift - simp: is_active_tcb_ptr_runnable' all_queued_tcb_ptrs_def - | rule hoare_lift_Pf2[where f=ksCurThread, OF setSchedulerAction_ksQ])+ - apply (wp tcbSchedEnqueue_in_ksQ' tcbSchedEnqueue_no_orphans hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift) - apply (wp hoare_lift_Pf2[where f=ksCurThread, OF tcbSchedEnqueue_pred_tcb_at'] - hoare_lift_Pf2[where f=ksCurThread, OF tcbSchedEnqueue_in_ksQ_already_queued] - tcbSchedEnqueue_no_orphans - | strengthen not_pred_tcb_at'_strengthen - | wp (once) hoare_vcg_imp_lift')+ - apply (clarsimp) - apply (frule invs_sch_act_wf', clarsimp simp: pred_tcb_at') - apply (simp add: st_tcb_at_neg' tcb_at_invs') + simp: is_active_tcb_ptr_runnable' all_queued_tcb_ptrs_def + | rule hoare_lift_Pf2[where f=ksCurThread, OF setSchedulerAction_tcbQueued])+ + apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift + | strengthen not_pred_tcb_at'_strengthen + | rule hoare_lift_Pf2[where f=ksCurThread])+ + apply (simp add: st_tcb_at_neg' tcb_at_invs' all_queued_tcb_ptrs_def) done have abort_switch_to_app: "\candidate. - \\s. no_orphans s \ invs' s \ valid_queues' s + \\s. no_orphans s \ invs' s \ ksSchedulerAction s = SwitchToThread candidate \ (st_tcb_at' runnable' (ksCurThread s) s - \ (\d p. ksCurThread s \ set (ksReadyQueues s (d, p))) ) \ - do tcbSchedAppend candidate; - setSchedulerAction ChooseNewThread; - scheduleChooseNewThread - od - \\rv. no_orphans\" - apply (rule hoare_pre) - apply (wp scheduleChooseNewThread_no_orphans ssa_no_orphans setSchedulerAction_direct) + \ ksCurThread s \ all_queued_tcb_ptrs s ) \ + do tcbSchedAppend candidate; + setSchedulerAction ChooseNewThread; + scheduleChooseNewThread + od + \\_. no_orphans\" + apply (wpsimp wp: scheduleChooseNewThread_no_orphans ssa_no_orphans setSchedulerAction_direct) apply (wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_ex_lift - simp: is_active_tcb_ptr_runnable' all_queued_tcb_ptrs_def - | rule hoare_lift_Pf2[where f=ksCurThread, OF setSchedulerAction_ksQ])+ - apply (wp tcbSchedAppend_in_ksQ'' tcbSchedAppend_no_orphans hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift) - apply (wp hoare_lift_Pf2[where f=ksCurThread, OF tcbSchedAppend_pred_tcb_at'] - hoare_lift_Pf2[where f=ksCurThread, OF tcbSchedAppend_in_ksQ_already_queued] - tcbSchedAppend_no_orphans - | strengthen not_pred_tcb_at'_strengthen - | wp (once) hoare_vcg_imp_lift')+ - apply (clarsimp) - apply (frule invs_sch_act_wf', clarsimp simp: pred_tcb_at') - apply (simp add: st_tcb_at_neg' tcb_at_invs') + simp: is_active_tcb_ptr_runnable' all_queued_tcb_ptrs_def + | rule hoare_lift_Pf2[where f=ksCurThread, OF setSchedulerAction_tcbQueued])+ + apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift + | strengthen not_pred_tcb_at'_strengthen + | rule hoare_lift_Pf2[where f=ksCurThread])+ + apply (simp add: st_tcb_at_neg' tcb_at_invs' all_queued_tcb_ptrs_def) done show ?thesis @@ -1144,24 +909,20 @@ proof - apply (wp ssa_no_orphans hoare_vcg_all_lift) apply (wp hoare_disjI1 chooseThread_nosch) apply (wp nextDomain_invs_no_cicd' hoare_vcg_imp_lift - hoare_lift_Pf2 [OF ksQ_all_queued_tcb_ptrs_lift - [OF nextDomain_ksQ] - nextDomain_ct'] + hoare_lift_Pf2 [OF tcbQueued_all_queued_tcb_ptrs_lift + [OF nextDomain_tcbQueued] + nextDomain_ct'] hoare_lift_Pf2 [OF st_tcb_at'_is_active_tcb_ptr_lift [OF nextDomain_st_tcb_at'] nextDomain_ct'] hoare_vcg_all_lift getDomainTime_wp)[2] - apply ((wp tcbSchedEnqueue_no_orphans tcbSchedEnqueue_in_ksQ' - hoare_drop_imp - | clarsimp simp: all_queued_tcb_ptrs_def - | strengthen all_invs_but_ct_idle_or_in_cur_domain'_strg - | wps tcbSchedEnqueue_ct')+)[1] - apply ((wp tcbSchedEnqueue_no_orphans tcbSchedEnqueue_in_ksQ' + apply wpsimp + apply ((wp tcbSchedEnqueue_no_orphans tcbSchedEnqueue_all_queued_tcb_ptrs' hoare_drop_imp - | clarsimp simp: all_queued_tcb_ptrs_def - | strengthen all_invs_but_ct_idle_or_in_cur_domain'_strg - | wps tcbSchedEnqueue_ct')+)[1] - apply wp[1] + | clarsimp simp: all_queued_tcb_ptrs_def + | strengthen all_invs_but_ct_idle_or_in_cur_domain'_strg + | wps)+)[1] + apply wpsimp \ \action = SwitchToThread candidate\ apply (clarsimp) apply (rename_tac candidate) @@ -1170,14 +931,11 @@ proof - apply (wp hoare_drop_imps) apply (wp add: tcbSchedEnqueue_no_orphans)+ apply (clarsimp simp: conj_comms cong: conj_cong imp_cong split del: if_split) - apply (wp hoare_lift_Pf2[where f=ksCurThread, OF tcbSchedEnqueue_pred_tcb_at'] - hoare_lift_Pf2[where f=ksCurThread, OF tcbSchedEnqueue_in_ksQ'] - hoare_vcg_imp_lift' + apply (wp hoare_vcg_imp_lift' | strengthen not_pred_tcb_at'_strengthen)+ - apply (clarsimp simp: comp_def) - apply (frule invs_queues) - apply (clarsimp simp: invs_valid_queues' tcb_at_invs' st_tcb_at_neg' is_active_tcb_ptr_runnable') - apply (fastforce simp: all_invs_but_ct_idle_or_in_cur_domain'_strg invs_switchToThread_runnable') + apply (wps | wpsimp wp: tcbSchedEnqueue_all_queued_tcb_ptrs')+ + apply (fastforce simp: is_active_tcb_ptr_runnable' all_invs_but_ct_idle_or_in_cur_domain'_strg + invs_switchToThread_runnable') done qed @@ -1194,36 +952,32 @@ crunch no_orphans [wp]: completeSignal "no_orphans" (simp: crunch_simps wp: crunch_wps) lemma possibleSwitchTo_almost_no_orphans [wp]: - "\ \s. almost_no_orphans target s \ valid_queues' s \ st_tcb_at' runnable' target s - \ weak_sch_act_wf (ksSchedulerAction s) s \ + "\\s. almost_no_orphans target s \ st_tcb_at' runnable' target s + \ weak_sch_act_wf (ksSchedulerAction s) s\ possibleSwitchTo target - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding possibleSwitchTo_def - by (wpsimp wp: rescheduleRequired_valid_queues'_weak tcbSchedEnqueue_almost_no_orphans + by (wpsimp wp: tcbSchedEnqueue_almost_no_orphans ssa_almost_no_orphans hoare_weak_lift_imp | wp (once) hoare_drop_imp)+ lemma possibleSwitchTo_almost_no_orphans': - "\ \s. almost_no_orphans target s \ valid_queues' s \ st_tcb_at' runnable' target s - \ sch_act_wf (ksSchedulerAction s) s \ + "\\s. almost_no_orphans target s \ st_tcb_at' runnable' target s + \ sch_act_wf (ksSchedulerAction s) s \ possibleSwitchTo target - \ \rv s. no_orphans s \" + \\_. no_orphans\" by wp (strengthen sch_act_wf_weak, assumption) +crunches tcbQueueAppend, tcbQueuePrepend + for almost_no_orphans[wp]: "almost_no_orphans tcbPtr" + lemma tcbSchedAppend_almost_no_orphans: - "\ \s. almost_no_orphans thread s \ valid_queues' s \ + "\almost_no_orphans thread\ tcbSchedAppend thread - \ \_ s. no_orphans s \" + \\_. no_orphans\" unfolding tcbSchedAppend_def - apply (wp setQueue_almost_no_orphans_enq[where tcb_ptr=thread] threadSet_no_orphans - | clarsimp simp: unless_def | simp only: subset_insertI)+ - apply (unfold threadGet_def) - apply (wp getObject_tcb_wp | clarsimp)+ - apply (drule obj_at_ko_at', clarsimp) - apply (rule_tac x=ko in exI) - apply (clarsimp simp: almost_no_orphans_def no_orphans_def) - apply (drule queued_in_queue | simp)+ - apply (auto simp: all_queued_tcb_ptrs_def) + apply (wpsimp wp: tcbQueued_update_True_no_orphans threadGet_wp) + apply (fastforce simp: almost_no_orphans_def no_orphans_def all_queued_tcb_ptrs_def obj_at'_def) done lemma no_orphans_is_almost[simp]: @@ -1232,7 +986,6 @@ lemma no_orphans_is_almost[simp]: crunches decDomainTime for no_orphans[wp]: no_orphans - and valid_queues'[wp]: valid_queues' (wp: no_orphans_lift) lemma timerTick_no_orphans [wp]: @@ -1242,23 +995,15 @@ lemma timerTick_no_orphans [wp]: unfolding timerTick_def getDomainTime_def supply if_split[split del] apply (subst threadState_case_if) - apply (wpsimp wp: threadSet_no_orphans threadSet_valid_queues' - threadSet_valid_queues' tcbSchedAppend_almost_no_orphans threadSet_sch_act + apply (wpsimp wp: threadSet_no_orphans tcbSchedAppend_almost_no_orphans threadSet_almost_no_orphans threadSet_no_orphans tcbSchedAppend_sch_act_wf hoare_drop_imp simp: if_apply_def2 | strengthen sch_act_wf_weak)+ - apply (rule_tac Q="\rv s. no_orphans s \ valid_queues' s \ tcb_at' thread s - \ sch_act_wf (ksSchedulerAction s) s" in hoare_post_imp) - apply (clarsimp simp: inQ_def) - apply (wp hoare_drop_imps | clarsimp)+ - apply (auto split: if_split) done lemma handleDoubleFault_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ - handleDoubleFault tptr ex1 ex2 - \ \rv s. no_orphans s \" + "\no_orphans\ handleDoubleFault tptr ex1 ex2 \\_. no_orphans \" unfolding handleDoubleFault_def by (wpsimp wp: setThreadState_not_active_no_orphans simp: is_active_thread_state_def isRestart_def isRunning_def) @@ -1271,21 +1016,25 @@ crunches cteInsert, getThreadCallerSlot, getThreadReplySlot (wp: crunch_wps) lemma setupCallerCap_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ - setupCallerCap sender receiver gr - \ \rv s. no_orphans s \" + "setupCallerCap sender receiver gr \no_orphans\" unfolding setupCallerCap_def by (wpsimp wp: setThreadState_not_active_no_orphans hoare_drop_imps simp: is_active_thread_state_def isRestart_def isRunning_def) lemma setupCallerCap_almost_no_orphans [wp]: - "\ \s. almost_no_orphans tcb_ptr s \ valid_queues' s \ + "\almost_no_orphans tcb_ptr\ setupCallerCap sender receiver gr - \ \rv s. almost_no_orphans tcb_ptr s \" + \\_. almost_no_orphans tcb_ptr\" unfolding setupCallerCap_def by (wpsimp wp: setThreadState_not_active_almost_no_orphans hoare_drop_imps simp: is_active_thread_state_def isRestart_def isRunning_def) +crunches cteInsert, setExtraBadge, setMessageInfo, transferCaps, copyMRs, + doNormalTransfer, doFaultTransfer, + invalidateVMIDEntry, invalidateASID, invalidateASIDEntry + for tcbQueued[wp]: "obj_at' (\tcb. P (tcbQueued tcb)) tcb_ptr" + (wp: crunch_wps simp: crunch_simps) + crunches doIPCTransfer, setMRs for no_orphans [wp]: "no_orphans" (wp: no_orphans_lift) @@ -1297,64 +1046,35 @@ crunch no_orphans [wp]: setEndpoint "no_orphans" (wp: no_orphans_lift) lemma sendIPC_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s \ + "\\s. no_orphans s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s\ sendIPC blocking call badge canGrant canGrantReply thread epptr - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding sendIPC_def apply (wp hoare_drop_imps setThreadState_not_active_no_orphans sts_st_tcb' possibleSwitchTo_almost_no_orphans' | wpc | clarsimp simp: is_active_thread_state_def isRestart_def isRunning_def)+ - - apply (rule_tac Q="\rv. no_orphans and valid_queues' and valid_objs' and ko_at' rv epptr - and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) - apply (fastforce simp: valid_objs'_def valid_obj'_def valid_ep'_def obj_at'_def) - apply (wp get_ep_sp' | clarsimp)+ + apply (rule_tac Q="\rv. no_orphans and valid_objs' and ko_at' rv epptr + and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) + apply (fastforce simp: valid_objs'_def valid_obj'_def valid_ep'_def obj_at'_def) + apply (wp get_ep_sp' | clarsimp)+ done lemma sendFaultIPC_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s \ + "\\s. no_orphans s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s\ sendFaultIPC tptr fault - \ \rv s. no_orphans s \" - unfolding sendFaultIPC_def - apply (wpsimp wp: threadSet_valid_queues' threadSet_no_orphans threadSet_valid_objs' - threadSet_sch_act) - apply (rule_tac Q'="\handlerCap s. no_orphans s \ valid_queues' s - \ valid_objs' s - \ sch_act_wf (ksSchedulerAction s) s" - in hoare_post_imp_R) - apply (wpsimp simp: inQ_def valid_tcb'_def tcb_cte_cases_def)+ - done - -lemma sendIPC_valid_queues' [wp]: - "\ \s. valid_queues' s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s \ - sendIPC blocking call badge canGrant canGrantReply thread epptr - \ \rv s. valid_queues' s \" - unfolding sendIPC_def - apply (wpsimp wp: hoare_drop_imps) - apply (wpsimp | wp (once) sts_st_tcb' hoare_drop_imps)+ - apply (rule_tac Q="\rv. valid_queues' and valid_objs' and ko_at' rv epptr - and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) - apply (clarsimp) - apply (wp get_ep_sp' | clarsimp)+ - done - -lemma sendFaultIPC_valid_queues' [wp]: - "\ \s. valid_queues' s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s \ - sendFaultIPC tptr fault - \ \rv s. valid_queues' s \" + \\_. no_orphans\" unfolding sendFaultIPC_def - apply (wpsimp wp: threadSet_valid_queues' threadSet_valid_objs' threadSet_sch_act) - apply (rule_tac Q'="\handlerCap s. valid_queues' s \ valid_objs' s - \ sch_act_wf (ksSchedulerAction s) s" + apply (wpsimp wp: threadSet_no_orphans threadSet_valid_objs' threadSet_sch_act) + apply (rule_tac Q'="\_ s. no_orphans s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s" in hoare_post_imp_R) - apply (wpsimp simp: inQ_def valid_tcb'_def tcb_cte_cases_def)+ + apply wpsimp+ done -lemma handleFault_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s \ +lemma handleFault_no_orphans[wp]: + "\\s. no_orphans s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s\ handleFault tptr ex1 - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding handleFault_def by wpsimp @@ -1362,27 +1082,22 @@ lemma replyFromKernel_no_orphans [wp]: "\ \s. no_orphans s \ replyFromKernel thread r \ \rv s. no_orphans s \" - by (cases r, wpsimp simp: replyFromKernel_def) + by (wpsimp simp: replyFromKernel_def) crunch inv [wp]: alignError "P" -lemma createObjects_no_orphans [wp]: - "\ \s. no_orphans s \ pspace_aligned' s \ pspace_no_overlap' ptr sz s \ pspace_distinct' s - \ n \ 0 \ range_cover ptr sz (objBitsKO val + gbits) n - \ \ case_option False (is_active_thread_state \ tcbState) (projectKO_opt val) \ +lemma createObjects_no_orphans[wp]: + "\\s. no_orphans s \ pspace_aligned' s \ pspace_no_overlap' ptr sz s \ pspace_distinct' s + \ n \ 0 \ range_cover ptr sz (objBitsKO val + gbits) n + \ \ case_option False (is_active_thread_state \ tcbState) (projectKO_opt val) + \ \ case_option False tcbQueued (projectKO_opt val)\ createObjects ptr n val gbits - \ \rv s. no_orphans s \" + \\_ s. no_orphans s\" apply (clarsimp simp: no_orphans_def all_active_tcb_ptrs_def is_active_tcb_ptr_def all_queued_tcb_ptrs_def) apply (simp only: imp_conv_disj pred_tcb_at'_def createObjects_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift createObjects_orig_obj_at2') - apply clarsimp - apply (erule(1) impE) - apply clarsimp - apply (drule_tac x = x in spec) - apply (erule impE) - apply (clarsimp simp: obj_at'_def split: option.splits) - apply simp + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift createObjects_orig_obj_at2'[where sz=sz]) + apply (clarsimp split: option.splits) done crunch no_orphans [wp]: insertNewCap "no_orphans" @@ -1516,11 +1231,9 @@ lemma invokeUntyped_no_orphans [wp]: done lemma setInterruptState_no_orphans [wp]: - "\ \s. no_orphans s \ - setInterruptState a - \ \rv s. no_orphans s \" + "setInterruptState a \no_orphans\" unfolding no_orphans_disj all_queued_tcb_ptrs_def - by (wp hoare_vcg_all_lift hoare_vcg_disj_lift) + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift) crunch no_orphans [wp]: emptySlot "no_orphans" @@ -1529,43 +1242,45 @@ lemma mapM_x_match: by assumption lemma cancelAllIPC_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ - cancelAllIPC epptr - \ \rv s. no_orphans s \" + "\\s. no_orphans s \ valid_objs' s \ pspace_aligned' s \ pspace_distinct' s\ + cancelAllIPC epptr + \\_. no_orphans\" unfolding cancelAllIPC_def apply (wp sts_valid_objs' set_ep_valid_objs' sts_st_tcb' hoare_vcg_const_Ball_lift tcbSchedEnqueue_almost_no_orphans | wpc | rule mapM_x_match, rename_tac list, - rule_tac V="\_. valid_queues' and valid_objs'" + rule_tac V="\_. valid_objs' and pspace_aligned' and pspace_distinct'" and I="no_orphans and (\s. \t\set list. tcb_at' t s)" in mapM_x_inv_wp2 | clarsimp simp: valid_tcb_state'_def)+ - apply (rule_tac Q="\rv. no_orphans and valid_objs' and valid_queues' and ko_at' rv epptr" + apply (rule_tac Q="\rv. no_orphans and valid_objs' and pspace_aligned' and pspace_distinct' and + ko_at' rv epptr" in hoare_post_imp) apply (fastforce simp: valid_obj'_def valid_ep'_def obj_at'_def) apply (wp get_ep_sp' | clarsimp)+ done lemma cancelAllSignals_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ + "\\s. no_orphans s \ valid_objs' s \ pspace_aligned' s \ pspace_distinct' s\ cancelAllSignals ntfn - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding cancelAllSignals_def apply (wp sts_valid_objs' set_ntfn_valid_objs' sts_st_tcb' hoare_vcg_const_Ball_lift tcbSchedEnqueue_almost_no_orphans | wpc | clarsimp simp: valid_tcb_state'_def)+ apply (rename_tac list) - apply (rule_tac V="\_. valid_queues' and valid_objs'" + apply (rule_tac V="\_. valid_objs' and pspace_aligned' and pspace_distinct'" and I="no_orphans and (\s. \t\set list. tcb_at' t s)" in mapM_x_inv_wp2) apply simp apply (wp sts_valid_objs' set_ntfn_valid_objs' sts_st_tcb' hoare_vcg_const_Ball_lift tcbSchedEnqueue_almost_no_orphans| clarsimp simp: valid_tcb_state'_def)+ - apply (rule_tac Q="\rv. no_orphans and valid_objs' and valid_queues' and ko_at' rv ntfn" + apply (rule_tac Q="\rv. no_orphans and valid_objs' and pspace_aligned' and pspace_distinct' and + ko_at' rv ntfn" in hoare_post_imp) apply (fastforce simp: valid_obj'_def valid_ntfn'_def obj_at'_def) apply (wp get_ntfn_sp' | clarsimp)+ @@ -1575,47 +1290,48 @@ crunches setBoundNotification, unbindNotification, unbindMaybeNotification for no_orphans[wp]: no_orphans lemma finaliseCapTrue_standin_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ + "\\s. no_orphans s \ valid_objs' s \ pspace_aligned' s \ pspace_distinct' s\ finaliseCapTrue_standin cap final - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding finaliseCapTrue_standin_def Let_def by wpsimp lemma cteDeleteOne_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ + "\\s. no_orphans s \ valid_objs' s \ pspace_aligned' s \ pspace_distinct' s\ cteDeleteOne slot - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding cteDeleteOne_def by (wpsimp wp: assert_inv haskell_assert_inv isFinalCapability_inv weak_if_wp) crunch valid_objs' [wp]: getThreadReplySlot "valid_objs'" lemma cancelSignal_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ + "\\s. no_orphans s \ valid_objs' s\ cancelSignal t ntfn - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding cancelSignal_def Let_def by (wpsimp wp: hoare_drop_imps setThreadState_not_active_no_orphans simp: is_active_thread_state_def isRestart_def isRunning_def) lemma cancelIPC_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ + "\\s. no_orphans s \ valid_objs' s \ pspace_aligned' s \ pspace_distinct' s\ cancelIPC t - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding cancelIPC_def Let_def by (wpsimp wp: setThreadState_not_active_no_orphans hoare_drop_imps weak_if_wp - threadSet_valid_queues' threadSet_valid_objs' threadSet_no_orphans + threadSet_valid_objs' threadSet_no_orphans simp: is_active_thread_state_def isRestart_def isRunning_def inQ_def) lemma asUser_almost_no_orphans: "\almost_no_orphans t\ asUser a f \\_. almost_no_orphans t\" unfolding almost_no_orphans_disj all_queued_tcb_ptrs_def - by (wp hoare_vcg_all_lift hoare_vcg_disj_lift) + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift) lemma sendSignal_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s\ + "\\s. no_orphans s \ valid_objs' s \ pspace_aligned' s \ pspace_distinct' s \ + sch_act_wf (ksSchedulerAction s) s\ sendSignal ntfnptr badge - \ \_ s. no_orphans s \" + \\_. no_orphans\" unfolding sendSignal_def by (wpsimp wp: sts_st_tcb' gts_wp' getNotification_wp asUser_almost_no_orphans cancelIPC_weak_sch_act_wf @@ -1627,15 +1343,13 @@ crunches vgicUpdateLR crunch not_pred_tcb_at'[wp]: vgicUpdateLR,doMachineOp "\s. \ (pred_tcb_at' proj P' t) s" -crunch valid_queues' [wp]: vgicUpdateLR valid_queues' - crunches vcpuUpdate, vgicUpdateLR, doMachineOp for no_orphans[wp]: no_orphans and tcb_in_cur_domain'[wp]: "tcb_in_cur_domain' t" (wp: no_orphans_lift tcb_in_cur_domain'_lift) lemma vgicMaintenance_no_orphans[wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s \ + "\\s. no_orphans s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s\ vgicMaintenance \\_. no_orphans\" unfolding vgicMaintenance_def Let_def @@ -1644,7 +1358,7 @@ lemma vgicMaintenance_no_orphans[wp]: hoare_drop_imp[where f="doMachineOp f" for f]) lemma vppiEvent_no_orphans[wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s \ + "\\s. no_orphans s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s\ vppiEvent irq \\_. no_orphans\" unfolding vppiEvent_def Let_def @@ -1657,7 +1371,7 @@ lemma irqVPPIEventIndex_irqVGICMaintenance_None[simp]: by simp lemma handleReservedIRQ_no_orphans[wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s \ + "\\s. no_orphans s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s\ handleReservedIRQ irq \\_. no_orphans \" unfolding handleReservedIRQ_def @@ -1672,6 +1386,7 @@ lemma handleInterrupt_no_orphans [wp]: apply (wp hoare_drop_imps hoare_vcg_all_lift getIRQState_inv | wpc | clarsimp simp: invs'_def valid_state'_def maskIrqSignal_def if_apply_def2)+ + apply fastforce done lemma updateRestartPC_no_orphans[wp]: @@ -1680,20 +1395,6 @@ lemma updateRestartPC_no_orphans[wp]: \ \rv s. no_orphans s \" by (wpsimp simp: updateRestartPC_def asUser_no_orphans) -lemma updateRestartPC_valid_queues'[wp]: - "\ \s. valid_queues' s \ - updateRestartPC t - \ \rv s. valid_queues' s \" - unfolding updateRestartPC_def - apply (rule asUser_valid_queues') - done - -lemma updateRestartPC_no_orphans_invs'_valid_queues'[wp]: - "\\s. no_orphans s \ invs' s \ valid_queues' s \ - updateRestartPC t - \\rv s. no_orphans s \ valid_queues' s \" - by (wpsimp simp: updateRestartPC_def asUser_no_orphans) - lemma suspend_no_orphans [wp]: "\ \s. no_orphans s \ invs' s \ sch_act_simple s \ tcb_at' t s \ suspend t @@ -1726,9 +1427,19 @@ lemma deleteASIDPool_no_orphans [wp]: lemma storePTE_no_orphans [wp]: "storePTE ptr val \ no_orphans \" unfolding no_orphans_disj all_queued_tcb_ptrs_def - by (wp hoare_vcg_all_lift hoare_vcg_disj_lift) + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift) + +lemma archThreadSet_tcbQueued_inv[wp]: + "archThreadSet f t \\s. obj_at' (\tcb. P (tcbQueued tcb)) tcb_ptr s\" + unfolding archThreadSet_def + by (wp setObject_tcb_strongest getObject_tcb_wp) (fastforce simp: obj_at'_def) -crunch no_orphans [wp]: modifyArchState, vcpuUpdate, archThreadSet, dissociateVCPUTCB, vcpuFinalise "no_orphans" +crunches dissociateVCPUTCB + for tcbQueued_inv[wp]: "\s. obj_at' (\tcb. P (tcbQueued tcb)) t s" + (wp: threadGet_wp crunch_wps asUser_tcbQueued_inv simp: crunch_simps) + +crunches modifyArchState, vcpuUpdate, archThreadSet, dissociateVCPUTCB, vcpuFinalise + for no_orphans[wp]: "no_orphans" (wp: no_orphans_lift crunch_wps) crunch no_orphans [wp]: unmapPage "no_orphans" @@ -1741,7 +1452,7 @@ crunches unmapPageTable, prepareThreadDelete lemma setASIDPool_no_orphans [wp]: "setObject p (ap :: asidpool) \ no_orphans \" unfolding no_orphans_disj all_queued_tcb_ptrs_def - by (wp hoare_vcg_all_lift hoare_vcg_disj_lift) + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift) crunches deleteASID, Arch.finaliseCap for no_orphans [wp]: "no_orphans" @@ -1809,9 +1520,7 @@ lemma cteRevoke_no_orphans [wp]: done lemma cancelBadgedSends_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ - cancelBadgedSends epptr badge - \ \rv s. no_orphans s \" + "cancelBadgedSends epptr badge \no_orphans\" unfolding cancelBadgedSends_def by (wpsimp wp: filterM_preserved tcbSchedEnqueue_almost_no_orphans gts_wp' sts_st_tcb' | wp (once) hoare_drop_imps)+ @@ -1824,10 +1533,10 @@ lemma doReplyTransfer_no_orphans[wp]: \\rv. no_orphans\" unfolding doReplyTransfer_def apply (wp sts_st_tcb' setThreadState_not_active_no_orphans threadSet_no_orphans - threadSet_valid_queues' threadSet_weak_sch_act_wf + threadSet_weak_sch_act_wf | wpc | clarsimp simp: is_active_thread_state_def isRunning_def isRestart_def | wp (once) hoare_drop_imps - | strengthen sch_act_wf_weak invs_valid_queues')+ + | strengthen sch_act_wf_weak)+ apply (rule_tac Q="\rv. invs' and no_orphans" in hoare_post_imp) apply (fastforce simp: inQ_def) apply (wp hoare_drop_imps | clarsimp)+ @@ -1845,7 +1554,6 @@ lemma restart_no_orphans [wp]: apply (wp tcbSchedEnqueue_almost_no_orphans sts_st_tcb' cancelIPC_weak_sch_act_wf | clarsimp simp: o_def if_apply_def2 | strengthen no_orphans_strg_almost - | strengthen invs_valid_queues' | wp (once) hoare_drop_imps)+ apply auto done @@ -1864,7 +1572,7 @@ lemma writereg_no_orphans[wp]: \ \rv s. no_orphans s \" unfolding invokeTCB_def performTransfer_def postModifyRegisters_def by (wp hoare_vcg_if_lift hoare_vcg_conj_lift restart_invs' hoare_weak_lift_imp - | strengthen invs_valid_queues' + | strengthen | clarsimp simp: invs'_def valid_state'_def dest!: global'_no_ex_cap )+ lemma copyreg_no_orphans[wp]: @@ -1876,8 +1584,8 @@ lemma copyreg_no_orphans[wp]: apply simp apply (wp hoare_vcg_if_lift hoare_weak_lift_imp) apply (wp hoare_weak_lift_imp hoare_vcg_conj_lift hoare_drop_imp mapM_x_wp' restart_invs' - restart_no_orphans asUser_no_orphans suspend_nonz_cap_to_tcb - | strengthen invs_valid_queues' | wpc | simp add: if_apply_def2)+ + restart_no_orphans asUser_no_orphans suspend_nonz_cap_to_tcb + | wpc | simp add: if_apply_def2)+ apply (fastforce simp: invs'_def valid_state'_def dest!: global'_no_ex_cap) done @@ -1896,22 +1604,19 @@ lemma almost_no_orphans_no_orphans': "\ almost_no_orphans t s; ksCurThread s = t\ \ no_orphans s" by (auto simp: almost_no_orphans_def no_orphans_def all_active_tcb_ptrs_def) -lemma setPriority_no_orphans [wp]: - "\ \s. no_orphans s \ invs' s \ tcb_at' tptr s \ +lemma setPriority_no_orphans[wp]: + "\no_orphans and invs' and tcb_at' tptr\ setPriority tptr prio - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding setPriority_def apply wpsimp - apply (rule_tac Q="\rv s. almost_no_orphans tptr s \ valid_queues' s \ weak_sch_act_wf (ksSchedulerAction s) s" in hoare_post_imp) + apply (rule_tac Q="\_ s. almost_no_orphans tptr s \ weak_sch_act_wf (ksSchedulerAction s) s" in hoare_post_imp) apply clarsimp apply (clarsimp simp: is_active_tcb_ptr_runnable' pred_tcb_at'_def obj_at'_def almost_no_orphans_no_orphans elim!: almost_no_orphans_no_orphans') - apply (wp threadSet_almost_no_orphans threadSet_valid_queues' | clarsimp simp: inQ_def)+ + apply (wp threadSet_almost_no_orphans | clarsimp simp: inQ_def)+ apply (wpsimp wp: threadSet_weak_sch_act_wf) apply (wp tcbSchedDequeue_almost_no_orphans| clarsimp)+ - apply (rule_tac Q="\rv. obj_at' (Not \ tcbQueued) tptr and invs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) - apply (clarsimp simp: obj_at'_def inQ_def) - apply (wp tcbSchedDequeue_not_queued | clarsimp)+ done crunches bindNotification, setMCPriority @@ -1958,7 +1663,6 @@ lemma tc_no_orphans: checkCap_inv[where P=no_orphans] checkCap_inv[where P="tcb_at' a"] threadSet_cte_wp_at' hoare_vcg_all_lift_R hoare_vcg_all_lift threadSet_no_orphans hoare_vcg_const_imp_lift_R hoare_weak_lift_imp hoare_drop_imp threadSet_ipcbuffer_invs - | strengthen invs_valid_queues' | (simp add: locateSlotTCB_def locateSlotBasic_def objBits_def objBitsKO_def tcbIPCBufferSlot_def tcb_cte_cases_def, wp hoare_return_sp) @@ -1979,13 +1683,12 @@ lemma invokeTCB_no_orphans [wp]: done lemma invokeCNode_no_orphans [wp]: - "\ \s. no_orphans s \ invs' s \ valid_cnode_inv' cinv s \ sch_act_simple s \ + "\no_orphans and invs' and valid_cnode_inv' cinv and sch_act_simple\ invokeCNode cinv - \ \rv. no_orphans \" + \\_. no_orphans\" unfolding invokeCNode_def apply (rule hoare_pre) apply (wp hoare_drop_imps unless_wp | wpc | clarsimp split del: if_split)+ - apply (simp add: invs_valid_queues') done crunches performIRQControl, InterruptDecls_H.invokeIRQHandler, performPageTableInvocation, @@ -1994,7 +1697,7 @@ crunches performIRQControl, InterruptDecls_H.invokeIRQHandler, performPageTableI (wp: crunch_wps) lemma handleHypervisorFault_no_orphans[wp]: - "\\s. valid_queues' s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s \ no_orphans s\ + "\\s. valid_objs' s \ sch_act_wf (ksSchedulerAction s) s \ no_orphans s\ handleHypervisorFault w f \\_. no_orphans\" unfolding handleHypervisorFault_def isFpuEnable_def @@ -2095,17 +1798,15 @@ lemma arch_performInvocation_no_orphans [wp]: by (wpsimp simp: valid_arch_inv'_def) lemma setDomain_no_orphans [wp]: - "\no_orphans and valid_queues and valid_queues' and cur_tcb'\ - setDomain tptr newdom + "\no_orphans and cur_tcb' and tcb_at' tptr\ + setDomain tptr newdom \\_. no_orphans\" apply (simp add: setDomain_def when_def) apply (wp tcbSchedEnqueue_almost_no_orphans hoare_vcg_imp_lift threadSet_almost_no_orphans - threadSet_valid_queues'_no_state threadSet_st_tcb_at2 hoare_vcg_disj_lift + threadSet_st_tcb_at2 hoare_vcg_disj_lift threadSet_no_orphans - | clarsimp simp: st_tcb_at_neg2 not_obj_at')+ - apply (auto simp: tcb_at_typ_at' st_tcb_at_neg' is_active_tcb_ptr_runnable' - cur_tcb'_def obj_at'_def - dest: pred_tcb_at') + | clarsimp simp: st_tcb_at_neg2 not_obj_at')+ + apply (fastforce simp: tcb_at_typ_at' is_active_tcb_ptr_runnable') done lemma performInvocation_no_orphans [wp]: @@ -2123,8 +1824,6 @@ lemma getThreadState_restart [wp]: apply (clarsimp simp add: pred_tcb_at'_def obj_at'_def isRestart_def) done -crunch valid_queues' [wp]: replyFromKernel "valid_queues'" - lemma handleInvocation_no_orphans [wp]: "\ \s. no_orphans s \ invs' s \ ct_active' s \ ksSchedulerAction s = ResumeCurrentThread \ @@ -2142,20 +1841,12 @@ lemma handleInvocation_no_orphans [wp]: ct_in_state'_set setThreadState_st_tcb hoare_vcg_all_lift | simp add: split_def split del: if_split)+ - apply (wps setThreadState_ct') - apply (wp sts_ksQ - setThreadState_current_no_orphans sts_invs_minor' - ct_in_state'_set setThreadState_st_tcb - | simp add: split_def split del: if_split)+ apply (clarsimp simp: if_apply_def2) - apply (frule(1) ct_not_ksQ) by (auto simp: ct_in_state'_def pred_tcb_at'_def obj_at'_def invs'_def cur_tcb'_def valid_state'_def valid_idle'_def) lemma receiveSignal_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ - receiveSignal thread cap isBlocking - \ \rv s. no_orphans s \" + "receiveSignal thread cap isBlocking \no_orphans\" unfolding receiveSignal_def apply (wp hoare_drop_imps setThreadState_not_active_no_orphans | wpc | clarsimp simp: is_active_thread_state_def isRunning_def isRestart_def @@ -2173,7 +1864,7 @@ lemma receiveIPC_no_orphans [wp]: hoare_vcg_all_lift sts_st_tcb' | wpc | clarsimp simp: is_active_thread_state_def isRunning_def isRestart_def - doNBRecvFailedTransfer_def invs_valid_queues' + doNBRecvFailedTransfer_def | strengthen sch_act_wf_weak)+ done @@ -2251,7 +1942,7 @@ lemma handleEvent_no_orphans [wp]: cong: event.case_cong syscall.case_cong) apply (rule hoare_pre) apply (wp hoare_drop_imps | wpc | clarsimp simp: handleHypervisorFault_def - | strengthen invs_valid_queues' invs_valid_objs' invs_sch_act_wf')+ + | strengthen invs_valid_objs' invs_sch_act_wf')+ apply (auto simp: activatable_from_running' active_from_running') done diff --git a/proof/refine/ARM/ADT_H.thy b/proof/refine/ARM/ADT_H.thy index 158ddb5aba..ad198a9a6e 100644 --- a/proof/refine/ARM/ADT_H.thy +++ b/proof/refine/ARM/ADT_H.thy @@ -622,7 +622,7 @@ proof - apply (intro conjI impI allI) apply (erule pspace_dom_relatedE[OF _ pspace_relation]) apply clarsimp - apply (case_tac ko, simp_all add: other_obj_relation_def) + 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) @@ -636,7 +636,7 @@ proof - apply (clarsimp split: if_split_asm)+ apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko, simp_all add: other_obj_relation_def) + 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) @@ -649,7 +649,7 @@ proof - apply (clarsimp split: if_split_asm)+ apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko, simp_all add: other_obj_relation_def) + 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) @@ -658,7 +658,7 @@ proof - apply (clarsimp split: if_split_asm)+ apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko, simp_all add: other_obj_relation_def) + 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) @@ -684,7 +684,7 @@ proof - 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: other_obj_relation_def) + 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) @@ -710,7 +710,7 @@ proof - 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: other_obj_relation_def) + 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) @@ -738,7 +738,7 @@ proof - 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: other_obj_relation_def + 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) @@ -805,7 +805,7 @@ proof - (* mapping architecture-specific objects *) apply clarsimp apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko, simp_all add: other_obj_relation_def) + 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 @@ -949,7 +949,7 @@ shows apply (case_tac "ksPSpace s' x", clarsimp) apply (erule_tac x=x in allE, clarsimp) apply clarsimp - apply (case_tac a, simp_all add: other_obj_relation_def) + 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) @@ -1018,7 +1018,7 @@ lemma TCB_implies_KOTCB: apply (clarsimp simp add: pspace_relation_def pspace_dom_def dom_def UNION_eq Collect_eq) apply (erule_tac x=a in allE)+ - apply (clarsimp simp add: other_obj_relation_def + apply (clarsimp simp add: tcb_relation_cut_def split: Structures_H.kernel_object.splits) apply (drule iffD1) apply (fastforce simp add: dom_def image_def) @@ -1802,7 +1802,7 @@ definition domain_index_internal = ksDomScheduleIdx s, cur_domain_internal = ksCurDomain s, domain_time_internal = ksDomainTime s, - ready_queues_internal = curry (ksReadyQueues 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: @@ -1810,12 +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 absEkheap_correct - absCDTList_correct[THEN fun_cong] state_relation_def invs_def valid_state_def - ready_queues_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) + 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 diff --git a/proof/refine/ARM/ArchAcc_R.thy b/proof/refine/ARM/ArchAcc_R.thy index 5212765530..5ddf93aedb 100644 --- a/proof/refine/ARM/ArchAcc_R.thy +++ b/proof/refine/ARM/ArchAcc_R.thy @@ -125,16 +125,6 @@ lemma getObject_ASIDPool_corres [corres]: apply (clarsimp simp: other_obj_relation_def asid_pool_relation_def) done -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 simp - done - lemmas aligned_distinct_asid_pool_atI' = aligned_distinct_obj_atI'[where 'a=asidpool, simplified, OF _ _ _ refl] @@ -758,18 +748,21 @@ lemma setObject_PD_corres [@lift_corres_args, corres]: apply (drule(1) ekheap_kheap_dom) apply clarsimp apply (drule_tac x=p in bspec, erule domI) - apply (simp add: other_obj_relation_def - split: Structures_A.kernel_object.splits) - apply (rule conjI) + 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 + apply (extract_conjunct \match conclusion in "ready_queues_relation_2 _ _ _ _ _" \ -\) + apply (prop_tac "typ_at' (koTypeOf (injectKO pde')) p b") + apply (simp add: typ_at'_def ko_wp_at'_def) + subgoal by (fastforce dest: tcbs_of'_non_tcb_update) apply (simp add: map_to_ctes_upd_other) apply (simp add: fun_upd_def) apply (simp add: caps_of_state_after_update obj_at_def swp_cte_at_caps_of) done - 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) @@ -835,12 +828,16 @@ lemma setObject_PT_corres [@lift_corres_args, corres]: apply (drule(1) ekheap_kheap_dom) apply clarsimp apply (drule_tac x=p in bspec, erule domI) - apply (simp add: other_obj_relation_def - split: Structures_A.kernel_object.splits) - apply (rule conjI) + 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 + apply (extract_conjunct \match conclusion in "ready_queues_relation_2 _ _ _ _ _" \ -\) + apply (prop_tac "typ_at' (koTypeOf (injectKO pte')) p b") + apply (simp add: typ_at'_def ko_wp_at'_def) + subgoal by (fastforce dest: tcbs_of'_non_tcb_update) apply (simp add: map_to_ctes_upd_other) apply (simp add: fun_upd_def) apply (simp add: caps_of_state_after_update obj_at_def swp_cte_at_caps_of) @@ -1433,5 +1430,161 @@ lemma dmo_clearMemory_invs'[wp]: apply fastforce done +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) + + \\TCB\ + apply (clarsimp simp: tcbBlockSizeBits_def elim!: is_aligned_weaken) + + \\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 (rule pbfs_atleast_pageBits) + apply (fastforce intro: is_aligned_shift is_aligned_mult_triv2) + + \\other_obj_relation\ + apply (simp add: other_obj_relation_def) + by (clarsimp simp: 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) + +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 bit_simps 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_def2) + 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=tcbBlockSizeBits in exI) + apply (simp add: tcbBlockSizeBits_def) + apply (rule_tac x=pteBits in exI) + apply (simp add: bit_simps is_aligned_shift mask_def pteBits_def) + apply word_bitwise + apply (rule_tac x=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 + pbfs_atleast_pageBits[simplified bit_simps] archObjSize_def pteBits_def + pdeBits_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 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 (rule ps_clearI, assumption) + apply (case_tac ko'; simp add: objBits_simps objBits_defs obj_at_simps) + apply (simp split: arch_kernel_object.splits add: obj_at_simps pteBits_def pdeBits_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_def2 objBits_simps) + apply (rule_tac n=cte_level_bits in is_aligned_add_step_le'; assumption?) + apply (rule is_aligned_add; (rule is_aligned_shift)?) + apply (erule is_aligned_weaken, simp add: cte_level_bits_def) + apply (rule is_aligned_add; (rule is_aligned_shift)?) + apply (erule is_aligned_weaken, simp add: cte_level_bits_def) + apply (simp add: cte_level_bits_def cteSizeBits_def) + 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 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) + done + end end diff --git a/proof/refine/ARM/Arch_R.thy b/proof/refine/ARM/Arch_R.thy index 33e79a0476..dd1fb9875d 100644 --- a/proof/refine/ARM/Arch_R.thy +++ b/proof/refine/ARM/Arch_R.thy @@ -263,11 +263,10 @@ lemma performASIDControlInvocation_corres: deleteObjects_cte_wp_at' deleteObjects_null_filter[where p="makePoolParent i'"]) apply (clarsimp simp:invs_mdb max_free_index_def invs_untyped_children) - 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 (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) @@ -339,7 +338,7 @@ lemma performASIDControlInvocation_corres: apply (simp add:pageBits_def) apply clarsimp apply (drule(1) cte_cap_in_untyped_range) - apply (fastforce simp:cte_wp_at_ctes_of) + apply (fastforce simp: cte_wp_at_ctes_of) apply assumption+ apply fastforce apply simp @@ -1290,7 +1289,7 @@ lemma tcbSchedEnqueue_vs_entry_align[wp]: "\\s. ko_wp_at' (\ko. P (vs_entry_align ko)) p s\ tcbSchedEnqueue pa \\rv. ko_wp_at' (\ko. P (vs_entry_align ko)) p\" - apply (clarsimp simp: tcbSchedEnqueue_def setQueue_def) + apply (clarsimp simp: tcbSchedEnqueue_def tcbQueuePrepend_def setQueue_def) by (wp unless_wp | simp)+ crunch vs_entry_align[wp]: diff --git a/proof/refine/ARM/Bits_R.thy b/proof/refine/ARM/Bits_R.thy index 278b3c5b43..5023c5e46e 100644 --- a/proof/refine/ARM/Bits_R.thy +++ b/proof/refine/ARM/Bits_R.thy @@ -78,6 +78,10 @@ lemma projectKO_tcb: "(projectKO_opt ko = Some t) = (ko = KOTCB t)" by (cases ko) (auto simp: projectKO_opts_defs) +lemma tcb_of'_TCB[simp]: + "tcb_of' (KOTCB tcb) = Some tcb" + by (simp add: projectKO_tcb) + lemma projectKO_cte: "(projectKO_opt ko = Some t) = (ko = KOCTE t)" by (cases ko) (auto simp: projectKO_opts_defs) diff --git a/proof/refine/ARM/CNodeInv_R.thy b/proof/refine/ARM/CNodeInv_R.thy index 3459ade0a2..f91f9e3469 100644 --- a/proof/refine/ARM/CNodeInv_R.thy +++ b/proof/refine/ARM/CNodeInv_R.thy @@ -5042,8 +5042,6 @@ crunch irq_states'[wp]: cteSwap "valid_irq_states'" crunch pde_mappings'[wp]: cteSwap "valid_pde_mappings'" -crunch vq'[wp]: cteSwap "valid_queues'" - crunch ksqsL1[wp]: cteSwap "\s. P (ksReadyQueuesL1Bitmap s)" crunch ksqsL2[wp]: cteSwap "\s. P (ksReadyQueuesL2Bitmap s)" @@ -5058,6 +5056,12 @@ crunch ct_not_inQ[wp]: cteSwap "ct_not_inQ" crunch ksDomScheduleIdx [wp]: cteSwap "\s. P (ksDomScheduleIdx s)" +crunches cteSwap + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + and valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift) + lemma cteSwap_invs'[wp]: "\invs' and valid_cap' c and valid_cap' c' and ex_cte_cap_to' c1 and ex_cte_cap_to' c2 and @@ -5514,6 +5518,10 @@ lemma updateCap_untyped_ranges_zero_simple: crunch tcb_in_cur_domain'[wp]: updateCap "tcb_in_cur_domain' t" (wp: crunch_wps simp: crunch_simps rule: tcb_in_cur_domain'_lift) +crunches updateCap + for valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift) + lemma make_zombie_invs': "\\s. invs' s \ s \' cap \ cte_wp_at' (\cte. isFinal (cteCap cte) sl (cteCaps_of s)) sl s \ @@ -5530,7 +5538,8 @@ lemma make_zombie_invs': st_tcb_at' ((=) Inactive) p s \ bound_tcb_at' ((=) None) p s \ obj_at' (Not \ tcbQueued) p s - \ (\pr. p \ set (ksReadyQueues s pr)))) sl 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_state'_def valid_pspace'_def valid_mdb'_def @@ -5567,7 +5576,9 @@ lemma make_zombie_invs': 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_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 @@ -8498,6 +8509,15 @@ lemma cteMove_urz [wp]: apply auto done +crunches updateMDB + for valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift) + +(* FIXME: arch_split *) +lemma haskell_assert_inv: + "haskell_assert Q L \P\" + by wpsimp + lemma cteMove_invs' [wp]: "\\x. invs' x \ ex_cte_cap_to' word2 x \ cte_wp_at' (\c. weak_derived' (cteCap c) capability) word1 x \ diff --git a/proof/refine/ARM/CSpace1_R.thy b/proof/refine/ARM/CSpace1_R.thy index f60dd64bc3..ee4898d676 100644 --- a/proof/refine/ARM/CSpace1_R.thy +++ b/proof/refine/ARM/CSpace1_R.thy @@ -236,7 +236,7 @@ lemma pspace_relation_cte_wp_at: apply (clarsimp elim!: cte_wp_at_weakenE') apply clarsimp apply (drule(1) pspace_relation_absD) - apply (clarsimp simp: other_obj_relation_def) + apply (clarsimp simp: tcb_relation_cut_def) apply (simp split: kernel_object.split_asm) apply (drule(2) aligned_distinct_obj_atI'[where 'a=tcb]) apply simp @@ -1597,10 +1597,10 @@ lemma cte_map_pulls_tcb_to_abstract: \ \tcb'. kheap s x = Some (TCB tcb') \ tcb_relation tcb' tcb \ (z = (x, tcb_cnode_index (unat ((y - x) >> cte_level_bits))))" apply (rule pspace_dom_relatedE, assumption+) - apply (erule(1) obj_relation_cutsE, simp_all split: if_split_asm) - apply (clarsimp simp: other_obj_relation_def + apply (erule(1) obj_relation_cutsE; + clarsimp simp: other_obj_relation_def split: Structures_A.kernel_object.split_asm - ARM_A.arch_kernel_obj.split_asm) + ARM_A.arch_kernel_obj.split_asm if_split_asm) apply (drule tcb_cases_related2) apply clarsimp apply (frule(1) cte_wp_at_tcbI [OF _ _ TrueI, where t="(a, b)" for a b, simplified]) @@ -1616,8 +1616,7 @@ lemma pspace_relation_update_tcbs: del: dom_fun_upd) apply (erule conjE) apply (rule ballI, drule(1) bspec) - apply (rule conjI, simp add: other_obj_relation_def) - apply (clarsimp split: Structures_A.kernel_object.split_asm) + apply (clarsimp simp: tcb_relation_cut_def split: Structures_A.kernel_object.split_asm) apply (drule bspec, fastforce) apply clarsimp apply (erule(1) obj_relation_cutsE, simp_all split: if_split_asm) @@ -1838,6 +1837,27 @@ lemma descendants_of_eq': apply simp done +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 + +lemma setObject_cte_tcbSchedNexts_of_use_valid_ksPSpace: + assumes step: "(x, s\ksPSpace := ps\) \ fst (setObject p (cte :: cte) s)" + 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_inQ_of_use_valid_ksPSpace: + assumes step: "(x, s\ksPSpace := ps\) \ fst (setObject p (cte :: cte) s)" + 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))) \ @@ -1851,7 +1871,12 @@ lemma updateCap_stuff: ksSchedulerAction s'' = ksSchedulerAction s' \ (ksArchState s'' = ksArchState s') \ (pspace_aligned' s' \ pspace_aligned' s'') \ - (pspace_distinct' s' \ pspace_distinct' s'')" using assms + (pspace_distinct' s' \ pspace_distinct' s'') \ + 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) @@ -1860,8 +1885,11 @@ lemma updateCap_stuff: apply (frule setCTE_pspace_only) apply (clarsimp simp: setCTE_def) apply (intro conjI impI) - apply (erule(1) use_valid [OF _ setObject_aligned]) - apply (erule(1) use_valid [OF _ setObject_distinct]) + 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 *) @@ -1878,16 +1906,16 @@ lemma pspace_relation_cte_wp_atI': apply (simp split: if_split_asm) apply (erule(1) pspace_dom_relatedE) apply (erule(1) obj_relation_cutsE, simp_all split: if_split_asm) + apply (subgoal_tac "n = x - y", clarsimp) + apply (drule tcb_cases_related2, clarsimp) + apply (intro exI, rule conjI) + apply (erule(1) cte_wp_at_tcbI[where t="(a, b)" for a b, simplified]) + apply fastforce + apply simp + apply clarsimp apply (simp add: other_obj_relation_def split: Structures_A.kernel_object.split_asm ARM_A.arch_kernel_obj.split_asm) - apply (subgoal_tac "n = x - y", clarsimp) - apply (drule tcb_cases_related2, clarsimp) - apply (intro exI, rule conjI) - apply (erule(1) cte_wp_at_tcbI[where t="(a, b)" for a b, simplified]) - apply fastforce - apply simp - apply clarsimp done lemma pspace_relation_cte_wp_atI: @@ -2287,7 +2315,7 @@ lemma updateCap_corres: apply (clarsimp simp: in_set_cap_cte_at_swp pspace_relations_def) apply (drule updateCap_stuff) apply simp - apply (rule conjI) + apply (extract_conjunct \match conclusion in "ghost_relation _ _ _" \ -\) apply (clarsimp simp: ghost_relation_typ_at set_cap_a_type_inv data_at_def) apply (rule conjI) prefer 2 @@ -2375,9 +2403,9 @@ lemma updateMDB_pspace_relation: apply (clarsimp simp: tcb_ctes_clear cte_level_bits_def objBits_defs) apply clarsimp apply (rule pspace_dom_relatedE, assumption+) - apply (rule obj_relation_cutsE, assumption+, simp_all split: if_split_asm)[1] - apply (clarsimp split: Structures_A.kernel_object.split_asm - ARM_A.arch_kernel_obj.split_asm + apply (rule obj_relation_cutsE, assumption+; + clarsimp split: Structures_A.kernel_object.split_asm + ARM_A.arch_kernel_obj.split_asm if_split_asm simp: other_obj_relation_def) apply (frule(1) tcb_cte_cases_aligned_helpers(1)) apply (frule(1) tcb_cte_cases_aligned_helpers(2)) @@ -2439,6 +2467,25 @@ lemma updateMDB_ctes_of: crunch aligned[wp]: updateMDB "pspace_aligned'" crunch pdistinct[wp]: updateMDB "pspace_distinct'" +crunch tcbSchedPrevs_of[wp]: updateMDB "\s. P (tcbSchedPrevs_of s)" +crunch tcbSchedNexts_of[wp]: updateMDB "\s. P (tcbSchedNexts_of s)" +crunch inQ_opt_pred[wp]: updateMDB "\s. P (inQ d p |< tcbs_of' s)" +crunch inQ_opt_pred'[wp]: updateMDB "\s. P (\d p. inQ d p |< tcbs_of' s)" +crunch ksReadyQueues[wp]: updateMDB "\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 + +crunches 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')" @@ -2461,7 +2508,11 @@ lemma updateMDB_the_lot: ksDomScheduleIdx s'' = ksDomScheduleIdx s' \ ksDomSchedule s'' = ksDomSchedule s' \ ksCurDomain s'' = ksCurDomain s' \ - ksDomainTime s'' = ksDomainTime s'" + ksDomainTime s'' = ksDomainTime s' \ + 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) @@ -2470,9 +2521,8 @@ using assms apply (erule use_valid) apply wp apply simp - 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: @@ -3665,6 +3715,9 @@ lemma updateUntypedCap_descendants_of: apply (clarsimp simp:mdb_next_rel_def mdb_next_def split:if_splits) done +crunches setCTE + for tcbQueued[wp]: "\s. P (tcbQueued |< tcbs_of' s)" + lemma setCTE_UntypedCap_corres: "\cap_relation cap (cteCap cte); is_untyped_cap cap; idx' = idx\ \ corres dc (cte_wp_at ((=) cap) src and valid_objs and @@ -3694,10 +3747,19 @@ lemma setCTE_UntypedCap_corres: apply assumption apply (clarsimp simp: pspace_relations_def) apply (subst conj_assoc[symmetric]) + apply clarsimp 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) @@ -4978,11 +5040,15 @@ lemma updateMDB_the_lot': ksDomScheduleIdx s'' = ksDomScheduleIdx s' \ ksDomSchedule s'' = ksDomSchedule s' \ ksCurDomain s'' = ksCurDomain s' \ - ksDomainTime s'' = ksDomainTime s'" + ksDomainTime s'' = ksDomainTime s' \ + 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 + done lemma cte_map_inj_eq': "\(cte_map p = cte_map p'); @@ -5084,7 +5150,6 @@ lemma cteInsert_corres: 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 "ksReadyQueues t = p" for p t)+ apply (thin_tac "ksSchedulerAction t = p" for p t)+ apply (clarsimp simp: pspace_relations_def) diff --git a/proof/refine/ARM/CSpace_R.thy b/proof/refine/ARM/CSpace_R.thy index 3e438cadef..f765387bad 100644 --- a/proof/refine/ARM/CSpace_R.thy +++ b/proof/refine/ARM/CSpace_R.thy @@ -1099,43 +1099,6 @@ lemma bitmapQ_no_L2_orphans_lift: apply (rule hoare_vcg_prop, assumption) done -lemma valid_queues_lift_asm: - assumes tat1: "\d p tcb. \obj_at' (inQ d p) tcb and Q \ f \\_. obj_at' (inQ d p) tcb\" - and tat2: "\tcb. \st_tcb_at' runnable' tcb and Q \ f \\_. st_tcb_at' runnable' tcb\" - and prq: "\P. \\s. P (ksReadyQueues s) \ f \\_ s. P (ksReadyQueues s)\" - and prqL1: "\P. \\s. P (ksReadyQueuesL1Bitmap s)\ f \\_ s. P (ksReadyQueuesL1Bitmap s)\" - and prqL2: "\P. \\s. P (ksReadyQueuesL2Bitmap s)\ f \\_ s. P (ksReadyQueuesL2Bitmap s)\" - shows "\Invariants_H.valid_queues and Q\ f \\_. Invariants_H.valid_queues\" - proof - - have tat: "\d p tcb. \obj_at' (inQ d p) tcb and st_tcb_at' runnable' tcb and Q\ f - \\_. obj_at' (inQ d p) tcb and st_tcb_at' runnable' tcb\" - apply (rule hoare_chain [OF hoare_vcg_conj_lift [OF tat1 tat2]]) - apply (fastforce)+ - done - have tat_combined: "\d p tcb. \obj_at' (inQ d p and runnable' \ tcbState) tcb and Q\ f - \\_. obj_at' (inQ d p and runnable' \ tcbState) tcb\" - apply (rule hoare_chain [OF tat]) - apply (fastforce simp add: obj_at'_and pred_tcb_at'_def o_def)+ - done - show ?thesis unfolding valid_queues_def valid_queues_no_bitmap_def - by (wp tat_combined prq prqL1 prqL2 valid_bitmapQ_lift bitmapQ_no_L2_orphans_lift - bitmapQ_no_L1_orphans_lift hoare_vcg_all_lift hoare_vcg_conj_lift hoare_Ball_helper) - simp_all - qed - -lemmas valid_queues_lift = valid_queues_lift_asm[where Q="\_. True", simplified] - -lemma valid_queues_lift': - assumes tat: "\d p tcb. \\s. \ obj_at' (inQ d p) tcb s\ f \\_ s. \ obj_at' (inQ d p) tcb s\" - and prq: "\P. \\s. P (ksReadyQueues s)\ f \\_ s. P (ksReadyQueues s)\" - shows "\valid_queues'\ f \\_. valid_queues'\" - unfolding valid_queues'_def imp_conv_disj - by (wp hoare_vcg_all_lift hoare_vcg_disj_lift tat prq) - -lemma setCTE_norq [wp]: - "\\s. P (ksReadyQueues s)\ setCTE ptr cte \\r s. P (ksReadyQueues s) \" - by (clarsimp simp: valid_def dest!: setCTE_pspace_only) - lemma setCTE_norqL1 [wp]: "\\s. P (ksReadyQueuesL1Bitmap s)\ setCTE ptr cte \\r s. P (ksReadyQueuesL1Bitmap s) \" by (clarsimp simp: valid_def dest!: setCTE_pspace_only) @@ -2784,12 +2747,6 @@ lemma setCTE_inQ[wp]: apply (simp_all add: inQ_def) done -lemma setCTE_valid_queues'[wp]: - "\valid_queues'\ setCTE p cte \\rv. valid_queues'\" - apply (simp only: valid_queues'_def imp_conv_disj) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - done - crunch inQ[wp]: cteInsert "\s. P (obj_at' (inQ d p) t s)" (wp: crunch_wps) @@ -3284,6 +3241,13 @@ lemma cteInsert_untyped_ranges_zero[wp]: apply blast done +crunches cteInsert + 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 (\s. src \ dest) and (\s. cte_wp_at' (is_derived' (ctes_of s) src cap \ cteCap) src s) @@ -3292,9 +3256,9 @@ lemma cteInsert_invs: cteInsert cap src dest \\rv. invs'\" 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 CSpace_R.valid_queues_lift - valid_irq_node_lift valid_queues_lift' irqs_masked_lift cteInsert_norq - simp: st_tcb_at'_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 @@ -3594,10 +3558,13 @@ lemma corres_caps_decomposition: "\P. \\s. P (new_ups' s)\ g \\rv s. P (gsUserPages s)\" "\P. \\s. P (new_cns s)\ f \\rv s. P (cns_of_heap (kheap s))\" "\P. \\s. P (new_cns' s)\ g \\rv s. P (gsCNodes s)\" - "\P. \\s. P (new_queues s)\ f \\rv s. P (ready_queues s)\" + "\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_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)\" @@ -3613,7 +3580,9 @@ lemma corres_caps_decomposition: "\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 (new_queues s) (new_rqs' s')" + \ ready_queues_relation_2 (new_ready_queues s) (new_ksReadyQueues s') + (new_tcbSchedNexts_of s') (new_tcbSchedPrevs_of s') + (\d p. new_inQs d p s')" "\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 \ @@ -3681,8 +3650,9 @@ proof - 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 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 pspace_relations_def swp_cte_at))+ + 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 @@ -3794,7 +3764,7 @@ lemma create_reply_master_corres: apply clarsimp apply (rule corres_caps_decomposition) defer - apply (wp|simp)+ + 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) @@ -4166,6 +4136,9 @@ crunches setupReplyMaster 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]: @@ -4194,7 +4167,8 @@ lemma setupReplyMaster_invs'[wp]: 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 valid_queues_lift' hoare_vcg_disj_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 @@ -4455,8 +4429,8 @@ lemma arch_update_setCTE_invs: 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 + 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) @@ -5811,7 +5785,7 @@ lemma cteInsert_simple_invs: apply (rule hoare_pre) 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' irqs_masked_lift + 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 @@ -5950,6 +5924,21 @@ lemma arch_update_updateCap_invs: apply clarsimp 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 @@ -5981,6 +5970,8 @@ lemma updateCap_same_master: apply 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 @@ -6207,8 +6198,9 @@ lemma updateFreeIndex_forward_invs': apply (simp add:updateCap_def) apply (wp setCTE_irq_handlers' getCTE_wp) apply (simp add:updateCap_def) - apply (wp irqs_masked_lift valid_queues_lift' cur_tcb_lift ct_idle_or_in_cur_domain'_lift + apply (wp irqs_masked_lift cur_tcb_lift ct_idle_or_in_cur_domain'_lift hoare_vcg_disj_lift untyped_ranges_zero_lift getCTE_wp + sym_heap_sched_pointers_lift valid_bitmaps_lift | wp (once) hoare_use_eq[where f="gsUntypedZeroRanges"] | simp add: getSlotCap_def)+ apply (clarsimp simp: cte_wp_at_ctes_of fun_upd_def[symmetric]) diff --git a/proof/refine/ARM/Detype_R.thy b/proof/refine/ARM/Detype_R.thy index e9dbf8de1e..abd93e2cc6 100644 --- a/proof/refine/ARM/Detype_R.thy +++ b/proof/refine/ARM/Detype_R.thy @@ -567,7 +567,6 @@ lemma sym_refs_ko_wp_atD: 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 = @@ -585,8 +584,9 @@ context delete_locale begin interpretation Arch . (*FIXME: arch_split*) lemma valid_objs: "valid_objs' s'" and pa: "pspace_aligned' s'" and pd: "pspace_distinct' s'" - and vq: "valid_queues s'" - and vq': "valid_queues' s'" + and vbm: "valid_bitmaps s'" + and sym_sched: "sym_heap_sched_pointers s'" + and vsp: "valid_sched_pointers s'" and sym_refs: "sym_refs (state_refs_of' s')" and iflive: "if_live_then_nonz_cap' s'" and ifunsafe: "if_unsafe_then_cap' s'" @@ -792,7 +792,6 @@ lemma refs_notRange: apply (rule refs_of_live') apply clarsimp done - end context begin interpretation Arch . (*FIXME: arch_split*) @@ -888,6 +887,70 @@ crunches doMachineOp for deletionIsSafe_delete_locale[wp]: "deletionIsSafe_delete_locale base magnitude" (simp: deletionIsSafe_delete_locale_def) +lemma detype_tcbSchedNexts_of: + "\pspace_aligned' s'; pspace_distinct' s'; \p. p \ S \ \ ko_wp_at' live' p s'\ + \ ((\x. if x \ S then None else ksPSpace s' x) |> tcb_of' |> tcbSchedNext) + = tcbSchedNexts_of s'" + using pspace_alignedD' pspace_distinctD' + apply (clarsimp simp: opt_map_def) + apply (rule ext) + apply (rename_tac s) + apply (clarsimp simp: ko_wp_at'_def projectKOs split: option.splits) + apply (drule_tac x=s in spec) + apply force + done + +lemma detype_tcbSchedPrevs_of: + "\pspace_aligned' s'; pspace_distinct' s'; \p. p \ S \ \ ko_wp_at' live' p s'\ + \ ((\x. if x \ S then None else ksPSpace s' x) |> tcb_of' |> tcbSchedPrev) + = tcbSchedPrevs_of s'" + using pspace_alignedD' pspace_distinctD' + using pspace_alignedD' pspace_distinctD' + apply (clarsimp simp: opt_map_def) + apply (rule ext) + apply (rename_tac s) + apply (clarsimp simp: ko_wp_at'_def projectKOs split: option.splits) + apply (drule_tac x=s in spec) + apply force + done + +lemma detype_inQ: + "\pspace_aligned' s'; pspace_distinct' s'; \p. p \ S \ \ ko_wp_at' live' p s'\ + \ \d p. (inQ d p |< ((\x. if x \ S then None else ksPSpace s' x) |> tcb_of')) + = (inQ d p |< tcbs_of' s')" + using pspace_alignedD' pspace_distinctD' + using pspace_alignedD' pspace_distinctD' + apply (clarsimp simp: opt_map_def) + apply (rule ext) + apply (rename_tac s) + apply (clarsimp simp: inQ_def opt_pred_def ko_wp_at'_def projectKOs split: option.splits) + apply (drule_tac x=s in spec) + apply force + done + +lemma detype_ready_queues_relation: + "\pspace_aligned' s'; pspace_distinct' s'; + \p. p \ {lower..upper} \ \ ko_wp_at' live' p s'; + ready_queues_relation s s'; upper = upper'\ + \ ready_queues_relation_2 + (ready_queues (detype {lower..upper'} s)) + (ksReadyQueues s') + ((\x. if lower \ x \ x \ upper then None + else ksPSpace s' x) |> + tcb_of' |> + tcbSchedNext) + ((\x. if lower \ x \ x \ upper then None + else ksPSpace s' x) |> + tcb_of' |> + tcbSchedPrev) + (\d p. inQ d p |< ((\x. if lower \ x \ x \ upper then None else ksPSpace s' x) |> tcb_of'))" + apply (clarsimp simp: detype_ext_def ready_queues_relation_def Let_def) + apply (frule (1) detype_tcbSchedNexts_of[where S="{lower..upper}"]; simp) + apply (frule (1) detype_tcbSchedPrevs_of[where S="{lower..upper}"]; simp) + apply (frule (1) detype_inQ[where S="{lower..upper}"]; simp) + apply (fastforce simp add: detype_def detype_ext_def) + done + lemma deleteObjects_corres: "is_aligned base magnitude \ magnitude \ 2 \ corres dc @@ -908,11 +971,10 @@ lemma deleteObjects_corres: apply (rule corres_stateAssert_implied[where P'=\, simplified]) prefer 2 apply clarsimp - 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 p_assoc_help invs_valid_pspace)[1] - apply (simp add:valid_cap_simps) + 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) @@ -939,15 +1001,16 @@ lemma deleteObjects_corres: 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 ) \ - 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" and - Q'="\_ s. s \' capability.UntypedCap d base magnitude idx \ - valid_pspace' s" in corres_underlying_split) + (\cref. cte_wp_at ((=) (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" + 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]) apply (rule corres_split[OF _ cNodeNoPartialOverlap]) @@ -960,52 +1023,70 @@ 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, rule state.equality; simp add: detype_ext_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 (drule(4) cte_map_not_null_outside') - apply (fastforce simp add: cte_wp_at_caps_of_state) + 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 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 (fastforce simp add: detype_def detype_ext_def intro!: ekheap_relation_detype) - apply (clarsimp simp: state_relation_def ghost_relation_of_heap - detype_def) + 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 add: ups_of_heap_def cns_of_heap_def ext - split: option.splits kernel_object.splits)[1] + 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 | 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' live' p s' \ p = idle_thread_ptr \ p \ base_bits" + apply (case_tac "ko_wp_at' live' 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 invs_valid_idle'[OF invs]) + 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 mask_eq_exp_minus_1) + by fastforce + +lemma untyped_range_live_idle': + "p \ base_bits \ \ (ko_wp_at' live' p s' \ p = idle_thread_ptr)" + using live_idle_untyped_range' by blast + lemma valid_obj': - "\ valid_obj' obj s'; ko_wp_at' ((=) obj) p s' \ \ valid_obj' obj state'" + "\ 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 (rename_tac endpoint) apply (case_tac endpoint, simp_all add: valid_ep'_def)[1] @@ -1032,10 +1113,23 @@ lemma valid_obj': apply (erule(2) cte_wp_at_tcbI') apply fastforce apply simp - 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 (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]) @@ -1051,6 +1145,40 @@ lemma valid_obj': apply (case_tac pde, simp_all add: valid_mapping'_def) done +lemma tcbSchedNexts_of_pspace': + "\pspace_aligned' s'; pspace_distinct' s'; pspace_distinct' state'\ + \ (pspace' |> tcb_of' |> tcbSchedNext) = tcbSchedNexts_of s'" + supply projectKOs[simp] + apply (rule ext) + apply (rename_tac p) + apply (case_tac "p \ base_bits") + apply (frule untyped_range_live_idle') + apply (clarsimp simp: opt_map_def) + apply (case_tac "ksPSpace s' p"; clarsimp) + apply (rename_tac obj) + apply (case_tac "tcb_of' obj"; clarsimp) + apply (clarsimp simp: ko_wp_at'_def obj_at'_def) + apply (fastforce dest: pspace_alignedD' pspace_distinctD') + apply (clarsimp simp: opt_map_def split: option.splits) + done + +lemma tcbSchedPrevs_of_pspace': + "\pspace_aligned' s'; pspace_distinct' s'; pspace_distinct' state'\ + \ (pspace' |> tcb_of' |> tcbSchedPrev) = tcbSchedPrevs_of s'" + supply projectKOs[simp] + apply (rule ext) + apply (rename_tac p) + apply (case_tac "p \ base_bits") + apply (frule untyped_range_live_idle') + apply (clarsimp simp: opt_map_def) + apply (case_tac "ksPSpace s' p"; clarsimp) + apply (rename_tac obj) + apply (case_tac "tcb_of' obj"; clarsimp) + apply (clarsimp simp: ko_wp_at'_def obj_at'_def) + apply (fastforce simp: pspace_alignedD' pspace_distinctD') + apply (clarsimp simp: opt_map_def split: option.splits) + done + lemma st_tcb: "\P p. \ st_tcb_at' P p s'; \ P Inactive; \ P IdleThreadState \ \ st_tcb_at' P p state'" by (fastforce simp: pred_tcb_at'_def obj_at'_real_def projectKOs dest: live_notRange) @@ -1257,17 +1385,18 @@ proof (simp add: invs'_def valid_state'_def valid_pspace'_def show "pspace_aligned' ?s" using pa by (simp add: pspace_aligned'_def dom_def) - show "pspace_distinct' ?s" using pd + show pspace_distinct'_state': "pspace_distinct' ?s" using pd by (clarsimp simp add: pspace_distinct'_def ps_clear_def dom_if_None Diff_Int_distrib) - show "valid_objs' ?s" using valid_objs + show "valid_objs' ?s" using valid_objs sym_sched apply (clarsimp simp: valid_objs'_def ran_def) 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 + apply (frule pspace_alignedD'[OF _ pa]) + apply (frule pspace_distinctD'[OF _ pd]) + apply (clarsimp simp: ko_wp_at'_def) + apply fastforce done from sym_refs show "sym_refs (state_refs_of' ?s)" @@ -1279,19 +1408,6 @@ proof (simp add: invs'_def valid_state'_def valid_pspace'_def apply (simp add: refs_notRange[simplified] state_refs_ko_wp_at_eq) done - 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) - done - - from vq' show "valid_queues' ?s" - by (simp add: valid_queues'_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) @@ -1550,6 +1666,20 @@ proof (simp add: invs'_def valid_state'_def valid_pspace'_def apply simp done + from vbm + show "valid_bitmaps state'" + by (simp add: valid_bitmaps_def bitmapQ_defs) + + from sym_sched + show "sym_heap (pspace' |> tcb_of' |> tcbSchedNext) (pspace' |> tcb_of' |> tcbSchedPrev)" + using pa pd pspace_distinct'_state' + by (fastforce simp: tcbSchedNexts_of_pspace' tcbSchedPrevs_of_pspace') + + from vsp show "valid_sched_pointers_2 (pspace' |> tcb_of' |> tcbSchedPrev) + (pspace' |> tcb_of' |> tcbSchedNext) + (tcbQueued |< (pspace' |> tcb_of'))" + by (clarsimp simp: valid_sched_pointers_def opt_pred_def opt_map_def) + qed (clarsimp) lemma (in delete_locale) delete_ko_wp_at': @@ -4670,7 +4800,6 @@ lemma createTCBs_tcb_at': apply simp apply simp apply (clarsimp simp: retype_obj_at_disj') - apply (clarsimp simp: projectKO_opt_tcb) apply (clarsimp simp: new_cap_addrs_def image_def) apply (drule_tac x = "unat x" in bspec) apply (simp add:objBits_simps' shiftl_t2n) diff --git a/proof/refine/ARM/Finalise_R.thy b/proof/refine/ARM/Finalise_R.thy index 1ccfbae968..4a7d071453 100644 --- a/proof/refine/ARM/Finalise_R.thy +++ b/proof/refine/ARM/Finalise_R.thy @@ -76,20 +76,10 @@ crunch ksRQL1[wp]: emptySlot "\s. P (ksReadyQueuesL1Bitmap s)" crunch ksRQL2[wp]: emptySlot "\s. P (ksReadyQueuesL2Bitmap s)" crunch obj_at'[wp]: postCapDeletion "obj_at' P p" -lemmas postCapDeletion_valid_queues[wp] = - valid_queues_lift [OF postCapDeletion_obj_at' - postCapDeletion_pred_tcb_at' - postCapDeletion_ksRQ] - crunch inQ[wp]: clearUntypedFreeIndex "\s. P (obj_at' (inQ d p) t s)" crunch tcbDomain[wp]: clearUntypedFreeIndex "obj_at' (\tcb. P (tcbDomain tcb)) t" crunch tcbPriority[wp]: clearUntypedFreeIndex "obj_at' (\tcb. P (tcbPriority tcb)) t" -lemma emptySlot_queues [wp]: - "\Invariants_H.valid_queues\ emptySlot sl opt \\rv. Invariants_H.valid_queues\" - unfolding emptySlot_def - by (wp | wpcw | wp valid_queues_lift | simp)+ - crunch nosch[wp]: emptySlot "\s. P (ksSchedulerAction s)" crunch ksCurDomain[wp]: emptySlot "\s. P (ksCurDomain s)" @@ -1162,8 +1152,7 @@ definition "removeable' sl \ \s cap. (\p. p \ sl \ cte_wp_at' (\cte. capMasterCap (cteCap cte) = capMasterCap cap) p s) \ ((\p \ cte_refs' cap (irq_node' s). p \ sl \ cte_wp_at' (\cte. cteCap cte = NullCap) p s) - \ (\p \ zobj_refs' cap. ko_wp_at' (Not \ live') p s) - \ (\t \ threadCapRefs cap. \p. t \ set (ksReadyQueues s p)))" + \ (\p \ zobj_refs' cap. ko_wp_at' (Not \ live') p s))" lemma not_Final_removeable: "\ isFinal cap sl (cteCaps_of s) @@ -1354,11 +1343,6 @@ crunch irq_states' [wp]: emptySlot valid_irq_states' crunch no_0_obj' [wp]: emptySlot no_0_obj' (wp: crunch_wps) -crunch valid_queues'[wp]: setInterruptState "valid_queues'" - (simp: valid_queues'_def) - -crunch valid_queues'[wp]: emptySlot "valid_queues'" - crunch pde_mappings'[wp]: emptySlot "valid_pde_mappings'" end @@ -1445,6 +1429,13 @@ lemma emptySlot_untyped_ranges[wp]: apply (simp add: untypedZeroRange_def isCap_simps) done +crunches emptySlot + 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)\ @@ -2240,6 +2231,14 @@ 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) +crunches 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]: "\invs'\ unbindNotification tcb \\rv. invs'\" apply (simp add: unbindNotification_def invs'_def valid_state'_def) @@ -2248,8 +2247,8 @@ lemma unbindNotification_invs[wp]: apply clarsimp apply (rule hoare_seq_ext[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 + 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 (clarsimp elim!: obj_atE' @@ -2291,7 +2290,7 @@ lemma unbindMaybeNotification_invs[wp]: apply (simp add: unbindMaybeNotification_def invs'_def valid_state'_def) apply (rule hoare_seq_ext[OF _ get_ntfn_sp']) apply (rule hoare_pre) - apply (wp sbn'_valid_pspace'_inv sbn_sch_act' sbn_valid_queues valid_irq_node_lift + 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)+ @@ -2486,7 +2485,6 @@ lemma cteDeleteOne_isFinal: 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 setQueue_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF setQueue_ctes_of] lemmas threadSet_cteCaps_of = ctes_of_cteCaps_of_lift [OF threadSet_ctes_of] crunch isFinal: suspend, prepareThreadDelete "\s. isFinal cap slot (cteCaps_of s)" @@ -2570,16 +2568,6 @@ lemma unbindNotification_valid_objs'_helper': by (clarsimp simp: valid_bound_tcb'_def valid_ntfn'_def split: option.splits ntfn.splits) -lemma typ_at'_valid_tcb'_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_tcb' tcb s\ f \\rv s. valid_tcb' tcb s\" - including no_pre - apply (simp add: valid_tcb'_def) - apply (case_tac "tcbState tcb", simp_all add: valid_tcb_state'_def split_def valid_bound_ntfn'_def) - apply (wp hoare_vcg_const_Ball_lift typ_at_lifts[OF P] - | case_tac "tcbBoundNotification tcb", simp_all)+ - done - lemmas setNotification_valid_tcb' = typ_at'_valid_tcb'_lift [OF setNotification_typ_at'] lemma unbindNotification_valid_objs'[wp]: @@ -2702,10 +2690,6 @@ lemma unbindNotification_bound_tcb_at': apply (wp setBoundNotification_bound_tcb gbn_wp' | wpc | simp)+ done -crunches unbindNotification, unbindMaybeNotification - for valid_queues[wp]: "Invariants_H.valid_queues" - (wp: sbn_valid_queues) - crunches unbindNotification, unbindMaybeNotification for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" @@ -2725,8 +2709,42 @@ crunch cte_wp_at'[wp]: prepareThreadDelete "cte_wp_at' P p" crunch valid_cap'[wp]: prepareThreadDelete "valid_cap' cap" crunch invs[wp]: prepareThreadDelete "invs'" +crunches prepareThreadDelete + for sched_projs_obj_at'[wp]: + "\s. obj_at' (\tcb. tcbSchedNext tcb = None \ tcbSchedPrev tcb = None) t s" + end +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) + +crunches updateRestartPC, cancelIPC + for valid_sched_pointers[wp]: valid_sched_pointers + (simp: crunch_simps wp: crunch_wps) + +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))) @@ -2746,21 +2764,22 @@ 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))))\" + \ 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 (wp prepares_delete_helper'' [OF cancelAllIPC_unlive] prepares_delete_helper'' [OF cancelAllSignals_unlive] - suspend_isFinal prepareThreadDelete_unqueued prepareThreadDelete_nonq + suspend_isFinal prepareThreadDelete_unqueued prepareThreadDelete_inactive prepareThreadDelete_isFinal - suspend_makes_inactive suspend_nonq + 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]], @@ -2828,7 +2847,9 @@ lemma cancelIPC_cte_wp_at': apply (clarsimp simp: cteCaps_of_def cte_wp_at_ctes_of x) done -crunch cte_wp_at'[wp]: tcbSchedDequeue "cte_wp_at' P p" +crunches tcbSchedDequeue + for cte_wp_at'[wp]: "cte_wp_at' P p" + (wp: crunch_wps) lemma suspend_cte_wp_at': assumes x: "\cap final. P cap \ finaliseCap cap final True = fail" @@ -2954,25 +2975,6 @@ crunch sch_act_not[wp]: cteDeleteOne "sch_act_not t" (simp: crunch_simps case_Null_If unless_def wp: crunch_wps getObject_inv loadObject_default_inv) -lemma cancelAllIPC_mapM_x_valid_queues: - "\Invariants_H.valid_queues and valid_objs' and (\s. \t\set q. tcb_at' t s)\ - mapM_x (\t. do - y \ setThreadState Structures_H.thread_state.Restart t; - tcbSchedEnqueue t - od) q - \\rv. Invariants_H.valid_queues\" - apply (rule_tac R="\_ s. (\t\set q. tcb_at' t s) \ valid_objs' s" - in hoare_post_add) - apply (rule hoare_pre) - apply (rule mapM_x_wp') - apply (rule hoare_name_pre_state) - apply (wp hoare_vcg_const_Ball_lift - tcbSchedEnqueue_valid_queues tcbSchedEnqueue_not_st - sts_valid_queues sts_st_tcb_at'_cases setThreadState_not_st - | simp - | ((elim conjE)?, drule (1) bspec, clarsimp elim!: obj_at'_weakenE simp: valid_tcb_state'_def))+ - done - lemma cancelAllIPC_mapM_x_weak_sch_act: "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ mapM_x (\t. do @@ -2986,13 +2988,15 @@ lemma cancelAllIPC_mapM_x_weak_sch_act: done lemma cancelAllIPC_mapM_x_valid_objs': - "\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 (wpsimp wp: mapM_x_wp' sts_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 @@ -3003,18 +3007,12 @@ lemma cancelAllIPC_mapM_x_tcbDomain_obj_at': tcbSchedEnqueue t od) q \\_. obj_at' (\tcb. P (tcbDomain tcb)) t'\" -apply (wp mapM_x_wp' tcbSchedEnqueue_not_st setThreadState_oa_queued | simp)+ -done + by (wpsimp wp: mapM_x_wp') 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) -apply (wp tcbSchedEnqueue_not_st - | wpc - | simp)+ -done + "rescheduleRequired \obj_at' (\tcb. Q (tcbDomain tcb) (tcbPriority tcb)) t\" + unfolding rescheduleRequired_def tcbSchedEnqueue_def tcbQueuePrepend_def + by wpsimp lemma cancelAllIPC_tcbDomain_obj_at': "\obj_at' (\tcb. P (tcbDomain tcb)) t'\ @@ -3028,21 +3026,6 @@ apply (wp hoare_vcg_conj_lift hoare_vcg_const_Ball_lift | simp)+ done -lemma cancelAllIPC_valid_queues[wp]: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - cancelAllIPC ep_ptr - \\rv. Invariants_H.valid_queues\" - apply (simp add: cancelAllIPC_def ep'_Idle_case_helper) - apply (wp hoare_vcg_conj_lift hoare_vcg_const_Ball_lift - cancelAllIPC_mapM_x_valid_queues cancelAllIPC_mapM_x_valid_objs' cancelAllIPC_mapM_x_weak_sch_act - set_ep_valid_objs' getEndpoint_wp) - apply (clarsimp simp: valid_ep'_def) - apply (drule (1) ko_at_valid_objs') - apply (auto simp: valid_obj'_def valid_ep'_def valid_tcb'_def projectKOs - split: endpoint.splits - elim: valid_objs_valid_tcbE) - done - lemma cancelAllSignals_tcbDomain_obj_at': "\obj_at' (\tcb. P (tcbDomain tcb)) t'\ cancelAllSignals epptr @@ -3059,41 +3042,8 @@ lemma unbindMaybeNotification_tcbDomain_obj_at': "\obj_at' (\tcb. P (tcbDomain tcb)) t'\ unbindMaybeNotification r \\_. obj_at' (\tcb. P (tcbDomain tcb)) t'\" - apply (simp add: unbindMaybeNotification_def) - apply (wp setBoundNotification_oa_queued getNotification_wp gbn_wp' | wpc | simp)+ - done - -lemma cancelAllSignals_valid_queues[wp]: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - cancelAllSignals ntfn - \\rv. Invariants_H.valid_queues\" - apply (simp add: cancelAllSignals_def) - apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) - apply (case_tac "ntfnObj ntfna", simp_all) - apply (wp, simp)+ - apply (wp hoare_vcg_conj_lift hoare_vcg_const_Ball_lift - cancelAllIPC_mapM_x_valid_queues cancelAllIPC_mapM_x_valid_objs' cancelAllIPC_mapM_x_weak_sch_act - set_ntfn_valid_objs' - | simp)+ - apply (clarsimp simp: valid_ep'_def) - apply (drule (1) ko_at_valid_objs') - apply (auto simp: valid_obj'_def valid_ntfn'_def valid_tcb'_def projectKOs - split: endpoint.splits - elim: valid_objs_valid_tcbE) - done - -lemma finaliseCapTrue_standin_valid_queues[wp]: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - finaliseCapTrue_standin cap final - \\_. Invariants_H.valid_queues\" - apply (simp add: finaliseCapTrue_standin_def Let_def) - apply (safe) - apply (wp | clarsimp | wpc)+ - done - - -crunch valid_queues[wp]: isFinalCapability "Invariants_H.valid_queues" - (simp: crunch_simps) + unfolding unbindMaybeNotification_def + by (wpsimp wp: getNotification_wp gbn_wp' simp: setBoundNotification_def)+ crunch sch_act[wp]: isFinalCapability "\s. sch_act_wf (ksSchedulerAction s) s" (simp: crunch_simps) @@ -3102,96 +3052,6 @@ crunch weak_sch_act[wp]: isFinalCapability "\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. \obj_at' (inQ d p) tcb\ f \\_. obj_at' (inQ d p) tcb\" - and prq: "\P. \\s. P (ksReadyQueues s)\ f \\_ s. P (ksReadyQueues s)\" - shows "\valid_inQ_queues\ f \\_. valid_inQ_queues\" - proof - - show ?thesis - apply (clarsimp simp: valid_def valid_inQ_queues_def) - apply safe - apply (rule use_valid [OF _ tat], assumption) - apply (drule spec, drule spec, erule conjE, erule bspec) - apply (rule ccontr) - apply (erule notE[rotated], erule(1) use_valid [OF _ prq]) - apply (erule use_valid [OF _ prq]) - apply simp - done - qed - -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)+ - -crunch valid_inQ_queues[wp]: emptySlot valid_inQ_queues - (simp: crunch_simps) - -lemma cancelAllIPC_mapM_x_valid_inQ_queues: - "\valid_inQ_queues\ - mapM_x (\t. do - y \ setThreadState Structures_H.thread_state.Restart t; - tcbSchedEnqueue t - od) q - \\rv. valid_inQ_queues\" - apply (rule mapM_x_wp_inv) - apply (wp sts_valid_queues [where st="Structures_H.thread_state.Restart", simplified] - setThreadState_st_tcb) - done - -lemma cancelAllIPC_valid_inQ_queues[wp]: - "\valid_inQ_queues\ - cancelAllIPC ep_ptr - \\rv. valid_inQ_queues\" - apply (simp add: cancelAllIPC_def ep'_Idle_case_helper) - apply (wp cancelAllIPC_mapM_x_valid_inQ_queues) - apply (wp hoare_conjI hoare_drop_imp | simp)+ - done - -lemma cancelAllSignals_valid_inQ_queues[wp]: - "\valid_inQ_queues\ - cancelAllSignals ntfn - \\rv. valid_inQ_queues\" - apply (simp add: cancelAllSignals_def) - apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) - apply (case_tac "ntfnObj ntfna", simp_all) - apply (wp, simp)+ - apply (wp cancelAllIPC_mapM_x_valid_inQ_queues)+ - apply (simp) - done - -crunches unbindNotification, unbindMaybeNotification - for valid_inQ_queues[wp]: "valid_inQ_queues" - -lemma finaliseCapTrue_standin_valid_inQ_queues[wp]: - "\valid_inQ_queues\ - finaliseCapTrue_standin cap final - \\_. valid_inQ_queues\" - apply (simp add: finaliseCapTrue_standin_def Let_def) - apply (safe) - apply (wp | clarsimp | wpc)+ - done - -crunch valid_inQ_queues[wp]: isFinalCapability valid_inQ_queues - (simp: crunch_simps) - -lemma cteDeleteOne_valid_inQ_queues[wp]: - "\valid_inQ_queues\ - cteDeleteOne sl - \\_. valid_inQ_queues\" - apply (simp add: cteDeleteOne_def unless_def) - apply (wpsimp wp: hoare_drop_imp hoare_vcg_all_lift) - done - crunch ksCurDomain[wp]: cteDeleteOne "\s. P (ksCurDomain s)" (wp: crunch_wps simp: crunch_simps unless_def) @@ -3435,10 +3295,9 @@ lemma arch_finaliseCap_corres: lemma unbindNotification_corres: "corres dc (invs and tcb_at t) - (invs' and tcb_at' t) + invs' (unbind_notification t) (unbindNotification t)" - supply option.case_cong_weak[cong] apply (simp add: unbind_notification_def unbindNotification_def) apply (rule corres_guard_imp) apply (rule corres_split[OF getBoundNotification_corres]) @@ -3453,12 +3312,12 @@ lemma unbindNotification_corres: 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 - valid_tcb_def valid_bound_ntfn_def + 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 - tcb_ntfn_is_bound'_def + simp: valid_obj'_def valid_tcb'_def valid_bound_ntfn'_def tcb_ntfn_is_bound'_def + projectKOs split: option.splits) done @@ -3479,11 +3338,11 @@ lemma unbindMaybeNotification_corres: 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 + 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 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 valid_ntfn'_def split: option.splits) done @@ -3618,12 +3477,6 @@ lemma arch_recycleCap_improve_cases: \ isASIDControlCap cap \ \ (if isASIDPoolCap cap then v else undefined) = v" by (cases cap, simp_all add: isCap_simps) -crunch queues[wp]: copyGlobalMappings "Invariants_H.valid_queues" - (wp: crunch_wps ignore: storePDE) - -crunch queues'[wp]: copyGlobalMappings "Invariants_H.valid_queues'" - (wp: crunch_wps ignore: storePDE) - crunch ifunsafe'[wp]: copyGlobalMappings "if_unsafe_then_cap'" (wp: crunch_wps ignore: storePDE) @@ -3672,178 +3525,6 @@ lemma cteCaps_of_ctes_of_lift: lemmas final_matters'_simps = final_matters'_def [split_simps capability.split arch_capability.split] -definition set_thread_all :: "obj_ref \ Structures_A.tcb \ etcb - \ unit det_ext_monad" where - "set_thread_all ptr tcb etcb \ - do s \ get; - kh \ return $ (kheap s)(ptr \ (TCB tcb)); - ekh \ return $ (ekheap s)(ptr \ etcb); - put (s\kheap := kh, ekheap := ekh\) - od" - -definition thread_gets_the_all :: "obj_ref \ (Structures_A.tcb \ etcb) det_ext_monad" where - "thread_gets_the_all tptr \ - do tcb \ gets_the $ get_tcb tptr; - etcb \ gets_the $ get_etcb tptr; - return $ (tcb, etcb) od" - -definition thread_set_all :: "(Structures_A.tcb \ Structures_A.tcb) \ (etcb \ etcb) - \ obj_ref \ unit det_ext_monad" where - "thread_set_all f g tptr \ - do (tcb, etcb) \ thread_gets_the_all tptr; - set_thread_all tptr (f tcb) (g etcb) - od" - -lemma set_thread_all_corres: - fixes ob' :: "'a :: pspace_storable" - assumes x: "updateObject ob' = updateObject_default ob'" - assumes z: "\s. obj_at' P ptr s - \ map_to_ctes ((ksPSpace s) (ptr \ injectKO ob')) = map_to_ctes (ksPSpace s)" - assumes b: "\ko. P ko \ objBits ko = objBits ob'" - assumes P: "\(v::'a::pspace_storable). (1 :: word32) < 2 ^ (objBits v)" - assumes e: "etcb_relation etcb tcb'" - assumes is_t: "injectKO (ob' :: 'a :: pspace_storable) = KOTCB tcb'" - shows "other_obj_relation (TCB tcb) (injectKO (ob' :: 'a :: pspace_storable)) \ - corres dc (obj_at (same_caps (TCB tcb)) ptr and is_etcb_at ptr) - (obj_at' (P :: 'a \ bool) ptr) - (set_thread_all ptr tcb etcb) (setObject ptr ob')" - apply (rule corres_no_failI) - apply (rule no_fail_pre) - apply wp - apply (rule x) - apply (clarsimp simp: b elim!: obj_at'_weakenE) - apply (unfold set_thread_all_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 - updateObject_default_def in_magnitude_check [OF _ P]) - apply (clarsimp simp add: state_relation_def z) - apply (simp add: trans_state_update'[symmetric] trans_state_update[symmetric] - del: trans_state_update) - apply (clarsimp simp add: swp_def fun_upd_def obj_at_def is_etcb_at_def) - apply (subst cte_wp_at_after_update,fastforce simp add: obj_at_def) - apply (subst caps_of_state_after_update,fastforce simp add: obj_at_def) - apply clarsimp - 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 - split: Structures_A.kernel_object.splits if_split_asm) - - apply (fold fun_upd_def) - apply (simp only: pspace_relation_def dom_fun_upd2 simp_thms) - apply (subst pspace_dom_update) - apply assumption - apply simp - 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: is_other_obj_relation_type) - apply (drule(1) bspec) - apply clarsimp - apply (frule_tac ko'="TCB tcb'" and x'=ptr in obj_relation_cut_same_type, - (fastforce simp add: is_other_obj_relation_type)+)[1] - 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 (clarsimp simp: projectKOs) - apply (insert e is_t) - by (clarsimp simp: other_obj_relation_def etcb_relation_def is_other_obj_relation_type split: Structures_A.kernel_object.splits Structures_H.kernel_object.splits ARM_A.arch_kernel_obj.splits) - -lemma tcb_update_all_corres': - assumes tcbs: "tcb_relation tcb tcb' \ tcb_relation tcbu tcbu'" - assumes tables: "\(getF, v) \ ran tcb_cap_cases. getF tcbu = getF tcb" - assumes tables': "\(getF, v) \ ran tcb_cte_cases. getF tcbu' = getF tcb'" - assumes r: "r () ()" - assumes e: "etcb_relation etcb tcb' \ etcb_relation etcbu tcbu'" - shows "corres r (ko_at (TCB tcb) add and (\s. ekheap s add = Some etcb)) - (ko_at' tcb' add) - (set_thread_all add tcbu etcbu) (setObject add tcbu')" - apply (rule_tac F="tcb_relation tcb tcb' \ 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 (force simp: projectKOs other_obj_relation_def ekheap_relation_def e) - apply (erule conjE) - apply (rule corres_guard_imp) - apply (rule corres_rel_imp) - apply (rule set_thread_all_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 simp: is_etcb_at_def 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 - done - -lemma thread_gets_the_all_corres: - shows "corres (\(tcb, etcb) tcb'. tcb_relation tcb tcb' \ etcb_relation etcb tcb') - (tcb_at t and is_etcb_at t) (tcb_at' t) - (thread_gets_the_all t) (getObject t)" - apply (rule corres_no_failI) - apply wp - apply (clarsimp simp add: gets_def get_def return_def bind_def get_tcb_def thread_gets_the_all_def threadGet_def ethread_get_def gets_the_def assert_opt_def get_etcb_def is_etcb_at_def tcb_at_def liftM_def split: option.splits Structures_A.kernel_object.splits) - 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 ko) - apply (simp_all add: fail_def return_def) - apply (clarsimp simp add: state_relation_def pspace_relation_def ekheap_relation_def) - apply (drule bspec) - apply clarsimp - apply blast - apply (drule bspec, erule domI) - apply (clarsimp simp add: other_obj_relation_def - lookupAround2_known1) - done - -lemma thread_set_all_corresT: - assumes x: "\tcb tcb'. tcb_relation tcb tcb' \ - tcb_relation (f tcb) (f' tcb')" - 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" - assumes e: "\etcb tcb'. etcb_relation etcb tcb' \ - etcb_relation (g etcb) (f' tcb')" - shows "corres dc (tcb_at t and valid_etcbs) - (tcb_at' t) - (thread_set_all f g t) (threadSet f' t)" - apply (simp add: thread_set_all_def threadSet_def bind_assoc) - apply (rule corres_guard_imp) - apply (rule corres_split[OF thread_gets_the_all_corres]) - apply (simp add: split_def) - apply (rule tcb_update_all_corres') - apply (erule x) - apply (rule y) - apply (clarsimp simp: bspec_split [OF spec [OF z]]) - apply fastforce - apply (erule e) - apply (simp add: thread_gets_the_all_def, wp+) - apply clarsimp - apply (frule(1) tcb_at_is_etcb_at) - apply (clarsimp simp add: tcb_at_def get_etcb_def obj_at_def) - apply (drule get_tcb_SomeD) - apply fastforce - apply simp - done - -lemmas thread_set_all_corres = - thread_set_all_corresT [OF _ _ all_tcbI, OF _ ball_tcb_cap_casesI ball_tcb_cte_casesI] - crunch idle_thread[wp]: deleteCallerCap "\s. P (ksIdleThread s)" (wp: crunch_wps) crunch sch_act_simple: deleteCallerCap sch_act_simple @@ -3861,89 +3542,6 @@ lemma setEndpoint_sch_act_not_ct[wp]: setEndpoint ptr val \\_ s. sch_act_not (ksCurThread s) s\" by (rule hoare_weaken_pre, wps setEndpoint_ct', wp, simp) -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 - -lemma cancelAllIPC_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - cancelAllIPC epptr - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - (is "\?PRE\ _ \\_. ?POST\") - apply (simp add: cancelAllIPC_def) - apply (wp, wpc, wp) - apply (wps rescheduleRequired_ct') - apply (wp rescheduleRequired_ksQ') - apply clarsimp - apply (wp cancelAll_ct_not_ksQ_helper mapM_x_wp_inv) - apply (wp hoare_lift_Pf2 [OF setEndpoint_ksQ setEndpoint_ct'])+ - apply (wps rescheduleRequired_ct') - apply (wp rescheduleRequired_ksQ') - apply clarsimp - apply (wp cancelAll_ct_not_ksQ_helper mapM_x_wp_inv) - apply (wp hoare_lift_Pf2 [OF setEndpoint_ksQ setEndpoint_ct'])+ - prefer 2 - apply assumption - apply (rule_tac Q="\ep. ?PRE and ko_at' ep epptr" in hoare_post_imp) - apply (clarsimp) - apply (rule conjI) - apply ((clarsimp simp: invs'_def valid_state'_def - sch_act_sane_def - | drule(1) ct_not_in_epQueue)+)[2] - apply (wp get_ep_sp') - done - -lemma cancelAllSignals_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - cancelAllSignals ntfnptr - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - (is "\?PRE\ _ \\_. ?POST\") - apply (simp add: cancelAllSignals_def) - apply (wp, wpc, wp+) - apply (wps rescheduleRequired_ct') - apply (wp rescheduleRequired_ksQ') - apply clarsimp - apply (wp cancelAll_ct_not_ksQ_helper mapM_x_wp_inv) - apply (wp hoare_lift_Pf2 [OF setNotification_ksQ setNotification_ksCurThread]) - apply (wps setNotification_ksCurThread, wp) - prefer 2 - apply assumption - apply (rule_tac Q="\ep. ?PRE and ko_at' ep ntfnptr" in hoare_post_imp) - apply ((clarsimp simp: invs'_def valid_state'_def sch_act_sane_def - | drule(1) ct_not_in_ntfnQueue)+)[1] - apply (wp get_ntfn_sp') - done - -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 hoare_seq_ext[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 setNotification_ksCurThread, wp) - apply clarsimp - done - lemma sbn_ct_in_state'[wp]: "\ct_in_state' P\ setBoundNotification ntfn t \\_. ct_in_state' P\" apply (simp add: ct_in_state'_def) @@ -3976,37 +3574,6 @@ crunches unbindNotification, unbindMaybeNotification for sch_act_sane[wp]: "sch_act_sane" end -lemma finaliseCapTrue_standin_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - finaliseCapTrue_standin cap final - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - apply (simp add: finaliseCapTrue_standin_def Let_def) - apply (safe) - apply (wp cancelAllIPC_ct_not_ksQ cancelAllSignals_ct_not_ksQ - hoare_drop_imps unbindMaybeNotification_ct_not_ksQ - | wpc - | clarsimp simp: isNotificationCap_def isReplyCap_def split:capability.splits)+ - done - -lemma cteDeleteOne_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - cteDeleteOne slot - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - apply (simp add: cteDeleteOne_def unless_def split_def) - apply (rule hoare_seq_ext [OF _ getCTE_sp]) - apply (case_tac "\final. finaliseCap (cteCap cte) final True = fail") - apply (simp add: finaliseCapTrue_standin_simple_def) - apply wp - apply (clarsimp) - apply (wp emptySlot_cteCaps_of hoare_lift_Pf2 [OF emptySlot_ksRQ emptySlot_ct]) - apply (simp add: cteCaps_of_def) - apply (wp (once) hoare_drop_imps) - apply (wp finaliseCapTrue_standin_ct_not_ksQ isFinalCapability_inv)+ - apply (clarsimp) - done - end end diff --git a/proof/refine/ARM/Init_R.thy b/proof/refine/ARM/Init_R.thy index 0a530b3998..6192b6c601 100644 --- a/proof/refine/ARM/Init_R.thy +++ b/proof/refine/ARM/Init_R.thy @@ -95,7 +95,7 @@ definition zeroed_intermediate_state :: ksDomSchedule = [], ksCurDomain = 0, ksDomainTime = 0, - ksReadyQueues = K [], + ksReadyQueues = K (TcbQueue None None), ksReadyQueuesL1Bitmap = K 0, ksReadyQueuesL2Bitmap = K 0, ksCurThread = 0, @@ -116,9 +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: ekheap_relation_def) - apply (clarsimp simp: ready_queues_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 5d5bd979c7..d01a725e25 100644 --- a/proof/refine/ARM/InterruptAcc_R.thy +++ b/proof/refine/ARM/InterruptAcc_R.thy @@ -52,14 +52,13 @@ lemma setIRQState_invs[wp]: apply (simp add: setIRQState_def setInterruptState_def getInterruptState_def) apply (wp dmo_maskInterrupt) apply (clarsimp simp: invs'_def valid_state'_def cur_tcb'_def - Invariants_H.valid_queues_def valid_queues'_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) + bitmapQ_defs valid_bitmaps_def) apply (rule conjI, clarsimp) apply (clarsimp simp: irqs_masked'_def ct_not_inQ_def) apply (rule conjI) @@ -149,8 +148,7 @@ lemma invs'_irq_state_independent [simp, intro!]: 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_queues_no_bitmap_def - valid_queues'_def valid_pde_mappings'_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 diff --git a/proof/refine/ARM/Interrupt_R.thy b/proof/refine/ARM/Interrupt_R.thy index 7394b96018..cd04d7b08d 100644 --- a/proof/refine/ARM/Interrupt_R.thy +++ b/proof/refine/ARM/Interrupt_R.thy @@ -617,13 +617,6 @@ lemma decDomainTime_corres: apply (clarsimp simp:state_relation_def) done -lemma tcbSchedAppend_valid_objs': - "\valid_objs'\tcbSchedAppend t \\r. valid_objs'\" - apply (simp add:tcbSchedAppend_def) - apply (wpsimp wp: unless_wp threadSet_valid_objs' threadGet_wp) - apply (clarsimp simp add:obj_at'_def typ_at'_def) - done - lemma thread_state_case_if: "(case state of Structures_A.thread_state.Running \ f | _ \ g) = (if state = Structures_A.thread_state.Running then f else g)" @@ -634,35 +627,27 @@ lemma threadState_case_if: (if state = Structures_H.thread_state.Running then f else g)" by (case_tac state,auto) -lemma tcbSchedAppend_invs_but_ct_not_inQ': - "\invs' and st_tcb_at' runnable' t \ - tcbSchedAppend t \\_. all_invs_but_ct_not_inQ'\" - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp 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 - | fastforce elim!: st_tcb_ex_cap'' split: thread_state.split_asm)+ - done +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 timerTick_corres: - "corres dc (cur_tcb and valid_sched) - invs' - timer_tick timerTick" - supply if_weak_cong[cong] + "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="\ and (cur_tcb and valid_sched)" and Q'="\ and invs'" in corres_guard_imp) + 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_split[where r' = dc]) apply (rule corres_if[where Q = \ and Q' = \]) apply (case_tac state,simp_all)[1] - apply (simp add: Let_def) apply (rule_tac r'="(=)" in corres_split[OF ethreadget_corres]) apply (simp add:etcb_relation_def) apply (rename_tac ts ts') @@ -672,55 +657,53 @@ lemma timerTick_corres: apply (rule ethread_set_corres, simp+) apply (clarsimp simp: etcb_relation_def) apply simp - apply (rule corres_split) - apply (rule ethread_set_corres; simp) - apply (simp add: etcb_relation_def) - apply (rule corres_split[OF tcbSchedAppend_corres]) + 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)[1] - apply (rule hoare_strengthen_post) - apply (rule tcbSchedAppend_invs_but_ct_not_inQ', - clarsimp simp: sch_act_wf_weak) - apply (wp threadSet_timeslice_invs threadSet_valid_queues - threadSet_valid_queues' threadSet_pred_tcb_at_state)+ - apply simp - apply simp - apply (rule corres_when,simp) + 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 (simp add:dec_domain_time_def) - apply wp+ - apply (simp add:decDomainTime_def) - apply wp - apply (wp|wpc|unfold Let_def|simp)+ - apply (wp hoare_weak_lift_imp threadSet_timeslice_invs threadSet_valid_queues threadSet_valid_queues' - threadSet_pred_tcb_at_state threadSet_weak_sch_act_wf tcbSchedAppend_valid_objs' - rescheduleRequired_weak_sch_act_wf tcbSchedAppend_valid_queues| simp)+ - apply (strengthen sch_act_wf_weak) - apply (clarsimp simp:conj_comms) - apply (wp tcbSchedAppend_valid_queues tcbSchedAppend_sch_act_wf) - apply simp - apply (wp threadSet_valid_queues threadSet_pred_tcb_at_state threadSet_sch_act - threadSet_tcbDomain_triv threadSet_valid_queues' threadSet_valid_objs'| simp)+ - apply (wp threadGet_wp gts_wp gts_wp')+ - apply (clarsimp simp: cur_tcb_def tcb_at_is_etcb_at valid_sched_def valid_sched_action_def) - prefer 2 - apply clarsimp - apply (clarsimp simp add:cur_tcb_def valid_sched_def - valid_sched_action_def valid_etcbs_def is_tcb_def - is_etcb_at_def st_tcb_at_def obj_at_def - dest!:get_tcb_SomeD) - apply (clarsimp simp: invs'_def valid_state'_def - sch_act_wf_weak - cur_tcb'_def inQ_def - ct_in_state'_def obj_at'_def) - apply (clarsimp simp:st_tcb_at'_def - valid_idle'_def ct_idle_or_in_cur_domain'_def - obj_at'_def projectKO_eq) - apply simp + 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] @@ -772,7 +755,7 @@ lemma handleInterrupt_corres: apply (rule corres_machine_op) apply (rule corres_eq_trivial, (simp add: no_fail_ackInterrupt)+) apply wp+ - apply clarsimp + apply fastforce apply clarsimp done @@ -801,16 +784,6 @@ lemma updateTimeSlice_sch_act_wf[wp]: \\r s. sch_act_wf (ksSchedulerAction s) s\" by (wp threadSet_sch_act,simp) - -lemma updateTimeSlice_valid_queues[wp]: - "\\s. Invariants_H.valid_queues s \ - threadSet (tcbTimeSlice_update (\_. ts')) thread - \\r s. Invariants_H.valid_queues s\" - apply (wp threadSet_valid_queues,simp) - apply (clarsimp simp:obj_at'_def inQ_def) - done - - (* catch up tcbSchedAppend to tcbSchedEnqueue, which has these from crunches on possibleSwitchTo *) crunch irq_handlers'[wp]: tcbSchedAppend valid_irq_handlers' (simp: unless_def tcb_cte_cases_def wp: crunch_wps) @@ -820,29 +793,29 @@ crunch ct[wp]: tcbSchedAppend cur_tcb' (wp: cur_tcb_lift crunch_wps) lemma timerTick_invs'[wp]: - "\invs'\ timerTick \\rv. invs'\" + "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 - tcbSchedAppend_invs_but_ct_not_inQ' - simp: tcb_cte_cases_def) - apply (rule_tac Q="\rv. invs'" in hoare_post_imp) - apply (clarsimp simp add:invs'_def valid_state'_def) + 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' - del: tcbSchedAppend_sch_act_wf)+ - apply (rule hoare_strengthen_post[OF tcbSchedAppend_invs_but_ct_not_inQ']) - apply (wpsimp simp: valid_pspace'_def sch_act_wf_weak)+ - apply (wpsimp wp: threadSet_pred_tcb_no_state threadSet_tcbDomain_triv - threadSet_valid_objs' threadSet_timeslice_invs)+ - apply (wp threadGet_wp) + 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 (clarsimp simp: invs'_def st_tcb_at'_def obj_at'_def valid_state'_def) + apply (auto simp: invs'_def st_tcb_at'_def obj_at'_def valid_state'_def cong: conj_cong) done lemma resetTimer_invs'[wp]: diff --git a/proof/refine/ARM/InvariantUpdates_H.thy b/proof/refine/ARM/InvariantUpdates_H.thy index 938a45b494..1e6db0685c 100644 --- a/proof/refine/ARM/InvariantUpdates_H.thy +++ b/proof/refine/ARM/InvariantUpdates_H.thy @@ -38,8 +38,9 @@ lemma invs'_machine: proof - show ?thesis apply (cases "ksSchedulerAction s") - 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_queues_def valid_queues_no_bitmap_def bitmapQ_defs + 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 @@ -56,12 +57,13 @@ lemma invs_no_cicd'_machine: 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_queues_def valid_queues_no_bitmap_def bitmapQ_defs - vms ct_not_inQ_def - state_refs_of'_def ps_clear_def - valid_irq_node'_def mask - cong: option.case_cong) + 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) done qed @@ -98,14 +100,9 @@ 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_queues_ksSchedulerAction_update[simp]: - "valid_queues (ksSchedulerAction_update f s) = valid_queues s" - unfolding valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs - by simp - -lemma valid_queues'_ksSchedulerAction_update[simp]: - "valid_queues' (ksSchedulerAction_update f s) = valid_queues' s" - by (simp add: valid_queues'_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'" @@ -140,45 +137,25 @@ lemma tcb_in_cur_domain_ct[simp]: "tcb_in_cur_domain' t (ksCurThread_update f s) = tcb_in_cur_domain' t s" by (fastforce simp: tcb_in_cur_domain'_def) -lemma valid_queues'_ksCurDomain[simp]: - "valid_queues' (ksCurDomain_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) - -lemma valid_queues'_ksDomScheduleIdx[simp]: - "valid_queues' (ksDomScheduleIdx_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) +lemma valid_bitmaps_ksCurDomain[simp]: + "valid_bitmaps (ksCurDomain_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) -lemma valid_queues'_ksDomSchedule[simp]: - "valid_queues' (ksDomSchedule_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) +lemma valid_bitmaps_ksDomScheduleIdx[simp]: + "valid_bitmaps (ksDomScheduleIdx_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) -lemma valid_queues'_ksDomainTime[simp]: - "valid_queues' (ksDomainTime_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) +lemma valid_bitmaps_ksDomSchedule[simp]: + "valid_bitmaps (ksDomSchedule_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) -lemma valid_queues'_ksWorkUnitsCompleted[simp]: - "valid_queues' (ksWorkUnitsCompleted_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) +lemma valid_bitmaps_ksDomainTime[simp]: + "valid_bitmaps (ksDomainTime_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) -lemma valid_queues_ksCurDomain[simp]: - "valid_queues (ksCurDomain_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_ksDomScheduleIdx[simp]: - "valid_queues (ksDomScheduleIdx_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_ksDomSchedule[simp]: - "valid_queues (ksDomSchedule_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_ksDomainTime[simp]: - "valid_queues (ksDomainTime_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_ksWorkUnitsCompleted[simp]: - "valid_queues (ksWorkUnitsCompleted_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) +lemma valid_bitmaps_ksWorkUnitsCompleted[simp]: + "valid_bitmaps (ksWorkUnitsCompleted_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) lemma valid_irq_node'_ksCurDomain[simp]: "valid_irq_node' w (ksCurDomain_update f s) = valid_irq_node' w s" @@ -255,6 +232,10 @@ lemma valid_mdb_interrupts'[simp]: "valid_mdb' (ksInterruptState_update f s) = valid_mdb' s" by (simp add: valid_mdb'_def) +lemma valid_mdb'_ksReadyQueues_update[simp]: + "valid_mdb' (ksReadyQueues_update f s) = valid_mdb' s" + by (simp add: valid_mdb'_def) + lemma vms_ksReadyQueues_update[simp]: "valid_machine_state' (ksReadyQueues_update f s) = valid_machine_state' s" by (simp add: valid_machine_state'_def) @@ -279,10 +260,10 @@ lemma ct_in_state_ksSched[simp]: lemma invs'_wu [simp]: "invs' (ksWorkUnitsCompleted_update f s) = invs' s" - apply (simp add: invs'_def cur_tcb'_def valid_state'_def Invariants_H.valid_queues_def - valid_queues'_def valid_irq_node'_def valid_machine_state'_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 valid_queues_no_bitmap_def) + bitmapQ_defs) done lemma valid_arch_state'_interrupt[simp]: @@ -334,9 +315,8 @@ lemma sch_act_simple_ksReadyQueuesL2Bitmap[simp]: lemma ksDomainTime_invs[simp]: "invs' (ksDomainTime_update f s) = invs' s" - 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) + 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" @@ -364,9 +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 valid_state'_def valid_queues_def valid_queues'_def - valid_irq_node'_def cur_tcb'_def ct_idle_or_in_cur_domain'_def - tcb_in_cur_domain'_def valid_queues_no_bitmap_def - bitmapQ_no_L2_orphans_def bitmapQ_no_L1_orphans_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 \ No newline at end of file diff --git a/proof/refine/ARM/Invariants_H.thy b/proof/refine/ARM/Invariants_H.thy index 70718807a6..cd883e784f 100644 --- a/proof/refine/ARM/Invariants_H.thy +++ b/proof/refine/ARM/Invariants_H.thy @@ -10,6 +10,7 @@ imports "AInvs.Deterministic_AI" "AInvs.AInvs" "Lib.AddUpdSimps" + Lib.Heap_List begin context Arch begin @@ -158,6 +159,21 @@ definition abbreviation "cte_at' \ cte_wp_at' \" +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 tcbSchedPrevs_of :: "kernel_state \ obj_ref \ obj_ref option" where + "tcbSchedPrevs_of s \ tcbs_of' s |> tcbSchedPrev" + +abbreviation tcbSchedNexts_of :: "kernel_state \ obj_ref \ obj_ref option" where + "tcbSchedNexts_of s \ tcbs_of' s |> tcbSchedNext" + +abbreviation sym_heap_sched_pointers :: "global.kernel_state \ bool" where + "sym_heap_sched_pointers s \ sym_heap (tcbSchedNexts_of s) (tcbSchedPrevs_of s)" + definition tcb_cte_cases :: "word32 \ ((tcb \ cte) \ ((cte \ cte) \ tcb \ tcb))" where @@ -232,13 +248,14 @@ where then refs_of' ko else {}))" - primrec live' :: "Structures_H.kernel_object \ bool" where "live' (KOTCB tcb) = - (bound (tcbBoundNotification 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) = (bound (ntfnBoundTCB ntfn) \ (\ts. ntfnObj ntfn = WaitingNtfn ts))" @@ -479,6 +496,11 @@ 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' :: "Structures_H.tcb \ kernel_state \ bool" where @@ -488,7 +510,9 @@ where \ valid_bound_ntfn' (tcbBoundNotification t) s \ tcbDomain t \ maxDomain \ tcbPriority t \ maxPriority - \ tcbMCP 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" @@ -866,10 +890,15 @@ where | "runnable' (Structures_H.BlockedOnSend a b c d e) = False" | "runnable' (Structures_H.BlockedOnNotification x) = False" -definition - inQ :: "domain \ priority \ tcb \ bool" -where - "inQ d p tcb \ tcbQueued tcb \ tcbPriority tcb = p \ tcbDomain tcb = d" +definition inQ :: "domain \ priority \ tcb \ bool" where + "inQ d p tcb \ tcbQueued tcb \ tcbPriority tcb = p \ tcbDomain tcb = d" + +lemma inQ_implies_tcbQueueds_of: + "(inQ domain priority |< tcbs_of' s') tcbPtr \ (tcbQueued |< tcbs_of' s') tcbPtr" + by (clarsimp simp: opt_map_def opt_pred_def inQ_def split: option.splits) + +defs ready_qs_runnable_def: + "ready_qs_runnable s \ \t. obj_at' tcbQueued t s \ st_tcb_at' runnable' t s" definition (* for given domain and priority, the scheduler bitmap indicates a thread is in the queue *) @@ -879,15 +908,6 @@ where "bitmapQ d p s \ ksReadyQueuesL1Bitmap s d !! prioToL1Index p \ ksReadyQueuesL2Bitmap s (d, invertL1Index (prioToL1Index p)) !! unat (p && mask wordRadix)" - -definition - valid_queues_no_bitmap :: "kernel_state \ bool" -where - "valid_queues_no_bitmap \ \s. - (\d p. (\t \ set (ksReadyQueues s (d, p)). obj_at' (inQ d p and runnable' \ tcbState) t s) - \ distinct (ksReadyQueues s (d, p)) - \ (d > maxDomain \ p > maxPriority \ ksReadyQueues s (d,p) = []))" - 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 @@ -911,31 +931,62 @@ where \d i. ksReadyQueuesL1Bitmap s d !! i \ ksReadyQueuesL2Bitmap s (d, invertL1Index i) \ 0 \ i < l2BitmapSize" -definition - valid_bitmapQ :: "kernel_state \ bool" -where - "valid_bitmapQ \ \s. (\d p. bitmapQ d p s \ ksReadyQueues s (d,p) \ [])" +definition valid_bitmapQ :: "kernel_state \ bool" where + "valid_bitmapQ \ \s. \d p. bitmapQ d p s \ \ tcbQueueEmpty (ksReadyQueues s (d,p))" -definition - valid_queues :: "kernel_state \ bool" -where - "valid_queues \ \s. valid_queues_no_bitmap s \ valid_bitmapQ s \ - bitmapQ_no_L2_orphans s \ bitmapQ_no_L1_orphans s" +definition valid_bitmaps :: "kernel_state \ bool" where + "valid_bitmaps \ \s. valid_bitmapQ s \ bitmapQ_no_L2_orphans s \ bitmapQ_no_L1_orphans s" -definition - (* when a thread gets added to / removed from a queue, but before bitmap updated *) - valid_bitmapQ_except :: "domain \ priority \ kernel_state \ bool" -where +lemma valid_bitmaps_valid_bitmapQ[elim!]: + "valid_bitmaps s \ valid_bitmapQ s" + by (simp add: valid_bitmaps_def) + +lemma valid_bitmaps_bitmapQ_no_L2_orphans[elim!]: + "valid_bitmaps s \ bitmapQ_no_L2_orphans s" + by (simp add: valid_bitmaps_def) + +lemma valid_bitmaps_bitmapQ_no_L1_orphans[elim!]: + "valid_bitmaps s \ bitmapQ_no_L1_orphans s" + by (simp add: valid_bitmaps_def) + +lemma valid_bitmaps_lift: + assumes prq: "\P. f \\s. P (ksReadyQueues s)\" + assumes prqL1: "\P. f \\s. P (ksReadyQueuesL1Bitmap s)\" + assumes prqL2: "\P. f \\s. P (ksReadyQueuesL2Bitmap s)\" + shows "f \valid_bitmaps\" + unfolding valid_bitmaps_def valid_bitmapQ_def bitmapQ_def + bitmapQ_no_L1_orphans_def bitmapQ_no_L2_orphans_def + apply (rule hoare_pre) + apply (wps assms | wpsimp)+ + done + +(* when a thread gets added to / removed from a queue, but before bitmap updated *) +definition valid_bitmapQ_except :: "domain \ priority \ kernel_state \ bool" where "valid_bitmapQ_except d' p' \ \s. - (\d p. (d \ d' \ p \ p') \ (bitmapQ d p s \ ksReadyQueues s (d,p) \ []))" + \d p. (d \ d' \ p \ p') \ (bitmapQ d p s \ \ tcbQueueEmpty (ksReadyQueues s (d,p)))" lemmas bitmapQ_defs = valid_bitmapQ_def valid_bitmapQ_except_def bitmapQ_def bitmapQ_no_L2_orphans_def bitmapQ_no_L1_orphans_def -definition - valid_queues' :: "kernel_state \ bool" -where - "valid_queues' \ \s. \d p t. obj_at' (inQ d p) t s \ t \ set (ksReadyQueues s (d, p))" +\ \ + The tcbSchedPrev and tcbSchedNext fields of a TCB are used only to indicate membership in + one of the ready queues. \ +definition valid_sched_pointers_2 :: + "(obj_ref \ obj_ref) \ (obj_ref \ obj_ref) \ (obj_ref \ bool) \ bool " + where + "valid_sched_pointers_2 prevs nexts ready \ + \ptr. prevs ptr \ None \ nexts ptr \ None \ ready ptr" + +abbreviation valid_sched_pointers :: "kernel_state \ bool" where + "valid_sched_pointers s \ + valid_sched_pointers_2 (tcbSchedPrevs_of s) (tcbSchedNexts_of s) (tcbQueued |< tcbs_of' s)" + +lemmas valid_sched_pointers_def = valid_sched_pointers_2_def + +lemma valid_sched_pointersD: + "\valid_sched_pointers s; \ (tcbQueued |< tcbs_of' s) t\ + \ tcbSchedPrevs_of s t = None \ tcbSchedNexts_of s t = None" + by (fastforce simp: valid_sched_pointers_def in_opt_pred opt_map_red) 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" @@ -1152,7 +1203,7 @@ definition valid_state' :: "kernel_state \ bool" where "valid_state' \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s - \ valid_queues s \ sym_refs (state_refs_of' 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 @@ -1161,7 +1212,9 @@ where \ valid_irq_states' s \ valid_machine_state' s \ irqs_masked' s - \ valid_queues' 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 @@ -1213,6 +1266,11 @@ definition abbreviation "active' st \ st = Structures_H.Running \ st = Structures_H.Restart" +lemma runnable_eq_active': "runnable' = active'" + apply (rule ext) + apply (case_tac st, simp_all) + done + abbreviation "simple' st \ st = Structures_H.Inactive \ st = Structures_H.Running \ @@ -1228,11 +1286,12 @@ abbreviation abbreviation(input) "all_invs_but_sym_refs_ct_not_inQ' \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s - \ valid_queues s \ if_live_then_nonz_cap' s \ if_unsafe_then_cap' 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 - \ cur_tcb' s \ valid_queues' s \ ct_idle_or_in_cur_domain' s \ valid_pde_mappings' 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" @@ -1240,12 +1299,13 @@ abbreviation(input) abbreviation(input) "all_invs_but_ct_not_inQ' \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s - \ valid_queues s \ sym_refs (state_refs_of' 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 - \ cur_tcb' s \ valid_queues' s \ ct_idle_or_in_cur_domain' s \ valid_pde_mappings' 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" @@ -1261,12 +1321,13 @@ lemma all_invs_but_not_ct_inQ_check': definition "all_invs_but_ct_idle_or_in_cur_domain' \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s - \ valid_queues s \ sym_refs (state_refs_of' 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 - \ cur_tcb' s \ valid_queues' s \ ct_not_inQ s \ valid_pde_mappings' 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" @@ -2990,9 +3051,9 @@ lemma sch_act_wf_arch [simp]: "sch_act_wf sa (ksArchState_update f s) = sch_act_wf sa s" by (cases sa) (simp_all add: ct_in_state'_def tcb_in_cur_domain'_def) -lemma valid_queues_arch [simp]: - "valid_queues (ksArchState_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) +lemma valid_bitmaps_arch[simp]: + "valid_bitmaps (ksArchState_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) lemma if_unsafe_then_cap_arch' [simp]: "if_unsafe_then_cap' (ksArchState_update f s) = if_unsafe_then_cap' s" @@ -3010,22 +3071,14 @@ lemma sch_act_wf_machine_state [simp]: "sch_act_wf sa (ksMachineState_update f s) = sch_act_wf sa s" by (cases sa) (simp_all add: ct_in_state'_def tcb_in_cur_domain'_def) -lemma valid_queues_machine_state [simp]: - "valid_queues (ksMachineState_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_arch' [simp]: - "valid_queues' (ksArchState_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) - -lemma valid_queues_machine_state' [simp]: - "valid_queues' (ksMachineState_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) - lemma valid_irq_node'_machine_state [simp]: "valid_irq_node' x (ksMachineState_update f s) = valid_irq_node' x s" by (simp add: valid_irq_node'_def) +lemma valid_bitmaps_machine_state[simp]: + "valid_bitmaps (ksMachineState_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) + (* these should be reasonable safe for automation because of the 0 pattern *) lemma no_0_ko_wp' [elim!]: "\ ko_wp_at' Q 0 s; no_0_obj' s \ \ P" @@ -3099,19 +3152,6 @@ lemma objBitsT_koTypeOf : pteBits_def pdeBits_def) done -lemma valid_queues_obj_at'D: - "\ t \ set (ksReadyQueues s (d, p)); valid_queues s \ - \ obj_at' (inQ d p) t s" - apply (unfold valid_queues_def valid_queues_no_bitmap_def) - apply (elim conjE) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE) - apply (clarsimp) - done - lemma obj_at'_and: "obj_at' (P and P') t s = (obj_at' P t s \ obj_at' P' t s)" by (rule iffI, (clarsimp simp: obj_at'_def)+) @@ -3149,16 +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 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 \ st_tcb_at' runnable' t s) \ - distinct (ksReadyQueues s (d, p)) \ (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) @@ -3239,8 +3269,16 @@ lemma invs_sch_act_wf' [elim!]: "invs' s \ sch_act_wf (ksSchedulerAction s) s" by (simp add: invs'_def valid_state'_def) -lemma invs_queues [elim!]: - "invs' s \ valid_queues s" +lemma invs_valid_bitmaps[elim!]: + "invs' s \ valid_bitmaps s" + by (simp add: invs'_def valid_state'_def) + +lemma invs_sym_heap_sched_pointers[elim!]: + "invs' s \ sym_heap_sched_pointers s" + by (simp add: invs'_def valid_state'_def) + +lemma invs_valid_sched_pointers[elim!]: + "invs' s \ valid_sched_pointers s" by (simp add: invs'_def valid_state'_def) lemma invs_valid_idle'[elim!]: @@ -3257,7 +3295,7 @@ lemma invs'_invs_no_cicd: lemma invs'_bitmapQ_no_L1_orphans: "invs' s \ bitmapQ_no_L1_orphans s" - by (drule invs_queues, simp add: valid_queues_def) + by (simp add: invs'_def valid_state'_def valid_bitmaps_def) lemma invs_ksCurDomain_maxDomain' [elim!]: "invs' s \ ksCurDomain s \ maxDomain" @@ -3282,24 +3320,22 @@ lemma invs_no_0_obj'[elim!]: lemma invs'_gsCNodes_update[simp]: "invs' (gsCNodes_update f s') = invs' s'" - apply (clarsimp simp: invs'_def valid_state'_def valid_queues_def valid_queues_no_bitmap_def - bitmapQ_defs - valid_queues'_def 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'") - apply (simp_all add: ct_in_state'_def tcb_in_cur_domain'_def ct_idle_or_in_cur_domain'_def ct_not_inQ_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_state'_def valid_queues_def valid_queues_no_bitmap_def - bitmapQ_defs - valid_queues'_def 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'") - apply (simp_all add: ct_in_state'_def ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def ct_not_inQ_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: @@ -3315,7 +3351,7 @@ lemma invs'_ksDomScheduleIdx: unfolding invs'_def valid_state'_def by clarsimp lemma valid_bitmap_valid_bitmapQ_exceptE: - "\ valid_bitmapQ_except d p s ; (bitmapQ d p s \ ksReadyQueues s (d,p) \ []) ; + "\ valid_bitmapQ_except d p s; bitmapQ d p s \ \ tcbQueueEmpty (ksReadyQueues s (d,p)); bitmapQ_no_L2_orphans s \ \ valid_bitmapQ s" unfolding valid_bitmapQ_def valid_bitmapQ_except_def diff --git a/proof/refine/ARM/IpcCancel_R.thy b/proof/refine/ARM/IpcCancel_R.thy index aaf563b9a8..b2ffe21508 100644 --- a/proof/refine/ARM/IpcCancel_R.thy +++ b/proof/refine/ARM/IpcCancel_R.thy @@ -48,25 +48,6 @@ lemma set_ep_pred_tcb_at' [wp]: apply (simp add: updateObject_default_def in_monad projectKOs) done -(* valid_queues is too strong *) -definition valid_inQ_queues :: "KernelStateData_H.kernel_state \ bool" where - "valid_inQ_queues \ - \s. \d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) \ distinct (ksReadyQueues s (d, p))" - -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_inQ_queues_ksReadyQueuesL1Bitmap_upd[simp]: - "valid_inQ_queues (ksReadyQueuesL1Bitmap_update f s) = valid_inQ_queues s" - unfolding valid_inQ_queues_def - by simp - -lemma valid_inQ_queues_ksReadyQueuesL2Bitmap_upd[simp]: - "valid_inQ_queues (ksReadyQueuesL2Bitmap_update f s) = valid_inQ_queues s" - unfolding valid_inQ_queues_def - by simp - defs capHasProperty_def: "capHasProperty ptr P \ cte_wp_at' (\c. P (cteCap c)) ptr" end @@ -83,11 +64,6 @@ locale delete_one_conc_pre = "\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_queues: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - cteDeleteOne sl \\rv. Invariants_H.valid_queues\" - assumes delete_one_inQ_queues: - "\valid_inQ_queues\ cteDeleteOne sl \\rv. valid_inQ_queues\" assumes delete_one_sch_act_simple: "\sch_act_simple\ cteDeleteOne sl \\rv. sch_act_simple\" assumes delete_one_sch_act_not: @@ -343,6 +319,7 @@ lemma cancelSignal_corres: apply fastforce apply (clarsimp simp: valid_obj_def valid_tcb_def valid_tcb_state_def) apply (drule sym, simp add: obj_at_def) + apply fastforce apply (clarsimp simp: conj_comms pred_tcb_at' cong: conj_cong) apply (rule conjI) apply (simp add: pred_tcb_at'_def) @@ -547,12 +524,12 @@ lemma (in delete_one) cancelIPC_ReplyCap_corres: and Q'="\_. invs' and st_tcb_at' awaiting_reply' t" in corres_underlying_split) apply (rule corres_guard_imp) - apply (rule threadset_corresT) + 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 (clarsimp simp: st_tcb_at_tcb_at) + apply (fastforce simp: st_tcb_at_tcb_at) apply clarsimp defer apply (wp thread_set_invs_trivial thread_set_no_change_tcb_state @@ -639,7 +616,7 @@ lemma (in delete_one) cancel_ipc_corres: apply (rule hoare_strengthen_post) apply (rule gts_sp'[where P="\"]) apply (clarsimp elim!: pred_tcb'_weakenE) - apply simp + apply fastforce apply simp done @@ -671,16 +648,15 @@ lemma sch_act_simple_not_t[simp]: "sch_act_simple s \ sch_act_no context begin interpretation Arch . (*FIXME: arch_split*) +crunches setNotification + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_bitmaps[wp]: valid_bitmaps + (wp: valid_bitmaps_lift) + lemma cancelSignal_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. \ Invariants_H.valid_queues s; st_tcb_at' (Not \ runnable') t s \ - \ \x. t \ set (ksReadyQueues s x)" - 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\" @@ -691,9 +667,9 @@ lemma cancelSignal_invs': show ?thesis 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 setNotification_ksQ] sts_valid_queues + hoare_vcg_all_lift setThreadState_ct_not_inQ NTFNSN - hoare_vcg_all_lift setNotification_ksQ + hoare_vcg_all_lift | simp add: valid_tcb_state'_def list_case_If split del: if_split)+ prefer 2 apply assumption @@ -701,8 +677,6 @@ lemma cancelSignal_invs': apply (rule get_ntfn_sp') apply (rename_tac rv s) apply (clarsimp simp: pred_tcb_at') - apply (frule NIQ) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) apply (rule conjI) apply (clarsimp simp: valid_ntfn'_def) apply (case_tac "ntfnObj rv", simp_all add: isWaitingNtfn_def) @@ -742,9 +716,10 @@ lemma cancelSignal_invs': 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 r") + 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) @@ -810,23 +785,25 @@ lemma setEndpoint_ct_not_inQ[wp]: done lemma setEndpoint_ksDomScheduleIdx[wp]: - "\\s. P (ksDomScheduleIdx s)\ setEndpoint ptr ep \\_ s. P (ksDomScheduleIdx s)\" + "setEndpoint ptr ep \\s. P (ksDomScheduleIdx s)\" apply (simp add: setEndpoint_def setObject_def split_def) apply (wp updateObject_default_inv | simp)+ done + end +crunches 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 NIQ: "\s. \ Invariants_H.valid_queues s; st_tcb_at' (Not \ runnable') t s \ - \ \x. t \ set (ksReadyQueues s x)" - 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 EPSCHN: "\eeptr ep'. \\s. sch_act_not (ksCurThread s) s\ setEndpoint eeptr ep' \\_ s. sch_act_not (ksCurThread s) s\" @@ -851,8 +828,8 @@ proof - 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] - sts_valid_queues setThreadState_ct_not_inQ EPSCHN - hoare_vcg_all_lift setNotification_ksQ + setThreadState_ct_not_inQ EPSCHN + hoare_vcg_all_lift | simp add: valid_tcb_state'_def split del: if_split | wpc)+ prefer 2 @@ -860,14 +837,14 @@ proof - 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 (frule NIQ) - apply (erule pred_tcb'_weakenE, fastforce) apply (clarsimp, rule conjI) apply (auto simp: pred_tcb_at'_def obj_at'_def)[1] apply (rule conjI) @@ -1054,31 +1031,6 @@ apply (wp hoare_vcg_conj_lift delete_one_ksCurDomain | simp add: getThreadReplySlot_def o_def if_fun_split)+ done -(* FIXME move *) -lemma tcbSchedEnqueue_not_st: - "(\tcb st qd. P (tcb\tcbState := st, tcbQueued := qd\) \ P tcb) - \ \obj_at' P t'\ tcbSchedEnqueue t \\_. obj_at' P t'\" -apply (simp add: tcbSchedEnqueue_def unless_def) -apply (wp threadGet_wp | simp)+ -apply (clarsimp simp: obj_at'_def) -apply (case_tac obja) -apply fastforce -done - -(* FIXME move *) -lemma setThreadState_not_st: - "(\tcb st qd. P (tcb\tcbState := st, tcbQueued := qd\) \ P tcb) - \ \obj_at' P t'\ setThreadState st t \\_. obj_at' P t'\" -apply (simp add: setThreadState_def rescheduleRequired_def) -apply (wp hoare_vcg_conj_lift tcbSchedEnqueue_not_st - | wpc - | rule hoare_drop_imps - | simp)+ -apply (clarsimp simp: obj_at'_def) -apply (case_tac obj) -apply fastforce -done - (* FIXME move *) lemma setBoundNotification_not_ntfn: "(\tcb ntfn. P (tcb\tcbBoundNotification := ntfn\) \ P tcb) @@ -1090,15 +1042,6 @@ lemma setBoundNotification_not_ntfn: | simp)+ done -(* FIXME move *) -lemma setThreadState_tcb_in_cur_domain'[wp]: - "\tcb_in_cur_domain' t'\ setThreadState st t \\_. tcb_in_cur_domain' t'\" -apply (simp add: tcb_in_cur_domain'_def) -apply (rule hoare_pre) -apply wps -apply (wp setThreadState_not_st | simp)+ -done - 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) @@ -1107,30 +1050,33 @@ lemma setBoundNotification_tcb_in_cur_domain'[wp]: apply (wp setBoundNotification_not_ntfn | simp)+ done -lemma cancelSignal_tcb_obj_at': - "(\tcb st qd. P (tcb\tcbState := st, tcbQueued := qd\) \ P tcb) - \ \obj_at' P t'\ cancelSignal t word \\_. obj_at' P t'\" -apply (simp add: cancelSignal_def setNotification_def) -apply (wp setThreadState_not_st getNotification_wp | wpc | simp)+ -done + +lemma setThreadState_tcbDomain_obj_at'[wp]: + "setThreadState ts t \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding setThreadState_def + by wpsimp + +crunches 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 (simp add: cancelIPC_def Let_def) -apply (wp hoare_vcg_conj_lift - setThreadState_not_st delete_one_tcbDomain_obj_at' cancelSignal_tcb_obj_at' - | wpc - | rule hoare_drop_imps - | simp add: getThreadReplySlot_def o_def if_fun_split)+ -done + 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': "\tcb_in_cur_domain' t'\ cancelIPC t \\_. tcb_in_cur_domain' t'\" -apply (simp add: tcb_in_cur_domain'_def) -apply (rule hoare_pre) -apply wps -apply (wp cancelIPC_tcbDomain_obj_at' | simp)+ -done + apply (simp add: tcb_in_cur_domain'_def) + apply (rule hoare_pre) + apply wps + 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'\" @@ -1225,190 +1171,54 @@ lemma setNotification_weak_sch_act_wf[wp]: lemmas ipccancel_weak_sch_act_wfs = weak_sch_act_wf_lift[OF _ setCTE_pred_tcb_at'] -lemma tcbSchedDequeue_corres': - "corres dc (is_etcb_at t) (tcb_at' t and valid_inQ_queues) (tcb_sched_action (tcb_sched_dequeue) t) (tcbSchedDequeue t)" - apply (simp only: tcbSchedDequeue_def tcb_sched_action_def) - apply (rule corres_symb_exec_r[OF _ _ threadGet_inv, where Q'="\rv. tcb_at' t and valid_inQ_queues and obj_at' (\obj. tcbQueued obj = rv) t"]) - defer - apply (wp threadGet_obj_at', simp, simp) - apply (wp, simp) - apply (case_tac queued) - defer - apply (simp add: unless_def when_def) - apply (rule corres_no_failI) - apply (wp) - apply (clarsimp simp: in_monad ethread_get_def get_etcb_def set_tcb_queue_def is_etcb_at_def state_relation_def gets_the_def gets_def get_def return_def bind_def assert_opt_def get_tcb_queue_def modify_def put_def) - apply (subgoal_tac "t \ set (ready_queues a (tcb_domain y) (tcb_priority y))") - prefer 2 - apply (force simp: tcb_sched_dequeue_def valid_inQ_queues_def - ready_queues_relation_def obj_at'_def inQ_def projectKO_eq project_inject) - apply (simp add: ready_queues_relation_def) - apply (simp add: unless_def when_def) - apply (rule corres_guard_imp) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres, simp add: etcb_relation_def) - apply (simp split del: if_split) - apply (rule corres_split_eqr) - apply (rule ethreadget_corres, simp add: etcb_relation_def) - apply (rule corres_split_eqr[OF getQueue_corres]) - apply (simp split del: if_split) - apply (subst bind_return_unit, rule corres_split[where r'=dc]) - apply (simp add: tcb_sched_dequeue_def) - apply (rule setQueue_corres) - apply (rule corres_split_noop_rhs) - apply (clarsimp, rule removeFromBitmap_corres_noop) - apply (simp add: dc_def[symmetric]) - apply (rule threadSet_corres_noop, simp_all add: tcb_relation_def exst_same_def)[1] - apply (wp | simp)+ - done - -lemma setQueue_valid_inQ_queues: - "\valid_inQ_queues - and (\s. \t \ set ts. obj_at' (inQ d p) t s) - and K (distinct ts)\ - setQueue d p ts - \\_. valid_inQ_queues\" - apply (simp add: setQueue_def valid_inQ_queues_def) - apply wp - apply clarsimp - done - -lemma threadSet_valid_inQ_queues: - "\valid_inQ_queues and (\s. \d p. (\tcb. (inQ d p tcb) \ \(inQ d p (f tcb))) - \ obj_at' (\tcb. (inQ d p tcb) \ \(inQ d p (f tcb))) t s - \ t \ set (ksReadyQueues s (d, p)))\ - threadSet f t - \\rv. valid_inQ_queues\" - apply (simp add: threadSet_def) - apply wp - apply (simp add: valid_inQ_queues_def pred_tcb_at'_def) - apply (wp setObject_queues_unchanged_tcb - hoare_Ball_helper - hoare_vcg_all_lift - setObject_tcb_strongest)[1] - apply (wp getObject_tcb_wp) - apply (clarsimp simp: valid_inQ_queues_def pred_tcb_at'_def) - apply (clarsimp simp: obj_at'_def projectKOs) - apply (fastforce) - done - -(* reorder the threadSet before the setQueue, useful for lemmas that don't refer to bitmap *) -lemma setQueue_after_addToBitmap: - "(setQueue d p q >>= (\rv. (when P (addToBitmap d p)) >>= (\rv. threadSet f t))) = - (when P (addToBitmap d p) >>= (\rv. (threadSet f t) >>= (\rv. setQueue d p q)))" - 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 (simp add: threadSet_def getObject_def setObject_def - loadObject_default_def bitmap_fun_defs - split_def projectKO_def2 alignCheck_assert - magnitudeCheck_assert updateObject_default_def) - apply (intro oblivious_bind, simp_all) - apply (clarsimp simp: bind_assoc) - done - -lemma tcbSchedEnqueue_valid_inQ_queues[wp]: - "\valid_inQ_queues\ tcbSchedEnqueue t \\_. valid_inQ_queues\" - apply (simp add: tcbSchedEnqueue_def setQueue_after_addToBitmap) - apply (rule hoare_pre) - apply (rule_tac B="\rv. valid_inQ_queues and obj_at' (\obj. tcbQueued obj = rv) t" - in hoare_seq_ext) - apply (rename_tac queued) - apply (case_tac queued, simp_all add: unless_def)[1] - apply (wp setQueue_valid_inQ_queues threadSet_valid_inQ_queues threadGet_wp - hoare_vcg_const_Ball_lift - | simp add: inQ_def bitmap_fun_defs - | fastforce simp: valid_inQ_queues_def inQ_def obj_at'_def)+ - done - - (* prevents wp from splitting on the when; stronger technique than hoare_when_weak_wp - FIXME: possible to replace with hoare_when_weak_wp? - *) -definition - "removeFromBitmap_conceal d p q t \ when (null [x\q . x \ t]) (removeFromBitmap d p)" - -lemma rescheduleRequired_valid_inQ_queues[wp]: - "\valid_inQ_queues\ rescheduleRequired \\_. valid_inQ_queues\" - apply (simp add: rescheduleRequired_def) - apply wpsimp - done - -lemma sts_valid_inQ_queues[wp]: - "\valid_inQ_queues\ setThreadState st t \\rv. valid_inQ_queues\" - apply (simp add: setThreadState_def) - apply (wp threadSet_valid_inQ_queues [THEN hoare_strengthen_post]) - apply (clarsimp simp: sch_act_simple_def Invariants_H.valid_queues_def inQ_def)+ - done - lemma updateObject_ep_inv: "\P\ updateObject (obj::endpoint) ko p q n \\rv. P\" by simp (rule updateObject_default_inv) -lemma sbn_valid_inQ_queues[wp]: - "\valid_inQ_queues\ setBoundNotification ntfn t \\rv. valid_inQ_queues\" - apply (simp add: setBoundNotification_def) - apply (wp threadSet_valid_inQ_queues [THEN hoare_strengthen_post]) - apply (clarsimp simp: sch_act_simple_def Invariants_H.valid_queues_def inQ_def)+ +lemma asUser_tcbQueued_inv[wp]: + "\obj_at' (\tcb. P (tcbQueued tcb)) t'\ asUser t m \\_. obj_at' (\tcb. P (tcbQueued tcb)) t'\" + 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 setEndpoint_valid_inQ_queues[wp]: - "\valid_inQ_queues\ setEndpoint ptr ep \\rv. valid_inQ_queues\" - apply (unfold setEndpoint_def) - apply (rule setObject_ep_pre) - apply (simp add: valid_inQ_queues_def) - apply (wp hoare_Ball_helper hoare_vcg_all_lift setObject_queues_unchanged[OF updateObject_ep_inv]) - apply simp - done +context begin interpretation Arch . -lemma set_ntfn_valid_inQ_queues[wp]: - "\valid_inQ_queues\ setNotification ptr ntfn \\rv. valid_inQ_queues\" - apply (unfold setNotification_def) - apply (rule setObject_ntfn_pre) - apply (simp add: valid_inQ_queues_def) - apply (wp hoare_Ball_helper hoare_vcg_all_lift) - apply (clarsimp simp: updateObject_default_def in_monad) - apply (wp updateObject_default_inv | simp)+ - done +crunches cancel_ipc + for pspace_aligned[wp]: "pspace_aligned :: det_state \ _" + and pspace_distinct[wp]: "pspace_distinct :: det_state \ _" + (simp: crunch_simps wp: crunch_wps) -crunch valid_inQ_queues[wp]: cancelSignal valid_inQ_queues - (simp: updateObject_tcb_inv crunch_simps wp: crunch_wps) +end -lemma (in delete_one_conc_pre) cancelIPC_valid_inQ_queues[wp]: - "\valid_inQ_queues\ cancelIPC t \\_. valid_inQ_queues\" - apply (simp add: cancelIPC_def Let_def getThreadReplySlot_def) - apply (wp hoare_drop_imps delete_one_inQ_queues threadSet_valid_inQ_queues | wpc | simp add:if_apply_def2 Fun.comp_def)+ - apply (clarsimp simp: valid_inQ_queues_def inQ_def)+ - done +crunches asUser + for valid_sched_pointers[wp]: valid_sched_pointers + (wp: crunch_wps) -lemma valid_queues_inQ_queues: - "Invariants_H.valid_queues s \ valid_inQ_queues s" - by (force simp: Invariants_H.valid_queues_def valid_inQ_queues_def obj_at'_def - valid_queues_no_bitmap_def) +crunches set_thread_state + for in_correct_ready_q[wp]: in_correct_ready_q + (ignore_del: set_thread_state_ext) -lemma asUser_tcbQueued_inv[wp]: - "\obj_at' (\tcb. P (tcbQueued tcb)) t'\ asUser t m \\_. obj_at' (\tcb. P (tcbQueued tcb)) t'\" - 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 +crunches set_thread_state_ext + for ready_qs_distinct[wp]: ready_qs_distinct + (wp: crunch_wps ignore_del: set_thread_state_ext) -lemma asUser_valid_inQ_queues[wp]: - "\ valid_inQ_queues \ asUser t f \\rv. valid_inQ_queues \" - unfolding valid_inQ_queues_def Ball_def - apply (wpsimp wp: hoare_vcg_all_lift) - defer - apply (wp asUser_ksQ) - apply assumption - apply (simp add: inQ_def[abs_def] obj_at'_conj) - apply (rule hoare_convert_imp) - apply (wp asUser_ksQ) - apply wp - done +lemma set_thread_state_ready_qs_distinct[wp]: + "set_thread_state ref ts \ready_qs_distinct\" + unfolding set_thread_state_def + apply (wpsimp wp: set_object_wp) + by (clarsimp simp: ready_qs_distinct_def) + +lemma as_user_ready_qs_distinct[wp]: + "as_user tptr f \ready_qs_distinct\" + unfolding as_user_def + apply (wpsimp wp: set_object_wp) + by (clarsimp simp: ready_qs_distinct_def) lemma (in delete_one) suspend_corres: "corres dc (einvs and tcb_at t) (invs' and tcb_at' t) (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]) @@ -1426,17 +1236,19 @@ lemma (in delete_one) suspend_corres: apply (wpsimp simp: ARM.setRegister_def ARM.getRegister_def) apply (rule corres_return_trivial) apply (rule corres_split_nor[OF setThreadState_corres]) - apply simp - apply (rule tcbSchedDequeue_corres') - apply (wpsimp simp: update_restart_pc_def updateRestartPC_def)+ - apply (rule hoare_post_imp[where Q = "\rv s. tcb_at t s \ is_etcb_at t s"]) - apply simp + 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 = "\rv s. tcb_at' t s \ valid_inQ_queues s"]) - apply (wpsimp simp: valid_queues_inQ_queues) - apply wp+ - apply (force simp: valid_sched_def tcb_at_is_etcb_at) - apply (clarsimp simp add: invs'_def valid_state'_def valid_queues_inQ_queues) + 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: @@ -1461,248 +1273,8 @@ lemma (in delete_one_conc_pre) cancelIPC_it[wp]: crunch ksQ: threadGet "\s. P (ksReadyQueues s p)" -lemma tcbSchedDequeue_notksQ: - "\\s. t' \ set(ksReadyQueues s p)\ - tcbSchedDequeue t - \\_ s. t' \ set(ksReadyQueues s p)\" - 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+ - apply clarsimp - apply (rule_tac Q="\_ s. t' \ set(ksReadyQueues s p)" in hoare_post_imp) - apply (wp | clarsimp)+ - done - -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 B="\rv s. (rv = ResumeCurrentThread \ rv = ChooseNewThread) - \ ?OAQ t' p s" in hoare_seq_ext) - including classic_wp_pre - apply (wp | clarsimp)+ - apply (case_tac x) - apply (wp | clarsimp)+ - done - -lemma setThreadState_oa_queued: - "\\s. P' (obj_at' (\tcb. P (tcbQueued tcb) (tcbDomain tcb) (tcbPriority tcb)) t' s) \ - setThreadState st 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 \ setThreadState st t \\_. ?Q R \" - apply (simp add: setThreadState_def) - apply (wp rescheduleRequired_oa_queued) - apply (simp add: sch_act_simple_def) - apply (rule_tac Q="\_. ?Q R" in hoare_post_imp, clarsimp) - apply (wp threadSet_obj_at'_strongish) - apply (clarsimp) - done - show "\\s. \ ?Q P s\ setThreadState st t \\_ s. \ ?Q P s\" - by (simp add: not_obj_at' comp_def, wp hoare_convert_imp pos) - qed - -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 sts_valid_queues_partial: - "\Invariants_H.valid_queues and sch_act_simple\ - setThreadState st t - \\_ s. \t' d p. - (t' \ set(ksReadyQueues s (d, p)) \ - (obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t' s - \ (t' \ t \ st_tcb_at' runnable' t' s))) - \ distinct (ksReadyQueues s (d, p))\" - (is "\_\ _ \\_ s. \t' d p. ?OA t' d p s \ ?DISTINCT d p s \") - apply (rule_tac Q="\_ s. (\t' d p. ?OA t' d p s) \ (\d p. ?DISTINCT d p s)" - in hoare_post_imp) - apply (clarsimp) - apply (rule hoare_conjI) - apply (rule_tac Q="\s. \t' d p. - ((t'\set(ksReadyQueues s (d, p)) - \ \ (sch_act_simple s)) - \ (obj_at'(\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t' s - \ st_tcb_at' runnable' t' s))" in hoare_pre_imp) - apply (fastforce simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def - pred_tcb_at'_def obj_at'_def inQ_def) - apply (rule hoare_vcg_all_lift)+ - apply (rule hoare_convert_imp) - including classic_wp_pre - apply (wp sts_ksQ setThreadState_oa_queued hoare_impI sts_pred_tcb_neq' - | clarsimp)+ - apply (rule_tac Q="\s. \d p. ?DISTINCT d p s \ sch_act_simple s" in hoare_pre_imp) - apply (clarsimp simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def) - apply (wp hoare_vcg_all_lift sts_ksQ) - apply (clarsimp) - done - -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 Q="(\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) - done - -lemma sts_invs_minor'_no_valid_queues: - "\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 \ obj_at' tcbQueued t s \ st_tcb_at' runnable' t s) - and sch_act_simple - and invs'\ - setThreadState st t - \\_ s. (\t' d p. - (t' \ set(ksReadyQueues s (d, p)) \ - (obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t' s - \ (t' \ t \ st_tcb_at' runnable' t' s))) - \ distinct (ksReadyQueues s (d, p)) \ (maxDomain < d \ maxPriority < p \ ksReadyQueues s (d, p) = [])) \ - valid_bitmapQ s \ - bitmapQ_no_L2_orphans s \ - bitmapQ_no_L1_orphans 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 \ - valid_queues' 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 \ - cur_tcb' s \ - tcb_at' t s\" - apply (simp add: invs'_def valid_state'_def valid_queues_def) - apply (wp sts_valid_queues_partial sts_ksQ - setThreadState_oa_queued sts_st_tcb_at'_cases - irqs_masked_lift - valid_irq_node_lift - setThreadState_ct_not_inQ - sts_valid_bitmapQ_sch_act_simple - sts_valid_bitmapQ_no_L2_orphans_sch_act_simple - sts_valid_bitmapQ_no_L1_orphans_sch_act_simple - hoare_vcg_conj_lift hoare_vcg_imp_lift hoare_vcg_all_lift)+ - apply (clarsimp simp: disj_imp) - apply (intro conjI) - apply (clarsimp simp: valid_queues_def) - apply (rule conjI, clarsimp) - apply (drule valid_queues_no_bitmap_objD, assumption) - apply (clarsimp simp: inQ_def comp_def) - apply (rule conjI) - apply (erule obj_at'_weaken) - apply (simp add: inQ_def) - apply (clarsimp simp: st_tcb_at'_def) - apply (erule obj_at'_weaken) - apply (simp add: inQ_def) - apply (simp add: valid_queues_no_bitmap_def) - apply clarsimp - apply (clarsimp simp: st_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 (fastforce simp: valid_tcb_state'_def - split: Structures_H.thread_state.splits) - apply (clarsimp dest!: st_tcb_at_state_refs_ofD' - elim!: rsubst[where P=sym_refs] - intro!: ext) - apply (fastforce simp: valid_queues_def inQ_def pred_tcb_at' pred_tcb_at'_def - elim!: st_tcb_ex_cap'' obj_at'_weakenE)+ - done - crunch ct_idle_or_in_cur_domain'[wp]: tcbSchedDequeue ct_idle_or_in_cur_domain' - -lemma tcbSchedDequeue_invs'_no_valid_queues: - "\\s. (\t' d p. - (t' \ set(ksReadyQueues s (d, p)) \ - (obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t' s - \ (t' \ t \ st_tcb_at' runnable' t' s))) - \ distinct (ksReadyQueues s (d, p)) \ (maxDomain < d \ maxPriority < p \ ksReadyQueues s (d, p) = [])) \ - valid_bitmapQ s \ - bitmapQ_no_L2_orphans s \ - bitmapQ_no_L1_orphans 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 \ - valid_queues' 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 \ - cur_tcb' s \ - tcb_at' t s\ - tcbSchedDequeue t - \\_. invs' \" - apply (simp add: invs'_def valid_state'_def) - apply (wp tcbSchedDequeue_valid_queues_weak valid_irq_handlers_lift - valid_irq_node_lift valid_irq_handlers_lift' - tcbSchedDequeue_irq_states irqs_masked_lift cur_tcb_lift - untyped_ranges_zero_lift - | clarsimp simp add: cteCaps_of_def valid_queues_def o_def)+ - apply (rule conjI) - apply (fastforce simp: obj_at'_def inQ_def st_tcb_at'_def valid_queues_no_bitmap_except_def) - apply (rule conjI, clarsimp simp: correct_queue_def) - apply (fastforce simp: valid_pspace'_def intro: obj_at'_conjI - elim: valid_objs'_maxDomain valid_objs'_maxPriority) - done - -lemmas sts_tcbSchedDequeue_invs' = - sts_invs_minor'_no_valid_queues - tcbSchedDequeue_invs'_no_valid_queues + (wp: crunch_wps) lemma asUser_sch_act_simple[wp]: "\sch_act_simple\ asUser s t \\_. sch_act_simple\" @@ -1714,11 +1286,14 @@ lemma (in delete_one_conc) suspend_invs'[wp]: "\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 (wp sts_tcbSchedDequeue_invs') - apply (simp add: updateRestartPC_def | strengthen no_refs_simple_strg')+ - prefer 2 - apply (wpsimp wp: hoare_drop_imps hoare_vcg_imp_lift' - | strengthen no_refs_simple_strg')+ + 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]: @@ -1763,109 +1338,6 @@ lemma (in delete_one_conc_pre) suspend_st_tcb_at': lemmas (in delete_one_conc_pre) suspend_makes_simple' = suspend_st_tcb_at' [where P=simple', simplified] -lemma valid_queues_not_runnable'_not_ksQ: - assumes "Invariants_H.valid_queues s" and "st_tcb_at' (Not \ runnable') t s" - shows "\d p. t \ set (ksReadyQueues s (d, p))" - using assms - apply - - apply (clarsimp simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def pred_tcb_at'_def) - apply (erule_tac x=d in allE) - apply (erule_tac x=p in allE) - apply (clarsimp) - apply (drule(1) bspec) - apply (clarsimp simp: obj_at'_def) - done - -declare valid_queues_not_runnable'_not_ksQ[OF ByAssum, simp] - -lemma cancelSignal_queues[wp]: - "\Invariants_H.valid_queues and st_tcb_at' (Not \ runnable') t\ - cancelSignal t ae \\_. Invariants_H.valid_queues \" - apply (simp add: cancelSignal_def) - apply (wp sts_valid_queues) - apply (rule_tac Q="\_ s. \p. t \ set (ksReadyQueues s p)" in hoare_post_imp, simp) - apply (wp hoare_vcg_all_lift) - apply (wpc) - apply (wp)+ - apply (rule_tac Q="\_ s. Invariants_H.valid_queues s \ (\p. t \ set (ksReadyQueues s p))" in hoare_post_imp) - apply (clarsimp) - apply (wp) - apply (clarsimp) - done - -lemma (in delete_one_conc_pre) cancelIPC_queues[wp]: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - cancelIPC t \\rv. Invariants_H.valid_queues\" - apply (simp add: cancelIPC_def Let_def getThreadReplySlot_def - cong: Structures_H.thread_state.case_cong list.case_cong) - apply (rule hoare_seq_ext [OF _ gts_sp']) - apply (rule hoare_pre) - apply (wpc - | wp hoare_vcg_conj_lift delete_one_queues threadSet_valid_queues - threadSet_valid_objs' sts_valid_queues setEndpoint_ksQ - hoare_vcg_all_lift threadSet_sch_act threadSet_weak_sch_act_wf - | simp add: o_def if_apply_def2 inQ_def - | rule hoare_drop_imps - | clarsimp simp: valid_tcb'_def tcb_cte_cases_def - elim!: pred_tcb'_weakenE)+ - apply (fastforce dest: valid_queues_not_runnable'_not_ksQ elim: pred_tcb'_weakenE) - done - -(* FIXME: move to Schedule_R *) -lemma tcbSchedDequeue_nonq[wp]: - "\Invariants_H.valid_queues and tcb_at' t and K (t = t')\ - tcbSchedDequeue t \\_ s. \d p. t' \ set (ksReadyQueues s (d, p))\" - apply (rule hoare_gen_asm) - apply (simp add: tcbSchedDequeue_def) - apply (wp threadGet_wp|simp)+ - apply (fastforce simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def obj_at'_def projectKOs inQ_def) - done - -lemma sts_ksQ_oaQ: - "\Invariants_H.valid_queues\ - setThreadState st t - \\_ s. t \ set (ksReadyQueues s (d, p)) \ - obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t s\" - (is "\_\ _ \\_. ?POST\") - proof - - have RR: "\sch_act_simple and ?POST\ rescheduleRequired \\_. ?POST\" - apply (simp add: rescheduleRequired_def) - apply (wp) - apply (clarsimp) - apply (rule_tac - Q="(\s. action = ResumeCurrentThread \ action = ChooseNewThread) and ?POST" - in hoare_pre_imp, assumption) - apply (case_tac action) - apply (clarsimp)+ - apply (wp) - apply (clarsimp simp: sch_act_simple_def) - done - show ?thesis - apply (simp add: setThreadState_def) - apply (wp RR) - apply (rule_tac Q="\_. ?POST" in hoare_post_imp) - apply (clarsimp simp add: sch_act_simple_def) - apply (wp hoare_convert_imp) - apply (clarsimp simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (fastforce dest: bspec elim!: obj_at'_weakenE simp: inQ_def) - done - qed - -lemma (in delete_one_conc_pre) suspend_nonq: - "\Invariants_H.valid_queues and valid_objs' and tcb_at' t - and (\s. weak_sch_act_wf (ksSchedulerAction s) s) - and (\s. t \ ksIdleThread s) and K (t = t')\ - suspend t - \\rv s. \d p. t' \ set (ksReadyQueues s (d, p))\" - apply (rule hoare_gen_asm) - apply (simp add: suspend_def unless_def) - unfolding updateRestartPC_def - apply (wp hoare_allI tcbSchedDequeue_t_notksQ sts_ksQ_oaQ) - apply wpsimp+ - done - lemma suspend_makes_inactive: "\K (t = t')\ suspend t \\rv. st_tcb_at' ((=) Inactive) t'\" apply (cases "t = t'", simp_all) @@ -1878,20 +1350,19 @@ 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 tcbSchedEnqueue_ct', wp, simp) + by (rule hoare_weaken_pre, wps, wp, simp) lemma sts_sch_act_not_ct[wp]: "\\s. sch_act_not (ksCurThread s) s\ setThreadState st t \\_ s. sch_act_not (ksCurThread s) s\" - by (rule hoare_weaken_pre, wps tcbSchedEnqueue_ct', wp, simp) + by (rule hoare_weaken_pre, wps, wp, simp) text \Cancelling all IPC in an endpoint or notification object\ lemma ep_cancel_corres_helper: - "corres dc ((\s. \t \ set list. tcb_at t s) and valid_etcbs) - ((\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') + "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 @@ -1900,28 +1371,34 @@ lemma ep_cancel_corres_helper: 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 (rule corres_guard_imp [OF setThreadState_corres]) - apply simp - apply (simp add: valid_tcb_state_def) - apply simp - apply (wp sts_valid_queues)+ - apply (force simp: tcb_at_is_etcb_at) - apply (fastforce elim: obj_at'_weakenE) - apply ((wp hoare_vcg_const_Ball_lift | simp)+)[1] - apply (rule hoare_pre) - apply (wp hoare_vcg_const_Ball_lift - weak_sch_act_wf_lift_linear sts_st_tcb' setThreadState_not_st - sts_valid_queues tcbSchedEnqueue_not_st - | simp)+ - apply (auto elim: obj_at'_weakenE simp: valid_tcb_state'_def) + 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 +crunches 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 ep_cancel_corres: "corres dc (invs and valid_sched and ep_at ep) (invs' and ep_at' ep) (cancel_all_ipc ep) (cancelAllIPC ep)" @@ -1929,10 +1406,10 @@ proof - have P: "\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_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 - \ Invariants_H.valid_queues s \ valid_queues' s \ valid_objs' 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; @@ -1954,22 +1431,23 @@ proof - 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 R="\_ s. \x\set list. tcb_at' x s \ valid_objs' s" + apply (rule_tac R="\_ 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 (rule hoare_name_pre_state) - apply ((wp hoare_vcg_const_Ball_lift mapM_x_wp' - sts_valid_queues setThreadState_not_st sts_st_tcb' tcbSchedEnqueue_not_st - | clarsimp - | fastforce elim: obj_at'_weakenE simp: valid_tcb_state'_def)+)[2] - apply (rule hoare_name_pre_state) + 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 elim!: valid_objs_valid_tcbE))+ + | (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 (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 @@ -1997,6 +1475,8 @@ lemma cancelAllSignals_corres: "corres dc (invs and valid_sched and ntfn_at ntfn) (invs' and ntfn_at' ntfn) (cancel_all_signals ntfn) (cancelAllSignals ntfn)" apply (simp add: cancel_all_signals_def cancelAllSignals_def) + 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+ @@ -2007,22 +1487,26 @@ lemma cancelAllSignals_corres: 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 setThreadState_not_st + weak_sch_act_wf_lift_linear set_thread_state_runnable_weak_valid_sched_action | simp)+ apply (rename_tac list) - apply (rule_tac R="\_ s. (\x\set list. tcb_at' x s) \ valid_objs' s" + apply (rule_tac R="\_ 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_queues setThreadState_not_st - simp: valid_tcb_state'_def) + 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')+ + 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: @@ -2061,6 +1545,11 @@ proof - done qed +lemma tcbSchedEnqueue_valid_pspace'[wp]: + "tcbSchedEnqueue tcbPtr \valid_pspace'\" + unfolding valid_pspace'_def + by wpsimp + lemma cancel_all_invs'_helper: "\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} @@ -2075,8 +1564,7 @@ lemma cancel_all_invs'_helper: apply clarsimp 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_valid_queues sts_st_tcb' setThreadState_not_st + 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 @@ -2085,7 +1573,7 @@ lemma cancel_all_invs'_helper: elim!: rsubst[where P=sym_refs] dest!: set_mono_suffix intro!: ext - | (drule (1) bspec, clarsimp simp: valid_pspace'_def valid_tcb'_def elim!: valid_objs_valid_tcbE))+ + | (drule (1) bspec, clarsimp simp: valid_pspace'_def valid_tcb'_def))+ done lemma ep_q_refs_max: @@ -2116,7 +1604,6 @@ lemma rescheduleRequired_invs'[wp]: "\invs'\ rescheduleRequired \\rv. invs'\" apply (simp add: rescheduleRequired_def) apply (wp ssa_invs' | simp | wpc)+ - apply (clarsimp simp: invs'_def valid_state'_def) done lemma invs_rct_ct_activatable': @@ -2243,6 +1730,7 @@ lemma rescheduleRequired_all_invs_but_ct_not_inQ: lemma cancelAllIPC_invs'[wp]: "\invs'\ cancelAllIPC ep_ptr \\rv. invs'\" apply (simp add: cancelAllIPC_def ep'_Idle_case_helper cong del: if_cong) + apply (rule hoare_seq_ext[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' @@ -2271,6 +1759,7 @@ lemma cancelAllIPC_invs'[wp]: lemma cancelAllSignals_invs'[wp]: "\invs'\ cancelAllSignals ntfn \\rv. invs'\" apply (simp add: cancelAllSignals_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) apply (case_tac "ntfnObj ntfna", simp_all) apply (wp, simp) @@ -2305,12 +1794,14 @@ crunch valid_objs'[wp]: tcbSchedEnqueue valid_objs' (simp: unless_def valid_tcb'_def tcb_cte_cases_def) lemma cancelAllIPC_valid_objs'[wp]: - "\valid_objs'\ cancelAllIPC ep \\rv. valid_objs'\" + "\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 hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ep_sp']) apply (rule hoare_pre) apply (wp set_ep_valid_objs' setSchedulerAction_valid_objs') - apply (rule_tac Q="\rv s. valid_objs' s \ (\x\set (epQueue ep). tcb_at' x s)" + 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) @@ -2327,8 +1818,9 @@ lemma cancelAllIPC_valid_objs'[wp]: done lemma cancelAllSignals_valid_objs'[wp]: - "\valid_objs'\ cancelAllSignals ntfn \\rv. valid_objs'\" + "\valid_objs' and pspace_aligned' and pspace_distinct'\ cancelAllSignals ntfn \\rv. valid_objs'\" apply (simp add: cancelAllSignals_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) apply (case_tac "ntfnObj ntfna", simp_all) apply (wp, simp) @@ -2381,19 +1873,17 @@ 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\" - apply (simp add: setThreadState_def setQueue_def - rescheduleRequired_def tcbSchedEnqueue_def - unless_def bitmap_fun_defs - cong: scheduler_action.case_cong cong del: if_cong - | wp | wpcw)+ - done + 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 unless_def) + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_def) apply (wp | simp add: setQueue_def bitmap_fun_defs)+ done @@ -2427,19 +1917,41 @@ lemma setObject_ko_wp_at': objBits_def[symmetric] ps_clear_upd in_magnitude_check v projectKOs) -lemma rescheduleRequired_unlive: - "\\s. ko_wp_at' (Not \ live') p s \ ksSchedulerAction s \ SwitchToThread p\ - rescheduleRequired +lemma threadSet_unlive_other: + "\ko_wp_at' (Not \ live') p and K (p \ t)\ + threadSet f t \\rv. ko_wp_at' (Not \ live') p\" - apply (simp add: rescheduleRequired_def) - apply (wp | simp | wpc)+ - apply (simp add: tcbSchedEnqueue_def unless_def - threadSet_def setQueue_def threadGet_def) - apply (wp setObject_ko_wp_at getObject_tcb_wp - | simp add: objBits_simps' bitmap_fun_defs split del: if_split)+ - apply (clarsimp simp: o_def) - apply (drule obj_at_ko_at') - apply clarsimp + by (clarsimp simp: threadSet_def valid_def getObject_def + setObject_def in_monad loadObject_default_def + ko_wp_at'_def split_def in_magnitude_check + objBits_simps' updateObject_default_def projectKOs + ps_clear_upd ARM_H.fromPPtr_def) + +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 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 + +lemma rescheduleRequired_unlive[wp]: + "\\s. ko_wp_at' (Not \ live') p s \ ksSchedulerAction s \ SwitchToThread p\ + rescheduleRequired + \\_. ko_wp_at' (Not \ live') p\" + supply comp_apply[simp del] + unfolding rescheduleRequired_def + apply (wpsimp wp: tcbSchedEnqueue_unlive_other) done lemmas setEndpoint_ko_wp_at' @@ -2449,6 +1961,7 @@ lemma cancelAllIPC_unlive: "\valid_objs' and (\s. sch_act_wf (ksSchedulerAction s) s)\ cancelAllIPC ep \\rv. ko_wp_at' (Not \ live') ep\" apply (simp add: cancelAllIPC_def ep'_Idle_case_helper) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ep_sp']) apply (rule hoare_pre) apply (wp cancelAll_unlive_helper setEndpoint_ko_wp_at' @@ -2468,6 +1981,7 @@ lemma cancelAllSignals_unlive: \ obj_at' (\ko. ntfnBoundTCB ko = None) ntfnptr s\ cancelAllSignals ntfnptr \\rv. ko_wp_at' (Not \ live') ntfnptr\" apply (simp add: cancelAllSignals_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) apply (case_tac "ntfnObj ntfn", simp_all add: setNotification_def) apply wp @@ -2533,25 +2047,20 @@ lemma cancelBadgedSends_filterM_helper': apply (rule hoare_pre) 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' sts_valid_queues setThreadState_not_st - tcbSchedEnqueue_not_st - untyped_ranges_zero_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 + apply (clarsimp simp: valid_pspace'_def cong: conj_cong) apply (intro conjI) - apply (clarsimp simp: valid_pspace'_def valid_tcb'_def elim!: valid_objs_valid_tcbE dest!: st_tcb_ex_cap'') - apply (fastforce dest!: 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) - apply (fastforce elim!: obj_atE' - simp: state_refs_of'_def projectKOs tcb_bound_refs'_def - subsetD symreftype_inverse' - split: if_split_asm)+ - done + 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] @@ -2561,7 +2070,8 @@ lemma cancelBadgedSends_invs[wp]: shows "\invs'\ cancelBadgedSends epptr badge \\rv. invs'\" apply (simp add: cancelBadgedSends_def) - apply (rule hoare_seq_ext [OF _ get_ep_sp']) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) + apply (rule hoare_seq_ext [OF _ get_ep_sp'], rename_tac ep) apply (case_tac ep, simp_all) apply ((wp | simp)+)[2] apply (subst bind_assoc [where g="\_. rescheduleRequired", @@ -2594,10 +2104,20 @@ lemma cancelBadgedSends_invs[wp]: crunch state_refs_of[wp]: tcb_sched_action "\s. P (state_refs_of s)" (ignore_del: tcb_sched_action) +lemma setEndpoint_valid_tcbs'[wp]: + "setEndpoint ePtr val \valid_tcbs'\" + unfolding setEndpoint_def + apply (wpsimp wp: setObject_valid_tcbs'[where P=\]) + apply (clarsimp simp: updateObject_default_def monad_simps projectKOs) + apply fastforce + done + lemma cancelBadgedSends_corres: "corres dc (invs and valid_sched and ep_at epptr) (invs' and ep_at' epptr) (cancel_badged_sends epptr bdg) (cancelBadgedSends epptr bdg)" 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 Q'=invs']) @@ -2607,10 +2127,16 @@ lemma cancelBadgedSends_corres: apply (rule corres_guard_imp) apply (rule corres_split_nor[OF setEndpoint_corres]) apply (simp add: ep_relation_def) - apply (rule corres_split_eqr[OF _ _ _ hoare_post_add[where R="\_. valid_objs'"]]) + apply (rule corres_split_eqr[OF _ _ _ hoare_post_add + [where R="\_. 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" - and Q'="\xs s. (\x \ set xs. tcb_at' x s) \ weak_sch_act_wf (ksSchedulerAction s) s \ Invariants_H.valid_queues s \ valid_queues' s \ valid_objs' 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) @@ -2621,56 +2147,56 @@ lemma cancelBadgedSends_corres: 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]) + apply (rule corres_split[OF tcbSchedEnqueue_corres], simp) apply (rule corres_trivial) apply simp - apply (wp sts_valid_queues gts_st_tcb_at)+ + 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: is_tcb_def) - apply (wp hoare_vcg_const_Ball_lift gts_wp | clarsimp)+ - apply (wp gts_st_tcb_at hoare_vcg_imp_lift - sts_st_tcb' sts_valid_queues + 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 (wp gts_st_tcb_at hoare_vcg_imp_lift mapM_wp' - sts_st_tcb' sts_valid_queues - set_thread_state_runnable_weak_valid_sched_action - | clarsimp simp: valid_tcb_state'_def)+ - apply (wp hoare_vcg_const_Ball_lift set_ep_valid_objs')+ + 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 (drule ko_at_valid_objs', clarsimp) - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ep'_def invs_weak_sch_act_wf - invs'_def valid_state'_def) + apply (fastforce simp: valid_ep'_def) done +crunches 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 (simp add: threadGet_def| wp getObject_tcb_wp)+ - apply (rule hoare_strengthen_post, rule hoare_post_taut) - apply (fastforce simp: obj_at'_def projectKOs) - apply (rule hoare_post_taut) - apply wp+ - done + unfolding suspend_def + by (wpsimp simp: comp_def wp: tcbSchedDequeue_not_tcbQueued) crunch unqueued: prepareThreadDelete "obj_at' (Not \ tcbQueued) t" crunch inactive: prepareThreadDelete "st_tcb_at' ((=) Inactive) t'" -crunch nonq: prepareThreadDelete " \s. \d p. t' \ set (ksReadyQueues s (d, p))" end end diff --git a/proof/refine/ARM/Ipc_R.thy b/proof/refine/ARM/Ipc_R.thy index e6a261e3d3..6c418b8e94 100644 --- a/proof/refine/ARM/Ipc_R.thy +++ b/proof/refine/ARM/Ipc_R.thy @@ -14,7 +14,7 @@ lemmas lookup_slot_wrapper_defs'[simp] = lookupSourceSlot_def lookupTargetSlot_def lookupPivotSlot_def lemma getMessageInfo_corres: "corres ((=) \ message_info_map) - (tcb_at t) (tcb_at' t) + (tcb_at t and pspace_aligned and pspace_distinct) \ (get_message_info t) (getMessageInfo t)" apply (rule corres_guard_imp) apply (unfold get_message_info_def getMessageInfo_def fun_app_def) @@ -755,14 +755,6 @@ lemma tcts_sch_act[wp]: \\rv s. sch_act_wf (ksSchedulerAction s) s\" by (wp sch_act_wf_lift tcb_in_cur_domain'_lift transferCapsToSlots_pres1) -lemma tcts_vq[wp]: - "\Invariants_H.valid_queues\ transferCapsToSlots ep buffer n caps slots mi \\rv. Invariants_H.valid_queues\" - by (wp valid_queues_lift transferCapsToSlots_pres1) - -lemma tcts_vq'[wp]: - "\valid_queues'\ transferCapsToSlots ep buffer n caps slots mi \\rv. valid_queues'\" - by (wp valid_queues_lift' transferCapsToSlots_pres1) - crunch state_refs_of' [wp]: setExtraBadge "\s. P (state_refs_of' s)" lemma tcts_state_refs_of'[wp]: @@ -976,6 +968,11 @@ crunch ksDomScheduleIdx[wp]: setExtraBadge "\s. P (ksDomScheduleIdx s)" crunch ksDomSchedule[wp]: transferCapsToSlots "\s. P (ksDomSchedule s)" crunch ksDomScheduleIdx[wp]: transferCapsToSlots "\s. P (ksDomScheduleIdx s)" +crunches transferCapsToSlots + 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) lemma transferCapsToSlots_invs[wp]: "\\s. invs' s \ distinct slots @@ -1181,18 +1178,12 @@ lemma set_mrs_valid_objs' [wp]: crunch valid_objs'[wp]: copyMRs valid_objs' (wp: crunch_wps simp: crunch_simps) -crunch valid_queues'[wp]: asUser "Invariants_H.valid_queues'" - (simp: crunch_simps wp: hoare_drop_imps) - - lemma setMRs_invs_bits[wp]: "\valid_pspace'\ setMRs t buf mrs \\rv. valid_pspace'\" "\\s. sch_act_wf (ksSchedulerAction s) s\ setMRs t buf mrs \\rv s. sch_act_wf (ksSchedulerAction s) s\" "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ setMRs t buf mrs \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" - "\Invariants_H.valid_queues\ setMRs t buf mrs \\rv. Invariants_H.valid_queues\" - "\valid_queues'\ setMRs t buf mrs \\rv. valid_queues'\" "\\s. P (state_refs_of' s)\ setMRs t buf mrs \\rv s. P (state_refs_of' s)\" @@ -1209,8 +1200,6 @@ lemma copyMRs_invs_bits[wp]: "\valid_pspace'\ copyMRs s sb r rb n \\rv. valid_pspace'\" "\\s. sch_act_wf (ksSchedulerAction s) s\ copyMRs s sb r rb n \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\Invariants_H.valid_queues\ copyMRs s sb r rb n \\rv. Invariants_H.valid_queues\" - "\valid_queues'\ copyMRs s sb r rb n \\rv. valid_queues'\" "\\s. P (state_refs_of' s)\ copyMRs s sb r rb n \\rv s. P (state_refs_of' s)\" @@ -1467,15 +1456,15 @@ lemma msgFromLookupFailure_map[simp]: by (cases lf, simp_all add: lookup_failure_map_def msgFromLookupFailure_def) lemma asUser_getRestartPC_corres: - "corres (=) (tcb_at t) (tcb_at' t) - (as_user t getRestartPC) (asUser t getRestartPC)" + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ + (as_user t getRestartPC) (asUser t getRestartPC)" apply (rule asUser_corres') apply (rule corres_Id, simp, simp) apply (rule no_fail_getRestartPC) done lemma asUser_mapM_getRegister_corres: - "corres (=) (tcb_at t) (tcb_at' t) + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ (as_user t (mapM getRegister regs)) (asUser t (mapM getRegister regs))" apply (rule asUser_corres') @@ -1485,7 +1474,7 @@ lemma asUser_mapM_getRegister_corres: done lemma makeArchFaultMessage_corres: - "corres (=) (tcb_at t) (tcb_at' t) + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ (make_arch_fault_msg f t) (makeArchFaultMessage (arch_fault_map f) t)" apply (cases f, clarsimp simp: makeArchFaultMessage_def split: arch_fault.split) @@ -1496,7 +1485,7 @@ lemma makeArchFaultMessage_corres: done lemma makeFaultMessage_corres: - "corres (=) (tcb_at t) (tcb_at' t) + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ (make_fault_msg ft t) (makeFaultMessage (fault_map ft) t)" apply (cases ft, simp_all add: makeFaultMessage_def split del: if_split) @@ -1534,7 +1523,8 @@ lemmas threadget_fault_corres = lemma doFaultTransfer_corres: "corres dc (obj_at (\ko. \tcb ft. ko = TCB tcb \ tcb_fault tcb = Some ft) sender - and tcb_at receiver and case_option \ in_user_frame recv_buf) + and 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) @@ -1543,7 +1533,8 @@ lemma doFaultTransfer_corres: ARM_H.badgeRegister_def badge_register_def) apply (rule_tac Q="\fault. K (\f. fault = Some f) and tcb_at sender and tcb_at receiver and - case_option \ in_user_frame recv_buf" + case_option \ in_user_frame recv_buf and + pspace_aligned and pspace_distinct" and Q'="\fault'. tcb_at' sender and tcb_at' receiver and case_option \ valid_ipc_buffer_ptr' recv_buf" in corres_underlying_split) @@ -1681,10 +1672,6 @@ crunch vp[wp]: doIPCTransfer "valid_pspace'" (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' wp: transferCapsToSlots_vp simp:ball_conj_distrib ) crunch sch_act_wf[wp]: doIPCTransfer "\s. sch_act_wf (ksSchedulerAction s) s" (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch vq[wp]: doIPCTransfer "Invariants_H.valid_queues" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch vq'[wp]: doIPCTransfer "valid_queues'" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) crunch state_refs_of[wp]: doIPCTransfer "\s. P (state_refs_of' s)" (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) crunch ct[wp]: doIPCTransfer "cur_tcb'" @@ -1759,7 +1746,7 @@ crunch nosch[wp]: doIPCTransfer "\s. P (ksSchedulerAction s)" simp: split_def zipWithM_x_mapM) lemma handle_fault_reply_registers_corres: - "corres (=) (tcb_at t) (tcb_at' t) + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ (do t' \ arch_get_sanitise_register_info t; y \ as_user t (zipWithM_x @@ -1788,7 +1775,7 @@ lemma handle_fault_reply_registers_corres: lemma handleFaultReply_corres: "ft' = fault_map ft \ - corres (=) (tcb_at t) (tcb_at' t) + 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) @@ -1831,16 +1818,6 @@ lemma getThreadCallerSlot_inv: "\P\ getThreadCallerSlot t \\_. P\" by (simp add: getThreadCallerSlot_def, wp) -lemma deleteCallerCap_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - deleteCallerCap t - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - apply (simp add: deleteCallerCap_def getSlotCap_def getThreadCallerSlot_def locateSlot_conv) - apply (wp getThreadCallerSlot_inv cteDeleteOne_ct_not_ksQ getCTE_wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - done - crunch tcb_at'[wp]: unbindNotification "tcb_at' x" lemma finaliseCapTrue_standin_tcb_at' [wp]: @@ -1994,39 +1971,11 @@ lemma cteDeleteOne_weak_sch_act[wp]: crunch weak_sch_act_wf[wp]: emptySlot "\s. weak_sch_act_wf (ksSchedulerAction s) s" crunch pred_tcb_at'[wp]: handleFaultReply "pred_tcb_at' proj P t" -crunch valid_queues[wp]: handleFaultReply "Invariants_H.valid_queues" -crunch valid_queues'[wp]: handleFaultReply "valid_queues'" crunch tcb_in_cur_domain'[wp]: handleFaultReply "tcb_in_cur_domain' t" crunch sch_act_wf[wp]: unbindNotification "\s. sch_act_wf (ksSchedulerAction s) s" (wp: sbn_sch_act') -crunch valid_queues'[wp]: cteDeleteOne valid_queues' - (simp: crunch_simps inQ_def - wp: crunch_wps sts_st_tcb' getObject_inv loadObject_default_inv - threadSet_valid_queues' rescheduleRequired_valid_queues'_weak) - -lemma cancelSignal_valid_queues'[wp]: - "\valid_queues'\ cancelSignal t ntfn \\rv. valid_queues'\" - apply (simp add: cancelSignal_def) - apply (rule hoare_pre) - apply (wp getNotification_wp| wpc | simp)+ - done - -lemma cancelIPC_valid_queues'[wp]: - "\valid_queues' and (\s. sch_act_wf (ksSchedulerAction s) s) \ cancelIPC t \\rv. valid_queues'\" - apply (simp add: cancelIPC_def Let_def getThreadReplySlot_def locateSlot_conv liftM_def) - apply (rule hoare_seq_ext[OF _ gts_sp']) - apply (case_tac state, simp_all) defer 2 - apply (rule hoare_pre) - apply ((wp getEndpoint_wp getCTE_wp | wpc | simp)+)[8] - apply (wp cteDeleteOne_valid_queues') - apply (rule_tac Q="\_. valid_queues' and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) - apply (clarsimp simp: capHasProperty_def cte_wp_at_ctes_of) - apply (wp threadSet_valid_queues' threadSet_sch_act| simp)+ - apply (clarsimp simp: inQ_def) - done - crunch valid_objs'[wp]: handleFaultReply valid_objs' lemma cte_wp_at_is_reply_cap_toI: @@ -2034,6 +1983,17 @@ lemma cte_wp_at_is_reply_cap_toI: \ cte_wp_at (is_reply_cap_to t) ptr s" by (fastforce simp: cte_wp_at_reply_cap_to_ex_rights) +crunches handle_fault_reply + for pspace_alignedp[wp]: pspace_aligned + and pspace_distinct[wp]: pspace_distinct + +crunches cteDeleteOne, doIPCTransfer, handleFaultReply + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + and pspace_aligned'[wp]: pspace_aligned' + and pspace_distinct'[wp]: pspace_distinct' + (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) + lemma doReplyTransfer_corres: "corres dc (einvs and tcb_at receiver and tcb_at sender @@ -2045,7 +2005,7 @@ lemma doReplyTransfer_corres: 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)+) + 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 @@ -2079,8 +2039,12 @@ lemma doReplyTransfer_corres: apply (rule corres_split[OF setThreadState_corres]) apply simp apply (rule possibleSwitchTo_corres) - apply (wp set_thread_state_runnable_valid_sched set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' sts_st_tcb' sts_valid_queues sts_valid_objs' delete_one_tcbDomain_obj_at' - | simp add: valid_tcb_state'_def)+ + 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]) @@ -2089,12 +2053,16 @@ lemma doReplyTransfer_corres: apply (fastforce) apply (clarsimp simp:is_cap_simps) apply (wp weak_valid_sched_action_lift)+ - apply (rule_tac Q="\_. valid_queues' and valid_objs' and cur_tcb' and tcb_at' receiver and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp, simp add: sch_act_wf_weak) + 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) + apply (clarsimp simp: invs_psp_aligned invs_distinct) apply (rule conjI, erule invs_valid_objs) apply (rule conjI, clarsimp)+ apply (rule conjI) @@ -2118,11 +2086,13 @@ lemma doReplyTransfer_corres: 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 P="valid_sched and cur_tcb and tcb_at receiver" - and P'="tcb_at' receiver and cur_tcb' + 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 Invariants_H.valid_queues and valid_queues' and valid_objs'" - in corres_inst) + 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]) @@ -2130,24 +2100,24 @@ lemma doReplyTransfer_corres: 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_queues | simp | force simp: valid_sched_def valid_sched_action_def valid_tcb_state'_def)+ + 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_valid_queues threadSet_valid_queues' + 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 (wp threadSet_cur weak_sch_act_wf_lift_linear threadSet_pred_tcb_no_state - thread_set_not_state_valid_sched threadSet_valid_queues threadSet_valid_queues' - | simp add: runnable_def inQ_def valid_tcb'_def)+ - apply (rule_tac Q="\_. valid_sched and cur_tcb and tcb_at sender and tcb_at receiver and valid_objs and pspace_aligned" + 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) + 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\) @@ -2358,7 +2328,7 @@ proof - apply (rule setEndpoint_corres) apply (simp add: ep_relation_def) apply wp+ - apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def) + 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) @@ -2368,7 +2338,7 @@ proof - apply (rule setEndpoint_corres) apply (simp add: ep_relation_def) apply wp+ - apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def) + 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) @@ -2407,10 +2377,12 @@ proof - 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 setThreadState_valid_queues' sts_valid_queues sts_weak_sch_act_wf + 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) + 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) @@ -2475,11 +2447,13 @@ proof - 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 setThreadState_valid_queues' sts_valid_queues sts_weak_sch_act_wf + 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)+)[1] + | 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) @@ -2560,14 +2534,15 @@ lemma sendSignal_corres: apply (rule possibleSwitchTo_corres) apply wp apply (wp set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' - sts_valid_queues sts_st_tcb' hoare_disjI2 + 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 (clarsimp simp: invs'_def valid_state'_def sch_act_wf_weak - valid_tcb_state'_def) + 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)+ @@ -2593,23 +2568,23 @@ lemma sendSignal_corres: apply (rule corres_split[OF asUser_setRegister_corres]) apply (rule possibleSwitchTo_corres) apply ((wp | simp)+)[1] - apply (rule_tac Q="\_. Invariants_H.valid_queues and valid_queues' and - (\s. sch_act_wf (ksSchedulerAction s) s) and + apply (rule_tac Q="\_. (\s. sch_act_wf (ksSchedulerAction s) s) and cur_tcb' and - st_tcb_at' runnable' (hd list) and valid_objs'" + 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_queues setThreadState_valid_queues' - setThreadState_st_tcb + 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 (clarsimp 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 (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) @@ -2627,16 +2602,14 @@ lemma sendSignal_corres: apply (wp cur_tcb_lift | 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_queues setThreadState_valid_queues' - setThreadState_st_tcb - | 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 (clarsimp 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 (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] @@ -2667,38 +2640,6 @@ lemma possibleSwitchTo_sch_act[wp]: apply (auto simp: obj_at'_def projectKOs tcb_in_cur_domain'_def) done -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\" - apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs) - apply (wp hoare_drop_imps | wpc | simp)+ - apply (auto simp: valid_tcb'_def weak_sch_act_wf_def - dest: pred_tcb_at' - elim!: valid_objs_valid_tcbE) - done - -lemma possibleSwitchTo_ksQ': - "\(\s. t' \ set (ksReadyQueues s p) \ sch_act_not t' s) and K(t' \ t)\ - possibleSwitchTo t - \\_ s. t' \ set (ksReadyQueues s p)\" - apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs) - apply (wp hoare_weak_lift_imp rescheduleRequired_ksQ' tcbSchedEnqueue_ksQ threadGet_wp - | wpc - | simp split del: if_split)+ - apply (auto simp: obj_at'_def) - done - -lemma possibleSwitchTo_valid_queues'[wp]: - "\valid_queues' and (\s. sch_act_wf (ksSchedulerAction s) s) - and st_tcb_at' runnable' t\ - possibleSwitchTo t - \\rv. valid_queues'\" - apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs) - apply (wp hoare_weak_lift_imp threadGet_wp | wpc | simp)+ - apply (auto simp: obj_at'_def) - done - crunch st_refs_of'[wp]: possibleSwitchTo "\s. P (state_refs_of' s)" (wp: crunch_wps) @@ -2710,15 +2651,15 @@ crunch ct[wp]: possibleSwitchTo 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'\" + "\if_live_then_nonz_cap' and ex_nonz_cap_to' t and (\s. sch_act_wf (ksSchedulerAction s) s) + and pspace_aligned' and pspace_distinct'\ + possibleSwitchTo t + \\_. if_live_then_nonz_cap'\" apply (simp add: possibleSwitchTo_def curDomain_def) apply (wp | wpc | simp)+ apply (simp only: imp_conv_disj, wp hoare_vcg_all_lift hoare_vcg_disj_lift) apply (wp threadGet_wp)+ - apply (auto simp: obj_at'_def projectKOs) + apply (auto simp: obj_at'_def) done crunches possibleSwitchTo @@ -2748,10 +2689,6 @@ crunches sendSignal, setBoundNotification rule: irqs_masked_lift) end -lemma sts_running_valid_queues: - "runnable' st \ \ Invariants_H.valid_queues \ setThreadState st t \\_. Invariants_H.valid_queues \" - by (wp sts_valid_queues, clarsimp) - 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) @@ -2764,24 +2701,21 @@ lemma setThreadState_nonqueued_state_update: \ st \ {Inactive, Running, Restart, IdleThreadState} \ (st \ Inactive \ ex_nonz_cap_to' t s) \ (t = ksIdleThread s \ idle' st) - - \ (\ runnable' st \ sch_act_simple s) - \ (\ runnable' st \ (\p. t \ set (ksReadyQueues s p)))\ - setThreadState st t \\rv. invs'\" + \ (\ 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 - sts_valid_queues - setThreadState_ct_not_inQ) + 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 (drule simple_st_tcb_at_state_refs_ofD') apply (drule bound_tcb_at_state_refs_ofD') - apply (rule conjI, fastforce) - 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 (rule conjI) + apply clarsimp + apply (erule delta_sym_refs) + apply (fastforce split: if_split_asm) + apply (fastforce simp: symreftype_inverse' tcb_bound_refs'_def split: if_split_asm) + apply fastforce done lemma cteDeleteOne_reply_cap_to'[wp]: @@ -2849,16 +2783,14 @@ lemma cancelAllIPC_not_rct[wp]: \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" apply (simp add: cancelAllIPC_def) apply (wp | wpc)+ + apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) + apply simp + apply (rule mapM_x_wp_inv) + apply (wp)+ apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) apply simp apply (rule mapM_x_wp_inv) - apply (wp)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wp)+ - apply (wp hoare_vcg_all_lift hoare_drop_imp) - apply (simp_all) + apply (wpsimp wp: hoare_vcg_all_lift hoare_drop_imp)+ done lemma cancelAllSignals_not_rct[wp]: @@ -2867,12 +2799,10 @@ lemma cancelAllSignals_not_rct[wp]: \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" apply (simp add: cancelAllSignals_def) apply (wp | wpc)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wp)+ - apply (wp hoare_vcg_all_lift hoare_drop_imp) - apply (simp_all) + 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 not_rct[wp]: finaliseCapTrue_standin "\s. ksSchedulerAction s \ ResumeCurrentThread" @@ -2958,7 +2888,6 @@ lemma sai_invs'[wp]: 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 - sts_valid_queues [where st="Structures_H.thread_state.Running", simplified] set_ntfn_valid_objs' cur_tcb_lift sts_st_tcb' hoare_convert_imp [OF setNotification_nosch] | simp split del: if_split)+)[3] @@ -3033,8 +2962,10 @@ lemma sai_invs'[wp]: dest!: global'_no_ex_cap st_tcb_ex_cap'' ko_at_valid_objs')+ lemma replyFromKernel_corres: - "corres dc (tcb_at t and invs) (tcb_at' t and invs') + "corres dc (tcb_at t and invs) invs' (reply_from_kernel t r) (replyFromKernel t r)" + apply (rule corres_cross_add_guard[where Q'="tcb_at' t"]) + apply (fastforce intro!: tcb_at_cross) apply (case_tac r) apply (clarsimp simp: replyFromKernel_def reply_from_kernel_def badge_register_def badgeRegister_def) @@ -3045,7 +2976,7 @@ lemma replyFromKernel_corres: apply simp apply (rule setMessageInfo_corres) apply (wp hoare_case_option_wp hoare_valid_ipc_buffer_ptr_typ_at' - | clarsimp)+ + | fastforce)+ done lemma rfk_invs': @@ -3058,7 +2989,7 @@ lemma rfk_invs': crunch nosch[wp]: replyFromKernel "\s. P (ksSchedulerAction s)" lemma completeSignal_corres: - "corres dc (ntfn_at ntfnptr and tcb_at tcb and pspace_aligned and valid_objs + "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)" @@ -3083,12 +3014,12 @@ lemma completeSignal_corres: lemma doNBRecvFailedTransfer_corres: - "corres dc (tcb_at thread) - (tcb_at' thread) - (do_nbrecv_failed_transfer thread) - (doNBRecvFailedTransfer thread)" + "corres dc (tcb_at thread and pspace_aligned and pspace_distinct) \ + (do_nbrecv_failed_transfer thread) + (doNBRecvFailedTransfer thread)" unfolding do_nbrecv_failed_transfer_def doNBRecvFailedTransfer_def - by (simp add: badgeRegister_def badge_register_def, rule asUser_setRegister_corres) + by (corres corres: asUser_setRegister_corres + simp: badgeRegister_def badge_register_def)+ lemma receiveIPC_corres: assumes "is_ep_cap cap" and "cap_relation cap cap'" @@ -3173,11 +3104,11 @@ lemma receiveIPC_corres: 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 Invariants_H.valid_queues - and valid_queues' and valid_pspace' and valid_objs' - and (\s. weak_sch_act_wf (ksSchedulerAction s) s)" + 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]) @@ -3186,17 +3117,18 @@ lemma receiveIPC_corres: apply (rule corres_split[OF setThreadState_corres]) apply simp apply (rule possibleSwitchTo_corres) - apply (wp sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action - | simp)+ - apply (wp sts_st_tcb_at'_cases sts_valid_queues setThreadState_valid_queues' - setThreadState_st_tcb + 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 (clarsimp simp: st_tcb_at_tcb_at st_tcb_def2 valid_sched_def - valid_sched_action_def) + 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" - in hoare_post_imp, erule sch_act_wf_weak) + 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 @@ -3219,16 +3151,15 @@ lemma receiveIPC_corres: apply wp+ apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, simp) apply simp - apply (clarsimp simp: valid_tcb_state_def) + apply (fastforce simp: valid_tcb_state_def) apply (clarsimp simp add: valid_tcb_state'_def) apply (wp get_simple_ko_wp[where f=Notification] getNotification_wp gbn_wp gbn_wp' hoare_vcg_all_lift hoare_vcg_imp_lift hoare_vcg_if_lift | wpc | simp add: ep_at_def2[symmetric, simplified] | clarsimp)+ - apply (clarsimp simp: valid_cap_def invs_psp_aligned invs_valid_objs pred_tcb_at_def - valid_obj_def valid_tcb_def valid_bound_ntfn_def - dest!: invs_valid_objs - elim!: obj_at_valid_objsE - split: option.splits) + 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' @@ -3262,7 +3193,7 @@ lemma receiveSignal_corres: apply (rule setNotification_corres) apply (simp add: ntfn_relation_def) apply wp+ - apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, simp+) + apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, fastforce+) \ \WaitingNtfn\ apply (simp add: ntfn_relation_def) apply (rule corres_guard_imp) @@ -3273,7 +3204,7 @@ lemma receiveSignal_corres: apply (simp add: ntfn_relation_def) apply wp+ apply (rule corres_guard_imp) - apply (rule doNBRecvFailedTransfer_corres, simp+) + apply (rule doNBRecvFailedTransfer_corres, fastforce+) \ \ActiveNtfn\ apply (simp add: ntfn_relation_def) apply (rule corres_guard_imp) @@ -3343,7 +3274,7 @@ lemma sendFaultIPC_corres: | 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 (simp add: valid_cap_def) + apply (fastforce simp: valid_cap_def) apply (clarsimp simp: valid_cap'_def inQ_def) apply auto[1] apply (clarsimp simp: lookup_failure_map_def) @@ -3361,14 +3292,16 @@ lemma gets_the_noop_corres: done lemma handleDoubleFault_corres: - "corres dc (tcb_at thread) - (tcb_at' thread and (\s. weak_sch_act_wf (ksSchedulerAction s) s)) + "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_underlying_split [OF setThreadState_corres]) + rule corres_split[OF setThreadState_corres]) apply simp apply (rule corres_noop2) apply (simp add: exs_valid_def return_def) @@ -3377,7 +3310,7 @@ lemma handleDoubleFault_corres: apply (rule asUser_inv) apply (rule getRestartPC_inv) apply (wp no_fail_getRestartPC)+ - apply (wp|simp)+ + apply (wp|simp)+ done crunch tcb' [wp]: sendFaultIPC "tcb_at' t" (wp: crunch_wps) @@ -3417,30 +3350,6 @@ crunch sch_act_wf: setupCallerCap "\s. sch_act_wf (ksSchedulerAction s) s" (wp: crunch_wps ssa_sch_act sts_sch_act rule: sch_act_wf_lift) -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 vq[wp]: cteInsert "Invariants_H.valid_queues" - (wp: crunch_wps) - -crunch vq[wp]: getThreadCallerSlot "Invariants_H.valid_queues" - (wp: crunch_wps) - -crunch vq[wp]: getThreadReplySlot "Invariants_H.valid_queues" - (wp: crunch_wps) - -lemma setupCallerCap_vq[wp]: - "\Invariants_H.valid_queues and (\s. \p. send \ set (ksReadyQueues s p))\ - setupCallerCap send recv grant \\_. Invariants_H.valid_queues\" - apply (simp add: setupCallerCap_def) - apply (wp crunch_wps sts_valid_queues) - apply (fastforce simp: valid_queues_def obj_at'_def inQ_def) - done - -crunch vq'[wp]: setupCallerCap "valid_queues'" - (wp: crunch_wps) - 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)" @@ -3484,7 +3393,7 @@ lemma setupCallerCap_vp[wp]: declare haskell_assert_inv[wp del] lemma setupCallerCap_iflive[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' sender\ + "\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 @@ -3496,7 +3405,7 @@ lemma setupCallerCap_iflive[wp]: lemma setupCallerCap_ifunsafe[wp]: "\if_unsafe_then_cap' and valid_objs' and - ex_nonz_cap_to' rcvr and tcb_at' rcvr\ + 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 @@ -3518,13 +3427,11 @@ lemma setupCallerCap_global_refs'[wp]: \\rv. valid_global_refs'\" unfolding setupCallerCap_def getThreadCallerSlot_def getThreadReplySlot_def locateSlot_conv - apply (wp getSlotCap_cte_wp_at - | simp add: o_def unique_master_reply_cap' - | strengthen eq_imp_strg - | wp (once) getCTE_wp | clarsimp simp: cte_wp_at_ctes_of)+ - (* at setThreadState *) - apply (rule_tac Q="\_. valid_global_refs'" in hoare_post_imp, wpsimp+) - done + 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 valid_arch'[wp]: setupCallerCap "valid_arch_state'" (wp: hoare_drop_imps) @@ -3703,12 +3610,21 @@ crunch ctes_of[wp]: possibleSwitchTo "\s. P (ctes_of s)" lemmas possibleSwitchToTo_cteCaps_of[wp] = cteCaps_of_ctes_of_lift[OF possibleSwitchTo_ctes_of] +crunches asUser + for valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift wp: crunch_wps) + +crunches setupCallerCap, possibleSwitchTo, doIPCTransfer + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + and valid_bitmaps[wp]: valid_bitmaps + (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) + (* t = ksCurThread s *) lemma ri_invs' [wp]: "\invs' and sch_act_not t and ct_in_state' simple' and st_tcb_at' simple' t - and (\s. \p. t \ set (ksReadyQueues s p)) and ex_nonz_cap_to' t and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s)\ receiveIPC t cap isBlocking @@ -3726,7 +3642,7 @@ lemma ri_invs' [wp]: 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 - sts_valid_queues setThreadState_ct_not_inQ + 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) @@ -3747,7 +3663,6 @@ lemma ri_invs' [wp]: 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 (thin_tac "\a b. t \ set (ksReadyQueues one (a, b))") \ \causes slowdown\ apply (safe ; solves \auto\) apply fastforce apply fastforce @@ -3758,7 +3673,7 @@ lemma ri_invs' [wp]: 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 - sts_valid_queues setThreadState_ct_not_inQ + 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) @@ -3782,9 +3697,8 @@ lemma ri_invs' [wp]: 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' sts_valid_queues - setThreadState_ct_not_inQ possibleSwitchTo_valid_queues - possibleSwitchTo_valid_queues' + 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 @@ -3802,8 +3716,6 @@ lemma ri_invs' [wp]: st_tcb_at_refs_of_rev' conj_ac split del: if_split cong: if_cong) - apply (frule_tac t=sender in valid_queues_not_runnable'_not_ksQ) - apply (erule pred_tcb'_weakenE, clarsimp) apply (subgoal_tac "sch_act_not sender s") prefer 2 apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) @@ -3837,7 +3749,6 @@ lemma ri_invs' [wp]: lemma rai_invs'[wp]: "\invs' and sch_act_not t and st_tcb_at' simple' t - and (\s. \p. t \ set (ksReadyQueues s p)) and ex_nonz_cap_to' t and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s) and (\s. \ntfnptr. isNotificationCap cap @@ -3854,7 +3765,7 @@ lemma rai_invs'[wp]: apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) apply (wp valid_irq_node_lift sts_sch_act' typ_at_lifts - sts_valid_queues setThreadState_ct_not_inQ + setThreadState_ct_not_inQ asUser_urz | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def | wpc)+ apply (clarsimp simp: pred_tcb_at' valid_tcb_state'_def) @@ -3872,7 +3783,7 @@ lemma rai_invs'[wp]: apply (clarsimp split: if_split_asm) apply (fastforce simp: tcb_bound_refs'_def symreftype_inverse' split: if_split_asm) - apply (clarsimp dest!: global'_no_ex_cap) + 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) @@ -3892,7 +3803,7 @@ lemma rai_invs'[wp]: apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) apply (wp hoare_vcg_const_Ball_lift valid_irq_node_lift sts_sch_act' - sts_valid_queues setThreadState_ct_not_inQ typ_at_lifts + setThreadState_ct_not_inQ typ_at_lifts asUser_urz | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def | wpc)+ apply (clarsimp simp: valid_tcb_state'_def) @@ -3920,7 +3831,7 @@ lemma rai_invs'[wp]: 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 (clarsimp dest!: global'_no_ex_cap) + apply (fastforce dest!: global'_no_ex_cap) done lemma getCTE_cap_to_refs[wp]: @@ -3949,7 +3860,6 @@ lemma cteInsert_invs_bits[wp]: "\\s. sch_act_wf (ksSchedulerAction s) s\ cteInsert a b c \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\Invariants_H.valid_queues\ cteInsert a b c \\rv. Invariants_H.valid_queues\" "\cur_tcb'\ cteInsert a b c \\rv. cur_tcb'\" "\\s. P (state_refs_of' s)\ cteInsert a b c @@ -3974,9 +3884,12 @@ crunch irqs_masked'[wp]: possibleSwitchTo "irqs_masked'" crunch urz[wp]: possibleSwitchTo "untyped_ranges_zero'" (simp: crunch_simps unless_def wp: crunch_wps) +crunches possibleSwitchTo + for pspace_aligned'[wp]: pspace_aligned' + and pspace_distinct'[wp]: pspace_distinct' + lemma si_invs'[wp]: "\invs' and st_tcb_at' simple' t - and (\s. \p. t \ set (ksReadyQueues s p)) and sch_act_not t and ex_nonz_cap_to' ep and ex_nonz_cap_to' t\ sendIPC bl call ba cg cgr t ep @@ -3995,8 +3908,8 @@ lemma si_invs'[wp]: 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 sts_valid_queues setThreadState_ct_not_inQ - possibleSwitchTo_ksQ' possibleSwitchTo_ct_not_inQ hoare_vcg_all_lift sts_ksQ' + 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"] @@ -4050,8 +3963,7 @@ lemma si_invs'[wp]: 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' sts_valid_queues - setThreadState_ct_not_inQ) + 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") @@ -4070,8 +3982,7 @@ lemma si_invs'[wp]: 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' - sts_valid_queues setThreadState_ct_not_inQ) + 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) @@ -4098,19 +4009,15 @@ lemma si_invs'[wp]: lemma sfi_invs_plus': "\invs' and st_tcb_at' simple' t and sch_act_not t - and (\s. \p. t \ set (ksReadyQueues s p)) and ex_nonz_cap_to' t\ - sendFaultIPC t f - \\rv. invs'\, \\rv. invs' and st_tcb_at' simple' t - and (\s. \p. t \ set (ksReadyQueues s p)) - and sch_act_not t and (\s. ksIdleThread s \ t)\" + sendFaultIPC t f + \\_. invs'\, \\_. invs' and st_tcb_at' simple' t and sch_act_not t and (\s. ksIdleThread s \ t)\" apply (simp add: sendFaultIPC_def) apply (wp threadSet_invs_trivial threadSet_pred_tcb_no_state threadSet_cap_to' | wpc | simp)+ apply (rule_tac Q'="\rv s. invs' s \ sch_act_not t s \ st_tcb_at' simple' t s - \ (\p. t \ set (ksReadyQueues s p)) \ ex_nonz_cap_to' t s \ t \ ksIdleThread s \ (\r\zobj_refs' rv. ex_nonz_cap_to' r s)" @@ -4122,12 +4029,16 @@ lemma sfi_invs_plus': apply (subst(asm) global'_no_ex_cap, auto) done +crunches send_fault_ipc + for pspace_aligned[wp]: "pspace_aligned :: det_ext state \ _" + and pspace_distinct[wp]: "pspace_distinct :: det_ext state \ _" + (simp: crunch_simps wp: crunch_wps) + lemma handleFault_corres: "fr f f' \ corres dc (einvs and st_tcb_at active thread and ex_nonz_cap_to thread and (%_. valid_fault f)) (invs' and sch_act_not thread - and (\s. \p. thread \ set(ksReadyQueues s p)) 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) @@ -4142,9 +4053,6 @@ lemma handleFault_corres: apply simp apply (rule handleDoubleFault_corres) apply wp+ - apply (rule hoare_post_impErr, rule sfi_invs_plus', simp_all)[1] - apply clarsimp - apply wp+ apply (clarsimp simp: st_tcb_at_tcb_at st_tcb_def2 invs_def valid_state_def valid_idle_def) apply auto @@ -4155,17 +4063,13 @@ lemma sts_invs_minor'': \ (st \ Inactive \ \ idle' st \ st' \ Inactive \ \ idle' st')) t and (\s. t = ksIdleThread s \ idle' st) - and (\s. (\p. t \ set (ksReadyQueues s p)) \ runnable' st) - and (\s. runnable' st \ obj_at' tcbQueued t s - \ st_tcb_at' runnable' t s) 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' sts_valid_queues - setThreadState_ct_not_inQ) + apply (wp valid_irq_node_lift sts_sch_act' setThreadState_ct_not_inQ) apply clarsimp apply (rule conjI) apply fastforce @@ -4180,12 +4084,11 @@ lemma sts_invs_minor'': apply (clarsimp dest!: st_tcb_at_state_refs_ofD' elim!: rsubst[where P=sym_refs] intro!: ext) - apply (clarsimp elim!: st_tcb_ex_cap'') + apply (fastforce elim!: st_tcb_ex_cap'') done lemma hf_invs' [wp]: "\invs' and sch_act_not t - and (\s. \p. t \ set(ksReadyQueues s p)) and st_tcb_at' simple' t and ex_nonz_cap_to' t and (\s. t \ ksIdleThread s)\ handleFault t f \\r. invs'\" diff --git a/proof/refine/ARM/KHeap_R.thy b/proof/refine/ARM/KHeap_R.thy index 2708b28ab0..913226b0b9 100644 --- a/proof/refine/ARM/KHeap_R.thy +++ b/proof/refine/ARM/KHeap_R.thy @@ -14,8 +14,45 @@ lemma lookupAround2_known1: "m x = Some y \ fst (lookupAround2 x m) = Some (x, y)" by (fastforce simp: lookupAround2_char1) +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 + context begin interpretation Arch . (*FIXME: arch_split*) +lemma setObject_modify_variable_size: + fixes v :: "'a :: pspace_storable" shows + "\obj_at' (P :: 'a \ bool) p s; updateObject v = updateObject_default v; + (1 :: machine_word) < 2 ^ objBits v; obj_at' (\obj. objBits v = objBits obj) p s\ + \ setObject p v s = modify (ksPSpace_update (\ps. ps (p \ injectKO v))) s" + apply (clarsimp simp: setObject_def split_def exec_gets obj_at'_def projectKOs + lookupAround2_known1 assert_opt_def updateObject_default_def bind_assoc) + apply (simp add: projectKO_def alignCheck_assert) + apply (simp add: project_inject objBits_def) + apply (clarsimp simp only: koTypeOf_injectKO) + apply (frule in_magnitude_check[where s'=s]) + apply blast + apply fastforce + apply (simp add: magnitudeCheck_assert in_monad bind_def gets_def oassert_opt_def + get_def return_def) + apply (simp add: simpler_modify_def) + done + +lemma setObject_modify: + fixes v :: "'a :: pspace_storable" shows + "\obj_at' (P :: 'a \ bool) p s; updateObject v = updateObject_default v; + (1 :: machine_word) < 2 ^ objBits v; \ko. P ko \ objBits ko = objBits v \ + \ setObject p v s = modify (ksPSpace_update (\ps. ps (p \ injectKO v))) s" + apply (rule setObject_modify_variable_size) + apply fastforce + apply fastforce + apply fastforce + unfolding obj_at'_def + by fastforce + lemma obj_at_getObject: assumes R: "\a b n ko s obj::'a::pspace_storable. @@ -116,8 +153,7 @@ lemma corres_get_tcb [corres]: apply (drule bspec) apply clarsimp apply blast - apply (clarsimp simp add: other_obj_relation_def - lookupAround2_known1) + apply (clarsimp simp: tcb_relation_cut_def lookupAround2_known1) done lemma lookupAround2_same1[simp]: @@ -383,6 +419,40 @@ lemma setObject_tcb_strongest: ps_clear_upd) done +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 opt_pred_def projectKO_opts_defs projectKOs projectKO_eq + split: if_split_asm + Structures_H.kernel_object.split_asm + +lemma setObject_endpoint_tcbs_of'[wp]: + "setObject c (endpoint :: endpoint) \\s. P' (tcbs_of' s)\" + by setObject_easy_cases + +lemma setObject_notification_tcbs_of'[wp]: + "setObject c (notification :: notification) \\s. P' (tcbs_of' s)\" + by setObject_easy_cases + +lemma setObject_cte_tcbSchedNexts_of[wp]: + "setObject c (cte :: cte) \\s. P' (tcbSchedNexts_of s)\" + by setObject_easy_cases + +lemma setObject_cte_tcbSchedPrevs_of[wp]: + "setObject c (cte :: cte) \\s. P' (tcbSchedPrevs_of s)\" + by setObject_easy_cases + +lemma setObject_cte_tcbQueued[wp]: + "setObject c (cte :: cte) \\s. P' (tcbQueued |< tcbs_of' s)\" + supply inQ_def[simp] + by setObject_easy_cases + +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 getObject_obj_at': assumes x: "\q n ko. loadObject p q n ko = (loadObject_default p q n ko :: ('a :: pspace_storable) kernel)" @@ -870,7 +940,7 @@ lemma obj_relation_cut_same_type: \ (\sz sz'. a_type ko = AArch (ADeviceData sz) \ a_type ko' = AArch (ADeviceData sz'))" apply (rule ccontr) apply (simp add: obj_relation_cuts_def2 a_type_def) - apply (auto simp: other_obj_relation_def cte_relation_def + apply (auto simp: other_obj_relation_def tcb_relation_cut_def cte_relation_def pte_relation_def pde_relation_def split: Structures_A.kernel_object.split_asm if_split_asm Structures_H.kernel_object.split_asm @@ -888,6 +958,16 @@ 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\ + \ tcbs_of' (s'\ksPSpace := (ksPSpace s')(ptr \ ko)\) = tcbs_of' s'" + by (fastforce simp: typ_at'_def ko_wp_at'_def opt_map_def projectKO_opts_defs + split: kernel_object.splits) + +lemma typ_at'_koTypeOf: + "ko_at' ob' ptr b \ typ_at' (koTypeOf (injectKO ob')) ptr b" + by (auto simp: typ_at'_def ko_wp_at'_def obj_at'_def project_inject projectKOs) + lemma setObject_other_corres: fixes ob' :: "'a :: pspace_storable" assumes x: "updateObject ob' = updateObject_default ob'" @@ -917,7 +997,7 @@ lemma setObject_other_corres: 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 (extract_conjunct \match conclusion in "ghost_relation _ _ _" \ -\) apply (clarsimp simp add: ghost_relation_def) apply (erule_tac x=ptr in allE)+ apply (clarsimp simp: obj_at_def a_type_def @@ -927,6 +1007,14 @@ lemma setObject_other_corres: apply (simp only: pspace_relation_def pspace_dom_update dom_fun_upd2 simp_thms) apply (elim conjE) apply (frule bspec, erule domI) + apply (prop_tac "typ_at' (koTypeOf (injectKO ob')) ptr b") + subgoal + by (clarsimp simp: typ_at'_def ko_wp_at'_def obj_at'_def projectKO_opts_defs + 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 clarsimp apply (rule conjI) apply (rule ballI, drule(1) bspec) apply (drule domD) @@ -935,30 +1023,30 @@ lemma setObject_other_corres: apply clarsimp apply (frule_tac ko'=ko and x'=ptr in obj_relation_cut_same_type, (fastforce simp add: is_other_obj_relation_type t)+) - apply (erule disjE) - apply (simp add: is_other_obj_relation_type t) - apply (erule disjE) - apply (insert t, - clarsimp simp: is_other_obj_relation_type_CapTable a_type_def) - apply (erule disjE) - apply (insert t, - clarsimp simp: is_other_obj_relation_type_UserData a_type_def) - apply (insert t, - clarsimp simp: is_other_obj_relation_type_DeviceData a_type_def) - 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) - by (clarsimp simp: is_other_obj_relation_type t exst_same_def - split: Structures_A.kernel_object.splits Structures_H.kernel_object.splits - ARM_A.arch_kernel_obj.splits)+ + apply (insert t) + apply ((erule disjE + | 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 @@ -1056,9 +1144,10 @@ lemma typ_at'_valid_obj'_lift: (wpsimp|rule conjI)+) apply (rename_tac tcb) apply (case_tac "tcbState tcb"; - simp add: valid_tcb'_def valid_tcb_state'_def split_def valid_bound_ntfn'_def - split: option.splits, - wpsimp) + 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) @@ -1340,32 +1429,6 @@ lemma set_ep_bitmapQ_no_L2_orphans[wp]: apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp add: bitmapQ_def)+ done -lemma set_ep_valid_queues[wp]: - "\Invariants_H.valid_queues\ setEndpoint epptr ep \\rv. Invariants_H.valid_queues\" - apply (simp add: Invariants_H.valid_queues_def) - apply (wp hoare_vcg_conj_lift) - apply (simp add: setEndpoint_def valid_queues_no_bitmap_def) - apply (wp hoare_Ball_helper hoare_vcg_all_lift) - apply (rule obj_at_setObject2) - apply (clarsimp simp: updateObject_default_def in_monad) - apply (wp updateObject_default_inv set_ep_valid_bitmapQ[unfolded setEndpoint_def] - | simp add: valid_queues_no_bitmap_def)+ - done - -lemma set_ep_valid_queues'[wp]: - "\valid_queues'\ setEndpoint epptr ep \\rv. valid_queues'\" - apply (unfold setEndpoint_def) - apply (simp only: valid_queues'_def imp_conv_disj - obj_at'_real_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - apply (rule setObject_ko_wp_at) - apply simp - apply (simp add: objBits_simps') - apply simp - apply (wp updateObject_default_inv | simp)+ - apply (clarsimp simp: projectKOs ko_wp_at'_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\" @@ -1565,34 +1628,6 @@ lemma set_ntfn_bitmapQ_no_L2_orphans[wp]: apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp)+ done -lemma set_ntfn_valid_queues[wp]: - "\Invariants_H.valid_queues\ setNotification p ntfn \\rv. Invariants_H.valid_queues\" - apply (simp add: Invariants_H.valid_queues_def) - apply (rule hoare_pre) - apply (wp hoare_vcg_conj_lift) - apply (simp add: setNotification_def valid_queues_no_bitmap_def) - apply (wp hoare_Ball_helper hoare_vcg_all_lift) - apply (rule obj_at_setObject2) - apply (clarsimp simp: updateObject_default_def in_monad) - apply (wp updateObject_default_inv set_ep_valid_bitmapQ[unfolded setEndpoint_def] - | simp add: valid_queues_no_bitmap_def)+ - done - -lemma set_ntfn_valid_queues'[wp]: - "\valid_queues'\ setNotification p ntfn \\rv. valid_queues'\" - apply (unfold setNotification_def) - apply (rule setObject_ntfn_pre) - apply (simp only: valid_queues'_def imp_conv_disj - obj_at'_real_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - apply (rule setObject_ko_wp_at) - apply simp - apply (simp add: objBits_simps') - apply simp - apply (wp updateObject_default_inv | simp)+ - apply (clarsimp simp: projectKOs ko_wp_at'_def) - 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)))\ @@ -2014,6 +2049,21 @@ lemma setNotification_ct_idle_or_in_cur_domain'[wp]: crunch gsUntypedZeroRanges[wp]: setNotification "\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)\" + assumes nexts: "\P. f \\s. P (tcbSchedNexts_of s)\" + shows "f \sym_heap_sched_pointers\" + by (rule_tac f=tcbSchedPrevs_of in hoare_lift_Pf2; wpsimp wp: assms) + +crunches setNotification + for tcbSchedNexts_of[wp]: "\s. P (tcbSchedNexts_of s)" + and tcbSchedPrevs_of[wp]: "\s. P (tcbSchedPrevs_of s)" + and valid_sched_pointers[wp]: valid_sched_pointers + and ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" + and ksReadyQueuesL1Bitmap[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" + and ksReadyQueuesL2Bitmap[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" + (simp: updateObject_default_def) + lemma set_ntfn_minor_invs': "\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)) @@ -2023,9 +2073,10 @@ lemma set_ntfn_minor_invs': and (\s. ptr \ ksIdleThread s) \ setNotification ptr val \\rv. invs'\" - apply (clarsimp simp add: invs'_def valid_state'_def cteCaps_of_def) - apply (wp irqs_masked_lift valid_irq_node_lift untyped_ranges_zero_lift, - simp_all add: o_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')+ @@ -2111,21 +2162,17 @@ crunch typ_at'[wp]: doMachineOp "\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'\" + "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 - valid_pspace'_def valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs - | wp cur_tcb_lift sch_act_wf_lift tcb_in_cur_domain'_lift - | fastforce elim: state_refs_of'_pspaceI)+ + | wp + | fastforce elim: state_refs_of'_pspaceI)+ crunch cte_wp_at'[wp]: doMachineOp "\s. P (cte_wp_at' P' p s)" crunch obj_at'[wp]: doMachineOp "\s. P (obj_at' P' p s)" @@ -2148,6 +2195,29 @@ lemma setEndpoint_ct': apply (wp updateObject_default_inv | simp)+ done +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 (clarsimp simp: bit_simps objBits_simps' word_bits_def + split: kernel_object.splits arch_kernel_object.splits) + done + +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 + +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] diff --git a/proof/refine/ARM/Refine.thy b/proof/refine/ARM/Refine.thy index 07192b70f0..5b974fc45d 100644 --- a/proof/refine/ARM/Refine.thy +++ b/proof/refine/ARM/Refine.thy @@ -81,7 +81,7 @@ lemma typ_at_UserDataI: apply clarsimp apply (subst mask_lower_twice [where n = pageBits, OF pbfs_atleast_pageBits, symmetric]) apply (clarsimp simp: obj_relation_cuts_def2 pte_relation_def - cte_relation_def other_obj_relation_def + cte_relation_def other_obj_relation_def tcb_relation_cut_def pde_relation_def split: Structures_A.kernel_object.split_asm Structures_H.kernel_object.split_asm @@ -112,7 +112,7 @@ lemma typ_at_DeviceDataI: apply clarsimp apply (subst mask_lower_twice [where n = pageBits, OF pbfs_atleast_pageBits, symmetric]) apply (clarsimp simp: obj_relation_cuts_def2 pte_relation_def - cte_relation_def other_obj_relation_def + cte_relation_def other_obj_relation_def tcb_relation_cut_def pde_relation_def split: Structures_A.kernel_object.split_asm Structures_H.kernel_object.split_asm @@ -565,7 +565,7 @@ lemma kernel_corres': apply simp apply (rule handleInterrupt_corres[simplified dc_def]) apply simp - apply (wp hoare_drop_imps hoare_vcg_all_lift)[1] + 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' \ @@ -643,7 +643,7 @@ lemma entry_corres: apply (rule corres_split[OF getCurThread_corres]) apply (rule corres_split) apply simp - apply (rule threadset_corresT) + 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) @@ -655,7 +655,7 @@ lemma entry_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, simp add: invs_def cur_tcb_def) + 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' @@ -664,7 +664,7 @@ lemma entry_corres: | 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 (fastforce simp: invs_def cur_tcb_def) apply (clarsimp simp: ct_in_state'_def) done diff --git a/proof/refine/ARM/Retype_R.thy b/proof/refine/ARM/Retype_R.thy index c77ec89d27..6a5ed86224 100644 --- a/proof/refine/ARM/Retype_R.thy +++ b/proof/refine/ARM/Retype_R.thy @@ -303,7 +303,7 @@ lemma state_relation_null_filterE: null_filter (caps_of_state t) = null_filter (caps_of_state s); null_filter' (ctes_of t') = null_filter' (ctes_of s'); pspace_relation (kheap t) (ksPSpace t'); - ekheap_relation (ekheap t) (ksPSpace 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'; @@ -989,7 +989,7 @@ lemma retype_ekheap_relation: apply (intro impI conjI) apply clarsimp apply (drule_tac x=a in bspec,force) - apply (clarsimp simp add: other_obj_relation_def split: if_split_asm) + 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 @@ -1165,6 +1165,11 @@ global_interpretation update_gs: PSpace_update_eq "update_gs ty us ptrs" context begin interpretation Arch . (*FIXME: arch_split*) +lemma ksReadyQueues_update_gs[simp]: + "ksReadyQueues (update_gs tp us addrs s) = ksReadyQueues s" + by (simp add: update_gs_def + split: aobject_type.splits Structures_A.apiobject_type.splits) + lemma update_gs_id: "tp \ no_gs_types \ update_gs tp us addrs = id" by (simp add: no_gs_types_def update_gs_def @@ -1184,6 +1189,144 @@ lemma update_gs_simps[simp]: else ups x)" by (simp_all add: update_gs_def) +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 - + 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_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 "\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 (fastforce simp: ptr_add_def p_assoc_help) + done +qed + +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 + "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 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_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 + "tcbSchedNexts_of + (s'\ksPSpace := foldr (\addr. data_map_insert addr ko) (new_cap_addrs m ptr ko) (ksPSpace s')\) + = tcbSchedNexts_of s'" +proof - + 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 + 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 + 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" @@ -1212,7 +1355,7 @@ lemma retype_state_relation: \ state_relation" (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) + 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 ko] num_r]) @@ -1403,6 +1546,16 @@ lemma retype_state_relation: else cns x" in exI, simp) apply (rule_tac x=id in exI, simp)+ done + + have rdyqrel: "ready_queues_relation s s'" + using sr by (simp add: state_relation_def) + + thus "ready_queues_relation_2 (ready_queues s) (ksReadyQueues s') + (?ps' |> tcb_of' |> tcbSchedNext) (?ps' |> tcb_of' |> tcbSchedPrev) + (\d p. inQ d p |< (?ps' |> tcb_of'))" + using retype_ready_queues_relation[OF _ vs' pn' ko cover num_r] + by (clarsimp simp: ready_queues_relation_def Let_def) + qed lemma new_cap_addrs_fold': @@ -2408,7 +2561,6 @@ qed lemma other_objs_default_relation: "\ case ty of Structures_A.EndpointObject \ ko = injectKO (makeObject :: endpoint) | Structures_A.NotificationObject \ ko = injectKO (makeObject :: Structures_H.notification) - | Structures_A.TCBObject \ ko = injectKO (makeObject :: tcb) | _ \ False \ \ obj_relation_retype (default_object ty dev n) ko" apply (rule obj_relation_retype_other_obj) @@ -2429,6 +2581,13 @@ lemma other_objs_default_relation: split: Structures_A.apiobject_type.split_asm) done +lemma tcb_relation_retype: + "obj_relation_retype (default_object Structures_A.TCBObject dev n) (KOTCB makeObject)" + by (clarsimp simp: default_object_def obj_relation_retype_def tcb_relation_def default_tcb_def + makeObject_tcb makeObject_cte new_context_def newContext_def + fault_rel_optionation_def initContext_def default_arch_tcb_def newArchTCB_def + arch_tcb_relation_def objBits_simps' tcb_relation_cut_def) + lemma captable_relation_retype: "n < word_bits \ obj_relation_retype (default_object Structures_A.CapTableObject dev n) (KOCTE makeObject)" @@ -3155,10 +3314,10 @@ proof (intro conjI impI) apply (rule_tac ptr="x + xa" in cte_wp_at_tcbI', assumption+) apply fastforce apply simp - apply (rename_tac thread_state mcp priority bool option nat cptr vptr bound user_context) - apply (case_tac thread_state, simp_all add: valid_tcb_state'_def - valid_bound_ntfn'_def obj_at_disj' - split: option.splits)[2] + 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)]) @@ -3853,16 +4012,6 @@ lemma sch_act_wf_lift_asm: apply auto done -lemma valid_queues_lift_asm': - assumes tat: "\d p t. \\s. \ obj_at' (inQ d p) t s \ Q d p s\ f \\_ s. \ obj_at' (inQ d p) t s\" - and prq: "\P. \\s. P (ksReadyQueues s)\ f \\_ s. P (ksReadyQueues s)\" - shows "\\s. valid_queues' s \ (\d p. Q d p s)\ f \\_. valid_queues'\" - apply (simp only: valid_queues'_def imp_conv_disj) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift - tat prq) - apply simp - done - lemma createObjects'_ct[wp]: "\\s. P (ksCurThread s)\ createObjects' p n v us \\rv s. P (ksCurThread s)\" by (rule createObjects_pspace_only, simp) @@ -4331,35 +4480,153 @@ crunch ksMachine[wp]: createObjects "\s. P (ksMachineState s)" crunch cur_domain[wp]: createObjects "\s. P (ksCurDomain s)" (simp: unless_def) -lemma createNewCaps_valid_queues': - "\valid_queues' and pspace_no_overlap' ptr sz - 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_queues'\" - apply (wp valid_queues_lift_asm' [OF createNewCaps_obj_at2]) - apply (clarsimp simp: projectKOs) - apply (simp add: makeObjectKO_def - split: object_type.split_asm - apiobject_type.split_asm) - apply (clarsimp simp: inQ_def) - apply (auto simp: makeObject_tcb - split: object_type.splits apiobject_type.splits) +lemma createObjects_valid_bitmaps: + "createObjects' ptr n val gbits \valid_bitmaps\" + apply (clarsimp simp: createObjects'_def alignError_def split_def) + apply (wp case_option_wp[where P="\_. P" and P'=P for P, simplified] assert_inv + | clarsimp simp del: fun_upd_apply)+ + apply (clarsimp simp: valid_bitmaps_def valid_bitmapQ_def bitmapQ_def bitmapQ_no_L2_orphans_def + bitmapQ_no_L1_orphans_def) done -lemma createNewCaps_valid_queues: - "\valid_queues and pspace_no_overlap' ptr sz - 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_queues\" - apply (rule hoare_gen_asm) - apply (wpsimp wp: valid_queues_lift_asm createNewCaps_obj_at2[where sz=sz]) - apply (clarsimp simp: projectKO_opts_defs) - apply (simp add: inQ_def) - apply (wpsimp wp: createNewCaps_pred_tcb_at'[where sz=sz])+ +lemma valid_bitmaps_gsCNodes_update[simp]: + "valid_bitmaps (gsCNodes_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) + +lemma valid_bitmaps_gsUserPages_update[simp]: + "valid_bitmaps (gsUserPages_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) + +crunches curDomain, copyGlobalMappings + for valid_bitmaps[wp]: valid_bitmaps + and sched_pointers[wp]: "\s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)" + and valid_sched_pointers[wp]: valid_sched_pointers + (wp: crunch_wps valid_bitmaps_lift) + +lemma createNewCaps_valid_bitmaps: + "\\s. valid_pspace' s \ pspace_no_overlap' ptr sz s \ valid_bitmaps s\ + createNewCaps ty ptr n us dev + \\_. valid_bitmaps\" + 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 (wpsimp wp: createObjects_valid_bitmaps) + by (wpsimp wp: createObjects_valid_bitmaps[simplified o_def] mapM_x_wp + | simp add: makeObject_tcb objBits_def createObjects_def + | intro conjI impI)+ + +lemma createObjects_sched_queues: + "\\s. n \ 0 + \ range_cover ptr sz (objBitsKO val + gbits) n + \ P (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ (case val of KOTCB tcb \ tcbSchedNext tcb = None \ tcbSchedPrev tcb = None + | _ \ True) + \ pspace_aligned' s \ pspace_distinct' s + \ pspace_no_overlap' ptr sz s\ + createObjects' ptr n val gbits + \\_ s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" + (is "\ \s. _ \ _ \ ?Pre s \ _ \\_. _\") +proof (rule hoare_grab_asm)+ + 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 \\_ s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" + proof - + have shiftr_not_zero:" 1 \ ((of_nat n)::machine_word) << gbits" + using range_cover_not_zero_shift[OF not_0 cover,where gbits = gbits] + by (simp add:word_le_sub1) + show ?thesis + apply (clarsimp simp: createObjects'_def unless_def alignError_def split_def) + apply (wp | clarsimp simp del: fun_upd_apply)+ + 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 (clarsimp simp: foldr_upd_app_if) + apply (rule_tac a="tcbSchedNexts_of s" and b="tcbSchedPrevs_of s" + in rsubst2[rotated, OF sym sym, where P=P]) + apply (rule ext) + apply (clarsimp simp: opt_map_def) + apply (frule (3) retype_ksPSpace_None[simplified mult.commute]) + apply (fastforce intro: cover) + apply fastforce + apply (clarsimp simp: projectKOs split: kernel_object.splits option.splits) + apply (rule ext) + apply (clarsimp simp: opt_map_def) + apply (frule (3) retype_ksPSpace_None[simplified mult.commute]) + apply (fastforce intro: cover) + apply fastforce + apply (clarsimp simp: projectKOs split: kernel_object.splits option.splits) + apply simp + done + qed +qed + +crunches doMachineOp + for sched_projs[wp]: "\s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)" + +lemma createNewCaps_sched_queues: + assumes cover: "range_cover ptr sz (APIType_capBits ty us) n" + assumes not_0: "n \ 0" + shows + "\\s. valid_pspace' s \ pspace_no_overlap' ptr sz s + \ P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\ + createNewCaps ty ptr n us dev + \\_ s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of 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) + apply (wpsimp wp: mapM_x_wp' createObjects_sched_queues + simp: curDomain_def) + by (wpsimp wp: mapM_x_wp' createObjects_sched_queues[simplified o_def] + threadSet_sched_pointers + | simp add: objBitsKO_def APIType_capBits_def valid_pspace'_def makeObject_tcb + objBits_def pageBits_def archObjSize_def createObjects_def + pt_bits_def ptBits_def pteBits_def pdBits_def pdeBits_def word_size_bits_def + | intro conjI impI)+ + +lemma createObjects_valid_sched_pointers: + "\\s. valid_sched_pointers s + \ (case val of KOTCB tcb \ tcbSchedNext tcb = None \ tcbSchedPrev tcb = None + | _ \ True)\ + createObjects' ptr n val gbits + \\_. valid_sched_pointers\" + apply (clarsimp simp: createObjects'_def unless_def alignError_def split_def) + apply (wp case_option_wp[where P="\_. P" and P'=P for P, simplified] assert_inv + | clarsimp simp del: fun_upd_apply)+ + apply (clarsimp simp: valid_sched_pointers_def foldr_upd_app_if opt_pred_def opt_map_def comp_def) + apply (cases "tcb_of' val"; clarsimp simp: projectKOs) done +lemma createNewCaps_valid_sched_pointers: + "\\s. valid_pspace' s \ pspace_no_overlap' ptr sz s \ valid_sched_pointers s\ + createNewCaps ty ptr n us dev + \\_. valid_sched_pointers\" + 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 (wpsimp wp: createObjects_valid_sched_pointers) + by (wpsimp wp: createObjects_valid_sched_pointers[simplified o_def] mapM_x_wp + threadSet_valid_sched_pointers + | simp add: makeObject_tcb objBits_def createObjects_def + | intro conjI impI)+ + lemma mapM_x_threadSet_valid_pspace: "\valid_pspace' and K (curdom \ maxDomain)\ mapM_x (threadSet (tcbDomain_update (\_. curdom))) addrs \\y. valid_pspace'\" @@ -4758,12 +5025,13 @@ proof (rule hoare_gen_asm, erule conjE) createNewCaps_valid_arch_state valid_irq_node_lift_asm [unfolded pred_conj_def, OF _ createNewCaps_obj_at'] createNewCaps_irq_handlers' createNewCaps_vms - createNewCaps_valid_queues - createNewCaps_valid_queues' createNewCaps_pred_tcb_at' cnc_ct_not_inQ createNewCaps_ct_idle_or_in_cur_domain' createNewCaps_sch_act_wf createNewCaps_urz[where sz=sz] + createNewCaps_sched_queues[OF cover not_0] + createNewCaps_valid_sched_pointers + createNewCaps_valid_bitmaps | simp)+ using not_0 apply (clarsimp simp: valid_pspace'_def) @@ -4809,35 +5077,6 @@ lemma createObjects_sch: apply (wp sch_act_wf_lift_asm createObjects_pred_tcb_at' createObjects_orig_obj_at3 | force)+ done -lemma createObjects_queues: - "\\s. valid_queues 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. valid_queues\" - apply (wpsimp wp: valid_queues_lift_asm [unfolded pred_conj_def, OF createObjects_orig_obj_at3] - createObjects_pred_tcb_at' [unfolded pred_conj_def]) - apply fastforce - apply wp+ - apply fastforce - done - -lemma createObjects_queues': - assumes no_tcb: "\t. projectKO_opt val \ Some (t::tcb)" - shows - "\\s. valid_queues' 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. valid_queues'\" - apply (simp add: createObjects_def) - apply (wp valid_queues_lift_asm') - apply (wp createObjects_orig_obj_at2') - apply clarsimp - apply assumption - apply wp - apply (clarsimp simp: no_tcb split: option.splits) - apply fastforce - done - lemma createObjects_no_cte_ifunsafe': assumes no_cte: "\c. projectKO_opt val \ Some (c::cte)" assumes no_tcb: "\t. projectKO_opt val \ Some (t::tcb)" @@ -5087,7 +5326,7 @@ proof - 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 (wp createObjects_sch) apply (rule hoare_vcg_conj_lift) apply (simp add: createObjects_def) apply (wp createObjects_state_refs_of'') @@ -5098,8 +5337,7 @@ proof - 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 | simp add: objBits_def )+ + assms | simp add: objBits_def)+ apply (rule hoare_vcg_conj_lift) apply (simp add: createObjects_def) apply (wp createObjects_idle') @@ -5107,7 +5345,25 @@ proof - 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 + 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] @@ -5115,7 +5371,8 @@ proof - 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 (clarsimp simp: invs'_def no_tcb valid_state'_def no_cte split: option.splits) + apply (auto simp: invs'_def no_tcb valid_state'_def no_cte + split: option.splits kernel_object.splits) done qed @@ -5152,7 +5409,7 @@ lemma gcd_corres: "corres (=) \ \ (gets cur_domain) curDomain" 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. 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 @@ -5163,7 +5420,7 @@ lemma retype_region2_extra_ext_mapM_x_corres: 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. tcb_at' t s" + and P'="\s. \t \ set addrs. obj_at' (Not \ tcbQueued) t s" in corres_mapM_x) apply simp apply (rule corres_guard_imp) @@ -5171,8 +5428,10 @@ lemma retype_region2_extra_ext_mapM_x_corres: apply (case_tac tcb') apply simp apply fastforce - 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 @@ -5204,10 +5463,11 @@ lemma retype_region2_obj_at: apply (auto simp: obj_at_def default_object_def is_tcb_def) done -lemma createObjects_tcb_at': +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\ - createObjects ptr n (KOTCB makeObject) 0 \\ptrs s. \addr\set ptrs. tcb_at' addr 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 @@ -5283,7 +5543,7 @@ lemma corres_retype_region_createNewCaps: apply (rule corres_retype[where 'a = tcb], simp_all add: obj_bits_api_def objBits_simps' pageBits_def APIType_map2_def makeObjectKO_def - other_objs_default_relation)[1] + tcb_relation_retype)[1] apply (fastforce simp: range_cover_def) apply (rule corres_split_nor) apply (simp add: APIType_map2_def) @@ -5294,7 +5554,7 @@ lemma corres_retype_region_createNewCaps: apply wp apply wp apply ((wp retype_region2_obj_at | 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 ((wp createObjects_Not_tcbQueued[where sz=sz] | simp add: APIType_map2_def objBits_simps' obj_bits_api_def)+)[1] apply simp apply simp apply (subst retype_region2_extra_ext_trivial) diff --git a/proof/refine/ARM/Schedule_R.thy b/proof/refine/ARM/Schedule_R.thy index f9d9b29e2e..efdafb723a 100644 --- a/proof/refine/ARM/Schedule_R.thy +++ b/proof/refine/ARM/Schedule_R.thy @@ -15,11 +15,6 @@ declare hoare_weak_lift_imp[wp_split del] (* Levity: added (20090713 10:04:12) *) declare sts_rel_idle [simp] -lemma invs_no_cicd'_queues: - "invs_no_cicd' s \ valid_queues s" - unfolding invs_no_cicd'_def - by simp - 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)" @@ -72,17 +67,21 @@ lemma arch_switchToThread_corres: 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 st_tcb_at' runnable' t) + (valid_arch_state' and st_tcb_at' runnable' t and no_0_obj') (arch_switch_to_thread t) (Arch.switchToThread t)" + apply (rule_tac Q="tcb_at t" 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 (simp add: arch_switch_to_thread_def ARM_H.switchToThread_def) apply (rule corres_guard_imp) apply (rule corres_underlying_split [OF setVMRoot_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 (erule st_tcb_at_tcb_at) - apply (clarsimp simp: valid_pspace'_def) + apply clarsimp done lemma schedule_choose_new_thread_sched_act_rct[wp]: @@ -90,355 +89,279 @@ lemma schedule_choose_new_thread_sched_act_rct[wp]: unfolding schedule_choose_new_thread_def by wp +\ \This proof shares many similarities with the proof of @{thm tcbSchedEnqueue_corres}\ lemma tcbSchedAppend_corres: - notes trans_state_update'[symmetric, simp del] - shows - "corres dc (is_etcb_at t) (tcb_at' t and Invariants_H.valid_queues and valid_queues') (tcb_sched_action (tcb_sched_append) t) (tcbSchedAppend t)" - apply (simp only: tcbSchedAppend_def tcb_sched_action_def) - apply (rule corres_symb_exec_r [OF _ _ threadGet_inv, 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, simp) - apply (rule no_fail_pre, wp, simp) - apply (case_tac queued) - apply (simp add: unless_def when_def) - apply (rule corres_no_failI) - apply wp+ - apply (clarsimp simp: in_monad ethread_get_def gets_the_def bind_assoc - assert_opt_def exec_gets is_etcb_at_def get_etcb_def get_tcb_queue_def - set_tcb_queue_def simpler_modify_def) - - apply (subgoal_tac "tcb_sched_append t (ready_queues a (tcb_domain y) (tcb_priority y)) - = (ready_queues a (tcb_domain y) (tcb_priority y))") - apply (simp add: state_relation_def ready_queues_relation_def) - apply (clarsimp simp: tcb_sched_append_def state_relation_def - valid_queues'_def ready_queues_relation_def - ekheap_relation_def etcb_relation_def - obj_at'_def inQ_def projectKO_eq project_inject) - apply (drule_tac x=t in bspec,clarsimp) + "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_append tcb_ptr) (tcbSchedAppend 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_append_def get_tcb_queue_def + tcbSchedAppend_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]; 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 projectKOs opt_pred_def opt_map_def obj_at_def is_tcb_def + in_correct_ready_q_def etcb_at_def is_etcb_at_def) + 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 (clarsimp simp: unless_def when_def cong: if_cong) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres) - apply (simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres) - apply (simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply simp - apply (rule getQueue_corres) - apply (rule corres_split_noop_rhs2) - apply (simp add: tcb_sched_append_def) - apply (intro conjI impI) - apply (rule corres_guard_imp) - apply (rule setQueue_corres) - prefer 3 - apply (rule_tac P=\ and Q="K (t \ set queuea)" in corres_assume_pre) - apply simp - apply simp - apply simp - apply (rule corres_split_noop_rhs2) - apply (rule addToBitmap_if_null_noop_corres) - apply (rule threadSet_corres_noop, simp_all add: tcb_relation_def exst_same_def)[1] - apply wp+ - apply (wp getObject_tcb_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 - - -crunches tcbSchedEnqueue, tcbSchedAppend, tcbSchedDequeue - for valid_pspace'[wp]: valid_pspace' - and valid_arch_state'[wp]: valid_arch_state' - and pred_tcb_at'[wp]: "pred_tcb_at' proj P t" - (wp: threadSet_pred_tcb_no_state simp: unless_def tcb_to_itcb'_def) - -lemma removeFromBitmap_valid_queues_no_bitmap_except[wp]: -" \ valid_queues_no_bitmap_except t \ - removeFromBitmap d p - \\_. valid_queues_no_bitmap_except t \" - unfolding bitmapQ_defs valid_queues_no_bitmap_except_def - by (wp | clarsimp simp: bitmap_fun_defs)+ - -lemma removeFromBitmap_bitmapQ: - "\ \s. True \ removeFromBitmap d p \\_ s. \ bitmapQ d p s \" - unfolding bitmapQ_defs bitmap_fun_defs - by (wpsimp simp: bitmap_fun_defs wordRadix_def) - -lemma removeFromBitmap_valid_bitmapQ[wp]: -" \ valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - (\s. ksReadyQueues s (d,p) = []) \ - removeFromBitmap d p - \\_. valid_bitmapQ \" -proof - - have "\ valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - (\s. ksReadyQueues s (d,p) = []) \ - removeFromBitmap d p - \\_. valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - (\s. \ bitmapQ d p s \ ksReadyQueues s (d,p) = []) \" - by (rule hoare_pre) - (wp removeFromBitmap_valid_queues_no_bitmap_except removeFromBitmap_valid_bitmapQ_except - removeFromBitmap_bitmapQ, simp) - thus ?thesis - by - (erule hoare_strengthen_post; fastforce elim: valid_bitmap_valid_bitmapQ_exceptE) -qed - -(* this should be the actual weakest precondition to establish valid_queues - under tagging a thread as not queued *) -lemma threadSet_valid_queues_dequeue_wp: - "\ valid_queues_no_bitmap_except t and - valid_bitmapQ and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - (\s. \d p. t \ set (ksReadyQueues s (d,p))) \ - threadSet (tcbQueued_update (\_. False)) t - \\rv. valid_queues \" - unfolding threadSet_def - apply (rule hoare_seq_ext[OF _ getObject_tcb_sp]) - apply (rule hoare_pre) - apply (simp add: valid_queues_def valid_queues_no_bitmap_except_def valid_queues_no_bitmap_def) - apply (wp setObject_queues_unchanged_tcb hoare_Ball_helper hoare_vcg_all_lift - setObject_tcb_strongest) - apply (clarsimp simp: valid_queues_no_bitmap_except_def obj_at'_def valid_queues_no_bitmap_def) - done + 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)?) -(* FIXME move *) -lemmas obj_at'_conjI = obj_at_conj' - -lemma setQueue_valid_queues_no_bitmap_except_dequeue_wp: - "\d p ts t. - \ \s. valid_queues_no_bitmap_except t s \ - (\t' \ set ts. obj_at' (inQ d p and runnable' \ tcbState) t' s) \ - t \ set ts \ distinct ts \ p \ maxPriority \ d \ maxDomain \ - setQueue d p ts - \\rv. valid_queues_no_bitmap_except t \" - unfolding setQueue_def valid_queues_no_bitmap_except_def null_def - by wp force - -definition (* if t is in a queue, it should be tagged with right priority and domain *) - "correct_queue t s \ \d p. t \ set(ksReadyQueues s (d, p)) \ - (obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t s)" - -lemma valid_queues_no_bitmap_correct_queueI[intro]: - "valid_queues_no_bitmap s \ correct_queue t s" - unfolding correct_queue_def valid_queues_no_bitmap_def - by (fastforce simp: obj_at'_def inQ_def) - - -lemma tcbSchedDequeue_valid_queues_weak: - "\ valid_queues_no_bitmap_except t and valid_bitmapQ and - bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - correct_queue t and - obj_at' (\tcb. tcbDomain tcb \ maxDomain \ tcbPriority tcb \ maxPriority) t \ - tcbSchedDequeue t - \\_. Invariants_H.valid_queues\" -proof - - show ?thesis - unfolding tcbSchedDequeue_def null_def valid_queues_def - apply wp (* stops on threadSet *) - apply (rule hoare_post_eq[OF _ threadSet_valid_queues_dequeue_wp], - simp add: valid_queues_def) - apply (wp hoare_vcg_if_lift hoare_vcg_conj_lift hoare_vcg_imp_lift)+ - apply (wp hoare_vcg_imp_lift setQueue_valid_queues_no_bitmap_except_dequeue_wp - setQueue_valid_bitmapQ threadGet_const_tcb_at hoare_vcg_if_lift)+ - (* wp done *) - apply (normalise_obj_at') - apply (clarsimp simp: correct_queue_def) - apply (normalise_obj_at') - apply (fastforce simp add: valid_queues_no_bitmap_except_def valid_queues_no_bitmap_def elim: obj_at'_weaken)+ - done -qed + \ \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']) -lemma tcbSchedDequeue_valid_queues: - "\Invariants_H.valid_queues - and obj_at' (\tcb. tcbDomain tcb \ maxDomain) t - and obj_at' (\tcb. tcbPriority tcb \ maxPriority) t\ - tcbSchedDequeue t - \\_. Invariants_H.valid_queues\" - apply (rule hoare_pre, rule tcbSchedDequeue_valid_queues_weak) - apply (fastforce simp: valid_queues_def valid_queues_no_bitmap_def obj_at'_def inQ_def) - done - -lemma tcbSchedAppend_valid_queues'[wp]: - (* most of this is identical to tcbSchedEnqueue_valid_queues' in TcbAcc_R *) - "\valid_queues' and tcb_at' t\ tcbSchedAppend t \\_. valid_queues'\" - apply (simp add: tcbSchedAppend_def) - apply (rule hoare_pre) - apply (rule_tac B="\rv. valid_queues' and obj_at' (\obj. tcbQueued obj = rv) t" - in hoare_seq_ext) - 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 wpsimp + apply (wpsimp wp: hoare_vcg_if_lift hoare_vcg_ex_lift) + apply (corres corres: addToBitmap_if_null_noop_corres) + + apply (rule corres_from_valid_det) + apply (fastforce intro: det_wp_modify det_wp_pre simp: set_tcb_queue_def) + apply (wpsimp simp: tcbQueueAppend_def wp: hoare_vcg_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'_tcbQueueEnd_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 simp: setQueue_def tcbQueueAppend_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 obj_at'_tcbQueueEnd_ksReadyQueues) + apply fast + apply fast + apply fastforce + apply fastforce + apply (cut_tac xs="ready_queues s d p" in heap_path_head') + apply (force dest!: spec simp: list_queue_relation_def) + 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 projectKOs opt_pred_def opt_map_def) + apply (metis inQ_def option.simps(5) tcb_of'_TCB) + apply (intro conjI impI; clarsimp) + + \ \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 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_def)+ - apply (clarsimp simp: obj_at'_def inQ_def projectKOs valid_queues'_def) - apply (wp getObject_tcb_wp | simp add: threadGet_def)+ - apply (clarsimp simp: obj_at'_def) - done - -crunch norq[wp]: threadSet "\s. P (ksReadyQueues s)" - (simp: updateObject_default_def) - -lemma threadSet_valid_queues'_dequeue: (* threadSet_valid_queues' is too weak for dequeue *) - "\\s. (\d p t'. obj_at' (inQ d p) t' s \ t' \ t \ t' \ set (ksReadyQueues s (d, p))) \ - obj_at' (inQ d p) t s \ - threadSet (tcbQueued_update (\_. False)) t - \\rv. valid_queues' \" - unfolding valid_queues'_def - apply (rule hoare_pre) - apply (wp hoare_vcg_all_lift) - apply (simp only: imp_conv_disj not_obj_at') - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - apply (simp add: not_obj_at') - apply (clarsimp simp: typ_at_tcb') - apply normalise_obj_at' - apply (fastforce elim: obj_at'_weaken simp: inQ_def) - done - -lemma setQueue_ksReadyQueues_lift: - "\ \s. P (s\ksReadyQueues := (ksReadyQueues s)((d, p) := ts)\) ts \ - setQueue d p ts - \ \_ s. P s (ksReadyQueues s (d,p))\" - unfolding setQueue_def - by (wp, clarsimp simp: fun_upd_def snd_def) - -lemma tcbSchedDequeue_valid_queues'[wp]: - "\valid_queues' and tcb_at' t\ - tcbSchedDequeue t \\_. valid_queues'\" - unfolding tcbSchedDequeue_def - apply (rule_tac B="\rv. valid_queues' and obj_at' (\obj. tcbQueued obj = rv) t" - in hoare_seq_ext) - prefer 2 - apply (wp threadGet_const_tcb_at) - apply (fastforce simp: obj_at'_def) + 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 (tcbQueueEnd (ksReadyQueues s' (tcb_domain etcb, tcb_priority etcb))) + \ set (ready_queues s d p)") + apply (erule orthD2) + apply (drule_tac x="tcb_domain etcb" in spec) + apply (drule_tac x="tcb_priority etcb" in spec) + apply clarsimp + apply (drule_tac x="the (tcbQueueEnd (ksReadyQueues s' (tcb_domain etcb, tcb_priority etcb)))" + in spec) + subgoal by (auto simp: in_opt_pred opt_map_red projectKOs) + 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"; + clarsimp 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: projectKOs inQ_def fun_upd_apply split: if_splits) + apply (case_tac "t = the (tcbQueueEnd (ksReadyQueues s' (tcb_domain etcb, tcb_priority etcb)))") + apply (clarsimp simp: projectKOs inQ_def opt_pred_def fun_upd_apply) + 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 tcb \ p = tcb_priority tcb\ apply clarsimp - apply (rename_tac queued) - apply (case_tac queued, simp_all) - apply wp - apply (rule_tac d=tdom and p=prio in threadSet_valid_queues'_dequeue) - apply (rule hoare_pre_post, assumption) - apply (wp | clarsimp simp: bitmap_fun_defs)+ - apply (wp hoare_vcg_all_lift setQueue_ksReadyQueues_lift) - apply clarsimp - apply (wp threadGet_obj_at' threadGet_const_tcb_at)+ - apply clarsimp - apply (rule context_conjI, clarsimp simp: obj_at'_def) - apply (clarsimp simp: valid_queues'_def obj_at'_def projectKOs inQ_def|wp)+ + 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 projectKOs) + apply (intro conjI; clarsimp) + + \ \the ready queue was originally empty\ + apply (force simp: inQ_def in_opt_pred fun_upd_apply opt_map_def obj_at'_def projectKOs + queue_end_valid_def prev_queue_head_def + split: if_splits option.splits) + + \ \the ready queue was not originally empty\ + apply (drule (2) heap_ls_append[where new=tcbPtr]) + apply (rule conjI) + apply (clarsimp simp: fun_upd_apply queue_end_valid_def opt_map_def obj_at'_def projectKOs + split: if_splits) + apply (rule conjI) + apply (clarsimp simp: fun_upd_apply queue_end_valid_def) + apply (rule conjI) + apply (subst opt_map_upd_triv) + apply (clarsimp simp: opt_map_def fun_upd_apply queue_end_valid_def obj_at'_def projectKOs + split: if_splits) + apply (clarsimp simp: prev_queue_head_def fun_upd_apply split: if_splits) + by (clarsimp simp: inQ_def in_opt_pred fun_upd_apply queue_end_valid_def + obj_at'_def projectKOs + split: if_splits) + +lemma tcbQueueAppend_valid_objs'[wp]: + "\\s. valid_objs' s \ tcb_at' tcbPtr s \ (\end. tcbQueueEnd queue = Some end \ tcb_at' end s)\ + tcbQueueAppend queue tcbPtr + \\_. valid_objs'\" + unfolding tcbQueueAppend_def + apply (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') + apply (clarsimp simp: tcbQueueEmpty_def valid_bound_tcb'_def split: option.splits) + done + +lemma tcbSchedAppend_valid_objs'[wp]: + "\valid_objs' and pspace_aligned' and pspace_distinct'\ + tcbSchedAppend tcbPtr + \\_. valid_objs'\" + apply (clarsimp simp: tcbSchedAppend_def setQueue_def) + apply (wpsimp wp: threadSet_valid_objs' threadGet_wp hoare_vcg_all_lift) + apply (normalise_obj_at', rename_tac tcb "end") + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (frule tcbQueueHead_iff_tcbQueueEnd) + apply (force dest!: obj_at'_tcbQueueEnd_ksReadyQueues simp: tcbQueueEmpty_def obj_at'_def) done -crunch tcb_at'[wp]: tcbSchedEnqueue "tcb_at' t" - (simp: unless_def) -crunch tcb_at'[wp]: tcbSchedAppend "tcb_at' t" - (simp: unless_def) -crunch tcb_at'[wp]: tcbSchedDequeue "tcb_at' t" - -crunch state_refs_of'[wp]: tcbSchedEnqueue "\s. P (state_refs_of' s)" - (wp: refl simp: crunch_simps unless_def) -crunch state_refs_of'[wp]: tcbSchedAppend "\s. P (state_refs_of' s)" - (wp: refl simp: crunch_simps unless_def) -crunch state_refs_of'[wp]: tcbSchedDequeue "\s. P (state_refs_of' s)" - (wp: refl simp: crunch_simps) +crunches tcbSchedAppend, tcbSchedDequeue + for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" + (wp: threadSet_pred_tcb_no_state simp: unless_def tcb_to_itcb'_def) -crunch cap_to'[wp]: tcbSchedEnqueue "ex_nonz_cap_to' p" - (simp: unless_def) -crunch cap_to'[wp]: tcbSchedAppend "ex_nonz_cap_to' p" - (simp: unless_def) -crunch cap_to'[wp]: tcbSchedDequeue "ex_nonz_cap_to' p" +(* FIXME move *) +lemmas obj_at'_conjI = obj_at_conj' -crunch iflive'[wp]: setQueue if_live_then_nonz_cap' +crunches tcbSchedAppend, tcbSchedDequeue, tcbSchedEnqueue + for tcb_at'[wp]: "tcb_at' t" + and cap_to'[wp]: "ex_nonz_cap_to' p" + and ifunsafe'[wp]: if_unsafe_then_cap' + (wp: crunch_wps simp: crunch_simps) lemma tcbSchedAppend_iflive'[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' tcb\ - tcbSchedAppend tcb \\_. if_live_then_nonz_cap'\" - apply (simp add: tcbSchedAppend_def unless_def) - apply (wp threadSet_iflive' hoare_drop_imps | simp add: crunch_simps)+ + "\if_live_then_nonz_cap' and pspace_aligned' and pspace_distinct'\ + tcbSchedAppend tcbPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbSchedAppend_def + apply (wpsimp wp: tcbQueueAppend_if_live_then_nonz_cap' threadGet_wp simp: bitmap_fun_defs) + apply (frule_tac p=tcbPtr in if_live_then_nonz_capE') + apply (fastforce simp: ko_wp_at'_def st_tcb_at'_def obj_at'_def projectKOs runnable_eq_active') + apply (clarsimp simp: tcbQueueEmpty_def) + apply (erule if_live_then_nonz_capE') + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (fastforce dest!: obj_at'_tcbQueueEnd_ksReadyQueues + simp: ko_wp_at'_def inQ_def obj_at'_def projectKOs tcbQueueEmpty_def) done lemma tcbSchedDequeue_iflive'[wp]: - "\if_live_then_nonz_cap'\ tcbSchedDequeue tcb \\_. if_live_then_nonz_cap'\" + "\if_live_then_nonz_cap' and valid_objs' and sym_heap_sched_pointers\ + tcbSchedDequeue tcbPtr + \\_. if_live_then_nonz_cap'\" apply (simp add: tcbSchedDequeue_def) - apply (wp threadSet_iflive' hoare_when_weak_wp | simp add: crunch_simps)+ - apply ((wp | clarsimp simp: bitmap_fun_defs)+)[1] (* deal with removeFromBitmap *) - apply (wp threadSet_iflive' hoare_when_weak_wp | simp add: crunch_simps)+ - apply (rule_tac Q="\rv. \" in hoare_post_imp, fastforce) - apply (wp | simp add: crunch_simps)+ - done - -crunch ifunsafe'[wp]: tcbSchedEnqueue if_unsafe_then_cap' - (simp: unless_def) -crunch ifunsafe'[wp]: tcbSchedAppend if_unsafe_then_cap' - (simp: unless_def) -crunch ifunsafe'[wp]: tcbSchedDequeue if_unsafe_then_cap' - -crunch idle'[wp]: tcbSchedEnqueue valid_idle' - (simp: crunch_simps unless_def) -crunch idle'[wp]: tcbSchedAppend valid_idle' - (simp: crunch_simps unless_def) -crunch idle'[wp]: tcbSchedDequeue valid_idle' - (simp: crunch_simps) - -crunch global_refs'[wp]: tcbSchedEnqueue valid_global_refs' - (wp: threadSet_global_refs simp: unless_def) -crunch global_refs'[wp]: tcbSchedAppend valid_global_refs' - (wp: threadSet_global_refs simp: unless_def) -crunch global_refs'[wp]: tcbSchedDequeue valid_global_refs' - (wp: threadSet_global_refs) - -crunch irq_node'[wp]: tcbSchedEnqueue "\s. P (irq_node' s)" - (simp: unless_def) -crunch irq_node'[wp]: tcbSchedAppend "\s. P (irq_node' s)" - (simp: unless_def) -crunch irq_node'[wp]: tcbSchedDequeue "\s. P (irq_node' s)" - -crunch typ_at'[wp]: tcbSchedEnqueue "\s. P (typ_at' T p s)" - (simp: unless_def) -crunch typ_at'[wp]: tcbSchedAppend "\s. P (typ_at' T p s)" - (simp: unless_def) -crunch typ_at'[wp]: tcbSchedDequeue "\s. P (typ_at' T p s)" - -crunch ctes_of[wp]: tcbSchedEnqueue "\s. P (ctes_of s)" - (simp: unless_def) -crunch ctes_of[wp]: tcbSchedAppend "\s. P (ctes_of s)" - (simp: unless_def) -crunch ctes_of[wp]: tcbSchedDequeue "\s. P (ctes_of s)" - -crunch ksInterrupt[wp]: tcbSchedEnqueue "\s. P (ksInterruptState s)" - (simp: unless_def) -crunch ksInterrupt[wp]: tcbSchedAppend "\s. P (ksInterruptState s)" - (simp: unless_def) -crunch ksInterrupt[wp]: tcbSchedDequeue "\s. P (ksInterruptState s)" - -crunch irq_states[wp]: tcbSchedEnqueue valid_irq_states' - (simp: unless_def) -crunch irq_states[wp]: tcbSchedAppend valid_irq_states' - (simp: unless_def) -crunch irq_states[wp]: tcbSchedDequeue valid_irq_states' - -crunch ct'[wp]: tcbSchedEnqueue "\s. P (ksCurThread s)" - (simp: unless_def) -crunch ct'[wp]: tcbSchedAppend "\s. P (ksCurThread s)" - (simp: unless_def) -crunch ct'[wp]: tcbSchedDequeue "\s. P (ksCurThread s)" - -crunch pde_mappings'[wp]: tcbSchedEnqueue "valid_pde_mappings'" - (simp: unless_def) -crunch pde_mappings'[wp]: tcbSchedAppend "valid_pde_mappings'" - (simp: unless_def) -crunch pde_mappings'[wp]: tcbSchedDequeue "valid_pde_mappings'" + apply (wpsimp wp: tcbQueueRemove_if_live_then_nonz_cap' threadGet_wp) + apply (fastforce elim: if_live_then_nonz_capE' simp: obj_at'_def projectKOs ko_wp_at'_def) + done + +crunches tcbSchedAppend, tcbSchedDequeue, tcbSchedEnqueue + for typ_at'[wp]: "\s. P (typ_at' T p s)" + and tcb_at'[wp]: "tcb_at' t" + and ctes_of[wp]: "\s. P (ctes_of s)" + and ksInterrupt[wp]: "\s. P (ksInterruptState s)" + and irq_states[wp]: valid_irq_states' + and irq_node'[wp]: "\s. P (irq_node' s)" + and ct'[wp]: "\s. P (ksCurThread s)" + and global_refs'[wp]: valid_global_refs' + and ifunsafe'[wp]: if_unsafe_then_cap' + and cap_to'[wp]: "ex_nonz_cap_to' p" + and state_refs_of'[wp]: "\s. P (state_refs_of' s)" + and idle'[wp]: valid_idle' + and valid_pde_mappings'[wp]: valid_pde_mappings' + (simp: unless_def crunch_simps wp: crunch_wps) lemma tcbSchedEnqueue_vms'[wp]: "\valid_machine_state'\ tcbSchedEnqueue t \\_. valid_machine_state'\" @@ -446,9 +369,6 @@ lemma tcbSchedEnqueue_vms'[wp]: apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift tcbSchedEnqueue_ksMachine) done -crunch ksCurDomain[wp]: tcbSchedEnqueue "\s. P (ksCurDomain s)" -(simp: unless_def) - lemma tcbSchedEnqueue_tcb_in_cur_domain'[wp]: "\tcb_in_cur_domain' t'\ tcbSchedEnqueue t \\_. tcb_in_cur_domain' t' \" apply (rule tcb_in_cur_domain'_lift) @@ -469,19 +389,85 @@ lemma ct_idle_or_in_cur_domain'_lift2: apply (wp hoare_weak_lift_imp hoare_vcg_disj_lift | assumption)+ done +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 tcbSchedNext_update_valid_mdb'[wp]: + "\valid_mdb' and tcb_at' tcbPtr\ threadSet (tcbSchedNext_update f) tcbPtr \\_. valid_mdb'\" + apply (wpsimp wp: threadSet_mdb') + apply (fastforce simp: obj_at'_def valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) + done + +lemma tcbSchedPrev_update_valid_mdb'[wp]: + "\valid_mdb' and tcb_at' tcbPtr\ threadSet (tcbSchedPrev_update f) tcbPtr \\_. valid_mdb'\" + apply (wpsimp wp: threadSet_mdb') + apply (fastforce simp: obj_at'_def valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) + done + +lemma tcbQueueRemove_valid_mdb': + "\\s. valid_mdb' s \ valid_objs' s\ tcbQueueRemove q tcbPtr \\_. valid_mdb'\" + unfolding tcbQueueRemove_def + apply (wpsimp wp: getTCB_wp) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (fastforce simp: valid_tcb'_def obj_at'_def) + done + +lemma tcbQueuePrepend_valid_mdb': + "\valid_mdb' and tcb_at' tcbPtr + and (\s. \ tcbQueueEmpty queue \ tcb_at' (the (tcbQueueHead queue)) s)\ + tcbQueuePrepend queue tcbPtr + \\_. valid_mdb'\" + unfolding tcbQueuePrepend_def + by (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') + +lemma tcbQueueAppend_valid_mdb': + "\\s. valid_mdb' s \ tcb_at' tcbPtr s + \ (\ tcbQueueEmpty queue \ tcb_at' (the (tcbQueueEnd queue)) s)\ + tcbQueueAppend queue tcbPtr + \\_. valid_mdb'\" + unfolding tcbQueueAppend_def + by (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') + +lemma tcbQueued_update_valid_mdb'[wp]: + "\valid_mdb' and tcb_at' tcbPtr\ threadSet (tcbQueued_update f) tcbPtr \\_. valid_mdb'\" + apply (wpsimp wp: threadSet_mdb') + apply (fastforce simp: obj_at'_def valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) + done + +lemma valid_mdb'_ksReadyQueuesL1Bitmap_update[simp]: + "valid_mdb' (ksReadyQueuesL1Bitmap_update f s) = valid_mdb' s" + by (simp add: valid_mdb'_def) + +lemma valid_mdb'_ksReadyQueuesL2Bitmap_update[simp]: + "valid_mdb' (ksReadyQueuesL2Bitmap_update f s) = valid_mdb' s" + by (simp add: valid_mdb'_def) + +lemma tcbSchedEnqueue_valid_mdb'[wp]: + "\valid_mdb' and valid_objs' and pspace_aligned' and pspace_distinct'\ + tcbSchedEnqueue tcbPtr + \\_. valid_mdb'\" + apply (clarsimp simp: tcbSchedEnqueue_def setQueue_def) + apply (wpsimp wp: tcbQueuePrepend_valid_mdb' threadGet_wp simp: bitmap_fun_defs) + apply normalise_obj_at' + apply (fastforce dest!: obj_at'_tcbQueueHead_ksReadyQueues + simp: ready_queue_relation_def ksReadyQueues_asrt_def obj_at'_def) + done + +crunches tcbSchedEnqueue + for cur_tcb'[wp]: cur_tcb' + (wp: threadSet_cur) + lemma tcbSchedEnqueue_invs'[wp]: - "\invs' - and st_tcb_at' runnable' t - and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ - tcbSchedEnqueue t + "\invs' and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ + tcbSchedEnqueue t \\_. invs'\" - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp tcbSchedEnqueue_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 tcbSchedEnqueue_ct_not_inQ + simp: cteCaps_of_def o_def) done crunch ksMachine[wp]: tcbSchedAppend "\s. P (ksMachineState s)" @@ -490,7 +476,7 @@ crunch ksMachine[wp]: tcbSchedAppend "\s. P (ksMachineState s)" lemma tcbSchedAppend_vms'[wp]: "\valid_machine_state'\ tcbSchedAppend t \\_. valid_machine_state'\" apply (simp add: valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift tcbSchedAppend_ksMachine) + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) done crunch pspace_domain_valid[wp]: tcbSchedAppend "pspace_domain_valid" @@ -505,21 +491,27 @@ crunch ksIdleThread[wp]: tcbSchedAppend "\s. P (ksIdleThread s)" crunch ksDomSchedule[wp]: tcbSchedAppend "\s. P (ksDomSchedule s)" (simp: unless_def) +lemma tcbQueueAppend_tcbPriority_obj_at'[wp]: + "tcbQueueAppend queue tptr \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + unfolding tcbQueueAppend_def + apply (wpsimp wp: threadSet_wp) + by (auto simp: obj_at'_def projectKOs objBits_simps ps_clear_def split: if_splits) + +lemma tcbQueueAppend_tcbDomain_obj_at'[wp]: + "tcbQueueAppend queue tptr \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding tcbQueueAppend_def + apply (wpsimp wp: threadSet_wp) + by (auto simp: obj_at'_def projectKOs objBits_simps ps_clear_def split: if_splits) + lemma tcbSchedAppend_tcbDomain[wp]: - "\ obj_at' (\tcb. P (tcbDomain tcb)) t' \ - tcbSchedAppend t - \ \_. obj_at' (\tcb. P (tcbDomain tcb)) t' \" + "tcbSchedAppend t \obj_at' (\tcb. P (tcbDomain tcb)) t'\" apply (clarsimp simp: tcbSchedAppend_def) - apply (wpsimp simp: unless_def)+ - done + by wpsimp lemma tcbSchedAppend_tcbPriority[wp]: - "\ obj_at' (\tcb. P (tcbPriority tcb)) t' \ - tcbSchedAppend t - \ \_. obj_at' (\tcb. P (tcbPriority tcb)) t' \" + "tcbSchedAppend t \obj_at' (\tcb. P (tcbPriority tcb)) t'\" apply (clarsimp simp: tcbSchedAppend_def) - apply (wpsimp simp: unless_def)+ - done + by wpsimp lemma tcbSchedAppend_tcb_in_cur_domain'[wp]: "\tcb_in_cur_domain' t'\ tcbSchedAppend t \\_. tcb_in_cur_domain' t' \" @@ -533,26 +525,58 @@ crunches tcbSchedAppend, tcbSchedDequeue (simp: unless_def) lemma tcbSchedAppend_sch_act_wf[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ tcbSchedAppend thread - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - apply (simp add:tcbSchedAppend_def bitmap_fun_defs) - apply (wp unless_wp setQueue_sch_act threadGet_wp|simp)+ - apply (fastforce simp:typ_at'_def obj_at'_def) + "tcbSchedAppend thread \\s. sch_act_wf (ksSchedulerAction s) s\" + by (wpsimp wp: sch_act_wf_lift) + +lemma tcbSchedAppend_valid_bitmapQ[wp]: + "\valid_bitmaps\ tcbSchedAppend tcbPtr \\_. valid_bitmapQ\" + supply if_split[split del] + unfolding tcbSchedAppend_def + apply (wpsimp simp: tcbQueueAppend_def + wp: setQueue_valid_bitmapQ' addToBitmap_valid_bitmapQ_except addToBitmap_bitmapQ + threadGet_wp hoare_vcg_if_lift2) + apply (clarsimp simp: ksReadyQueues_asrt_def split: if_splits) + apply normalise_obj_at' + apply (force dest: tcbQueueHead_iff_tcbQueueEnd + simp: valid_bitmaps_def valid_bitmapQ_def tcbQueueEmpty_def) + done + +lemma tcbSchedAppend_valid_mdb'[wp]: + "\valid_mdb' and valid_tcbs' and pspace_aligned' and pspace_distinct'\ + tcbSchedAppend tcbPtr + \\_. valid_mdb'\" + apply (clarsimp simp: tcbSchedAppend_def setQueue_def) + apply (wpsimp wp: tcbQueueAppend_valid_mdb' threadGet_wp simp: bitmap_fun_defs) + by (fastforce dest: obj_at'_tcbQueueEnd_ksReadyQueues + simp: ready_queue_relation_def ksReadyQueues_asrt_def obj_at'_def projectKOs) + +lemma tcbSchedAppend_valid_bitmaps[wp]: + "tcbSchedAppend tcbPtr \valid_bitmaps\" + unfolding valid_bitmaps_def + apply wpsimp + apply (clarsimp simp: valid_bitmaps_def) done lemma tcbSchedAppend_invs'[wp]: - "\invs' - and st_tcb_at' runnable' t - and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ - tcbSchedAppend t + "\invs' and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ + tcbSchedAppend t \\_. invs'\" - apply (simp add: invs'_def valid_state'_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: @@ -575,49 +599,13 @@ 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) -lemma valid_queues'_ko_atD: - "valid_queues' s \ ko_at' tcb t s \ tcbQueued tcb - \ t \ set (ksReadyQueues s (tcbDomain tcb, tcbPriority tcb))" - apply (simp add: valid_queues'_def) - apply (elim allE, erule mp) - apply normalise_obj_at' - apply (simp add: inQ_def) - done - -lemma tcbSchedEnqueue_in_ksQ: - "\valid_queues' and tcb_at' t\ tcbSchedEnqueue t - \\r s. \domain priority. t \ set (ksReadyQueues s (domain, priority))\" - apply (rule_tac Q="\s. \d p. valid_queues' s \ - obj_at' (\tcb. tcbPriority tcb = p) t s \ - obj_at' (\tcb. tcbDomain tcb = d) t s" - in hoare_pre_imp) - apply (clarsimp simp: tcb_at'_has_tcbPriority tcb_at'_has_tcbDomain) - apply (rule hoare_vcg_ex_lift)+ - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wpsimp simp: if_apply_def2) - apply (rule_tac Q="\rv s. tdom = d \ rv = p \ obj_at' (\tcb. tcbPriority tcb = p) t s - \ obj_at' (\tcb. tcbDomain tcb = d) t s" - in hoare_post_imp, clarsimp) - apply (wp, (wp threadGet_const)+) - apply (rule_tac Q="\rv s. - obj_at' (\tcb. tcbPriority tcb = p) t s \ - obj_at' (\tcb. tcbDomain tcb = d) t s \ - obj_at' (\tcb. tcbQueued tcb = rv) t s \ - (rv \ t \ set (ksReadyQueues s (d, p)))" in hoare_post_imp) - apply (clarsimp simp: o_def elim!: obj_at'_weakenE) - apply (wp threadGet_obj_at' hoare_vcg_imp_lift threadGet_const) - apply clarsimp - apply normalise_obj_at' - apply (frule(1) valid_queues'_ko_atD, simp+) - done - crunch ksMachine[wp]: tcbSchedDequeue "\s. P (ksMachineState s)" (simp: unless_def) lemma tcbSchedDequeue_vms'[wp]: "\valid_machine_state'\ tcbSchedDequeue t \\_. valid_machine_state'\" apply (simp add: valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift tcbSchedDequeue_ksMachine) + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) done crunch pspace_domain_valid[wp]: tcbSchedDequeue "pspace_domain_valid" @@ -631,50 +619,93 @@ crunch ksIdleThread[wp]: tcbSchedDequeue "\s. P (ksIdleThread s)" crunch ksDomSchedule[wp]: tcbSchedDequeue "\s. P (ksDomSchedule s)" (simp: unless_def) -crunch ksDomScheduleIdx[wp]: tcbSchedDequeue "\s. P (ksDomScheduleIdx s)" -(simp: unless_def) - lemma tcbSchedDequeue_tcb_in_cur_domain'[wp]: "\tcb_in_cur_domain' t'\ tcbSchedDequeue t \\_. tcb_in_cur_domain' t' \" apply (rule tcb_in_cur_domain'_lift) apply wp - apply (clarsimp simp: tcbSchedDequeue_def) - apply (wp hoare_when_weak_wp | simp)+ + apply (clarsimp simp: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wpsimp wp: hoare_when_weak_wp getObject_tcb_wp threadGet_wp) done -lemma tcbSchedDequeue_tcbDomain[wp]: - "\ obj_at' (\tcb. P (tcbDomain tcb)) t' \ - tcbSchedDequeue t - \ \_. obj_at' (\tcb. P (tcbDomain tcb)) t' \" - apply (clarsimp simp: tcbSchedDequeue_def) - apply (wp hoare_when_weak_wp | simp)+ - done +crunch ksDomScheduleIdx[wp]: tcbSchedDequeue "\s. P (ksDomScheduleIdx s)" + (simp: unless_def) -lemma tcbSchedDequeue_tcbPriority[wp]: - "\ obj_at' (\tcb. P (tcbPriority tcb)) t' \ - tcbSchedDequeue t - \ \_. obj_at' (\tcb. P (tcbPriority tcb)) t' \" - apply (clarsimp simp: tcbSchedDequeue_def) - apply (wp hoare_when_weak_wp | simp)+ +lemma tcbSchedDequeue_valid_mdb'[wp]: + "\valid_mdb' and valid_objs'\ tcbSchedDequeue tcbPtr \\_. valid_mdb'\" + unfolding tcbSchedDequeue_def + apply (wpsimp simp: bitmap_fun_defs setQueue_def wp: threadSet_mdb' tcbQueueRemove_valid_mdb') + apply (rule_tac Q="\_. tcb_at' tcbPtr" in hoare_post_imp) + apply (fastforce simp: tcb_cte_cases_def cteSizeBits_def) + apply (wpsimp wp: threadGet_wp)+ + apply (fastforce simp: obj_at'_def) done lemma tcbSchedDequeue_invs'[wp]: - "\invs' and tcb_at' t\ - tcbSchedDequeue t - \\_. invs'\" - unfolding invs'_def valid_state'_def - apply (rule hoare_pre) - 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 - tcbSchedDequeue_valid_queues - untyped_ranges_zero_lift - | simp add: cteCaps_of_def o_def)+ - apply (fastforce elim: valid_objs'_maxDomain valid_objs'_maxPriority simp: valid_pspace'_def)+ + "tcbSchedDequeue t \invs'\" + 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: + "\(s, s') \ state_relation; pspace_aligned s; pspace_distinct s; valid_queues s\ + \ ready_qs_runnable s'" + apply (clarsimp simp: ready_qs_runnable_def) + apply normalise_obj_at' + apply (frule state_relation_ready_queues_relation) + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def + list_queue_relation_def) + apply (drule_tac x="tcbDomain ko" in spec) + apply (drule_tac x="tcbPriority ko" in spec) + apply (clarsimp simp: valid_queues_def) + apply (drule_tac x="tcbDomain ko" in spec) + apply (drule_tac x="tcbPriority ko" in spec) + apply clarsimp + apply (drule_tac x=t in bspec) + apply (fastforce simp: inQ_def in_opt_pred obj_at'_def projectKOs opt_map_red) + apply (fastforce dest: st_tcb_at_runnable_cross simp: obj_at'_def projectKOs st_tcb_at'_def) + done + +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_queues)?, (frule invs_psp_aligned)?, (frule invs_distinct)?, + fastforce dest: ready_qs_runnable_cross + +defs idleThreadNotQueued_def: + "idleThreadNotQueued s \ obj_at' (Not \ tcbQueued) (ksIdleThread s) s" + +lemma idle_thread_not_queued: + "\valid_idle s; valid_queues s; valid_etcbs s\ + \ \ (\d p. idle_thread s \ set (ready_queues s d p))" + apply (clarsimp simp: valid_queues_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply clarsimp + apply (drule_tac x="idle_thread s" in bspec) + apply fastforce + apply (clarsimp simp: valid_idle_def pred_tcb_at_def obj_at_def valid_etcbs_def) + done + +lemma valid_idle_tcb_at: + "valid_idle s \ tcb_at (idle_thread s) s" + by (clarsimp simp: valid_idle_def pred_tcb_at_def obj_at_def is_tcb_def) + lemma setCurThread_corres: - "corres dc \ \ (modify (cur_thread_update (\_. t))) (setCurThread t)" - apply (unfold setCurThread_def) + "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 @@ -716,47 +747,62 @@ lemma arch_switch_thread_ksQ[wp]: apply (wp) done -crunch valid_queues[wp]: "Arch.switchToThread" "Invariants_H.valid_queues" -(wp: crunch_wps simp: crunch_simps ignore: clearExMonitor) +crunches storeWordUser, setVMRoot, asUser, storeWordUser, Arch.switchToThread + for ksQ[wp]: "\s. P (ksReadyQueues s p)" + and ksIdleThread[wp]: "\s. P (ksIdleThread s)" + and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_objs'[wp]: valid_objs' + (wp: crunch_wps threadSet_sched_pointers simp: crunch_simps) + +crunches arch_switch_to_thread, arch_switch_to_idle_thread + for pspace_aligned[wp]: pspace_aligned + and pspace_distinct[wp]: pspace_distinct + and ready_qs_distinct[wp]: ready_qs_distinct + and valid_idle[wp]: valid_idle + (wp: ready_qs_distinct_lift) + +lemma valid_queues_in_correct_ready_q[elim!]: + "valid_queues s \ in_correct_ready_q s" + by (clarsimp simp: valid_queues_def in_correct_ready_q_def) + +lemma valid_queues_ready_qs_distinct[elim!]: + "valid_queues s \ ready_qs_distinct s" + by (clarsimp simp: valid_queues_def ready_qs_distinct_def) 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_vs_lookup and valid_global_objs and unique_table_refs o caps_of_state - and st_tcb_at runnable t and valid_etcbs) - (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)" - (is "corres _ ?PA ?PH _ _") - -proof - - have mainpart: "corres dc (?PA) (?PH) - (do y \ arch_switch_to_thread t; - y \ (tcb_sched_action tcb_sched_dequeue t); - modify (cur_thread_update (\_. t)) - od) - (do y \ Arch.switchToThread t; - y \ tcbSchedDequeue t; - setCurThread 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) + apply add_ready_qs_runnable + apply (simp add: switch_to_thread_def Thread_H.switchToThread_def) + apply (rule corres_symb_exec_l[OF _ _ get_sp]; (solves wpsimp)?) + apply (rule corres_symb_exec_l[OF _ _ assert_sp]; (solves wpsimp)?) + 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_stateAssert_ignore) + apply (fastforce dest!: state_relation_ready_queues_relation intro: ksReadyQueues_asrt_cross) + apply (rule corres_stateAssert_add_assertion[rotated]) + apply fastforce apply (rule corres_guard_imp) apply (rule corres_split[OF arch_switchToThread_corres]) apply (rule corres_split[OF tcbSchedDequeue_corres setCurThread_corres]) - apply (wp|clarsimp simp: tcb_at_is_etcb_at st_tcb_at_tcb_at)+ - done - - show ?thesis - apply - - apply (simp add: switch_to_thread_def Thread_H.switchToThread_def) - apply (rule corres_symb_exec_l [where Q = "\ s rv. (?PA and (=) rv) s", - OF corres_symb_exec_l [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 @@ -771,15 +817,21 @@ lemma arch_switchToIdleThread_corres: done lemma switchToIdleThread_corres: - "corres dc invs invs_no_cicd' switch_to_idle_thread switchToIdleThread" + "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 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_trivial, rule corres_modify) - apply (simp add: state_relation_def cdt_relation_def) - apply (wp+, simp+) + 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) @@ -814,11 +866,9 @@ proof - 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 Invariants_H.valid_queues_def - sch_act_wf ct_in_state'_def state_refs_of'_def - ps_clear_def valid_irq_node'_def valid_queues'_def ct_not_inQ_ct - ct_idle_or_in_cur_domain'_def - bitmapQ_defs valid_queues_no_bitmap_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 @@ -832,101 +882,20 @@ lemma setCurThread_invs: by (rule hoare_pre, rule setCurThread_invs_no_cicd') (simp add: invs'_to_invs_no_cicd'_def) -lemma valid_queues_not_runnable_not_queued: - fixes s - assumes vq: "Invariants_H.valid_queues 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 - - with vq have "st_tcb_at' runnable' t s" - unfolding Invariants_H.valid_queues_def valid_queues_no_bitmap_def - apply - - apply clarsimp - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp simp add: st_tcb_at'_def) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE) - apply (clarsimp) - done - - with st show False - apply - - apply (drule(1) pred_tcb_at_conj') - apply (clarsimp) - done -qed - -(* - * The idle thread is not part of any ready queues. - *) -lemma idle'_not_tcbQueued': - assumes vq: "Invariants_H.valid_queues 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 vq' show ?thesis - by (rule valid_queues_not_runnable_not_queued) - qed - lemma setCurThread_invs_no_cicd'_idle_thread: - "\invs_no_cicd' and (\s. t = ksIdleThread s) \ 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 - have idle'_activatable': "\ s t. st_tcb_at' idle' t s \ st_tcb_at' activatable' t s" - apply (clarsimp simp: st_tcb_at'_def o_def obj_at'_def) + "\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 - show ?thesis - apply (simp add: setCurThread_def) - apply wp - apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def) - apply (frule (2) idle'_not_tcbQueued'[simplified o_def]) - apply (clarsimp simp add: ct_not_inQ_ct idle'_activatable' - 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_queues_no_bitmap_def valid_queues'_def - pred_tcb_at'_def - cong: option.case_cong) - apply (clarsimp simp: obj_at'_def projectKOs idle_tcb'_def) - done -qed lemma clearExMonitor_invs'[wp]: "\invs'\ doMachineOp ARM.clearExMonitor \\rv. invs'\" @@ -964,13 +933,13 @@ lemma Arch_switchToThread_tcb_in_cur_domain'[wp]: done lemma tcbSchedDequeue_not_tcbQueued: - "\ tcb_at' t \ tcbSchedDequeue t \ \_. obj_at' (\x. \ tcbQueued x) t \" + "\\\ tcbSchedDequeue t \\_. obj_at' (\x. \ tcbQueued x) t\" apply (simp add: tcbSchedDequeue_def) apply (wp|clarsimp)+ apply (rule_tac Q="\queued. obj_at' (\x. tcbQueued x = queued) t" in hoare_post_imp) - apply (clarsimp simp: obj_at'_def) - apply (wp threadGet_obj_at') - apply (simp) + apply (clarsimp simp: obj_at'_def) + apply (wpsimp wp: threadGet_wp)+ + apply (clarsimp simp: obj_at'_def) done lemma Arch_switchToThread_obj_at[wp]: @@ -1002,10 +971,6 @@ crunch valid_irq_states'[wp]: asUser "valid_irq_states'" crunch valid_machine_state'[wp]: asUser "valid_machine_state'" (wp: crunch_wps simp: crunch_simps) -crunch valid_queues'[wp]: asUser "valid_queues'" -(wp: crunch_wps simp: crunch_simps) - - crunch irq_masked'_helper: asUser "\s. P (intStateIRQTable (ksInterruptState s))" (wp: crunch_wps simp: crunch_simps) @@ -1033,22 +998,17 @@ lemma Arch_switchToThread_invs_no_cicd': lemma tcbSchedDequeue_invs_no_cicd'[wp]: - "\invs_no_cicd' and tcb_at' t\ - tcbSchedDequeue t - \\_. invs_no_cicd'\" - unfolding all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def + "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 - tcbSchedDequeue_valid_queues_weak untyped_ranges_zero_lift | simp add: cteCaps_of_def o_def)+ apply clarsimp - apply (fastforce simp: valid_pspace'_def valid_queues_def - elim: valid_objs'_maxDomain valid_objs'_maxPriority intro: obj_at'_conjI) done lemma switchToThread_invs_no_cicd': - "\invs_no_cicd' and st_tcb_at' runnable' t and tcb_in_cur_domain' t \ ThreadDecls_H.switchToThread t \\rv. invs' \" + "\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') @@ -1056,7 +1016,7 @@ lemma switchToThread_invs_no_cicd': done lemma switchToThread_invs[wp]: - "\invs' and st_tcb_at' runnable' t and tcb_in_cur_domain' t \ switchToThread t \\rv. invs' \" + "\invs' and tcb_in_cur_domain' t \ switchToThread t \\rv. invs' \" apply (simp add: Thread_H.switchToThread_def ) apply (wp threadSet_timeslice_invs setCurThread_invs Arch_switchToThread_invs dmo_invs' @@ -1141,62 +1101,6 @@ lemma tcb_at_typ_at': apply (case_tac ko, simp_all) done - -lemma invs'_not_runnable_not_queued: - fixes s - assumes inv: "invs' s" - and st: "st_tcb_at' (Not \ runnable') t s" - shows "obj_at' (Not \ tcbQueued) t s" - apply (insert assms) - apply (rule valid_queues_not_runnable_not_queued) - apply (clarsimp simp add: invs'_def valid_state'_def)+ - done - -lemma valid_queues_not_tcbQueued_not_ksQ: - fixes s - assumes vq: "Invariants_H.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" - unfolding Invariants_H.valid_queues_def valid_queues_no_bitmap_def - apply clarify - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE) - apply (simp) - done - 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 valid_state'_def) - apply (drule(1) valid_queues_not_tcbQueued_not_ksQ) - apply (clarsimp) - done - -lemma ct_not_ksQ: - "\ invs' s; ksSchedulerAction s = ResumeCurrentThread \ - \ \p. ksCurThread s \ set (ksReadyQueues s p)" - apply (clarsimp simp: invs'_def valid_state'_def ct_not_inQ_def) - apply (frule(1) valid_queues_not_tcbQueued_not_ksQ) - apply (fastforce) - done - crunch nosch[wp]: getCurThread "\s. P (ksSchedulerAction s)" lemma setThreadState_rct: @@ -1271,21 +1175,24 @@ lemma bitmapQ_from_bitmap_lookup: done lemma lookupBitmapPriority_obj_at': - "\ksReadyQueuesL1Bitmap s (ksCurDomain s) \ 0; valid_queues_no_bitmap s; valid_bitmapQ s; - bitmapQ_no_L1_orphans s\ - \ obj_at' (inQ (ksCurDomain s) (lookupBitmapPriority (ksCurDomain s) s) and runnable' \ tcbState) - (hd (ksReadyQueues s (ksCurDomain s, lookupBitmapPriority (ksCurDomain s) s))) s" + "\ksReadyQueuesL1Bitmap s d \ 0; valid_bitmapQ s; bitmapQ_no_L1_orphans s; + ksReadyQueues_asrt s; ready_qs_runnable s; pspace_aligned' s; pspace_distinct' s\ + \ obj_at' (inQ d (lookupBitmapPriority d s) and runnable' \ tcbState) + (the (tcbQueueHead (ksReadyQueues s (d, lookupBitmapPriority d s)))) s" apply (drule (2) bitmapQ_from_bitmap_lookup) apply (simp add: valid_bitmapQ_bitmapQ_simp) - apply (case_tac "ksReadyQueues s (ksCurDomain s, lookupBitmapPriority (ksCurDomain s) s)", simp) - apply (clarsimp, rename_tac t ts) - apply (drule cons_set_intro) - apply (drule (2) valid_queues_no_bitmap_objD) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def tcbQueueEmpty_def) + apply (drule_tac x=d in spec) + apply (drule_tac x="lookupBitmapPriority d s" in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (fastforce simp: obj_at'_and ready_qs_runnable_def obj_at'_def st_tcb_at'_def inQ_def + tcbQueueEmpty_def) done lemma bitmapL1_zero_ksReadyQueues: "\ valid_bitmapQ s ; bitmapQ_no_L1_orphans s \ - \ (ksReadyQueuesL1Bitmap s d = 0) = (\p. ksReadyQueues s (d,p) = [])" + \ (ksReadyQueuesL1Bitmap s d = 0) = (\p. tcbQueueEmpty (ksReadyQueues s (d, p)))" apply (cases "ksReadyQueuesL1Bitmap s d = 0") apply (force simp add: bitmapQ_def valid_bitmapQ_def) apply (fastforce dest: bitmapQ_from_bitmap_lookup simp: valid_bitmapQ_bitmapQ_simp) @@ -1356,7 +1263,7 @@ lemma bitmapL1_highest_lookup: done lemma bitmapQ_ksReadyQueuesI: - "\ bitmapQ d p s ; valid_bitmapQ s \ \ ksReadyQueues s (d, p) \ []" + "\ bitmapQ d p s ; valid_bitmapQ s \ \ \ tcbQueueEmpty (ksReadyQueues s (d, p))" unfolding valid_bitmapQ_def by simp lemma getReadyQueuesL2Bitmap_inv[wp]: @@ -1365,24 +1272,22 @@ lemma getReadyQueuesL2Bitmap_inv[wp]: lemma switchToThread_lookupBitmapPriority_wp: "\\s. invs_no_cicd' s \ bitmapQ (ksCurDomain s) (lookupBitmapPriority (ksCurDomain s) s) s \ - t = hd (ksReadyQueues s (ksCurDomain s, lookupBitmapPriority (ksCurDomain 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 ; 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 elim: obj_at'_weaken simp: inQ_def tcb_in_cur_domain'_def st_tcb_at'_def) - done - thus ?thesis - by (wp switchToThread_invs_no_cicd') (fastforce dest: invs_no_cicd'_queues) -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_no_cicd': "\invs_no_cicd'\ switchToIdleThread \\rv. invs'\" @@ -1482,9 +1387,8 @@ 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 st_tcb_at runnable t and valid_etcbs) - (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) @@ -1493,8 +1397,8 @@ lemma guarded_switch_to_corres: 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)+ - done + apply (force simp: st_tcb_at_tcb_at projectKOs)+ + done abbreviation "enumPrio \ [0.e.maxPriority]" @@ -1503,7 +1407,7 @@ lemma curDomain_corres: "corres (=) \ \ (gets cur_domain) (curDomain)" lemma curDomain_corres': "corres (=) \ (\s. ksCurDomain s \ maxDomain) - (gets cur_domain) (if 1 < numDomains then curDomain else return 0)" + (gets cur_domain) (if Suc 0 < numDomains then curDomain else return 0)" apply (case_tac "1 < numDomains"; simp) apply (rule corres_guard_imp[OF curDomain_corres]; solves simp) (* if we have only one domain, then we are in it *) @@ -1513,27 +1417,32 @@ lemma curDomain_corres': lemma lookupBitmapPriority_Max_eqI: "\ valid_bitmapQ s ; bitmapQ_no_L1_orphans s ; ksReadyQueuesL1Bitmap s d \ 0 \ - \ lookupBitmapPriority d s = (Max {prio. ksReadyQueues s (d, prio) \ []})" + \ lookupBitmapPriority d s = (Max {prio. \ tcbQueueEmpty (ksReadyQueues s (d, prio))})" apply (rule Max_eqI[simplified eq_commute]; simp) apply (fastforce simp: bitmapL1_highest_lookup valid_bitmapQ_bitmapQ_simp) apply (metis valid_bitmapQ_bitmapQ_simp bitmapQ_from_bitmap_lookup) done lemma corres_gets_queues_getReadyQueuesL1Bitmap: - "corres (\qs l1. ((l1 = 0) = (\p. qs p = []))) \ valid_queues + "corres (\qs l1. (l1 = 0) = (\p. qs p = [])) \ valid_bitmaps (gets (\s. ready_queues s d)) (getReadyQueuesL1Bitmap d)" - unfolding state_relation_def valid_queues_def getReadyQueuesL1Bitmap_def - by (clarsimp simp: bitmapL1_zero_ksReadyQueues ready_queues_relation_def) + unfolding state_relation_def valid_bitmaps_def getReadyQueuesL1Bitmap_def + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def) + apply (drule_tac x=d in spec) + apply (fastforce simp: bitmapL1_zero_ksReadyQueues list_queue_relation_def tcbQueueEmpty_def) + done lemma guarded_switch_to_chooseThread_fragment_corres: "corres dc (P and st_tcb_at runnable t and invs and valid_sched) - (P' and st_tcb_at' runnable' t and invs_no_cicd') - (guarded_switch_to t) - (do runnable \ isRunnable t; - y \ assert runnable; - ThreadDecls_H.switchToThread t - od)" + (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) @@ -1548,35 +1457,50 @@ lemma guarded_switch_to_chooseThread_fragment_corres: 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' + \ Max {prio. ready_queues s d prio \ []} + = Max {prio. \ tcbQueueEmpty (ksReadyQueues s' (d, prio))}" + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def + list_queue_relation_def tcbQueueEmpty_def) + apply (rule Max_eq_if) + apply fastforce + apply fastforce + apply (fastforce dest: heap_path_head) + apply clarsimp + apply (drule_tac x=d in spec) + apply (drule_tac x=b in spec) + apply force + done + lemma bitmap_lookup_queue_is_max_non_empty: - "\ valid_queues s'; (s, s') \ state_relation; invs s; + "\ 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 all_invs_but_ct_idle_or_in_cur_domain'_def 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 \ - \ 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 (simp add: valid_queues_no_bitmap_def) - apply (erule_tac x="ksCurDomain s" in allE) - apply (erule_tac x="lookupBitmapPriority (ksCurDomain s) s" in allE) - apply (clarsimp simp: st_tcb_at'_def) - apply (erule obj_at'_weaken) - apply simp - 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 \" @@ -1589,51 +1513,68 @@ lemma invs_no_cicd_ksCurDomain_maxDomain': unfolding invs_no_cicd'_def by simp lemma chooseThread_corres: - "corres dc (invs and valid_sched) (invs_no_cicd') - choose_thread chooseThread" (is "corres _ ?PREI ?PREH _ _") + "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 - unfolding choose_thread_def chooseThread_def - 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 \ 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 dest!: invs_no_cicd'_queues simp: bitmap_lookup_queue_is_max_non_empty) - 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 (clarsimp simp: if_apply_def2) - apply (wp hoare_vcg_conj_lift hoare_vcg_imp_lift ksReadyQueuesL1Bitmap_return_wp) - apply (wpsimp wp: curDomain_or_return_0 simp: curDomain_def)+ - apply (fastforce simp: invs_no_cicd'_def) - apply (clarsimp simp: valid_sched_def DetSchedInvs_AI.valid_queues_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 (simp add: invs_no_cicd_ksCurDomain_maxDomain') - apply (clarsimp dest!: invs_no_cicd'_queues) - apply (fastforce intro: ksReadyQueuesL1Bitmap_st_tcb_at') - done + 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 (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 = @@ -1722,7 +1663,7 @@ lemma isHighestPrio_corres: assumes "d' = d" assumes "p' = p" shows - "corres ((=)) \ valid_queues + "corres ((=)) \ valid_bitmaps (gets (is_highest_prio d p)) (isHighestPrio d' p')" using assms @@ -1732,18 +1673,16 @@ lemma isHighestPrio_corres: apply (rule corres_split[OF corres_gets_queues_getReadyQueuesL1Bitmap]) apply (rule corres_if_r'[where P'="\_. True",rotated]) apply (rule_tac corres_symb_exec_r) - apply (rule_tac - P="\s. q = ready_queues s d - " and - P'="\s. valid_queues s \ - l1 = ksReadyQueuesL1Bitmap s d \ - l1 \ 0 \ hprio = lookupBitmapPriority d s" and - F="hprio = Max {prio. q prio \ []}" in corres_req) - apply (elim conjE) - apply (clarsimp simp: valid_queues_def) - apply (subst lookupBitmapPriority_Max_eqI; blast?) - apply (fastforce simp: ready_queues_relation_def dest!: state_relationD) - apply fastforce + apply (rule_tac P="\s. q = ready_queues s d" + and P'="\s. valid_bitmaps s \ l1 = ksReadyQueuesL1Bitmap s d \ + l1 \ 0 \ hprio = lookupBitmapPriority d s" + and F="hprio = Max {prio. q prio \ []}" in corres_req) + apply (elim conjE) + apply (clarsimp simp: valid_bitmaps_def) + apply (subst lookupBitmapPriority_Max_eqI; blast?) + apply (fastforce dest: state_relation_ready_queues_relation Max_prio_helper[where d=d] + simp: tcbQueueEmpty_def) + apply fastforce apply (wpsimp simp: if_apply_def2 wp: hoare_drop_imps ksReadyQueuesL1Bitmap_return_wp)+ done @@ -1755,9 +1694,8 @@ crunch inv[wp]: schedule_switch_thread_fastfail P crunch inv[wp]: scheduleSwitchThreadFastfail P lemma setSchedulerAction_invs': (* not in wp set, clobbered by ssa_wp *) - "\\s. invs' s \ setSchedulerAction ChooseNewThread \\_. invs' \" + "setSchedulerAction ChooseNewThread \invs' \" by (wpsimp simp: invs'_def cur_tcb'_def valid_state'_def valid_irq_node'_def ct_not_inQ_def - valid_queues_def valid_queues_no_bitmap_def valid_queues'_def ct_idle_or_in_cur_domain'_def) lemma scheduleChooseNewThread_corres: @@ -1789,6 +1727,46 @@ lemma ethread_get_when_corres: 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 + +crunches 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) + +crunches 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] @@ -1816,7 +1794,7 @@ lemma schedule_corres: apply (rule corres_split[OF thread_get_isRunnable_corres]) apply (rule corres_split) apply (rule corres_when, simp) - apply (rule tcbSchedEnqueue_corres) + 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)+ @@ -1825,7 +1803,7 @@ lemma schedule_corres: rename_tac was_running wasRunning) apply (rule corres_split) apply (rule corres_when, simp) - apply (rule tcbSchedEnqueue_corres) + 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) @@ -1841,7 +1819,7 @@ lemma schedule_corres: 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]) + apply (rule corres_split[OF tcbSchedEnqueue_corres], simp) apply (simp, fold dc_def) apply (rule corres_split) apply (rule setSchedulerAction_corres; simp) @@ -1855,7 +1833,7 @@ lemma schedule_corres: 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]) + apply (rule corres_split[OF tcbSchedAppend_corres], simp) apply (simp, fold dc_def) apply (rule corres_split) apply (rule setSchedulerAction_corres; simp) @@ -1887,7 +1865,8 @@ lemma schedule_corres: 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)+ + del: gets_wp + | strengthen valid_objs'_valid_tcbs')+ apply (clarsimp simp: conj_ac if_apply_def2 cong: imp_cong conj_cong del: hoare_gets) apply (wp gets_wp)+ @@ -1910,18 +1889,17 @@ lemma schedule_corres: 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 (clarsimp simp add: pred_tcb_at_def obj_at_def is_tcb valid_idle_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)+ - apply (simp add: valid_sched_def valid_blocked_def valid_blocked_except_def) done (* haskell final subgoal *) - apply (clarsimp simp: if_apply_def2 invs'_def valid_state'_def + 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 @@ -1935,11 +1913,8 @@ proof - apply (simp add: setSchedulerAction_def) apply wp apply (clarsimp simp add: invs'_def valid_state'_def cur_tcb'_def - Invariants_H.valid_queues_def - state_refs_of'_def ps_clear_def - valid_irq_node'_def valid_queues'_def - tcb_in_cur_domain'_def ct_idle_or_in_cur_domain'_def - bitmapQ_defs valid_queues_no_bitmap_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 @@ -1979,7 +1954,7 @@ lemma switchToThread_ct_not_queued_2: apply (simp add: Thread_H.switchToThread_def) apply (wp) apply (simp add: ARM_H.switchToThread_def setCurThread_def) - apply (wp tcbSchedDequeue_not_tcbQueued | simp )+ + apply (wp tcbSchedDequeue_not_tcbQueued hoare_drop_imp | simp )+ done lemma setCurThread_obj_at': @@ -1993,11 +1968,12 @@ proof - qed lemma switchToIdleThread_ct_not_queued_no_cicd': - "\ invs_no_cicd' \ switchToIdleThread \\rv s. obj_at' (Not \ tcbQueued) (ksCurThread s) s \" + "\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 (rule idle'_not_tcbQueued') - apply (simp add: invs_no_cicd'_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]: @@ -2014,7 +1990,7 @@ lemma switchToThread_tcb_in_cur_domain': ThreadDecls_H.switchToThread thread \\y s. tcb_in_cur_domain' (ksCurThread s) s\" apply (simp add: Thread_H.switchToThread_def setCurThread_def) - apply (wpsimp wp: tcbSchedDequeue_not_tcbQueued) + apply (wpsimp wp: tcbSchedDequeue_not_tcbQueued hoare_drop_imps) done lemma chooseThread_invs_no_cicd'_posts: (* generic version *) @@ -2036,11 +2012,14 @@ proof - by (simp add: all_invs_but_ct_idle_or_in_cur_domain'_def maxDomain_def) show ?thesis - unfolding chooseThread_def Let_def curDomain_def + apply (clarsimp simp: chooseThread_def Let_def curDomain_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp])+ apply (simp only: return_bind, simp) - apply (rule hoare_seq_ext[where B="\rv s. invs_no_cicd' s \ rv = ksCurDomain s"]) + apply (rule hoare_seq_ext[where B="\rv s. invs_no_cicd' s \ rv = ksCurDomain s + \ ksReadyQueues_asrt s \ ready_qs_runnable s"]) apply (rule_tac B="\rv s. invs_no_cicd' s \ curdom = ksCurDomain s \ - rv = ksReadyQueuesL1Bitmap s curdom" in hoare_seq_ext) + rv = ksReadyQueuesL1Bitmap s curdom \ + ksReadyQueues_asrt s \ ready_qs_runnable s" in hoare_seq_ext) apply (rename_tac l1) apply (case_tac "l1 = 0") (* switch to idle thread *) @@ -2054,12 +2033,10 @@ proof - 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 - apply (clarsimp dest!: invs_no_cicd'_queues - simp: valid_queues_def lookupBitmapPriority_def[symmetric]) - 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 (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 @@ -2098,11 +2075,14 @@ proof - (* FIXME this is almost identical to the chooseThread_invs_no_cicd'_posts proof, can generalise? *) show ?thesis - unfolding chooseThread_def Let_def curDomain_def + apply (clarsimp simp: chooseThread_def Let_def curDomain_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp])+ apply (simp only: return_bind, simp) - apply (rule hoare_seq_ext[where B="\rv s. invs_no_cicd' s \ rv = ksCurDomain s"]) + apply (rule hoare_seq_ext[where B="\rv s. invs_no_cicd' s \ rv = ksCurDomain s + \ ksReadyQueues_asrt s \ ready_qs_runnable s"]) apply (rule_tac B="\rv s. invs_no_cicd' s \ curdom = ksCurDomain s \ - rv = ksReadyQueuesL1Bitmap s curdom" in hoare_seq_ext) + rv = ksReadyQueuesL1Bitmap s curdom \ + ksReadyQueues_asrt s \ ready_qs_runnable s" in hoare_seq_ext) apply (rename_tac l1) apply (case_tac "l1 = 0") (* switch to idle thread *) @@ -2110,7 +2090,10 @@ proof - (* we have a thread to switch to *) apply (clarsimp simp: bitmap_fun_defs) apply (wp assert_inv) - apply (clarsimp dest!: invs_no_cicd'_queues simp: valid_queues_def) + 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 @@ -2260,12 +2243,20 @@ crunch sch_act_sane: setThreadState, setBoundNotification "sch_act_sane" (simp: crunch_simps wp: crunch_wps) lemma possibleSwitchTo_corres: - "corres dc (valid_etcbs and weak_valid_sched_action and cur_tcb and st_tcb_at runnable t) - (Invariants_H.valid_queues and valid_queues' and - (\s. weak_sch_act_wf (ksSchedulerAction s) s) and cur_tcb' and tcb_at' t and st_tcb_at' runnable' t and valid_objs') - (possible_switch_to t) - (possibleSwitchTo t)" + "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 (rule corres_split[OF curDomain_corres], simp) @@ -2274,21 +2265,21 @@ lemma possibleSwitchTo_corres: apply (clarsimp simp: etcb_relation_def) apply (rule corres_split[OF getSchedulerAction_corres]) apply (rule corres_if, simp) - apply (rule tcbSchedEnqueue_corres) + 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) - apply (wp rescheduleRequired_valid_queues'_weak)+ + 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 (fastforce simp: valid_sched_def invs_def valid_state_def cur_tcb_def + 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 (simp add: tcb_at_is_etcb_at) + apply (fastforce simp: tcb_at_is_etcb_at) done end diff --git a/proof/refine/ARM/StateRelation.thy b/proof/refine/ARM/StateRelation.thy index 31c0ffb48f..2734b5ba88 100644 --- a/proof/refine/ARM/StateRelation.thy +++ b/proof/refine/ARM/StateRelation.thy @@ -20,6 +20,10 @@ where lemmas cte_map_def' = cte_map_def[simplified cte_level_bits_def, simplified] +lemma cte_map_def2: + "cte_map \ \(oref, cref). oref + (of_bl cref << cte_level_bits)" + by (simp add: cte_map_def word_shift_by_n) + definition lookup_failure_map :: "ExceptionTypes_A.lookup_failure \ Fault_H.lookup_failure" where @@ -192,13 +196,20 @@ where \ tcb_bound_notification tcb = tcbBoundNotification tcb' \ tcb_mcpriority tcb = tcbMCP tcb'" +\ \ + A pair of objects @{term "(obj, obj')"} should satisfy the following relation when, under further + mild assumptions, a @{term corres_underlying} lemma for @{term "set_object obj"} + and @{term "setObject obj'"} can be stated: see setObject_other_corres in KHeap_R. + + TCBs do not satisfy this relation because the tcbSchedPrev and tcbSchedNext fields of a TCB are + used to model the ready queues, and so an update to such a field would correspond to an update + to a ready queue (see ready_queues_relation below).\ definition other_obj_relation :: "Structures_A.kernel_object \ Structures_H.kernel_object \ bool" where "other_obj_relation obj obj' \ (case (obj, obj') of - (TCB tcb, KOTCB tcb') \ tcb_relation tcb tcb' - | (Endpoint ep, KOEndpoint ep') \ ep_relation ep ep' + (Endpoint ep, KOEndpoint ep') \ ep_relation ep ep' | (Notification ntfn, KONotification ntfn') \ ntfn_relation ntfn ntfn' | (ArchObj (ARM_A.ASIDPool pool), KOArch (KOASIDPool pool')) \ asid_pool_relation pool pool' @@ -277,6 +288,12 @@ where | "aobj_relation_cuts (PageDirectory pd) x = (\y. (x + (ucast y << 2), pde_relation y)) ` UNIV" +definition tcb_relation_cut :: "Structures_A.kernel_object \ kernel_object \ bool" where + "tcb_relation_cut obj obj' \ + case (obj, obj') of + (TCB t, KOTCB t') \ tcb_relation t t' + | _ \ False" + primrec obj_relation_cuts :: "Structures_A.kernel_object \ word32 \ obj_relation_cuts" where @@ -284,7 +301,7 @@ where (if well_formed_cnode_n sz cs then {(cte_map (x, y), cte_relation y) | y. y \ dom cs} else {(x, \\)})" -| "obj_relation_cuts (TCB tcb) x = {(x, other_obj_relation)}" +| "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 (ArchObj ao) x = aobj_relation_cuts ao x" @@ -295,6 +312,7 @@ 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, \\)} + | TCB tcb \ {(x, tcb_relation_cut)} | ArchObj (PageTable pt) \ (\y. (x + (ucast y << 2), pte_relation y)) ` (UNIV :: word8 set) | ArchObj (PageDirectory pd) \ (\y. (x + (ucast y << 2), pde_relation y)) @@ -309,6 +327,7 @@ lemma obj_relation_cuts_def3: "obj_relation_cuts ko x = (case (a_type ko) of ACapTable n \ {(cte_map (x, y), cte_relation y) | y. length y = n} + | ATCB \ {(x, tcb_relation_cut)} | AArch APageTable \ (\y. (x + (ucast y << 2), pte_relation y)) ` (UNIV :: word8 set) | AArch APageDirectory \ (\y. (x + (ucast y << 2), pde_relation y)) @@ -327,6 +346,7 @@ definition "is_other_obj_relation_type tp \ case tp of ACapTable n \ False + | ATCB \ False | AArch APageTable \ False | AArch APageDirectory \ False | AArch (AUserData _) \ False @@ -338,6 +358,10 @@ 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_TCB: + "\ is_other_obj_relation_type ATCB" + by (simp add: is_other_obj_relation_type_def) + lemma is_other_obj_relation_type_UserData: "\ is_other_obj_relation_type (AArch (AUserData sz))" unfolding is_other_obj_relation_type_def by simp @@ -385,11 +409,55 @@ where "sched_act_relation choose_new_thread a' = (a' = ChooseNewThread)" | "sched_act_relation (switch_thread x) a' = (a' = SwitchToThread x)" -definition - ready_queues_relation :: "(Deterministic_A.domain \ Structures_A.priority \ Deterministic_A.ready_queue) - \ (domain \ priority \ KernelStateData_H.ready_queue) \ bool" -where - "ready_queues_relation qs qs' \ \d p. (qs d p = qs' (d, p))" +definition queue_end_valid :: "obj_ref list \ tcb_queue \ bool" where + "queue_end_valid ts q \ + (ts = [] \ tcbQueueEnd q = None) \ (ts \ [] \ tcbQueueEnd q = Some (last ts))" + +definition prev_queue_head :: "tcb_queue \ (obj_ref \ 'a) \ bool" where + "prev_queue_head q prevs \ \head. tcbQueueHead q = Some head \ prevs head = None" + +lemma prev_queue_head_heap_upd: + "\prev_queue_head q prevs; Some r \ tcbQueueHead q\ \ prev_queue_head q (prevs(r := x))" + by (clarsimp simp: prev_queue_head_def) + +definition list_queue_relation :: + "obj_ref list \ tcb_queue \ (obj_ref \ obj_ref) \ (obj_ref \ obj_ref) \ bool" + where + "list_queue_relation ts q nexts prevs \ + heap_ls nexts (tcbQueueHead q) ts \ queue_end_valid ts q \ prev_queue_head q prevs" + +lemma list_queue_relation_nil: + "list_queue_relation ts q nexts prevs \ ts = [] \ tcbQueueEmpty q" + by (fastforce dest: heap_path_head simp: tcbQueueEmpty_def list_queue_relation_def) + +definition ready_queue_relation :: + "Deterministic_A.domain \ Structures_A.priority + \ Deterministic_A.ready_queue \ ready_queue + \ (obj_ref \ obj_ref) \ (obj_ref \ obj_ref) + \ (obj_ref \ bool) \ bool" + where + "ready_queue_relation d p q q' nexts prevs flag \ + list_queue_relation q q' nexts prevs + \ (\t. flag t \ t \ set q) + \ (d > maxDomain \ p > maxPriority \ tcbQueueEmpty q')" + +definition ready_queues_relation_2 :: + "(Deterministic_A.domain \ Structures_A.priority \ Deterministic_A.ready_queue) + \ (domain \ priority \ ready_queue) + \ (obj_ref \ obj_ref) \ (obj_ref \ obj_ref) + \ (domain \ priority \ obj_ref \ bool) \ bool" + where + "ready_queues_relation_2 qs qs' nexts prevs inQs \ + \d p. let q = qs d p; q' = qs' (d, p); flag = inQs d p in + ready_queue_relation d p q q' nexts prevs flag" + +abbreviation ready_queues_relation :: "det_state \ kernel_state \ bool" where + "ready_queues_relation s s' \ + ready_queues_relation_2 + (ready_queues s) (ksReadyQueues s') (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + (\d p. inQ d p |< tcbs_of' s')" + +lemmas ready_queues_relation_def = ready_queues_relation_2_def definition ghost_relation :: "Structures_A.kheap \ (word32 \ vmpage_size) \ (word32 \ nat) \ bool" @@ -463,6 +531,8 @@ lemma obj_relation_cutsE: \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; + \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); ko' = KOArch (KOPTE pte'); pte_relation_aligned z (pt z) pte' \ \ R; @@ -473,12 +543,12 @@ lemma obj_relation_cutsE: y = x + n * 2 ^ pageBits; n < 2 ^ (pageBitsForSize sz - pageBits) \ \ R; \ y = x; other_obj_relation ko ko'; is_other_obj_relation_type (a_type ko) \ \ R \ \ R" - apply (simp add: obj_relation_cuts_def2 is_other_obj_relation_type_def + 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) - apply ((clarsimp split: if_splits, - force simp: cte_relation_def pte_relation_def pde_relation_def)+)[5] + 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: @@ -554,7 +624,7 @@ where pspace_relation (kheap s) (ksPSpace s') \ ekheap_relation (ekheap s) (ksPSpace s') \ sched_act_relation (scheduler_action s) (ksSchedulerAction s') - \ ready_queues_relation (ready_queues s) (ksReadyQueues s') + \ ready_queues_relation s 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') @@ -576,6 +646,10 @@ lemma curthread_relation: "(a, b) \ state_relation \ ksCurThread b = cur_thread a" by (simp add: state_relation_def) +lemma curdomain_relation[elim!]: + "(s, s') \ state_relation \ cur_domain s = ksCurDomain s'" + by (clarsimp simp: state_relation_def) + lemma state_relation_pspace_relation[elim!]: "(s,s') \ state_relation \ pspace_relation (kheap s) (ksPSpace s')" by (simp add: state_relation_def) @@ -584,12 +658,24 @@ 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')" + by (clarsimp simp: state_relation_def) + +lemma state_relation_ready_queues_relation[elim!]: + "(s, s') \ state_relation \ ready_queues_relation s s'" + by (simp add: state_relation_def) + +lemma state_relation_idle_thread[elim!]: + "(s, s') \ state_relation \ idle_thread s = ksIdleThread s'" + by (clarsimp simp: state_relation_def) + lemma state_relationD: assumes sr: "(s, s') \ state_relation" shows "pspace_relation (kheap s) (ksPSpace s') \ ekheap_relation (ekheap s) (ksPSpace s') \ sched_act_relation (scheduler_action s) (ksSchedulerAction s') \ - ready_queues_relation (ready_queues s) (ksReadyQueues s') \ + ready_queues_relation s 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') \ @@ -611,7 +697,7 @@ lemma state_relationE [elim?]: and rl: "\pspace_relation (kheap s) (ksPSpace s'); ekheap_relation (ekheap s) (ksPSpace s'); sched_act_relation (scheduler_action s) (ksSchedulerAction s'); - ready_queues_relation (ready_queues s) (ksReadyQueues s'); + ready_queues_relation s 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'); diff --git a/proof/refine/ARM/Syscall_R.thy b/proof/refine/ARM/Syscall_R.thy index 6f8a7b6e96..1a1cb85d11 100644 --- a/proof/refine/ARM/Syscall_R.thy +++ b/proof/refine/ARM/Syscall_R.thy @@ -341,16 +341,14 @@ lemma threadSet_tcbDomain_update_sch_act_wf[wp]: lemma setDomain_corres: "corres dc - (valid_etcbs and valid_sched and tcb_at tptr) - (invs' and sch_act_simple - and tcb_at' tptr and (\s. 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 corres_guard_imp) apply (rule corres_split[OF getCurThread_corres]) - apply (rule corres_split[OF tcbSchedDequeue_corres]) + apply (rule corres_split[OF tcbSchedDequeue_corres], simp) apply (rule corres_split) apply (rule ethread_set_corres; simp) apply (clarsimp simp: etcb_relation_def) @@ -359,26 +357,38 @@ lemma setDomain_corres: apply (rule corres_split) apply clarsimp apply (rule corres_when[OF refl]) - apply (rule tcbSchedEnqueue_corres) + apply (rule tcbSchedEnqueue_corres, simp) apply (rule corres_when[OF refl]) apply (rule rescheduleRequired_corres) - apply ((wp hoare_drop_imps hoare_vcg_conj_lift | clarsimp| assumption)+)[5] - apply clarsimp - apply (rule_tac Q="\_. valid_objs' and valid_queues' and valid_queues and - (\s. sch_act_wf (ksSchedulerAction s) s) and tcb_at' tptr" - in hoare_strengthen_post[rotated]) - apply (auto simp: invs'_def valid_state'_def sch_act_wf_weak st_tcb_at'_def o_def)[1] - apply (wp threadSet_valid_objs' threadSet_valid_queues'_no_state - threadSet_valid_queues_no_state - threadSet_pred_tcb_no_state | simp)+ - apply (rule_tac Q = "\r s. invs' s \ (\p. tptr \ set (ksReadyQueues s p)) \ 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) - apply (drule(1) bspec) - apply (clarsimp simp:tcb_cte_cases_def) + 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 Tcb_R.tcbSchedDequeue_not_in_queue)+ + apply (wp hoare_vcg_all_lift tcbSchedDequeue_not_queued)+ apply clarsimp apply (frule tcb_at_is_etcb_at) apply simp+ @@ -447,7 +457,7 @@ lemma performInvocation_corres: apply (rule corres_split[OF setDomain_corres]) apply (rule corres_trivial, simp) apply (wp)+ - apply (clarsimp+)[2] + apply (fastforce+)[2] \ \CNodes\ apply clarsimp apply (rule corres_guard_imp) @@ -757,90 +767,71 @@ 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 - \\rv. invs'\" + doReplyTransfer t' t slot grant + \\_. invs'\" apply (simp add: doReplyTransfer_def liftM_def) apply (rule hoare_seq_ext [OF _ gts_sp']) apply (rule hoare_seq_ext [OF _ assert_sp]) apply (rule hoare_seq_ext [OF _ getCTE_sp]) apply (wp, wpc) - apply (wp) + apply wp apply (wp (once) sts_invs_minor'') - apply (simp) + apply simp apply (wp (once) sts_st_tcb') - apply (wp)[1] - apply (rule_tac Q="\rv s. invs' s - \ t \ ksIdleThread s - \ st_tcb_at' awaiting_reply' t s" + 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 (frule_tac t=t in invs'_not_runnable_not_queued) - apply (erule pred_tcb'_weakenE, case_tac st, clarsimp+) + apply clarsimp apply (rule conjI, erule pred_tcb'_weakenE, case_tac st, clarsimp+) - apply (rule conjI, rule impI, erule pred_tcb'_weakenE, case_tac st) - apply (clarsimp | drule(1) obj_at_conj')+ 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 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 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]) + 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 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="\rv s. invs' s \ sch_act_simple s - \ st_tcb_at' awaiting_reply' t s - \ t \ ksIdleThread s" - in hoare_post_imp) - apply (clarsimp) - apply (frule_tac t=t in invs'_not_runnable_not_queued) - apply (erule pred_tcb'_weakenE, case_tac st, clarsimp+) + 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 (rule conjI, rule impI, erule pred_tcb'_weakenE, case_tac st) - apply (clarsimp | drule(1) obj_at_conj')+ 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 clarsimp apply (erule_tac P="\st. awaiting_reply' st \ activatable' st" - in pred_tcb'_weakenE) + 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 clarsimp apply (rule conjI) - apply (clarsimp simp: invs'_def valid_state'_def valid_idle'_def) - apply (rule conjI) - apply clarsimp - apply (clarsimp simp: obj_at'_def idle_tcb'_def pred_tcb_at'_def) + 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 (rule conjI) apply (clarsimp simp : invs'_def valid_state'_def valid_idle'_def pred_tcb_at'_def obj_at'_def idle_tcb'_def) - apply (rule conjI) - apply clarsimp - apply (frule invs'_not_runnable_not_queued) - apply (erule pred_tcb'_weakenE, clarsimp) - apply (frule (1) not_tcbQueued_not_ksQ) - apply simp - apply clarsimp 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) @@ -850,35 +841,9 @@ lemma ct_active_runnable' [simp]: "ct_active' s \ ct_in_state' runnable' s" by (fastforce simp: ct_in_state'_def elim!: pred_tcb'_weakenE) -lemma valid_irq_node_tcbSchedEnqueue[wp]: - "\\s. valid_irq_node' (irq_node' s) s \ tcbSchedEnqueue ptr - \\rv s'. valid_irq_node' (irq_node' s') s'\" - apply (rule hoare_pre) - apply (simp add:valid_irq_node'_def ) - apply (wp unless_wp hoare_vcg_all_lift | wps)+ - apply (simp add:tcbSchedEnqueue_def) - apply (wp unless_wp| simp)+ - apply (simp add:valid_irq_node'_def) - done - -lemma rescheduleRequired_valid_queues_but_ct_domain: - "\\s. Invariants_H.valid_queues s \ valid_objs' s - \ (\x. ksSchedulerAction s = SwitchToThread x \ st_tcb_at' runnable' x s) \ - rescheduleRequired - \\_. Invariants_H.valid_queues\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp)+ - done - -lemma rescheduleRequired_valid_queues'_but_ct_domain: - "\\s. valid_queues' s - \ (\x. ksSchedulerAction s = SwitchToThread x \ st_tcb_at' runnable' x s) - \ - rescheduleRequired - \\_. valid_queues'\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp | fastforce simp: valid_queues'_def)+ - done +crunches tcbSchedEnqueue + for valid_irq_node[wp]: "\s. valid_irq_node' (irq_node' s) s" + (rule: valid_irq_node_lift) lemma tcbSchedEnqueue_valid_action: "\\s. \x. ksSchedulerAction s = SwitchToThread x \ st_tcb_at' runnable' x s\ @@ -889,9 +854,10 @@ lemma tcbSchedEnqueue_valid_action: done abbreviation (input) "all_invs_but_sch_extra \ - \s. valid_pspace' s \ Invariants_H.valid_queues s \ + \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 \ @@ -903,7 +869,6 @@ abbreviation (input) "all_invs_but_sch_extra \ valid_machine_state' s \ cur_tcb' s \ untyped_ranges_zero' s \ - valid_queues' 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)" @@ -913,18 +878,13 @@ lemma rescheduleRequired_all_invs_but_extra: "\\s. all_invs_but_sch_extra s\ rescheduleRequired \\_. invs'\" apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp add:rescheduleRequired_ct_not_inQ - rescheduleRequired_sch_act' - rescheduleRequired_valid_queues_but_ct_domain - rescheduleRequired_valid_queues'_but_ct_domain - valid_irq_node_lift valid_irq_handlers_lift'' - irqs_masked_lift cur_tcb_lift) + 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 (\s. (\p. t \ set (ksReadyQueues s p))) and + shows "\ tcb_at' t and all_invs_but_sch_extra and sch_act_simple and K (ds \ maxDomain) \ threadSet (tcbDomain_update (\_. ds)) t @@ -932,7 +892,7 @@ lemma threadSet_all_invs_but_sch_extra: apply (rule hoare_gen_asm) apply (rule hoare_pre) apply (wp threadSet_valid_pspace'T_P[where P = False and Q = \ and Q' = \]) - apply (simp add:tcb_cte_cases_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'=\] @@ -944,13 +904,11 @@ lemma threadSet_all_invs_but_sch_extra: 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 - | simp add:tcb_cte_cases_def cteCaps_of_def o_def)+ + 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) @@ -977,9 +935,7 @@ lemma setDomain_invs': \ (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 (erule st_tcb_ex_cap'') apply simp - apply (case_tac st,simp_all)[1] apply (rule hoare_strengthen_post[OF hoare_vcg_conj_lift]) apply (rule threadSet_all_invs_but_sch_extra) prefer 2 @@ -997,17 +953,14 @@ lemma setDomain_invs': done lemma performInv_invs'[wp]: - "\invs' and sch_act_simple - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p)) - and ct_active' and valid_invocation' i\ - RetypeDecls_H.performInvocation block call i \\rv. invs'\" + "\invs' and sch_act_simple and ct_active' and valid_invocation' i\ + RetypeDecls_H.performInvocation block call i + \\_. invs'\" unfolding performInvocation_def apply (cases i) - apply ((clarsimp simp: simple_sane_strg sch_act_simple_def - ct_not_ksQ sch_act_sane_def - | wp tcbinv_invs' arch_performInvocation_invs' - setDomain_invs' - | rule conjI | erule active_ex_cap')+) + 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]: @@ -1192,16 +1145,18 @@ crunch valid_duplicates'[wp]: addToBitmap "\s. vs_valid_duplicates' (ksP (wp: setObject_ksInterrupt updateObject_default_inv) lemma tcbSchedEnqueue_valid_duplicates'[wp]: - "\\s. vs_valid_duplicates' (ksPSpace s)\ - tcbSchedEnqueue a \\rv s. vs_valid_duplicates' (ksPSpace s)\" - by (simp add:tcbSchedEnqueue_def unless_def setQueue_def | wp | wpc)+ + "tcbSchedEnqueue tcbPtr \\s. vs_valid_duplicates' (ksPSpace s)\" + by (wpsimp simp: tcbSchedEnqueue_def tcbQueuePrepend_def unless_def setQueue_def) crunch valid_duplicates'[wp]: rescheduleRequired "\s. vs_valid_duplicates' (ksPSpace s)" (wp: setObject_ksInterrupt updateObject_default_inv) crunch valid_duplicates'[wp]: setThreadState "\s. vs_valid_duplicates' (ksPSpace s)" -(*FIXME: move to Nondet_VCG.valid_validE_R *) +crunches reply_from_kernel + for pspace_aligned[wp]: pspace_aligned + and pspace_distinct[wp]: pspace_distinct + lemma handleInvocation_corres: "c \ b \ corres (dc \ dc) @@ -1233,11 +1188,9 @@ lemma handleInvocation_corres: apply wp[1] apply (clarsimp simp: when_def) apply (rule replyFromKernel_corres) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule corres_splitEE) - apply (rule performInvocation_corres; simp) - apply simp + 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] @@ -1248,13 +1201,9 @@ lemma handleInvocation_corres: apply simp apply (simp add: when_def) apply (rule conjI, rule impI) - apply (rule reply_from_kernel_tcb_at) + apply (wp reply_from_kernel_tcb_at) apply (rule impI, wp+) - apply simp+ - apply (wp hoare_drop_imps)+ - apply simp - apply wp - apply simp + 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" @@ -1270,7 +1219,6 @@ lemma handleInvocation_corres: and (\s. vs_valid_duplicates' (ksPSpace s))" in hoare_post_imp) apply (clarsimp simp: ct_in_state'_def) - apply (frule(1) ct_not_ksQ) apply (clarsimp) apply (wp setThreadState_nonqueued_state_update setThreadState_st_tcb setThreadState_rct)[1] @@ -1280,19 +1228,19 @@ lemma handleInvocation_corres: | rule hoare_vcg_E_elim)+ apply (clarsimp simp: tcb_at_invs invs_valid_objs valid_tcb_state_def ct_in_state_def - simple_from_active invs_mdb) - apply (clarsimp simp: msg_max_length_def word_bits_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) apply (frule tcb_at_invs') apply (clarsimp simp: invs'_def valid_state'_def ct_in_state'_def ct_not_inQ_def) - apply (frule(1) valid_queues_not_tcbQueued_not_ksQ) 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 (frule (1) st_tcb_at_idle_thread') apply (simp) done @@ -1349,11 +1297,8 @@ lemma hinv_invs'[wp]: and st_tcb_at' active' thread" in hoare_post_imp) apply (clarsimp simp: ct_in_state'_def) - apply (frule(1) ct_not_ksQ) - apply (clarsimp) apply (wp sts_invs_minor' setThreadState_st_tcb setThreadState_rct | simp)+ apply (clarsimp) - apply (frule(1) ct_not_ksQ) apply (fastforce simp add: tcb_at_invs' ct_in_state'_def simple_sane_strg sch_act_simple_def @@ -1498,7 +1443,6 @@ lemma handleRecv_isBlocking_corres': and (\s. ex_nonz_cap_to (cur_thread s) s)) (invs' and ct_in_state' simple' and sch_act_sane - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p)) and (\s. ex_nonz_cap_to' (ksCurThread s) s)) (handle_recv isBlocking) (handleRecv isBlocking)" (is "corres dc (?pre1) (?pre2) (handle_recv _) (handleRecv _)") @@ -1561,8 +1505,7 @@ lemma handleRecv_isBlocking_corres': lemma handleRecv_isBlocking_corres: "corres dc (einvs and ct_active) - (invs' and ct_active' and sch_act_sane and - (\s. \p. ksCurThread s \ set (ksReadyQueues s p))) + (invs' and ct_active' and sch_act_sane) (handle_recv isBlocking) (handleRecv isBlocking)" apply (rule corres_guard_imp) apply (rule handleRecv_isBlocking_corres') @@ -1577,42 +1520,27 @@ lemma lookupCap_refs[wp]: "\invs'\ lookupCap t ref \\rv s. \r\zobj_refs' rv. ex_nonz_cap_to' r s\,-" by (simp add: lookupCap_def split_def | wp | simp add: o_def)+ -lemma deleteCallerCap_ksQ_ct': - "\invs' and ct_in_state' simple' and sch_act_sane and - (\s. ksCurThread s \ set (ksReadyQueues s p) \ thread = ksCurThread s)\ - deleteCallerCap thread - \\rv s. thread \ set (ksReadyQueues s p)\" - apply (rule_tac Q="\rv s. thread = ksCurThread s \ ksCurThread s \ set (ksReadyQueues s p)" - in hoare_strengthen_post) - apply (wp deleteCallerCap_ct_not_ksQ) - apply auto - done - lemma hw_invs'[wp]: "\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) - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p))\ + 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 - deleteCallerCap_ksQ_ct' hoare_lift_Pf2[OF deleteCallerCap_simple deleteCallerCap_ct'] | wpc | simp)+)[1] apply simp apply (wp deleteCallerCap_nonz_cap hoare_vcg_all_lift - deleteCallerCap_ksQ_ct' 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 - \ (\p. ksCurThread s \ set (ksReadyQueues s p)) \ thread = ksCurThread s \ ct_in_state' simple' s \ ex_nonz_cap_to' thread s @@ -1636,34 +1564,45 @@ lemma setSchedulerAction_obj_at'[wp]: by (wp, clarsimp elim!: obj_at'_pspaceI) lemma handleYield_corres: - "corres dc einvs (invs' and ct_active' and (\s. ksSchedulerAction s = ResumeCurrentThread)) handle_yield handleYield" + "corres dc + (einvs and ct_active) + (invs' and (\s. ksSchedulerAction s = ResumeCurrentThread)) + handle_yield handleYield" apply (clarsimp simp: handle_yield_def handleYield_def) apply (rule corres_guard_imp) apply (rule corres_split[OF getCurThread_corres]) apply simp - apply (rule corres_split[OF tcbSchedDequeue_corres]) - apply (rule corres_split[OF tcbSchedAppend_corres]) + apply (rule corres_split[OF tcbSchedDequeue_corres], simp) + apply (rule corres_split[OF tcbSchedAppend_corres], simp) apply (rule rescheduleRequired_corres) - apply (wp weak_sch_act_wf_lift_linear tcbSchedDequeue_valid_queues | simp add: )+ - apply (simp add: invs_def valid_sched_def valid_sched_action_def - cur_tcb_def tcb_at_is_etcb_at) - apply clarsimp - apply (frule ct_active_runnable') - apply (clarsimp simp: invs'_def valid_state'_def ct_in_state'_def sch_act_wf_weak cur_tcb'_def + 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) - apply (erule(1) valid_objs_valid_tcbE[OF valid_pspace_valid_objs']) - apply (simp add:valid_tcb'_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 hy_invs': "\invs' and ct_active'\ handleYield \\r. invs' and ct_active'\" apply (simp add: handleYield_def) - apply (wp ct_in_state_thread_state_lift' - rescheduleRequired_all_invs_but_ct_not_inQ - tcbSchedAppend_invs_but_ct_not_inQ' | simp)+ - apply (clarsimp simp add: 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 - ) + 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 @@ -1866,7 +1805,7 @@ 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 haskell_assert_wp doReplyTransfer_sane getCTE_wp'| wpc)+ + apply (wp doReplyTransfer_sane getCTE_wp'| wpc)+ apply (clarsimp simp: cte_wp_at_ctes_of) done @@ -1882,74 +1821,6 @@ lemma handleReply_nonz_cap_to_ct: crunch ksQ[wp]: handleFaultReply "\s. P (ksReadyQueues s p)" -lemma doReplyTransfer_ct_not_ksQ: - "\ invs' and sch_act_simple - and tcb_at' thread and tcb_at' word - and ct_in_state' simple' - and (\s. ksCurThread s \ word) - and (\s. \p. ksCurThread s \ set(ksReadyQueues s p))\ - doReplyTransfer thread word callerSlot g - \\rv s. \p. ksCurThread s \ set(ksReadyQueues s p)\" -proof - - have astct: "\t p. - \(\s. ksCurThread s \ set(ksReadyQueues s p) \ sch_act_sane s) - and (\s. ksCurThread s \ t)\ - possibleSwitchTo t \\rv s. ksCurThread s \ set(ksReadyQueues s p)\" - apply (rule hoare_weaken_pre) - apply (wps possibleSwitchTo_ct') - apply (wp possibleSwitchTo_ksQ') - apply (clarsimp simp: sch_act_sane_def) - done - have stsct: "\t st p. - \(\s. ksCurThread s \ set(ksReadyQueues s p)) and sch_act_simple\ - setThreadState st t - \\rv s. ksCurThread s \ set(ksReadyQueues s p)\" - apply (rule hoare_weaken_pre) - apply (wps setThreadState_ct') - apply (wp hoare_vcg_all_lift sts_ksQ) - apply (clarsimp) - done - show ?thesis - apply (simp add: doReplyTransfer_def) - apply (wp, wpc) - apply (wp astct stsct hoare_vcg_all_lift - cteDeleteOne_ct_not_ksQ hoare_drop_imp - hoare_lift_Pf2 [OF cteDeleteOne_sch_act_not cteDeleteOne_ct'] - hoare_lift_Pf2 [OF doIPCTransfer_pred_tcb_at' doIPCTransfer_ct'] - hoare_lift_Pf2 [OF doIPCTransfer_ksQ doIPCTransfer_ct'] - hoare_lift_Pf2 [OF threadSet_ksQ threadSet_ct] - hoare_lift_Pf2 [OF handleFaultReply_ksQ handleFaultReply_ct'] - | simp add: ct_in_state'_def)+ - apply (fastforce simp: sch_act_simple_def sch_act_sane_def ct_in_state'_def)+ - done -qed - -lemma handleReply_ct_not_ksQ: - "\invs' and sch_act_simple - and ct_in_state' simple' - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p))\ - handleReply - \\rv s. \p. ksCurThread s \ set (ksReadyQueues s p)\" - apply (simp add: handleReply_def del: split_paired_All) - apply (subst haskell_assert_def) - apply (wp | wpc)+ - apply (wp doReplyTransfer_ct_not_ksQ getThreadCallerSlot_inv)+ - apply (rule_tac Q="\cap. - (\s. \p. ksCurThread s \ set(ksReadyQueues s p)) - and invs' - and sch_act_simple - and (\s. thread = ksCurThread s) - and tcb_at' thread - and ct_in_state' simple' - and cte_wp_at' (\c. cteCap c = cap) callerSlot" - in hoare_post_imp) - apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def - cte_wp_at_ctes_of valid_cap'_def - dest!: ctes_of_valid') - apply (wp getSlotCap_cte_wp_at getThreadCallerSlot_inv)+ - apply (clarsimp) - done - crunches possible_switch_to, handle_recv for valid_etcbs[wp]: "valid_etcbs" (wp: crunch_wps simp: crunch_simps) @@ -1963,11 +1834,10 @@ lemma handleReply_handleRecv_corres: 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 handleReply_ct_not_ksQ handle_reply_valid_sched)+ + 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 (frule(1) ct_not_ksQ) apply (fastforce elim: pred_tcb'_weakenE) done @@ -1975,7 +1845,6 @@ lemma handleHypervisorFault_corres: "corres dc (einvs and st_tcb_at active thread and ex_nonz_cap_to thread and (%_. valid_fault f)) (invs' and sch_act_not thread - and (\s. \p. thread \ set(ksReadyQueues s p)) and st_tcb_at' simple' thread and ex_nonz_cap_to' thread) (handle_hypervisor_fault w fault) (handleHypervisorFault w fault)" @@ -1993,14 +1862,13 @@ lemma handleEvent_corres: (is "?handleEvent_corres") proof - have hw: - "\isBlocking. corres dc (einvs and ct_running and (\s. scheduler_action s = resume_cur_thread)) + "\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 - dest!: ct_not_ksQ)+ + elim!: st_tcb_weakenE pred_tcb'_weakenE)+ done show ?thesis apply (case_tac event) @@ -2015,7 +1883,7 @@ proof - corres_guard_imp[OF handleCall_corres] corres_guard_imp[OF handleYield_corres] active_from_running active_from_running' - simp: simple_sane_strg)[8] + 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) @@ -2026,7 +1894,6 @@ proof - simp: ct_in_state_def) apply wp apply (clarsimp) - apply (frule(1) ct_not_ksQ) apply (auto simp: ct_in_state'_def sch_act_simple_def sch_act_sane_def elim: pred_tcb'_weakenE st_tcb_ex_cap'')[1] @@ -2039,12 +1906,11 @@ proof - simp: ct_in_state_def valid_fault_def) apply wp apply clarsimp - apply (frule(1) ct_not_ksQ) 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="\rv. einvs" + 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) @@ -2054,7 +1920,6 @@ proof - apply (rule handleInterrupt_corres) apply (wp hoare_vcg_all_lift doMachineOp_getActiveIRQ_IRQ_active' - | simp | simp add: imp_conjR | wp (once) hoare_drop_imps)+ apply (simp add: invs'_def valid_state'_def) apply (rule_tac corres_underlying_split) @@ -2071,7 +1936,6 @@ proof - apply (fastforce elim!: st_tcb_ex_cap st_tcb_weakenE simp: ct_in_state_def) apply wp apply (clarsimp) - apply (frule(1) ct_not_ksQ) 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) @@ -2083,7 +1947,6 @@ proof - simp: ct_in_state_def) apply wp apply (clarsimp) - apply (frule(1) ct_not_ksQ) apply (auto simp: ct_in_state'_def sch_act_simple_def sch_act_sane_def elim: pred_tcb'_weakenE st_tcb_ex_cap'')[1] @@ -2160,10 +2023,8 @@ proof - apply (rename_tac syscall) apply (case_tac syscall, (wp handleReply_sane handleReply_nonz_cap_to_ct handleReply_ksCurThread - handleReply_ct_not_ksQ | clarsimp simp: active_from_running' simple_from_running' simple_sane_strg simp del: split_paired_All | rule conjI active_ex_cap' - | drule ct_not_ksQ[rotated] | strengthen nidle)+) apply (rule hoare_strengthen_post, rule hoare_weaken_pre, @@ -2175,7 +2036,6 @@ proof - | 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' - | drule ct_not_ksQ[rotated] | wpc | wp (once) hoare_drop_imps)+ done qed diff --git a/proof/refine/ARM/TcbAcc_R.thy b/proof/refine/ARM/TcbAcc_R.thy index 5dc688b212..f71e35bf68 100644 --- a/proof/refine/ARM/TcbAcc_R.thy +++ b/proof/refine/ARM/TcbAcc_R.thy @@ -58,10 +58,8 @@ lemma getHighestPrio_inv[wp]: unfolding bitmap_fun_defs by simp lemma valid_bitmapQ_bitmapQ_simp: - "\ valid_bitmapQ s \ \ - bitmapQ d p s = (ksReadyQueues s (d, p) \ [])" - unfolding valid_bitmapQ_def - by simp + "valid_bitmapQ s \ bitmapQ d p s = (\ tcbQueueEmpty (ksReadyQueues s (d, p)))" + by (simp add: valid_bitmapQ_def) lemma prioToL1Index_l1IndexToPrio_or_id: "\ unat (w'::priority) < 2 ^ wordRadix ; w < size w' \ @@ -84,54 +82,156 @@ 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 and runnable' \ tcbState) t s) - \ distinct (ksReadyQueues s (d, p)) - \ (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 - 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 objBits_simps) - 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 - ARM_A.arch_kernel_obj.split_asm)+ - apply fastforce + 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 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" +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) done -lemma valid_objs'_maxDomain: - "\s t. \ valid_objs' s; tcb_at' t s \ \ obj_at' (\tcb. tcbDomain tcb \ maxDomain) t s" - apply (erule (1) valid_objs_valid_tcbE) - apply (clarsimp simp: valid_tcb'_def) +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 + 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 objBits_simps') + done + +definition valid_tcbs' :: "kernel_state \ bool" where + "valid_tcbs' s' \ \ptr tcb. ksPSpace s' ptr = Some (KOTCB tcb) \ valid_tcb' tcb s'" + +lemma valid_objs'_valid_tcbs'[elim!]: + "valid_objs' s \ valid_tcbs' s" + by (auto simp: valid_objs'_def valid_tcbs'_def valid_obj'_def split: kernel_object.splits) + +lemma invs'_valid_tcbs'[elim!]: + "invs' s \ valid_tcbs' s" + by (fastforce intro: valid_objs'_valid_tcbs') + +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 valid_tcb'_def projectKOs) done -lemma valid_objs'_maxPriority: - "\s t. \ valid_objs' s; tcb_at' t s \ \ obj_at' (\tcb. tcbPriority tcb \ maxPriority) t s" - apply (erule (1) valid_objs_valid_tcbE) - apply (clarsimp simp: valid_tcb'_def) +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 valid_tcb'_def projectKOs) done +lemmas valid_objs'_maxPriority = valid_tcbs'_maxPriority[OF valid_objs'_valid_tcbs'] + +lemma valid_tcbs'_obj_at': + assumes "valid_tcbs' 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" + using assms + 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 (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" + "\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_valid_tcbs'[simp]: + "\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': assumes masks: "\P. \\s. P (irq_masks s)\ f \\_ s. P (irq_masks s)\" shows "\valid_irq_states'\ doMachineOp f \\rv. valid_irq_states'\" @@ -229,56 +329,117 @@ lemma updateObject_tcb_inv: by simp (rule updateObject_default_inv) lemma setObject_update_TCB_corres': - assumes tcbs: "tcb_relation tcb tcb' \ tcb_relation tcbu tcbu'" - assumes tables: "\(getF, v) \ ran tcb_cap_cases. getF tcbu = getF tcb" - assumes tables': "\(getF, v) \ ran tcb_cte_cases. getF tcbu' = getF tcb'" + 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" + assumes tables': "\(getF, v) \ ran tcb_cte_cases. getF new_tcb' = getF tcb'" + assumes sched_pointers: "tcbSchedPrev new_tcb' = tcbSchedPrev tcb'" + "tcbSchedNext new_tcb' = tcbSchedNext tcb'" + assumes flag: "tcbQueued new_tcb' = tcbQueued tcb'" assumes r: "r () ()" - assumes exst: "exst_same tcb' tcbu'" - 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' \ exst_same tcb' tcbu'" 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 exst) - 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 () (); exst_same tcb' tcbu'\ - \ 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 fastforce - apply (clarsimp simp: getObject_def in_monad split_def obj_at'_def - loadObject_default_def projectKOs objBits_simps' - in_magnitude_check) + 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: - "corres tcb_relation (tcb_at t) (tcb_at' t) + "corres tcb_relation (tcb_at t and pspace_aligned and pspace_distinct) \ (gets_the (get_tcb t)) (getObject t)" + 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 (rule corres_gets_the) apply (rule corres_get_tcb) @@ -288,7 +449,8 @@ 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)" + 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 @@ -310,7 +472,8 @@ lemma ball_tcb_cte_casesI: 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. P (Thread a b c d e f g h i j k l m n p q) \ \ \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: @@ -319,18 +482,24 @@ 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" + 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) - (tcb_at' t) - (thread_set f t) (threadSet f' t)" + 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 (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+ @@ -360,18 +529,20 @@ lemma threadSet_corres_noopT: tcb_relation tcb (fn tcb')" assumes y: "\tcb. \(getF, setF) \ ran tcb_cte_cases. getF (fn tcb) = getF tcb" + 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) - (return v) (threadSet fn t)" + 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 (simp add: return_def thread_set_def gets_the_def + 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 assert_def a_type_def[split_simps kernel_object.split arch_kernel_obj.split]) + 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: get_tcb_SomeD map_upd_triv) + apply (simp add: map_upd_triv get_tcb_SomeD)+ done show ?thesis apply (rule stronger_corres_guard_imp) @@ -379,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 (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 wpsimp+ - apply (erule pspace_relation_tcb_at[rotated]) - apply clarsimp - apply simp - apply simp + apply simp + apply (rule no_fail_pre, wpsimp+)[1] + apply wpsimp+ done qed @@ -402,14 +574,20 @@ 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'\" + 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 P (tcb_at' t and P') + 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)+ @@ -643,16 +821,23 @@ lemma threadSet_valid_pspace'T_P: assumes v: "\tcb. (P \ Q' (tcbBoundNotification tcb)) \ (\s. valid_bound_ntfn' (tcbBoundNotification tcb) s \ valid_bound_ntfn' (tcbBoundNotification (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)\ - threadSet F t - \\rv. valid_pspace'\" + "\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 + \\_. valid_pspace'\" apply (simp add: valid_pspace'_def threadSet_def) apply (rule hoare_pre, wp setObject_tcb_valid_objs getObject_tcb_wp) @@ -660,7 +845,7 @@ lemma threadSet_valid_pspace'T_P: 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 v w') + split_paired_Ball y u w v w' p n) done lemmas threadSet_valid_pspace'T = @@ -734,6 +919,10 @@ lemma threadSet_iflive'T: \ tcbState (F tcb) \ Inactive \ tcbState (F tcb) \ IdleThreadState \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) + \ ((\tcb. tcbSchedNext tcb = None \ tcbSchedNext (F tcb) \ None + \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) + \ ((\tcb. tcbSchedPrev tcb = None \ tcbSchedPrev (F tcb) \ None + \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) \ ((\tcb. \ tcbQueued tcb \ tcbQueued (F tcb) \ ko_at' tcb t s) \ ex_nonz_cap_to' t s)\ threadSet F t @@ -741,8 +930,7 @@ lemma threadSet_iflive'T: apply (simp add: threadSet_def) apply (wp setObject_tcb_iflive' getObject_tcb_wp) apply (clarsimp simp: obj_at'_def projectKOs) - apply (subst conj_assoc[symmetric], subst imp_disjL[symmetric]) - apply (subst conj_assoc[symmetric], subst imp_disjL[symmetric]) + apply (subst conj_assoc[symmetric], subst imp_disjL[symmetric])+ apply (rule conjI) apply (rule impI, clarsimp) apply (erule if_live_then_nonz_capE') @@ -788,6 +976,12 @@ lemmas threadSet_ctes_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) + \ 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 objBits_simps') + lemma threadSet_idle'T: assumes x: "\tcb. \(getF, setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" shows @@ -826,30 +1020,6 @@ lemma set_tcb_bitmapQ_no_L2_orphans[wp]: apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp add: bitmapQ_def)+ done -lemma threadSet_valid_queues_no_bitmap: - "\ valid_queues_no_bitmap and - (\s. \d p. (\tcb. (inQ d p tcb \ runnable' (tcbState tcb)) \ - \(inQ d p (f tcb) \ runnable' (tcbState (f tcb)))) - \ obj_at' (\tcb. (inQ d p tcb \ runnable' (tcbState tcb)) \ - \(inQ d p (f tcb) \ runnable' (tcbState (f tcb)))) t s - \ t \ set (ksReadyQueues s (d, p)) - )\ - threadSet f t - \\rv. valid_queues_no_bitmap \" - apply (simp add: threadSet_def) - apply wp - apply (simp add: Invariants_H.valid_queues_no_bitmap_def' pred_tcb_at'_def) - - apply (wp setObject_queues_unchanged_tcb - hoare_Ball_helper - hoare_vcg_all_lift - setObject_tcb_strongest)[1] - apply (wp getObject_tcb_wp) - apply (clarsimp simp: valid_queues_no_bitmap_def' pred_tcb_at'_def) - apply (clarsimp simp: obj_at'_def projectKOs) - apply (fastforce) - done - lemma threadSet_valid_bitmapQ[wp]: "\ valid_bitmapQ \ threadSet f t \ \rv. valid_bitmapQ \" unfolding bitmapQ_defs threadSet_def @@ -868,73 +1038,6 @@ lemma threadSet_valid_bitmapQ_no_L2_orphans[wp]: by (clarsimp simp: setObject_def split_def) (wp | simp add: updateObject_default_def)+ -lemma threadSet_valid_queues: - "\Invariants_H.valid_queues and - (\s. \d p. (\tcb. (inQ d p tcb \ runnable' (tcbState tcb)) \ - \(inQ d p (f tcb) \ runnable' (tcbState (f tcb)))) - \ obj_at' (\tcb. (inQ d p tcb \ runnable' (tcbState tcb)) \ - \(inQ d p (f tcb) \ runnable' (tcbState (f tcb)))) t s - \ t \ set (ksReadyQueues s (d, p)) - )\ - threadSet f t - \\rv. Invariants_H.valid_queues\" - unfolding valid_queues_def - by (wp threadSet_valid_queues_no_bitmap;simp) - -definition - addToQs :: "(Structures_H.tcb \ Structures_H.tcb) - \ word32 \ (domain \ priority \ word32 list) - \ (domain \ priority \ word32 list)" -where - "addToQs F t \ \qs (qdom, prio). if (\ko. \ inQ qdom prio (F ko)) - then t # qs (qdom, prio) - else qs (qdom, prio)" - -lemma addToQs_set_def: - "(t' \ set (addToQs F t qs (qdom, prio))) = (t' \ set (qs (qdom, prio)) - \ (t' = t \ (\ko. \ inQ qdom prio (F ko))))" - by (auto simp add: addToQs_def) - -lemma threadSet_valid_queues_addToQs: - "\\s. (\ko qdom prio. ko_at' ko t s \ inQ qdom prio (F ko) \ \ inQ qdom prio ko - \ t \ set (ksReadyQueues s (qdom, prio))) - \ valid_queues' (ksReadyQueues_update (addToQs F t) s)\ - threadSet F t - \\rv. 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_set_def - split del: if_split cong: if_cong) - apply (fastforce simp: projectKOs split: if_split_asm) - done - -lemma threadSet_valid_queues_Qf: - "\\s. (\ko qdom prio. ko_at' ko t s \ inQ qdom prio (F ko) \ \ inQ qdom prio ko - \ t \ set (ksReadyQueues s (qdom, prio))) - \ valid_queues' (ksReadyQueues_update Qf s) - \ (\prio. set (Qf (ksReadyQueues s) prio) - \ set (addToQs F t (ksReadyQueues s) prio))\ - threadSet F t - \\rv. valid_queues'\" - apply (wp threadSet_valid_queues_addToQs) - apply (clarsimp simp: valid_queues'_def subset_iff) - done - -lemma addToQs_subset: - "set (qs p) \ set (addToQs F t qs p)" -by (clarsimp simp: addToQs_def split_def) - -lemmas threadSet_valid_queues' - = threadSet_valid_queues_Qf - [where Qf=id, simplified ksReadyQueues_update_id - id_apply addToQs_subset simp_thms] - lemma threadSet_cur: "\\s. cur_tcb' s\ threadSet f t \\rv s. cur_tcb' s\" apply (simp add: threadSet_def cur_tcb'_def) @@ -950,7 +1053,7 @@ lemma modifyReadyQueuesL1Bitmap_obj_at[wp]: crunches setThreadState, setBoundNotification for valid_arch' [wp]: valid_arch_state' - (simp: unless_def crunch_simps) + (simp: unless_def crunch_simps wp: crunch_wps) crunch ksInterrupt'[wp]: threadSet "\s. P (ksInterruptState s)" (wp: setObject_ksInterrupt updateObject_default_inv) @@ -1212,57 +1315,103 @@ lemma threadSet_valid_dom_schedule': unfolding threadSet_def by (wp setObject_ksDomSchedule_inv hoare_Ball_helper) +lemma threadSet_wp: + "\\s. \tcb. ko_at' tcb t s \ P (s\ksPSpace := (ksPSpace s)(t \ injectKO (f tcb))\)\ + threadSet f t + \\_. P\" + unfolding threadSet_def setObject_def + apply (wpsimp wp: getObject_tcb_wp simp: updateObject_default_def) + apply (auto simp: obj_at'_def split: if_splits) + apply (erule rsubst[where P=P]) + apply (clarsimp simp: fun_upd_def) + apply (prop_tac "\ptr. psMap (ksPSpace s) ptr = ksPSpace s ptr") + apply fastforce + apply metis + done + +lemma threadSet_sched_pointers: + "\\tcb. tcbSchedNext (F tcb) = tcbSchedNext tcb; \tcb. tcbSchedPrev (F tcb) = tcbSchedPrev tcb\ + \ threadSet F tcbPtr \\s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + apply (erule rsubst2[where P=P]) + apply (fastforce simp: opt_map_def obj_at'_def projectKOs) + apply (fastforce simp: opt_map_def obj_at'_def projectKOs) + done + +lemma threadSet_valid_sched_pointers: + "\\tcb. tcbSchedNext (F tcb) = tcbSchedNext tcb; \tcb. tcbSchedPrev (F tcb) = tcbSchedPrev tcb; + \tcb. tcbQueued (F tcb) = tcbQueued tcb\ + \ threadSet F tcbPtr \valid_sched_pointers\" + unfolding valid_sched_pointers_def + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + by (fastforce simp: opt_pred_def opt_map_def obj_at'_def projectKOs split: option.splits if_splits) + +lemma threadSet_tcbSchedNexts_of: + "(\tcb. tcbSchedNext (F tcb) = tcbSchedNext tcb) \ + threadSet F t \\s. P (tcbSchedNexts_of s)\" + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + apply (erule rsubst[where P=P]) + apply (fastforce simp: opt_map_def obj_at'_def projectKOs) + done + +lemma threadSet_tcbSchedPrevs_of: + "(\tcb. tcbSchedPrev (F tcb) = tcbSchedPrev tcb) \ + threadSet F t \\s. P (tcbSchedPrevs_of s)\" + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + apply (erule rsubst[where P=P]) + apply (fastforce simp: opt_map_def obj_at'_def projectKOs) + done + +lemma threadSet_tcbQueued: + "(\tcb. tcbQueued (F tcb) = tcbQueued tcb) \ + threadSet F t \\s. P (tcbQueued |< tcbs_of' s)\" + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + apply (erule rsubst[where P=P]) + apply (fastforce simp: opt_pred_def opt_map_def obj_at'_def projectKOs) + done + +crunches threadSet + for ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" + and ksReadyQueuesL1Bitmap[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" + and ksReadyQueuesL2Bitmap[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" + lemma threadSet_invs_trivialT: - assumes x: "\tcb. \(getF,setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" - assumes z: "\tcb. tcbState (F tcb) = tcbState tcb \ tcbDomain (F tcb) = tcbDomain tcb" - assumes w: "\tcb. is_aligned (tcbIPCBuffer tcb) msg_align_bits \ is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits" - assumes a: "\tcb. tcbBoundNotification (F tcb) = tcbBoundNotification tcb" - assumes w: "\tcb. is_aligned (tcbIPCBuffer tcb) msg_align_bits \ is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits" - 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" - shows - "\\s. invs' s \ - 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. \ tcbQueued tcb \ tcbQueued (F tcb)) \ ex_nonz_cap_to' t s \ t \ ksCurThread s) \ - (\tcb. tcbQueued (F tcb) \ ksSchedulerAction s = ResumeCurrentThread \ tcbQueued tcb \ t \ ksCurThread s)\ - threadSet F t - \\rv. invs'\" -proof - - from z have domains: "\tcb. tcbDomain (F tcb) = tcbDomain tcb" by blast - note threadSet_sch_actT_P[where P=False, simplified] - have y: "\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 valid_state'_def split del: if_split) - apply (rule hoare_pre) - apply (wp x w v u b - threadSet_valid_pspace'T - threadSet_sch_actT_P[where P=False, simplified] - threadSet_valid_queues - 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_cur - untyped_ranges_zero_lift - |clarsimp simp: y z a domains cteCaps_of_def |rule refl)+ - apply (clarsimp simp: obj_at'_def projectKOs pred_tcb_at'_def) - apply (clarsimp simp: cur_tcb'_def valid_irq_node'_def valid_queues'_def o_def) - by (fastforce simp: domains ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def z a) -qed + assumes + "\tcb. \(getF,setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" + "\tcb. tcbState (F tcb) = tcbState tcb" + "\tcb. is_aligned (tcbIPCBuffer tcb) msg_align_bits + \ is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits" + "\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. tcbMCP tcb \ maxPriority \ tcbMCP (F tcb) \ maxPriority" + shows "threadSet F t \invs'\" + apply (simp add: invs'_def valid_state'_def split del: if_split) + apply (wp threadSet_valid_pspace'T + threadSet_sch_actT_P[where P=False, simplified] + 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_cur + untyped_ranges_zero_lift + sym_heap_sched_pointers_lift threadSet_valid_sched_pointers + threadSet_tcbQueued + threadSet_tcbSchedPrevs_of threadSet_tcbSchedNexts_of valid_bitmaps_lift + | clarsimp simp: assms cteCaps_of_def | rule refl)+ + apply (clarsimp simp: o_def) + by (auto simp: assms obj_at'_def) lemmas threadSet_invs_trivial = threadSet_invs_trivialT [OF all_tcbI all_tcbI all_tcbI all_tcbI, OF ball_tcb_cte_casesI] @@ -1302,19 +1451,84 @@ lemma threadSet_valid_objs': apply (clarsimp elim!: obj_at'_weakenE) done +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'] + +lemma setObject_valid_tcbs': + assumes preserve_valid_tcb': "\s s' ko ko' x n tcb tcb'. + \ (ko', s') \ fst (updateObject val ko ptr x n s); P s; + lookupAround2 ptr (ksPSpace s) = (Some (x, ko), n); + projectKO_opt ko = Some tcb; projectKO_opt ko' = Some tcb'; + valid_tcb' tcb s \ \ valid_tcb' tcb' s" + shows "\valid_tcbs' and P\ setObject ptr val \\rv. valid_tcbs'\" + unfolding valid_tcbs'_def + apply (clarsimp simp: valid_def) + apply (rename_tac s s' ptr' tcb) + apply (prop_tac "\tcb'. valid_tcb' tcb s \ valid_tcb' tcb s'") + apply clarsimp + apply (erule (1) use_valid[OF _ setObject_valid_tcb']) + apply (drule spec, erule mp) + apply (clarsimp simp: setObject_def in_monad split_def lookupAround2_char1) + apply (rename_tac s ptr' new_tcb' ptr'' old_tcb_ko' s' f) + apply (case_tac "ptr'' = ptr'"; clarsimp) + apply (prop_tac "\old_tcb' :: tcb. projectKO_opt old_tcb_ko' = Some old_tcb'") + apply (frule updateObject_type) + apply (case_tac old_tcb_ko'; clarsimp simp: project_inject) + apply (erule exE) + apply (rule preserve_valid_tcb', assumption+) + apply (simp add: prod_eqI lookupAround2_char1) + apply force + apply (clarsimp simp: project_inject) + apply (clarsimp simp: project_inject) + done + +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 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 + \\_. valid_tcb' tcb\" + apply (simp add: threadSet_def) + apply (wpsimp wp: setObject_valid_tcb') + done + +lemma threadSet_valid_tcbs': + "\valid_tcbs' and (\s. \tcb. valid_tcb' tcb s \ valid_tcb' (f tcb) s)\ + threadSet f t + \\_. valid_tcbs'\" + apply (simp add: threadSet_def) + apply (rule hoare_seq_ext[OF _ getObject_tcb_sp]) + apply (wpsimp wp: setObject_tcb_valid_tcbs') + 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 objBits_simps') + done + lemma asUser_corres': assumes y: "corres_underlying Id False True r \ \ f g" - shows "corres r (tcb_at t) - (tcb_at' t) + shows "corres r (tcb_at t and pspace_aligned and pspace_distinct) \ (as_user t f) (asUser t g)" - proof - +proof - note arch_tcb_context_get_def[simp] note atcbContextGet_def[simp] note arch_tcb_context_set_def[simp] note atcbContextSet_def[simp] have L1: "corres (\tcb con. (arch_tcb_context_get o tcb_arch) tcb = con) - (tcb_at t) (tcb_at' t) - (gets_the (get_tcb t)) (threadGet (atcbContextGet o tcbArch) t)" + (tcb_at t and pspace_aligned and pspace_distinct) \ + (gets_the (get_tcb t)) (threadGet (atcbContextGet o tcbArch) t)" + 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 (rule corres_gets_the) apply (simp add: threadGet_def) @@ -1332,32 +1546,32 @@ lemma asUser_corres': (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 exst_same_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'))" using y by (fastforce simp: corres_underlying_def select_f_def split_def Id_def) show ?thesis - apply (simp add: as_user_def asUser_def) - apply (rule corres_guard_imp) - apply (rule_tac r'="\tcb con. (arch_tcb_context_get o tcb_arch) tcb = con" - in corres_split) - apply simp - apply (rule L1[simplified]) - apply (rule corres_split) - apply (rule L4; simp) - apply clarsimp - apply (rule corres_split_nor) - apply (simp add: threadSet_def) - apply (rule corres_symb_exec_r) - prefer 4 - apply (rule no_fail_pre_and, wp) - apply (rule L3[simplified]) - apply simp - apply simp - apply (wp select_f_inv | simp)+ - done + apply (rule corres_cross_over_guard[where Q="tcb_at' t"]) + apply (fastforce simp: tcb_at_cross state_relation_def) + apply (simp add: as_user_def asUser_def) + apply (rule corres_guard_imp) + apply (rule_tac r'="\tcb con. (arch_tcb_context_get o tcb_arch) tcb = con" + in corres_split) + apply simp + apply (rule L1[simplified]) + apply (rule corres_split[OF L4]) + apply simp + apply clarsimp + apply (rule corres_split_nor) + apply (simp add: threadSet_def) + apply (rule corres_symb_exec_r) + apply (rule L3[simplified]) + prefer 5 + apply (rule no_fail_pre_and, wp) + apply (wp select_f_inv | simp)+ + done qed lemma asUser_corres: @@ -1390,7 +1604,7 @@ proof - qed lemma asUser_getRegister_corres: - "corres (=) (tcb_at t) (tcb_at' t) + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ (as_user t (getRegister r)) (asUser t (getRegister r))" apply (rule asUser_corres') apply (clarsimp simp: getRegister_def) @@ -1438,14 +1652,6 @@ lemma asUser_valid_pspace'[wp]: apply (wp threadSet_valid_pspace' hoare_drop_imps | simp)+ done -lemma asUser_valid_queues[wp]: - "\Invariants_H.valid_queues\ asUser t m \\rv. Invariants_H.valid_queues\" - apply (simp add: asUser_def split_def) - apply (wp hoare_drop_imps | simp)+ - - apply (wp threadSet_valid_queues hoare_drop_imps | simp)+ - done - lemma asUser_ifunsafe'[wp]: "\if_unsafe_then_cap'\ asUser t m \\rv. if_unsafe_then_cap'\" apply (simp add: asUser_def split_def) @@ -1537,8 +1743,7 @@ lemma no_fail_asUser [wp]: done lemma asUser_setRegister_corres: - "corres dc (tcb_at t) - (tcb_at' t) + "corres dc (tcb_at t and pspace_aligned and pspace_distinct) \ (as_user t (setRegister r v)) (asUser t (setRegister r v))" apply (simp add: setRegister_def) @@ -1547,7 +1752,7 @@ lemma asUser_setRegister_corres: done lemma getThreadState_corres: - "corres thread_state_relation (tcb_at t) (tcb_at' t) + "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) @@ -1578,7 +1783,7 @@ lemma gts_inv'[wp]: "\P\ getThreadState t \\rv. by (simp add: getThreadState_def) wp lemma getBoundNotification_corres: - "corres (=) (tcb_at t) (tcb_at' t) + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ (get_bound_notification t) (getBoundNotification t)" apply (simp add: get_bound_notification_def getBoundNotification_def) apply (rule threadGet_corres) @@ -1719,19 +1924,22 @@ lemma ethreadget_corres: apply (simp add: x) done -lemma setQueue_corres: - "corres dc \ \ (set_tcb_queue d p q) (setQueue d p q)" - apply (rule corres_no_failI) - apply wp - apply (clarsimp simp: setQueue_def in_monad set_tcb_queue_def return_def simpler_modify_def) - apply (fastforce simp: state_relation_def ready_queues_relation_def) - done - - -lemma getQueue_corres: "corres (=) \ \ (get_tcb_queue qdom prio) (getQueue qdom prio)" - apply (clarsimp simp add: getQueue_def state_relation_def ready_queues_relation_def get_tcb_queue_def gets_def) - apply (fold gets_def) - apply simp +lemma getQueue_corres: + "corres (\ls q. (ls = [] \ tcbQueueEmpty q) \ (ls \ [] \ tcbQueueHead q = Some (hd ls)) + \ queue_end_valid ls q) + \ \ (get_tcb_queue qdom prio) (getQueue qdom prio)" + apply (clarsimp simp: get_tcb_queue_def getQueue_def tcbQueueEmpty_def) + apply (rule corres_bind_return2) + apply (rule corres_symb_exec_l[OF _ _ gets_sp]) + apply (rule corres_symb_exec_r[OF _ gets_sp]) + apply clarsimp + apply (drule state_relation_ready_queues_relation) + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def + list_queue_relation_def) + apply (drule_tac x=qdom in spec) + apply (drule_tac x=prio in spec) + apply (fastforce dest: heap_path_head) + apply wpsimp+ done lemma no_fail_return: @@ -1746,8 +1954,8 @@ lemma addToBitmap_noop_corres: (wp | simp add: state_relation_def | rule no_fail_pre)+ lemma addToBitmap_if_null_noop_corres: (* used this way in Haskell code *) - "corres dc \ \ (return ()) (if null queue then addToBitmap d p else return ())" - by (cases "null queue", simp_all add: addToBitmap_noop_corres) + "corres dc \ \ (return ()) (if tcbQueueEmpty queue then addToBitmap d p else return ())" + by (cases "tcbQueueHead queue", simp_all add: addToBitmap_noop_corres) lemma removeFromBitmap_corres_noop: "corres dc \ \ (return ()) (removeFromBitmap tdom prioa)" @@ -1764,54 +1972,704 @@ crunch typ_at'[wp]: removeFromBitmap "\s. P (typ_at' T p s)" 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 ekheap_relation_tcb_domain_priority: + "\ekheap_relation (ekheap s) (ksPSpace s'); ekheap s t = Some (tcb); + ksPSpace s' t = Some (KOTCB tcb')\ + \ 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 (clarsimp simp: other_obj_relation_def etcb_relation_def) + done + +lemma no_fail_thread_get[wp]: + "no_fail (tcb_at tcb_ptr) (thread_get f tcb_ptr)" + unfolding thread_get_def + apply wpsimp + apply (clarsimp simp: tcb_at_def) + done + +lemma pspace_relation_tcb_relation: + "\pspace_relation (kheap s) (ksPSpace s'); kheap s ptr = Some (TCB tcb); + ksPSpace s' ptr = Some (KOTCB tcb')\ + \ 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 + +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) + +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 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 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 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) + +crunches 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) + +crunches 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 + +crunches 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) + +crunches 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 + +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\ + isRunnable tcb_ptr + \\rv s. \tcb'. ko_at' tcb' tcb_ptr s + \ (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_def) + apply (fastforce simp: obj_at'_def split: Structures_H.thread_state.splits) + done + +crunch (no_fail) no_fail[wp]: isRunnable + +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) + +crunches 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 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 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 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 tcbSchedEnqueue_corres: - "corres dc (is_etcb_at t) (tcb_at' t and Invariants_H.valid_queues and valid_queues') - (tcb_sched_action (tcb_sched_enqueue) t) (tcbSchedEnqueue t)" -proof - - have ready_queues_helper: - "\t tcb a b. \ ekheap a t = Some tcb; obj_at' tcbQueued t b ; valid_queues' b ; - ekheap_relation (ekheap a) (ksPSpace b) \ - \ t \ set (ksReadyQueues b (tcb_domain tcb, tcb_priority tcb))" - unfolding valid_queues'_def - by (fastforce dest: ekheap_relation_absD simp: obj_at'_def inQ_def etcb_relation_def projectKO_eq projectKO_tcb) - - show ?thesis unfolding tcbSchedEnqueue_def tcb_sched_action_def - apply (rule corres_symb_exec_r [OF _ _ threadGet_inv, - 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 (rule no_fail_pre, wp, blast) - apply (case_tac queued; simp_all) - apply (rule corres_no_failI; simp add: no_fail_return) - apply (clarsimp simp: in_monad ethread_get_def gets_the_def bind_assoc - assert_opt_def exec_gets is_etcb_at_def get_etcb_def get_tcb_queue_def - set_tcb_queue_def simpler_modify_def ready_queues_relation_def - state_relation_def tcb_sched_enqueue_def) - apply (rule ready_queues_helper; auto) - apply (clarsimp simp: when_def) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres) - apply (simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres) - apply (simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply simp - apply (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 - apply (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 exst_same_def) - apply (wp getObject_tcb_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 + "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)?) + + \ \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) + + 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" @@ -1838,7 +2696,10 @@ lemma getSchedulerAction_corres: done lemma rescheduleRequired_corres: - "corres dc (weak_valid_sched_action and valid_etcbs) (Invariants_H.valid_queues and valid_queues' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)) + "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) @@ -1849,15 +2710,14 @@ lemma rescheduleRequired_corres: apply (case_tac action) apply simp apply simp - apply (rule tcbSchedEnqueue_corres) + 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 + 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 simp - apply (clarsimp simp: weak_sch_act_wf_def pred_tcb_at' split: scheduler_action.splits) + apply (clarsimp split: scheduler_action.splits) done lemma rescheduleRequired_corres_simple: @@ -1925,20 +2785,18 @@ lemmas addToBitmap_weak_sch_act_wf[wp] = weak_sch_act_wf_lift[OF addToBitmap_nosch] crunch st_tcb_at'[wp]: removeFromBitmap "st_tcb_at' P t" -crunch pred_tcb_at'[wp]: removeFromBitmap "pred_tcb_at' proj P t" +crunch pred_tcb_at'[wp]: removeFromBitmap "\s. Q (pred_tcb_at' proj P t s)" crunch not_st_tcb_at'[wp]: removeFromBitmap "\s. \ (st_tcb_at' P' t) s" -crunch not_pred_tcb_at'[wp]: removeFromBitmap "\s. \ (pred_tcb_at' proj P' t) s" crunch st_tcb_at'[wp]: addToBitmap "st_tcb_at' P' t" -crunch pred_tcb_at'[wp]: addToBitmap "pred_tcb_at' proj P' t" +crunch pred_tcb_at'[wp]: addToBitmap "\s. Q (pred_tcb_at' proj P t s)" crunch not_st_tcb_at'[wp]: addToBitmap "\s. \ (st_tcb_at' P' t) s" -crunch not_pred_tcb_at'[wp]: addToBitmap "\s. \ (pred_tcb_at' proj P' t) s" -crunch obj_at'[wp]: removeFromBitmap "obj_at' P t" +crunch obj_at'[wp]: removeFromBitmap "\s. Q (obj_at' P t s)" -crunch obj_at'[wp]: addToBitmap "obj_at' P t" +crunch obj_at'[wp]: addToBitmap "\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\" @@ -1955,9 +2813,11 @@ lemma addToBitmap_tcb_in_cur_domain'[wp]: done lemma tcbSchedDequeue_weak_sch_act_wf[wp]: - "\ \s. weak_sch_act_wf (ksSchedulerAction s) s \ tcbSchedDequeue a \ \_ s. weak_sch_act_wf (ksSchedulerAction s) s \" - apply (simp add: tcbSchedDequeue_def) - apply (wp threadSet_weak_sch_act_wf removeFromBitmap_weak_sch_act_wf | simp add: crunch_simps)+ + "tcbSchedDequeue tcbPtr \\s. weak_sch_act_wf (ksSchedulerAction s) s\" + apply (simp add: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wp threadSet_weak_sch_act_wf getObject_tcb_wp removeFromBitmap_weak_sch_act_wf + | simp add: crunch_simps threadGet_def)+ + apply (clarsimp simp: obj_at'_def) done lemma dequeue_nothing_eq[simp]: @@ -1973,44 +2833,345 @@ lemma gets_the_exec: "f s \ None \ (do x \ ge return_def assert_opt_def) done -lemma tcbSchedDequeue_corres: - "corres dc (is_etcb_at t) (tcb_at' t and Invariants_H.valid_queues) - (tcb_sched_action tcb_sched_dequeue t) (tcbSchedDequeue t)" - apply (simp only: tcbSchedDequeue_def tcb_sched_action_def) - apply (rule corres_symb_exec_r[OF _ _ threadGet_inv, where Q'="\rv. tcb_at' t and Invariants_H.valid_queues and obj_at' (\obj. tcbQueued obj = rv) t"]) - defer - apply (wp threadGet_obj_at', simp, simp) - apply (rule no_fail_pre, wp, simp) - apply (case_tac queued) - defer - apply (simp add: when_def) - apply (rule corres_no_failI) - apply (wp) - apply (clarsimp simp: in_monad ethread_get_def set_tcb_queue_def is_etcb_at_def state_relation_def) - apply (subgoal_tac "t \ set (ready_queues a (tcb_domain y) (tcb_priority y))") - prefer 2 - subgoal by (force simp: tcb_sched_dequeue_def Invariants_H.valid_queues_def valid_queues_no_bitmap_def - ready_queues_relation_def obj_at'_def inQ_def projectKO_eq project_inject) - apply (subst gets_the_exec) - apply (simp add: get_etcb_def) - apply (subst gets_the_exec) - apply (simp add: get_etcb_def) - apply (simp add: exec_gets simpler_modify_def get_etcb_def ready_queues_relation_def cong: if_cong get_tcb_queue_def) - apply (simp add: when_def) - apply (rule corres_guard_imp) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres, simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres, simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply (simp, rule getQueue_corres) - apply (rule corres_split_noop_rhs2) - apply (simp add: tcb_sched_dequeue_def) - apply (rule setQueue_corres) - apply (rule corres_split_noop_rhs) - apply (clarsimp, rule removeFromBitmap_corres_noop) - apply (rule threadSet_corres_noop; simp_all add: tcb_relation_def exst_same_def) - apply (wp | simp)+ +lemma tcbQueueRemove_no_fail: + "no_fail (\s. tcb_at' tcbPtr s + \ (\ts. list_queue_relation ts queue (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ tcbPtr \ set ts) + \ sym_heap_sched_pointers s \ valid_objs' s) + (tcbQueueRemove queue tcbPtr)" + unfolding tcbQueueRemove_def + apply (wpsimp wp: getObject_tcb_wp) + apply normalise_obj_at' + apply (frule (1) ko_at_valid_objs') + apply (fastforce simp: projectKOs) + apply (clarsimp simp: list_queue_relation_def) + apply (prop_tac "tcbQueueHead queue \ Some tcbPtr \ tcbSchedPrevs_of s tcbPtr \ None") + apply (rule impI) + apply (frule not_head_prev_not_None[where p=tcbPtr]) + apply (fastforce simp: inQ_def opt_pred_def opt_map_def obj_at'_def) + apply (fastforce dest: heap_path_head) + apply fastforce + apply (fastforce simp: opt_map_def obj_at'_def valid_tcb'_def valid_bound_tcb'_def) + by (fastforce dest!: not_last_next_not_None[where p=tcbPtr] + simp: queue_end_valid_def opt_map_def obj_at'_def projectKOs valid_obj'_def + valid_tcb'_def) + +crunch (no_fail) no_fail[wp]: removeFromBitmap + +crunches removeFromBitmap + for ready_queues_relation[wp]: "ready_queues_relation s" + and list_queue_relation[wp]: + "\s'. list_queue_relation ts (P (ksReadyQueues s')) + (tcbSchedNexts_of s') (tcbSchedPrevs_of s')" + (simp: bitmap_fun_defs ready_queues_relation_def) + +\ \ + A direct analogue of tcbQueueRemove, used in tcb_sched_dequeue' below, so that within the proof of + tcbQueueRemove_corres, we may reason in terms of the list operations used within this function + rather than @{term filter}.\ +definition tcb_queue_remove :: "'a \ 'a list \ 'a list" where + "tcb_queue_remove a ls \ + if ls = [a] + then [] + else if a = hd ls + then tl ls + else if a = last ls + then butlast ls + else list_remove ls a" + +definition tcb_sched_dequeue' :: "obj_ref \ unit det_ext_monad" where + "tcb_sched_dequeue' tcb_ptr \ do + d \ ethread_get tcb_domain tcb_ptr; + prio \ ethread_get tcb_priority tcb_ptr; + queue \ get_tcb_queue d prio; + when (tcb_ptr \ set queue) $ set_tcb_queue d prio (tcb_queue_remove tcb_ptr queue) + od" + +lemma filter_tcb_queue_remove: + "\a \ set ls; distinct ls \ \ filter ((\) a) ls = tcb_queue_remove a ls" + apply (clarsimp simp: tcb_queue_remove_def) + apply (intro conjI impI) + apply (fastforce elim: filter_hd_equals_tl) + apply (fastforce elim: filter_last_equals_butlast) + apply (fastforce elim: filter_hd_equals_tl) + apply (frule split_list) + apply (clarsimp simp: list_remove_middle_distinct) + apply (subst filter_True | clarsimp simp: list_remove_none)+ + done + +lemma tcb_sched_dequeue_monadic_rewrite: + "monadic_rewrite False True (is_etcb_at t and (\s. \d p. distinct (ready_queues s d p))) + (tcb_sched_action tcb_sched_dequeue t) (tcb_sched_dequeue' t)" + supply if_split[split del] + apply (clarsimp simp: tcb_sched_dequeue'_def tcb_sched_dequeue_def tcb_sched_action_def + set_tcb_queue_def) + apply (rule monadic_rewrite_bind_tail)+ + apply (clarsimp simp: when_def) + apply (rule monadic_rewrite_if_r) + apply (rule_tac P="\_. distinct queue" in monadic_rewrite_guard_arg_cong) + apply (frule (1) filter_tcb_queue_remove) + apply (metis (mono_tags, lifting) filter_cong) + apply (rule monadic_rewrite_modify_noop) + apply (wpsimp wp: thread_get_wp)+ + apply (clarsimp simp: etcb_at_def split: option.splits) + apply (prop_tac "(\d' p. if d' = tcb_domain x2 \ p = tcb_priority x2 + then filter (\x. x \ t) (ready_queues s (tcb_domain x2) (tcb_priority x2)) + else ready_queues s d' p) + = ready_queues s") + apply (subst filter_True) + apply fastforce + apply (clarsimp intro!: ext split: if_splits) + apply fastforce + done + +crunches removeFromBitmap + for ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" + +lemma list_queue_relation_neighbour_in_set: + "\list_queue_relation ls q hp hp'; sym_heap hp hp'; p \ set ls\ + \ \nbr. (hp p = Some nbr \ nbr \ set ls) \ (hp' p = Some nbr \ nbr \ set ls)" + apply (rule heap_ls_neighbour_in_set) + apply (fastforce simp: list_queue_relation_def) + apply fastforce + apply (clarsimp simp: list_queue_relation_def prev_queue_head_def) + apply fastforce + done + +lemma in_queue_not_head_or_not_tail_length_gt_1: + "\tcbPtr \ set ls; tcbQueueHead q \ Some tcbPtr \ tcbQueueEnd q \ Some tcbPtr; + list_queue_relation ls q nexts prevs\ + \ Suc 0 < length ls" + apply (clarsimp simp: list_queue_relation_def) + apply (cases ls; fastforce simp: queue_end_valid_def) + done + +lemma tcbSchedDequeue_corres: + "tcb_ptr = tcbPtr \ + corres dc + (in_correct_ready_q and ready_qs_distinct and valid_etcbs and tcb_at tcb_ptr + and pspace_aligned and pspace_distinct) + (sym_heap_sched_pointers and valid_objs') + (tcb_sched_action tcb_sched_dequeue tcb_ptr) (tcbSchedDequeue tcbPtr)" + supply heap_path_append[simp del] fun_upd_apply[simp del] distinct_append[simp del] + list_remove_append[simp del] + apply (rule_tac Q'="tcb_at' tcbPtr" in corres_cross_add_guard) + apply (fastforce intro!: tcb_at_cross simp: obj_at_def is_tcb_def) + apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) + apply (fastforce dest: pspace_aligned_cross) + apply (rule_tac Q'=pspace_distinct' in corres_cross_add_guard) + apply (fastforce dest: pspace_distinct_cross) + apply (rule monadic_rewrite_corres_l[where P=P and Q=P for P, simplified]) + apply (rule monadic_rewrite_guard_imp[OF tcb_sched_dequeue_monadic_rewrite]) + apply (fastforce dest: tcb_at_is_etcb_at simp: in_correct_ready_q_def ready_qs_distinct_def) + apply (clarsimp simp: tcb_sched_dequeue'_def get_tcb_queue_def tcbSchedDequeue_def getQueue_def + unless_def when_def) + apply (rule corres_symb_exec_l[OF _ _ ethread_get_sp]; wpsimp?) + apply (rename_tac dom) + apply (rule corres_symb_exec_l[OF _ _ ethread_get_sp]; wpsimp?) + apply (rename_tac prio) + 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 _ threadGet_sp]; (solves wpsimp)?) + apply (rule corres_if_strong'; fastforce?) + apply (frule state_relation_ready_queues_relation) + apply (frule in_ready_q_tcbQueued_eq[where t=tcbPtr]) + apply (fastforce simp: obj_at'_def projectKOs opt_pred_def opt_map_def obj_at_def is_tcb_def + in_correct_ready_q_def etcb_at_def is_etcb_at_def) + apply (rule corres_symb_exec_r[OF _ threadGet_sp]; wpsimp?) + apply (rule corres_symb_exec_r[OF _ threadGet_sp]; wpsimp?) + apply (rule corres_symb_exec_r[OF _ gets_sp]; wpsimp?) + apply (rule corres_from_valid_det) + apply (fastforce intro: det_wp_modify det_wp_pre simp: set_tcb_queue_def) + apply (wpsimp wp: tcbQueueRemove_no_fail) + apply (fastforce dest: state_relation_ready_queues_relation + simp: ex_abs_underlying_def ready_queues_relation_def ready_queue_relation_def + Let_def inQ_def opt_pred_def opt_map_def obj_at'_def projectKOs) + 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 tcbQueueRemove_def + split_del: if_split) + apply (frule (1) tcb_at_is_etcb_at) + apply (clarsimp simp: obj_at_def is_etcb_at_def etcb_at_def) + apply normalise_obj_at' + 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 (case_tac "d \ tcb_domain etcb \ p \ tcb_priority etcb") + apply clarsimp + apply (cut_tac p=tcbPtr and ls="ready_queues s (tcb_domain etcb) (tcb_priority etcb)" + in list_queue_relation_neighbour_in_set) + apply (fastforce dest!: spec) + apply fastforce + apply fastforce + apply (cut_tac xs="ready_queues s d p" in heap_path_head') + apply (force dest!: spec simp: ready_queues_relation_def Let_def list_queue_relation_def) + 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 (cut_tac ts="ready_queues s d p" in list_queue_relation_nil) + apply fast + apply (clarsimp simp: tcbQueueEmpty_def) + apply (prop_tac "Some tcbPtr \ tcbQueueHead (ksReadyQueues s' (d, p))") + apply (metis hd_in_set not_emptyI option.sel option.simps(2)) + apply (prop_tac "tcbPtr \ set (ready_queues s d p)") + apply blast + apply (clarsimp simp: list_queue_relation_def) + apply (intro conjI; clarsimp) + + \ \the ready queue is the singleton consisting of tcbPtr\ + apply (intro conjI) + apply (force intro!: heap_path_heap_upd_not_in simp: fun_upd_apply) + apply (clarsimp simp: queue_end_valid_def fun_upd_apply) + apply (force simp: prev_queue_head_heap_upd fun_upd_apply) + apply (clarsimp simp: inQ_def in_opt_pred fun_upd_apply) + apply (clarsimp simp: fun_upd_apply) + apply (clarsimp simp: fun_upd_apply) + + apply (clarsimp simp: etcb_at_def obj_at'_def projectKOs) + apply (intro conjI; clarsimp) + + \ \tcbPtr is the head of the ready queue\ + apply (intro conjI) + apply (intro heap_path_heap_upd_not_in) + apply (force simp: fun_upd_apply) + apply (force simp: not_emptyI opt_map_red) + apply assumption + apply (clarsimp simp: queue_end_valid_def fun_upd_apply) + apply (clarsimp simp: prev_queue_head_def fun_upd_apply) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + apply (clarsimp simp: fun_upd_apply) + apply (clarsimp simp: fun_upd_apply) + apply (intro conjI; clarsimp) + + \ \tcbPtr is the end of the ready queue\ + apply (intro conjI) + apply (intro heap_path_heap_upd_not_in) + apply (simp add: fun_upd_apply split: if_splits) + apply (force simp: not_emptyI opt_map_red) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + apply (clarsimp simp: queue_end_valid_def fun_upd_apply) + apply (force simp: prev_queue_head_def fun_upd_apply opt_map_red opt_map_upd_triv) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + apply (clarsimp simp: fun_upd_apply) + apply (clarsimp simp: fun_upd_apply) + + \ \tcbPtr is in the middle of the ready queue\ + apply (intro conjI) + apply (intro heap_path_heap_upd_not_in) + apply (simp add: fun_upd_apply) + apply (force simp: not_emptyI opt_map_red) + apply (force simp: not_emptyI opt_map_red) + apply fastforce + apply (clarsimp simp: opt_map_red opt_map_upd_triv) + apply (intro prev_queue_head_heap_upd) + apply (force dest!: spec) + apply (metis hd_in_set not_emptyI option.sel option.simps(2)) + apply fastforce + subgoal + by (clarsimp simp: inQ_def opt_map_def opt_pred_def fun_upd_apply + split: if_splits option.splits) + + \ \d = tcb_domain tcb \ p = tcb_priority tcb\ + apply clarsimp + apply (drule_tac x="tcb_domain etcb" in spec) + apply (drule_tac x="tcb_priority etcb" in spec) + apply (clarsimp simp: list_queue_relation_def) + apply (frule heap_path_head') + apply (frule heap_ls_distinct) + apply (intro conjI; clarsimp simp: tcbQueueEmpty_def) + + \ \the ready queue is the singleton consisting of tcbPtr\ + apply (intro conjI) + apply (simp add: fun_upd_apply tcb_queue_remove_def queue_end_valid_def heap_ls_unique + heap_path_last_end) + apply (simp add: fun_upd_apply tcb_queue_remove_def queue_end_valid_def heap_ls_unique + heap_path_last_end) + apply (simp add: fun_upd_apply prev_queue_head_def) + apply (case_tac "ready_queues s (tcb_domain etcb) (tcb_priority etcb)"; + clarsimp simp: tcb_queue_remove_def inQ_def opt_pred_def fun_upd_apply) + apply (intro conjI; clarsimp) + + \ \tcbPtr is the head of the ready queue\ + apply (frule set_list_mem_nonempty) + apply (frule in_queue_not_head_or_not_tail_length_gt_1) + apply fastforce + apply (fastforce simp: list_queue_relation_def) + apply (frule list_not_head) + apply (clarsimp simp: tcb_queue_remove_def) + apply (frule length_tail_nonempty) + apply (frule (2) heap_ls_next_of_hd) + apply (clarsimp simp: obj_at'_def) + apply (intro conjI impI allI) + apply (drule (1) heap_ls_remove_head_not_singleton) + apply (clarsimp simp: opt_map_red opt_map_upd_triv fun_upd_apply projectKOs) + apply (clarsimp simp: queue_end_valid_def fun_upd_apply last_tl) + apply (clarsimp simp: prev_queue_head_def fun_upd_apply projectKOs) + apply (case_tac "ready_queues s (tcb_domain etcb) (tcb_priority etcb)"; + clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply projectKOs + split: option.splits) + apply (intro conjI; clarsimp) + + \ \tcbPtr is the end of the ready queue\ + apply (frule set_list_mem_nonempty) + apply (frule in_queue_not_head_or_not_tail_length_gt_1) + apply fast + apply (force dest!: spec simp: list_queue_relation_def) + apply (clarsimp simp: queue_end_valid_def) + apply (frule list_not_last) + apply (clarsimp simp: tcb_queue_remove_def) + apply (frule length_gt_1_imp_butlast_nonempty) + apply (frule (3) heap_ls_prev_of_last) + apply (clarsimp simp: obj_at'_def) + apply (intro conjI impI; clarsimp?) + apply (drule (1) heap_ls_remove_last_not_singleton) + apply (force elim!: rsubst3[where P=heap_ls] simp: opt_map_def fun_upd_apply obj_at'_def projectKOs) + apply (clarsimp simp: opt_map_def fun_upd_apply projectKOs) + apply (clarsimp simp: prev_queue_head_def fun_upd_apply opt_map_def projectKOs) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply projectKOs + split: option.splits) + apply (meson distinct_in_butlast_not_last in_set_butlastD last_in_set not_last_in_set_butlast) + + \ \tcbPtr is in the middle of the ready queue\ + apply (clarsimp simp: obj_at'_def) + apply (frule set_list_mem_nonempty) + apply (frule split_list) + apply clarsimp + apply (rename_tac xs ys) + apply (prop_tac "xs \ [] \ ys \ []", fastforce simp: queue_end_valid_def) + apply clarsimp + apply (frule (2) ptr_in_middle_prev_next) + apply fastforce + apply (clarsimp simp: tcb_queue_remove_def) + apply (prop_tac "tcbPtr \ last xs") + apply (clarsimp simp: distinct_append) + apply (prop_tac "tcbPtr \ hd ys") + apply (fastforce dest: hd_in_set simp: distinct_append) + apply (prop_tac "last xs \ hd ys") + apply (metis distinct_decompose2 hd_Cons_tl last_in_set) + apply (prop_tac "list_remove (xs @ tcbPtr # ys) tcbPtr = xs @ ys") + apply (simp add: list_remove_middle_distinct del: list_remove_append) + apply (intro conjI impI allI; (solves \clarsimp simp: distinct_append\)?) + apply (fastforce elim!: rsubst3[where P=heap_ls] + dest!: heap_ls_remove_middle hd_in_set last_in_set + simp: distinct_append not_emptyI opt_map_def fun_upd_apply projectKOs) + apply (clarsimp simp: queue_end_valid_def fun_upd_apply) + apply (case_tac xs; + fastforce simp: prev_queue_head_def opt_map_def fun_upd_apply distinct_append projectKOs) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply distinct_append projectKOs + split: option.splits) done lemma thread_get_test: "do cur_ts \ get_thread_state cur; g (test cur_ts) od = @@ -2018,7 +3179,9 @@ lemma thread_get_test: "do cur_ts \ get_thread_state cur; g (test cur apply (simp add: get_thread_state_def thread_get_def) done -lemma thread_get_isRunnable_corres: "corres (=) (tcb_at t) (tcb_at' t) (thread_get (\tcb. runnable (tcb_state tcb)) t) (isRunnable t)" +lemma thread_get_isRunnable_corres: + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ + (thread_get (\tcb. runnable (tcb_state tcb)) t) (isRunnable t)" apply (simp add: isRunnable_def getThreadState_def threadGet_def thread_get_def) apply (fold liftM_def) @@ -2032,8 +3195,8 @@ lemma thread_get_isRunnable_corres: "corres (=) (tcb_at t) (tcb_at' t) (thread_g lemma setThreadState_corres: "thread_state_relation ts ts' \ corres dc - (tcb_at t) - (tcb_at' t) + (tcb_at t and pspace_aligned and pspace_distinct) + \ (set_thread_state t ts) (setThreadState ts' t)" (is "?tsr \ corres dc ?Pre ?Pre' ?sts ?sts'") apply (simp add: set_thread_state_def setThreadState_def) @@ -2057,8 +3220,8 @@ lemma setThreadState_corres: lemma setBoundNotification_corres: "corres dc - (tcb_at t) - (tcb_at' t) + (tcb_at t and pspace_aligned and pspace_distinct) + \ (set_bound_notification t ntfn) (setBoundNotification ntfn t)" apply (simp add: set_bound_notification_def setBoundNotification_def) apply (subst thread_set_def[simplified, symmetric]) @@ -2068,29 +3231,84 @@ lemma setBoundNotification_corres: crunches rescheduleRequired, tcbSchedDequeue, setThreadState, setBoundNotification for tcb'[wp]: "tcb_at' addr" +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 + +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 + +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) + +crunches addToBitmap + for valid_objs'[wp]: valid_objs' + (simp: unless_def crunch_simps wp: crunch_wps) + +lemma tcbSchedEnqueue_valid_objs'[wp]: + "\valid_objs' and pspace_aligned' and pspace_distinct'\ + tcbSchedEnqueue tcbPtr + \\_. valid_objs'\" + 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 + crunches rescheduleRequired, removeFromBitmap for valid_objs'[wp]: valid_objs' (simp: crunch_simps) -lemma tcbSchedDequeue_valid_objs' [wp]: "\ valid_objs' \ tcbSchedDequeue t \\_. valid_objs' \" - unfolding tcbSchedDequeue_def - apply (wp threadSet_valid_objs') - apply (clarsimp simp add: valid_tcb'_def tcb_cte_cases_def) - apply wp - apply (simp add: if_apply_def2) - apply (wp hoare_drop_imps) - apply (wp | simp cong: if_cong add: valid_tcb'_def tcb_cte_cases_def if_apply_def2)+ +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] + +lemma tcbQueueRemove_valid_objs'[wp]: + "tcbQueueRemove queue tcbPtr \valid_objs'\" + unfolding tcbQueueRemove_def + apply (wpsimp wp: getObject_tcb_wp) + apply normalise_obj_at' + apply (fastforce dest!: tcb_ko_at_valid_objs_valid_tcb' + simp: valid_tcb'_def valid_bound_tcb'_def obj_at'_def) done +lemma tcbSchedDequeue_valid_objs'[wp]: + "tcbSchedDequeue t \valid_objs'\" + unfolding tcbSchedDequeue_def setQueue_def + by (wpsimp wp: threadSet_valid_objs') + lemma sts_valid_objs': - "\valid_objs' and valid_tcb_state' st\ - setThreadState st t - \\rv. valid_objs'\" - apply (simp add: setThreadState_def setQueue_def isRunnable_def isStopped_def) - apply (wp threadSet_valid_objs') - apply (simp add: valid_tcb'_def tcb_cte_cases_def) - apply (wp threadSet_valid_objs' | simp)+ - apply (clarsimp simp: valid_tcb'_def tcb_cte_cases_def) + "\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') + 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': @@ -2176,18 +3394,6 @@ lemma setQueue_valid_bitmapQ_except[wp]: unfolding setQueue_def bitmapQ_defs by (wp, clarsimp simp: bitmapQ_def) -lemma setQueue_valid_bitmapQ: (* enqueue only *) - "\ valid_bitmapQ and (\s. (ksReadyQueues s (d, p) = []) = (ts = [])) \ - setQueue d p ts - \\_. valid_bitmapQ \" - unfolding setQueue_def bitmapQ_defs - by (wp, clarsimp simp: bitmapQ_def) - -lemma setQueue_valid_queues': - "\valid_queues' and (\s. \t. obj_at' (inQ d p) t s \ t \ set ts)\ - setQueue d p ts \\_. valid_queues'\" - by (wp | simp add: valid_queues'_def setQueue_def)+ - lemma setQueue_cur: "\\s. cur_tcb' s\ setQueue d p ts \\rv s. cur_tcb' s\" unfolding setQueue_def cur_tcb'_def @@ -2325,9 +3531,17 @@ lemma threadSet_queued_sch_act_wf[wp]: apply (wp tcb_in_cur_domain'_lift | simp add: obj_at'_def)+ done +lemma tcbSchedNext_update_pred_tcb_at'[wp]: + "threadSet (tcbSchedNext_update f) t \\s. P (pred_tcb_at' proj P' t' s)\" + by (wp threadSet_pred_tcb_no_state crunch_wps | clarsimp simp: tcb_to_itcb'_def)+ + +lemma tcbSchedPrev_update_pred_tcb_at'[wp]: + "threadSet (tcbSchedPrev_update f) t \\s. P (pred_tcb_at' proj P' t' s)\" + by (wp threadSet_pred_tcb_no_state crunch_wps | clarsimp simp: tcb_to_itcb'_def)+ + lemma tcbSchedEnqueue_pred_tcb_at'[wp]: "\\s. pred_tcb_at' proj P' t' s \ tcbSchedEnqueue t \\_ s. pred_tcb_at' proj P' t' s\" - apply (simp add: tcbSchedEnqueue_def when_def unless_def) + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def when_def unless_def) apply (wp threadSet_pred_tcb_no_state crunch_wps | clarsimp simp: tcb_to_itcb'_def)+ done @@ -2335,8 +3549,9 @@ lemma tcbSchedDequeue_sch_act_wf[wp]: "\\s. sch_act_wf (ksSchedulerAction s) s\ tcbSchedDequeue t \\_ s. sch_act_wf (ksSchedulerAction s) s\" - unfolding tcbSchedDequeue_def - by (wp setQueue_sch_act | wp sch_act_wf_lift | simp add: if_apply_def2)+ + unfolding tcbSchedDequeue_def tcbQueueRemove_def + by (wp setQueue_sch_act threadSet_tcbDomain_triv hoare_drop_imps + | wp sch_act_wf_lift | simp add: if_apply_def2)+ crunch nosch: tcbSchedDequeue "\s. P (ksSchedulerAction s)" @@ -2432,21 +3647,22 @@ lemma tcbSchedEnqueue_sch_act[wp]: "\\s. sch_act_wf (ksSchedulerAction s) s\ tcbSchedEnqueue t \\_ s. sch_act_wf (ksSchedulerAction s) s\" - by (simp add: tcbSchedEnqueue_def unless_def) - (wp setQueue_sch_act | wp sch_act_wf_lift | clarsimp)+ + by (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_def) + (wp setQueue_sch_act threadSet_tcbDomain_triv | wp sch_act_wf_lift | clarsimp)+ lemma tcbSchedEnqueue_weak_sch_act[wp]: "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ tcbSchedEnqueue t \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: tcbSchedEnqueue_def unless_def) + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_def) apply (wp setQueue_sch_act threadSet_weak_sch_act_wf | clarsimp)+ done -lemma threadGet_wp: "\\s. tcb_at' t s \ (\tcb. ko_at' tcb t s \ P (f tcb) s)\ threadGet f t \P\" +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 + apply (clarsimp simp: obj_at'_def) done lemma threadGet_const: @@ -2488,14 +3704,6 @@ lemma addToBitmap_bitmapQ: by (wpsimp simp: bitmap_fun_defs bitmapQ_def prioToL1Index_bit_set prioL2Index_bit_set simp_del: bit_exp_iff) -lemma addToBitmap_valid_queues_no_bitmap_except: -" \ valid_queues_no_bitmap_except t \ - addToBitmap d p - \\_. valid_queues_no_bitmap_except t \" - unfolding addToBitmap_def modifyReadyQueuesL1Bitmap_def modifyReadyQueuesL2Bitmap_def - getReadyQueuesL1Bitmap_def getReadyQueuesL2Bitmap_def valid_queues_no_bitmap_except_def - by (wp, clarsimp) - crunch norq[wp]: addToBitmap "\s. P (ksReadyQueues s)" (wp: updateObject_cte_inv hoare_drop_imps) crunch norq[wp]: removeFromBitmap "\s. P (ksReadyQueues s)" @@ -2527,9 +3735,8 @@ lemma prioToL1Index_complement_nth_w2p: lemma valid_bitmapQ_exceptE: "\ valid_bitmapQ_except d' p' s ; d \ d' \ p \ p' \ - \ bitmapQ d p s = (ksReadyQueues s (d, p) \ [])" - unfolding valid_bitmapQ_except_def - by blast + \ bitmapQ d p s = (\ tcbQueueEmpty (ksReadyQueues s (d, p)))" + by (fastforce simp: valid_bitmapQ_except_def) lemma invertL1Index_eq_cancelD: "\ invertL1Index i = invertL1Index j ; i < l2BitmapSize ; j < l2BitmapSize \ @@ -2643,22 +3850,15 @@ lemma addToBitmap_valid_bitmapQ_except: done lemma addToBitmap_valid_bitmapQ: -" \ valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and - (\s. ksReadyQueues s (d,p) \ []) \ - addToBitmap d p - \\_. valid_bitmapQ \" -proof - - have "\ valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and - (\s. ksReadyQueues s (d,p) \ []) \ - addToBitmap d p - \\_. valid_bitmapQ_except d p and - bitmapQ_no_L2_orphans and (\s. bitmapQ d p s \ ksReadyQueues s (d,p) \ []) \" - by (wp addToBitmap_valid_queues_no_bitmap_except addToBitmap_valid_bitmapQ_except - addToBitmap_bitmapQ_no_L2_orphans addToBitmap_bitmapQ; simp) - - thus ?thesis - by - (erule hoare_strengthen_post; fastforce elim: valid_bitmap_valid_bitmapQ_exceptE) -qed + "\valid_bitmapQ_except d p and bitmapQ_no_L2_orphans + and (\s. \ tcbQueueEmpty (ksReadyQueues s (d,p)))\ + addToBitmap d p + \\_. valid_bitmapQ\" + (is "\?pre\ _ \_\") + apply (rule_tac Q="\_ s. ?pre s \ bitmapQ d p s" in hoare_strengthen_post) + apply (wpsimp wp: addToBitmap_valid_bitmapQ_except addToBitmap_bitmapQ) + apply (fastforce elim: valid_bitmap_valid_bitmapQ_exceptE) + done 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 \" @@ -2676,12 +3876,6 @@ lemma threadGet_const_tcb_at_imp_lift: apply (clarsimp simp: obj_at'_def) done -lemma valid_queues_no_bitmap_objD: - "\ valid_queues_no_bitmap s; t \ set (ksReadyQueues s (d, p))\ - \ obj_at' (inQ d p and runnable' \ tcbState) t s" - unfolding valid_queues_no_bitmap_def - by blast - lemma setQueue_bitmapQ_no_L1_orphans[wp]: "\ bitmapQ_no_L1_orphans \ setQueue d p ts @@ -2701,126 +3895,6 @@ lemma setQueue_sets_queue[wp]: unfolding setQueue_def by (wp, simp) -lemma tcbSchedEnqueueOrAppend_valid_queues: - (* f is either (t#ts) or (ts @ [t]), so we define its properties generally *) - assumes f_set[simp]: "\ts. t \ set (f ts)" - assumes f_set_insert[simp]: "\ts. set (f ts) = insert t (set ts)" - assumes f_not_empty[simp]: "\ts. f ts \ []" - assumes f_distinct: "\ts. \ distinct ts ; t \ set ts \ \ distinct (f ts)" - shows "\Invariants_H.valid_queues and st_tcb_at' runnable' t and valid_objs' \ - do queued \ threadGet tcbQueued t; - unless queued $ - do tdom \ threadGet tcbDomain t; - prio \ threadGet tcbPriority t; - queue \ getQueue tdom prio; - setQueue tdom prio $ f queue; - when (null queue) $ addToBitmap tdom prio; - threadSet (tcbQueued_update (\_. True)) t - od - od - \\_. Invariants_H.valid_queues\" -proof - - - define could_run where "could_run == - \d p t. obj_at' (\tcb. inQ d p (tcbQueued_update (\_. True) tcb) \ runnable' (tcbState tcb)) t" - - have addToBitmap_could_run: - "\d p. \\s. \d p. t \ set (ksReadyQueues s (d, p)) \ could_run d p t s\ - addToBitmap d p - \\_ s. \d p. t \ set (ksReadyQueues s (d, p)) \ could_run d p t s\" - unfolding bitmap_fun_defs - by (wp, clarsimp simp: could_run_def) - - have setQueue_valid_queues_no_bitmap_except: - "\d p ts. - \ valid_queues_no_bitmap_except t and - (\s. ksReadyQueues s (d, p) = ts \ p \ maxPriority \ d \ maxDomain \ t \ set ts) \ - setQueue d p (f ts) - \\rv. valid_queues_no_bitmap_except t\" - unfolding setQueue_def valid_queues_no_bitmap_except_def null_def - by (wp, auto intro: f_distinct) - - have threadSet_valid_queues_could_run: - "\f. \ valid_queues_no_bitmap_except t and - (\s. \d p. t \ set (ksReadyQueues s (d,p)) \ could_run d p t s) and - valid_bitmapQ and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans \ - threadSet (tcbQueued_update (\_. True)) t - \\rv. Invariants_H.valid_queues \" - unfolding threadSet_def could_run_def - apply (rule hoare_seq_ext[OF _ getObject_tcb_sp]) - apply (rule hoare_pre) - apply (simp add: valid_queues_def valid_queues_no_bitmap_def) - apply (wp setObject_queues_unchanged_tcb hoare_Ball_helper hoare_vcg_all_lift - setObject_tcb_strongest) - apply (clarsimp simp: valid_queues_no_bitmap_except_def obj_at'_def) - done - - have setQueue_could_run: "\d p ts. - \ valid_queues and (\_. t \ set ts) and - (\s. could_run d p t s) \ - setQueue d p ts - \\rv s. (\d p. t \ set (ksReadyQueues s (d, p)) \ could_run d p t s)\" - unfolding setQueue_def valid_queues_def could_run_def - by wp (fastforce dest: valid_queues_no_bitmap_objD simp: obj_at'_def inQ_def) - - note hoare_vcg_if_lift[wp] hoare_vcg_conj_lift[wp] hoare_vcg_const_imp_lift[wp] - - show ?thesis - unfolding tcbSchedEnqueue_def null_def - apply (rule hoare_pre) - apply (rule hoare_seq_ext) - apply (simp add: unless_def) - apply (wp threadSet_valid_queues_could_run) - apply (wp addToBitmap_could_run addToBitmap_valid_bitmapQ - addToBitmap_valid_queues_no_bitmap_except addToBitmap_bitmapQ_no_L2_orphans)+ - apply (wp setQueue_valid_queues_no_bitmap_except setQueue_could_run - setQueue_valid_bitmapQ_except setQueue_sets_queue setQueue_valid_bitmapQ)+ - apply (wp threadGet_const_tcb_at_imp_lift | simp add: if_apply_def2)+ - apply clarsimp - apply (frule pred_tcb_at') - apply (frule (1) valid_objs'_maxDomain) - apply (frule (1) valid_objs'_maxPriority) - apply (clarsimp simp: valid_queues_def st_tcb_at'_def obj_at'_def valid_queues_no_bitmap_exceptI) - apply (fastforce dest!: valid_queues_no_bitmap_objD simp: obj_at'_def inQ_def could_run_def) - done -qed - -lemma tcbSchedEnqueue_valid_queues[wp]: - "\Invariants_H.valid_queues - and st_tcb_at' runnable' t - and valid_objs' \ - tcbSchedEnqueue t - \\_. Invariants_H.valid_queues\" - unfolding tcbSchedEnqueue_def - by (fastforce intro: tcbSchedEnqueueOrAppend_valid_queues) - -lemma tcbSchedAppend_valid_queues[wp]: - "\Invariants_H.valid_queues - and st_tcb_at' runnable' t - and valid_objs' \ - tcbSchedAppend t - \\_. Invariants_H.valid_queues\" - unfolding tcbSchedAppend_def - by (fastforce intro: tcbSchedEnqueueOrAppend_valid_queues) - -lemma rescheduleRequired_valid_queues[wp]: - "\\s. Invariants_H.valid_queues s \ valid_objs' s \ - weak_sch_act_wf (ksSchedulerAction s) s\ - rescheduleRequired - \\_. Invariants_H.valid_queues\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp)+ - apply (fastforce simp: weak_sch_act_wf_def elim: valid_objs'_maxDomain valid_objs'_maxPriority) - done - -lemma rescheduleRequired_valid_queues_sch_act_simple: - "\Invariants_H.valid_queues and sch_act_simple\ - rescheduleRequired - \\_. Invariants_H.valid_queues\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp | fastforce simp: Invariants_H.valid_queues_def sch_act_simple_def)+ - done - lemma rescheduleRequired_valid_bitmapQ_sch_act_simple: "\ valid_bitmapQ and sch_act_simple\ rescheduleRequired @@ -2862,151 +3936,32 @@ lemma rescheduleRequired_bitmapQ_no_L2_orphans_sch_act_simple: lemma sts_valid_bitmapQ_sch_act_simple: "\valid_bitmapQ and sch_act_simple\ - setThreadState st t + setThreadState st t \\_. valid_bitmapQ \" 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 Invariants_H.valid_queues_def inQ_def)+ + 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 \" + "\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 Invariants_H.valid_queues_def inQ_def)+ + 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 and sch_act_simple\ + setThreadState st t \\_. bitmapQ_no_L1_orphans \" 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 Invariants_H.valid_queues_def inQ_def)+ - done - -lemma sts_valid_queues: - "\\s. Invariants_H.valid_queues s \ - ((\p. t \ set(ksReadyQueues s p)) \ runnable' st)\ - setThreadState st t \\rv. Invariants_H.valid_queues\" - apply (simp add: setThreadState_def) - apply (wp rescheduleRequired_valid_queues_sch_act_simple - threadSet_valid_queues [THEN hoare_strengthen_post]) - apply (clarsimp simp: sch_act_simple_def Invariants_H.valid_queues_def inQ_def)+ - done - -lemma sbn_valid_queues: - "\\s. Invariants_H.valid_queues s\ - setBoundNotification ntfn t \\rv. Invariants_H.valid_queues\" - apply (simp add: setBoundNotification_def) - apply (wp threadSet_valid_queues [THEN hoare_strengthen_post]) - apply (clarsimp simp: sch_act_simple_def Invariants_H.valid_queues_def inQ_def)+ - done - - - -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]: - "\valid_queues' and st_tcb_at' runnable' t \ - tcbSchedEnqueue t - \\_. valid_queues'\" - apply (simp add: tcbSchedEnqueue_def) - apply (rule hoare_pre) - apply (rule_tac B="\rv. valid_queues' and obj_at' (\obj. tcbQueued obj = rv) t" - in hoare_seq_ext) - 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_def)+ - apply (clarsimp simp: obj_at'_def inQ_def projectKOs valid_queues'_def) - apply (wp getObject_tcb_wp | simp add: threadGet_def)+ - apply (clarsimp simp: obj_at'_def) - done - -lemma rescheduleRequired_valid_queues'_weak[wp]: - "\\s. valid_queues' s \ weak_sch_act_wf (ksSchedulerAction s) s\ - rescheduleRequired - \\_. valid_queues'\" - apply (simp add: rescheduleRequired_def) - apply wpsimp - apply (clarsimp simp: weak_sch_act_wf_def) - done - -lemma rescheduleRequired_valid_queues'_sch_act_simple: - "\valid_queues' and sch_act_simple\ - rescheduleRequired - \\_. valid_queues'\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp | fastforce simp: valid_queues'_def sch_act_simple_def)+ - done - -lemma setThreadState_valid_queues'[wp]: - "\\s. valid_queues' s\ setThreadState st t \\rv. valid_queues'\" - apply (simp add: setThreadState_def) - apply (wp rescheduleRequired_valid_queues'_sch_act_simple) - apply (rule_tac Q="\_. valid_queues'" in hoare_post_imp) - apply (clarsimp simp: sch_act_simple_def) - apply (wp threadSet_valid_queues') - apply (fastforce simp: inQ_def obj_at'_def pred_tcb_at'_def) - 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 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) - done - -lemma setThreadState_valid_objs'[wp]: - "\ valid_tcb_state' st and valid_objs' \ setThreadState st t \ \_. valid_objs' \" - apply (simp add: setThreadState_def) - apply (wp threadSet_valid_objs' | clarsimp simp: valid_tcb'_tcbState_update)+ - done - -lemma rescheduleRequired_ksQ: - "\\s. sch_act_simple s \ P (ksReadyQueues s p)\ - rescheduleRequired - \\_ s. P (ksReadyQueues s p)\" - including no_pre - apply (simp add: rescheduleRequired_def sch_act_simple_def) - apply (rule_tac B="\rv s. (rv = ResumeCurrentThread \ rv = ChooseNewThread) - \ P (ksReadyQueues s p)" in hoare_seq_ext) - apply wpsimp - apply (case_tac x; simp) - apply wp + apply (clarsimp simp: sch_act_simple_def inQ_def)+ done lemma setSchedulerAction_ksQ[wp]: @@ -3021,17 +3976,6 @@ lemma sbn_ksQ: "\\s. P (ksReadyQueues s p)\ setBoundNotification ntfn t \\rv s. P (ksReadyQueues s p)\" by (simp add: setBoundNotification_def, wp) -lemma sts_ksQ: - "\\s. sch_act_simple s \ P (ksReadyQueues s p)\ - setThreadState st t - \\_ s. P (ksReadyQueues s p)\" - apply (simp add: setThreadState_def) - apply (wp rescheduleRequired_ksQ) - apply (rule_tac Q="\_ s. P (ksReadyQueues s p)" in hoare_post_imp) - apply (clarsimp simp: sch_act_simple_def)+ - apply (wp, simp) - done - lemma setQueue_ksQ[wp]: "\\s. P ((ksReadyQueues s)((d, p) := q))\ setQueue d p q @@ -3039,22 +3983,6 @@ lemma setQueue_ksQ[wp]: by (simp add: setQueue_def fun_upd_def[symmetric] | wp)+ -lemma tcbSchedEnqueue_ksQ: - "\\s. t' \ set (ksReadyQueues s p) \ t' \ t \ - tcbSchedEnqueue t \\_ s. t' \ set (ksReadyQueues s p)\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wpsimp wp: hoare_vcg_imp_lift threadGet_wp) - apply (drule obj_at_ko_at') - apply fastforce - done - -lemma rescheduleRequired_ksQ': - "\\s. t \ set (ksReadyQueues s p) \ sch_act_not t s \ - rescheduleRequired \\_ s. t \ set (ksReadyQueues s p)\" - apply (simp add: rescheduleRequired_def) - apply (wpsimp wp: tcbSchedEnqueue_ksQ) - done - lemma threadSet_tcbState_st_tcb_at': "\\s. P st \ threadSet (tcbState_update (\_. st)) t \\_. st_tcb_at' P t\" apply (simp add: threadSet_def pred_tcb_at'_def) @@ -3065,36 +3993,6 @@ lemma isRunnable_const: "\st_tcb_at' runnable' t\ isRunnable t \\runnable _. runnable \" by (rule isRunnable_wp) -lemma sts_ksQ': - "\\s. (runnable' st \ ksCurThread s \ t) \ P (ksReadyQueues s p)\ - setThreadState st t - \\_ s. P (ksReadyQueues s p)\" - apply (simp add: setThreadState_def) - apply (rule hoare_pre_disj') - apply (rule hoare_seq_ext [OF _ - hoare_vcg_conj_lift - [OF threadSet_tcbState_st_tcb_at' [where P=runnable'] - threadSet_ksQ]]) - apply (rule hoare_seq_ext [OF _ - hoare_vcg_conj_lift [OF isRunnable_const isRunnable_inv]]) - apply (clarsimp simp: when_def) - apply (case_tac x) - apply (clarsimp, wp)[1] - apply (clarsimp) - apply (rule hoare_seq_ext [OF _ - hoare_vcg_conj_lift - [OF threadSet_ct threadSet_ksQ]]) - apply (rule hoare_seq_ext [OF _ isRunnable_inv]) - apply (rule hoare_seq_ext [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 valid_ipc_buffer_ptr'D: assumes yv: "y < unat max_ipc_words" and buf: "valid_ipc_buffer_ptr' a s" @@ -3212,14 +4110,16 @@ lemmas msgRegisters_unfold unfolded toEnum_def enum_register, simplified] lemma getMRs_corres: - "corres (=) (tcb_at t) - (tcb_at' t and case_option \ valid_ipc_buffer_ptr' buf) + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) + (case_option \ valid_ipc_buffer_ptr' buf) (get_mrs t buf mi) (getMRs t buf (message_info_map mi))" proof - have S: "get = gets id" by (simp add: gets_def) - have T: "corres (\con regs. regs = map con msg_registers) (tcb_at t) (tcb_at' t) - (thread_get (arch_tcb_get_registers o tcb_arch) t) (asUser t (mapM getRegister ARM_H.msgRegisters))" + have T: "corres (\con regs. regs = map con msg_registers) + (tcb_at t and pspace_aligned and pspace_distinct) \ + (thread_get (arch_tcb_get_registers o tcb_arch) t) + (asUser t (mapM getRegister ARM_H.msgRegisters))" unfolding arch_tcb_get_registers_def apply (subst thread_get_as_user) apply (rule asUser_corres') @@ -3303,8 +4203,8 @@ lemma storeWordUser_valid_ipc_buffer_ptr' [wp]: lemma setMRs_corres: assumes m: "mrs' = mrs" shows - "corres (=) (tcb_at t and case_option \ in_user_frame buf) - (tcb_at' t and case_option \ valid_ipc_buffer_ptr' buf) + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct and case_option \ in_user_frame buf) + (case_option \ valid_ipc_buffer_ptr' buf) (set_mrs t buf mrs) (setMRs t buf mrs')" proof - have setRegister_def2: "setRegister = (\r v. modify (\s. s ( r := v )))" @@ -3364,13 +4264,12 @@ proof - qed lemma copyMRs_corres: - "corres (=) (tcb_at s and tcb_at r + "corres (=) (tcb_at s and tcb_at r and pspace_aligned and pspace_distinct and case_option \ in_user_frame sb and case_option \ in_user_frame rb and K (unat n \ msg_max_length)) - (tcb_at' s and tcb_at' r - and case_option \ valid_ipc_buffer_ptr' sb - and case_option \ valid_ipc_buffer_ptr' rb) + (case_option \ valid_ipc_buffer_ptr' sb + and case_option \ valid_ipc_buffer_ptr' rb) (copy_mrs s sb r rb n) (copyMRs s sb r rb n)" proof - have U: "unat n \ msg_max_length \ @@ -3380,7 +4279,7 @@ proof - note R=R'[simplified] have as_user_bit: - "\v :: word32. corres dc (tcb_at s and tcb_at r) (tcb_at' s and tcb_at' r) + "\v :: word32. corres dc (tcb_at s and tcb_at r and pspace_aligned and pspace_distinct) \ (mapM (\ra. do v \ as_user s (getRegister ra); as_user r (setRegister ra v) @@ -3523,7 +4422,7 @@ qed lemmas valid_ipc_buffer_cap_simps = valid_ipc_buffer_cap_def [split_simps cap.split arch_cap.split] lemma lookupIPCBuffer_corres': - "corres (=) (tcb_at t and valid_objs and pspace_aligned) + "corres (=) (tcb_at t and valid_objs and pspace_aligned and pspace_distinct) (tcb_at' t and valid_objs' and pspace_aligned' and pspace_distinct' and no_0_obj') (lookup_ipc_buffer w t) (lookupIPCBuffer w t)" @@ -3635,7 +4534,7 @@ lemma ct_in_state'_set: crunches setQueue, rescheduleRequired, tcbSchedDequeue for idle'[wp]: "valid_idle'" - (simp: crunch_simps ) + (simp: crunch_simps wp: crunch_wps) lemma sts_valid_idle'[wp]: "\valid_idle' and valid_pspace' and @@ -3675,8 +4574,9 @@ lemma gbn_sp': lemma tcbSchedDequeue_tcbState_obj_at'[wp]: "\obj_at' (P \ tcbState) t'\ tcbSchedDequeue t \\rv. obj_at' (P \ tcbState) t'\" - apply (simp add: tcbSchedDequeue_def) - apply (wp | simp add: o_def split del: if_split cong: if_cong)+ + apply (simp add: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wpsimp wp: getObject_tcb_wp simp: o_def threadGet_def) + apply (clarsimp simp: obj_at'_def) done crunch typ_at'[wp]: setQueue "\s. P' (typ_at' P t s)" @@ -3695,10 +4595,14 @@ lemma setQueue_pred_tcb_at[wp]: lemma tcbSchedDequeue_pred_tcb_at'[wp]: "\\s. P' (pred_tcb_at' proj P t' s)\ tcbSchedDequeue t \\_ s. P' (pred_tcb_at' proj P t' s)\" apply (rule_tac P=P' in P_bool_lift) - apply (simp add: tcbSchedDequeue_def) - apply (wp threadSet_pred_tcb_no_state | clarsimp simp: tcb_to_itcb'_def)+ - apply (simp add: tcbSchedDequeue_def) - apply (wp threadSet_pred_tcb_no_state | clarsimp simp: tcb_to_itcb'_def)+ + apply (simp add: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wpsimp wp: threadSet_pred_tcb_no_state getObject_tcb_wp + simp: threadGet_def tcb_to_itcb'_def) + apply (clarsimp simp: obj_at'_def) + apply (simp add: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wpsimp wp: threadSet_pred_tcb_no_state getObject_tcb_wp + simp: threadGet_def tcb_to_itcb'_def) + apply (clarsimp simp: obj_at'_def) done lemma sts_st_tcb': @@ -3783,39 +4687,155 @@ crunch nonz_cap[wp]: addToBitmap "ex_nonz_cap_to' t" crunch iflive'[wp]: removeFromBitmap if_live_then_nonz_cap' crunch nonz_cap[wp]: removeFromBitmap "ex_nonz_cap_to' t" -lemma tcbSchedEnqueue_iflive'[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' tcb\ - tcbSchedEnqueue tcb \\_. if_live_then_nonz_cap'\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wp threadSet_iflive' hoare_drop_imps | simp add: crunch_simps)+ +crunches rescheduleRequired + for cap_to'[wp]: "ex_nonz_cap_to' p" + +lemma tcbQueued_update_tcb_cte_cases: + "(getF, setF) \ ran tcb_cte_cases \ getF (tcbQueued_update f tcb) = getF tcb" + unfolding tcb_cte_cases_def + by (case_tac tcb; fastforce simp: objBits_simps') + +lemma tcbSchedNext_update_tcb_cte_cases: + "(getF, setF) \ ran tcb_cte_cases \ getF (tcbSchedNext_update f tcb) = getF tcb" + unfolding tcb_cte_cases_def + by (case_tac tcb; fastforce simp: objBits_simps') + +lemma tcbSchedPrev_update_tcb_cte_cases: + "(getF, setF) \ ran tcb_cte_cases \ getF (tcbSchedPrev_update f tcb) = getF tcb" + unfolding tcb_cte_cases_def + by (case_tac tcb; fastforce simp: objBits_simps') + +lemma tcbSchedNext_update_ctes_of[wp]: + "threadSet (tcbSchedNext_update f) tptr \\s. P (ctes_of s)\" + by (wpsimp wp: threadSet_ctes_ofT simp: tcbSchedNext_update_tcb_cte_cases) + +lemma tcbSchedPrev_update_ctes_of[wp]: + "threadSet (tcbSchedPrev_update f) tptr \\s. P (ctes_of s)\" + by (wpsimp wp: threadSet_ctes_ofT simp: tcbSchedPrev_update_tcb_cte_cases) + +lemma tcbSchedNext_ex_nonz_cap_to'[wp]: + "threadSet (tcbSchedNext_update f) tptr \ex_nonz_cap_to' p\" + by (wpsimp wp: threadSet_cap_to simp: tcbSchedNext_update_tcb_cte_cases) + +lemma tcbSchedPrev_ex_nonz_cap_to'[wp]: + "threadSet (tcbSchedPrev_update f) tptr \ex_nonz_cap_to' p\" + by (wpsimp wp: threadSet_cap_to simp: tcbSchedPrev_update_tcb_cte_cases) + +lemma tcbSchedNext_update_iflive': + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' t s\ + threadSet (tcbSchedNext_update f) t + \\_. if_live_then_nonz_cap'\" + by (wpsimp wp: threadSet_iflive'T simp: tcbSchedNext_update_tcb_cte_cases) + +lemma tcbSchedPrev_update_iflive': + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' t s\ + threadSet (tcbSchedPrev_update f) t + \\_. if_live_then_nonz_cap'\" + by (wpsimp wp: threadSet_iflive'T simp: tcbSchedPrev_update_tcb_cte_cases) + +lemma tcbQueued_update_iflive'[wp]: + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' t s\ + threadSet (tcbQueued_update f) t + \\_. if_live_then_nonz_cap'\" + by (wpsimp wp: threadSet_iflive'T simp: tcbQueued_update_tcb_cte_cases) + +lemma getTCB_wp: + "\\s. \ko :: tcb. ko_at' ko p s \ Q ko s\ getObject p \Q\" + apply (wpsimp wp: getObject_tcb_wp) + apply (clarsimp simp: obj_at'_def) done -lemma rescheduleRequired_iflive'[wp]: - "\if_live_then_nonz_cap' - and (\s. \t. ksSchedulerAction s = SwitchToThread t - \ st_tcb_at' runnable' t s)\ - rescheduleRequired - \\rv. if_live_then_nonz_cap'\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp)+ - apply (clarsimp simp: pred_tcb_at'_def obj_at'_real_def) - apply (erule(1) if_live_then_nonz_capD') - apply (fastforce simp: projectKOs) +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]: + "tcbQueueRemove q tcbPtr \ex_nonz_cap_to' tcbPtr'\" + unfolding tcbQueueRemove_def + by (wpsimp wp: threadSet_cap_to' hoare_drop_imps getTCB_wp) + +(* We could write this one as "\t. tcbQueueHead t \ ..." instead, but we can't do the same in + tcbQueueAppend_if_live_then_nonz_cap', and it's nicer if the two lemmas are symmetric *) +lemma tcbQueuePrepend_if_live_then_nonz_cap': + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' tcbPtr s + \ (\ tcbQueueEmpty q \ ex_nonz_cap_to' (the (tcbQueueHead q)) s)\ + tcbQueuePrepend q tcbPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbQueuePrepend_def + by (wpsimp wp: tcbSchedPrev_update_iflive' tcbSchedNext_update_iflive' + hoare_vcg_if_lift2 hoare_vcg_imp_lift') + +lemma tcbQueueAppend_if_live_then_nonz_cap': + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' tcbPtr s + \ (\ tcbQueueEmpty q \ ex_nonz_cap_to' (the (tcbQueueEnd q)) s)\ + tcbQueueAppend q tcbPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbQueueAppend_def + by (wpsimp wp: tcbSchedPrev_update_iflive' tcbSchedNext_update_iflive') + +lemma tcbQueueInsert_if_live_then_nonz_cap': + "\if_live_then_nonz_cap' and ex_nonz_cap_to' tcbPtr and valid_objs' and sym_heap_sched_pointers\ + tcbQueueInsert tcbPtr afterPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbQueueInsert_def + apply (wpsimp wp: tcbSchedPrev_update_iflive' tcbSchedNext_update_iflive' getTCB_wp) + apply (intro conjI) + apply (erule if_live_then_nonz_capE') + apply (clarsimp simp: ko_wp_at'_def obj_at'_def projectKOs) + apply (erule if_live_then_nonz_capE') + apply (frule_tac p'=afterPtr in sym_heapD2) + apply (fastforce simp: opt_map_def obj_at'_def projectKOs) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (clarsimp simp: valid_tcb'_def ko_wp_at'_def obj_at'_def projectKOs opt_map_def) + done + +lemma tcbSchedEnqueue_iflive'[wp]: + "\if_live_then_nonz_cap' and pspace_aligned' and pspace_distinct'\ + tcbSchedEnqueue tcbPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbSchedEnqueue_def + apply (wpsimp wp: tcbQueuePrepend_if_live_then_nonz_cap' threadGet_wp) + apply normalise_obj_at' + apply (rename_tac tcb) + apply (frule_tac p=tcbPtr in if_live_then_nonz_capE') + apply (fastforce simp: ko_wp_at'_def obj_at'_def projectKOs) + apply clarsimp + apply (erule if_live_then_nonz_capE') + apply (clarsimp simp: ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (fastforce dest!: obj_at'_tcbQueueHead_ksReadyQueues + simp: ready_queue_relation_def ko_wp_at'_def inQ_def opt_pred_def opt_map_def + obj_at'_def projectKOs + split: option.splits) done +crunches rescheduleRequired + for iflive'[wp]: if_live_then_nonz_cap' + lemma sts_iflive'[wp]: "\\s. if_live_then_nonz_cap' s - \ (st \ Inactive \ \ idle' st \ ex_nonz_cap_to' t s)\ + \ (st \ Inactive \ \ idle' st \ ex_nonz_cap_to' t s) + \ pspace_aligned' s \ pspace_distinct' s\ setThreadState st t \\rv. if_live_then_nonz_cap'\" apply (simp add: setThreadState_def setQueue_def) - apply (rule hoare_pre) - apply (wp | simp)+ - apply (rule_tac Q="\rv. if_live_then_nonz_cap'" in hoare_post_imp) - apply clarsimp - apply (wp threadSet_iflive' | simp)+ - apply auto - done + 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 + done lemma sbn_iflive'[wp]: "\\s. if_live_then_nonz_cap' s @@ -3928,6 +4948,19 @@ lemma setBoundNotification_vms'[wp]: apply (intro hoare_vcg_all_lift hoare_vcg_disj_lift; wp) done +lemma threadSet_ct_not_inQ: + "(\tcb. tcbQueued tcb = tcbQueued (F tcb)) + \ threadSet F tcbPtr \\s. P (ct_not_inQ s)\" + unfolding threadSet_def + apply (wpsimp wp: getTCB_wp simp: setObject_def updateObject_default_def) + apply (erule rsubst[where P=P]) + by (fastforce simp: ct_not_inQ_def obj_at'_def projectKOs objBits_simps ps_clear_def + split: if_splits) + +crunches tcbQueuePrepend, tcbQueueAppend, tcbQueueInsert, tcbQueueRemove, addToBitmap + for ct_not_inQ[wp]: ct_not_inQ + (wp: threadSet_ct_not_inQ crunch_wps) + lemma tcbSchedEnqueue_ct_not_inQ: "\ct_not_inQ and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ tcbSchedEnqueue t \\_. ct_not_inQ\" @@ -3951,12 +4984,7 @@ lemma tcbSchedEnqueue_ct_not_inQ: done show ?thesis apply (simp add: tcbSchedEnqueue_def unless_def null_def) - apply (wp ts sq hoare_convert_imp [OF addToBitmap_nosch addToBitmap_ct'])+ - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, clarsimp) - apply (wp sq hoare_convert_imp [OF setQueue_nosch setQueue_ct])+ - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, clarsimp) - apply wp - apply assumption + apply (wpsimp wp: ts sq hoare_vcg_imp_lift' getTCB_wp simp: threadGet_def)+ done qed @@ -3983,12 +5011,7 @@ lemma tcbSchedAppend_ct_not_inQ: done show ?thesis apply (simp add: tcbSchedAppend_def unless_def null_def) - apply (wp ts sq hoare_convert_imp [OF addToBitmap_nosch addToBitmap_ct'])+ - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, clarsimp) - apply (wp sq hoare_convert_imp [OF setQueue_nosch setQueue_ct])+ - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, clarsimp) - apply wp - apply assumption + apply (wpsimp wp: ts sq hoare_vcg_imp_lift' getTCB_wp simp: threadGet_def)+ done qed @@ -4017,12 +5040,10 @@ lemma rescheduleRequired_sa_cnt[wp]: lemma possibleSwitchTo_ct_not_inQ: "\ct_not_inQ and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ possibleSwitchTo t \\_. ct_not_inQ\" - (is "\?PRE\ _ \_\") apply (simp add: possibleSwitchTo_def curDomain_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) + | (rule hoare_post_imp[OF _ rescheduleRequired_sa_cnt], fastforce))+ done lemma threadSet_tcbState_update_ct_not_inQ[wp]: @@ -4102,29 +5123,6 @@ lemma tcbSchedDequeue_ct_not_inQ[wp]: done qed -lemma tcbSchedEnqueue_not_st: - "(\tcb st qd. P (tcb\tcbState := st, tcbQueued := qd\) \ P tcb) - \ \obj_at' P t'\ tcbSchedEnqueue t \\_. obj_at' P t'\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wp threadGet_wp | simp)+ - apply (clarsimp simp: obj_at'_def) - apply (case_tac obja) - apply fastforce - done - -lemma setThreadState_not_st: - "(\tcb st qd. P (tcb\tcbState := st, tcbQueued := qd\) \ P tcb) - \ \obj_at' P t'\ setThreadState st t \\_. obj_at' P t'\" - apply (simp add: setThreadState_def rescheduleRequired_def) - apply (wp hoare_vcg_conj_lift tcbSchedEnqueue_not_st - | wpc - | rule hoare_drop_imps - | simp)+ - apply (clarsimp simp: obj_at'_def) - apply (case_tac obj) - apply fastforce - done - crunch ct_idle_or_in_cur_domain'[wp]: setQueue ct_idle_or_in_cur_domain' (simp: ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) @@ -4153,17 +5151,8 @@ lemma removeFromBitmap_ct_idle_or_in_cur_domain'[wp]: | clarsimp simp: updateObject_default_def in_monad setNotification_def)+ done -lemma tcbSchedEnqueue_ksCurDomain[wp]: - "\ \s. P (ksCurDomain s)\ tcbSchedEnqueue tptr \\_ s. P (ksCurDomain s)\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply wpsimp - done - -lemma tcbSchedEnqueue_ksDomSchedule[wp]: - "\ \s. P (ksDomSchedule s)\ tcbSchedEnqueue tptr \\_ s. P (ksDomSchedule s)\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply wpsimp - done +crunches tcbQueuePrepend + for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' lemma tcbSchedEnqueue_ct_idle_or_in_cur_domain'[wp]: "\ct_idle_or_in_cur_domain'\ tcbSchedEnqueue tptr \\_. ct_idle_or_in_cur_domain'\" @@ -4241,12 +5230,383 @@ lemma sts_utr[wp]: apply (wp untyped_ranges_zero_lift) done +lemma removeFromBitmap_bitmapQ: + "\\\ removeFromBitmap d p \\_ s. \ bitmapQ d p s \" + unfolding bitmapQ_defs bitmap_fun_defs + by (wpsimp simp: bitmap_fun_defs) + +lemma removeFromBitmap_valid_bitmapQ[wp]: + "\valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans + and (\s. tcbQueueEmpty (ksReadyQueues s (d,p)))\ + removeFromBitmap d p + \\_. valid_bitmapQ\" + (is "\?pre\ _ \_\") + apply (rule_tac Q="\_ s. ?pre s \ \ bitmapQ d p s" in hoare_strengthen_post) + apply (wpsimp wp: removeFromBitmap_valid_bitmapQ_except removeFromBitmap_bitmapQ) + apply (fastforce elim: valid_bitmap_valid_bitmapQ_exceptE) + done + +crunches tcbSchedDequeue + for bitmapQ_no_L1_orphans[wp]: bitmapQ_no_L1_orphans + and bitmapQ_no_L2_orphans[wp]: bitmapQ_no_L2_orphans + (wp: crunch_wps simp: crunch_simps) + +lemma setQueue_nonempty_valid_bitmapQ': + "\\s. valid_bitmapQ s \ \ tcbQueueEmpty (ksReadyQueues s (d, p))\ + setQueue d p queue + \\_ s. \ tcbQueueEmpty queue \ valid_bitmapQ s\" + apply (wpsimp simp: setQueue_def) + apply (fastforce simp: valid_bitmapQ_def bitmapQ_def) + done + +lemma threadSet_valid_bitmapQ_except[wp]: + "threadSet f tcbPtr \valid_bitmapQ_except d p\" + unfolding threadSet_def + apply (wpsimp wp: getTCB_wp simp: setObject_def updateObject_default_def) + apply (clarsimp simp: valid_bitmapQ_except_def bitmapQ_def) + done + +lemma threadSet_bitmapQ: + "threadSet F t \bitmapQ domain priority\" + unfolding threadSet_def + apply (wpsimp wp: getTCB_wp simp: setObject_def updateObject_default_def) + by (clarsimp simp: bitmapQ_def) + +crunches tcbQueueRemove, tcbQueuePrepend, tcbQueueAppend + for valid_bitmapQ_except[wp]: "valid_bitmapQ_except d p" + and valid_bitmapQ[wp]: valid_bitmapQ + and bitmapQ[wp]: "bitmapQ tdom prio" + (wp: crunch_wps) + +lemma tcbQueued_imp_queue_nonempty: + "\list_queue_relation ts (ksReadyQueues s (tcbDomain tcb, tcbPriority tcb)) nexts prevs; + \t. t \ set ts \ (inQ (tcbDomain tcb) (tcbPriority tcb) |< tcbs_of' s) t; + ko_at' tcb tcbPtr s; tcbQueued tcb\ + \ \ tcbQueueEmpty (ksReadyQueues s (tcbDomain tcb, tcbPriority tcb))" + apply (clarsimp simp: list_queue_relation_def tcbQueueEmpty_def) + apply (drule_tac x=tcbPtr in spec) + apply (fastforce dest: heap_path_head + simp: inQ_def opt_map_def opt_pred_def obj_at'_def projectKOs) + done + +lemma tcbSchedDequeue_valid_bitmapQ[wp]: + "\valid_bitmaps\ tcbSchedDequeue tcbPtr \\_. valid_bitmapQ\" + unfolding tcbSchedDequeue_def tcbQueueRemove_def + apply (wpsimp wp: setQueue_nonempty_valid_bitmapQ' hoare_vcg_conj_lift + hoare_vcg_if_lift2 hoare_vcg_const_imp_lift threadGet_wp + | wp (once) hoare_drop_imps)+ + by (fastforce dest!: tcbQueued_imp_queue_nonempty + simp: ready_queue_relation_def ksReadyQueues_asrt_def obj_at'_def) + +lemma tcbSchedDequeue_valid_bitmaps[wp]: + "tcbSchedDequeue tcbPtr \valid_bitmaps\" + by (wpsimp simp: valid_bitmaps_def) + +lemma setQueue_valid_bitmapQ': (* enqueue only *) + "\valid_bitmapQ_except d p and bitmapQ d p and K (\ tcbQueueEmpty q)\ + setQueue d p q + \\_. valid_bitmapQ\" + unfolding setQueue_def bitmapQ_defs + by (wpsimp simp: bitmapQ_def) + +lemma tcbSchedEnqueue_valid_bitmapQ[wp]: + "\valid_bitmaps\ tcbSchedEnqueue tcbPtr \\_. valid_bitmapQ\" + supply if_split[split del] + unfolding tcbSchedEnqueue_def + apply (wpsimp simp: tcbQueuePrepend_def + wp: setQueue_valid_bitmapQ' addToBitmap_valid_bitmapQ_except addToBitmap_bitmapQ + threadGet_wp) + apply (fastforce simp: valid_bitmaps_def valid_bitmapQ_def tcbQueueEmpty_def split: if_splits) + done + +crunches tcbSchedEnqueue, tcbSchedAppend + for bitmapQ_no_L1_orphans[wp]: bitmapQ_no_L1_orphans + and bitmapQ_no_L2_orphans[wp]: bitmapQ_no_L2_orphans + +lemma tcbSchedEnqueue_valid_bitmaps[wp]: + "tcbSchedEnqueue tcbPtr \valid_bitmaps\" + unfolding valid_bitmaps_def + apply wpsimp + apply (clarsimp simp: valid_bitmaps_def) + done + +crunches rescheduleRequired, threadSet, setThreadState + for valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift) + +lemma tcbSchedEnqueue_valid_sched_pointers[wp]: + "tcbSchedEnqueue tcbPtr \valid_sched_pointers\" + apply (clarsimp simp: tcbSchedEnqueue_def getQueue_def unless_def) + \ \we step forwards until we can step over the addToBitmap in order to avoid state blow-up\ + apply (intro hoare_seq_ext[OF _ stateAssert_sp] hoare_seq_ext[OF _ isRunnable_inv] + hoare_seq_ext[OF _ assert_sp] hoare_seq_ext[OF _ threadGet_sp] + hoare_seq_ext[OF _ gets_sp] + | rule hoare_when_cases, fastforce)+ + apply (forward_inv_step wp: hoare_vcg_ex_lift) + supply if_split[split del] + apply (wpsimp wp: getTCB_wp + simp: threadSet_def setObject_def updateObject_default_def tcbQueuePrepend_def + setQueue_def) + apply (clarsimp simp: valid_sched_pointers_def) + apply (intro conjI impI) + apply (fastforce simp: opt_pred_def opt_map_def split: if_splits) + apply normalise_obj_at' + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (clarsimp simp: valid_sched_pointers_def list_queue_relation_def) + apply (case_tac "ts = []", fastforce simp: tcbQueueEmpty_def) + by (intro conjI impI; + force dest!: hd_in_set heap_path_head + simp: inQ_def opt_pred_def opt_map_def obj_at'_def projectKOs split: if_splits) + +lemma tcbSchedAppend_valid_sched_pointers[wp]: + "tcbSchedAppend tcbPtr \valid_sched_pointers\" + apply (clarsimp simp: tcbSchedAppend_def getQueue_def unless_def) + \ \we step forwards until we can step over the addToBitmap in order to avoid state blow-up\ + apply (intro hoare_seq_ext[OF _ stateAssert_sp] hoare_seq_ext[OF _ isRunnable_inv] + hoare_seq_ext[OF _ assert_sp] hoare_seq_ext[OF _ threadGet_sp] + hoare_seq_ext[OF _ gets_sp] + | rule hoare_when_cases, fastforce)+ + apply (forward_inv_step wp: hoare_vcg_ex_lift) + supply if_split[split del] + apply (wpsimp wp: getTCB_wp + simp: threadSet_def setObject_def updateObject_default_def tcbQueueAppend_def + setQueue_def) + apply (clarsimp simp: valid_sched_pointers_def) + apply (intro conjI impI) + apply (fastforce simp: opt_pred_def opt_map_def split: if_splits) + apply normalise_obj_at' + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + by (intro conjI impI; + clarsimp dest: last_in_set + simp: valid_sched_pointers_def opt_map_def list_queue_relation_def tcbQueueEmpty_def + queue_end_valid_def inQ_def opt_pred_def obj_at'_def projectKOs + split: if_splits option.splits; + fastforce) + +lemma tcbSchedDequeue_valid_sched_pointers[wp]: + "\valid_sched_pointers and sym_heap_sched_pointers\ + tcbSchedDequeue tcbPtr + \\_. valid_sched_pointers\" + supply if_split[split del] fun_upd_apply[simp del] + apply (clarsimp simp: tcbSchedDequeue_def getQueue_def setQueue_def) + apply (wpsimp wp: threadSet_wp getTCB_wp threadGet_wp simp: tcbQueueRemove_def) + apply normalise_obj_at' + apply (rename_tac tcb) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (clarsimp split: if_splits) + apply (frule (1) list_queue_relation_neighbour_in_set[where p=tcbPtr]) + apply (fastforce simp: inQ_def opt_pred_def opt_map_def obj_at'_def projectKOs) + apply (clarsimp simp: list_queue_relation_def) + apply (intro conjI impI) + \ \the ready queue is the singleton consisting of tcbPtr\ + apply (clarsimp simp: valid_sched_pointers_def) + apply (case_tac "ptr = tcbPtr") + apply (force dest!: heap_ls_last_None + simp: prev_queue_head_def queue_end_valid_def inQ_def opt_map_def + obj_at'_def projectKOs) + apply (simp add: fun_upd_def opt_pred_def) + \ \tcbPtr is the head of the ready queue\ + subgoal + by (auto dest!: heap_ls_last_None + simp: valid_sched_pointers_def fun_upd_apply prev_queue_head_def + inQ_def opt_pred_def opt_map_def obj_at'_def projectKOs + split: if_splits option.splits) + \ \tcbPtr is the end of the ready queue\ + subgoal + by (auto dest!: heap_ls_last_None + simp: valid_sched_pointers_def queue_end_valid_def inQ_def opt_pred_def + opt_map_def fun_upd_apply obj_at'_def projectKOs + split: if_splits option.splits) + \ \tcbPtr is in the middle of the ready queue\ + apply (intro conjI impI allI) + by (clarsimp simp: valid_sched_pointers_def inQ_def opt_pred_def opt_map_def fun_upd_apply + obj_at'_def projectKOs + split: if_splits option.splits; + auto) + +lemma tcbQueueRemove_sym_heap_sched_pointers: + "\\s. sym_heap_sched_pointers s + \ (\ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ tcbPtr \ set ts)\ + tcbQueueRemove q tcbPtr + \\_. sym_heap_sched_pointers\" + supply heap_path_append[simp del] + apply (clarsimp simp: tcbQueueRemove_def) + apply (wpsimp wp: threadSet_wp getTCB_wp) + apply (rename_tac tcb ts) + + \ \tcbPtr is the head of q, which is not a singleton\ + apply (rule conjI) + apply clarsimp + apply (clarsimp simp: list_queue_relation_def Let_def) + apply (prop_tac "tcbSchedNext tcb \ Some tcbPtr") + apply (fastforce dest: heap_ls_no_loops[where p=tcbPtr] simp: opt_map_def obj_at'_def projectKOs) + apply (fastforce intro: sym_heap_remove_only' + simp: prev_queue_head_def opt_map_red opt_map_upd_triv obj_at'_def projectKOs) + + \ \tcbPtr is the end of q, which is not a singleton\ + apply (intro impI) + apply (rule conjI) + apply clarsimp + apply (prop_tac "tcbSchedPrev tcb \ Some tcbPtr") + apply (fastforce dest!: heap_ls_prev_no_loops[where p=tcbPtr] + simp: list_queue_relation_def opt_map_def obj_at'_def projectKOs) + apply (subst fun_upd_swap, fastforce) + apply (fastforce intro: sym_heap_remove_only + simp: opt_map_red opt_map_upd_triv obj_at'_def projectKOs) + + \ \tcbPtr is in the middle of q\ + apply (intro conjI impI allI) + apply (frule (2) list_queue_relation_neighbour_in_set[where p=tcbPtr]) + apply (frule split_list) + apply clarsimp + apply (rename_tac xs ys) + apply (prop_tac "xs \ [] \ ys \ []") + apply (fastforce simp: list_queue_relation_def queue_end_valid_def) + apply (clarsimp simp: list_queue_relation_def) + apply (frule (3) ptr_in_middle_prev_next) + apply (frule heap_ls_distinct) + apply (rename_tac afterPtr beforePtr xs ys) + apply (frule_tac before=beforePtr and middle=tcbPtr and after=afterPtr + in sym_heap_remove_middle_from_chain) + apply (fastforce dest: last_in_set simp: opt_map_def obj_at'_def projectKOs) + apply (fastforce dest: hd_in_set simp: opt_map_def obj_at'_def projectKOs) + apply (rule_tac hp="tcbSchedNexts_of s" in sym_heapD2) + apply fastforce + apply (fastforce simp: opt_map_def obj_at'_def projectKOs) + apply (fastforce simp: opt_map_def obj_at'_def projectKOs) + apply (fastforce simp: fun_upd_swap opt_map_red opt_map_upd_triv obj_at'_def projectKOs + split: if_splits) + done + +lemma tcbQueuePrepend_sym_heap_sched_pointers: + "\\s. sym_heap_sched_pointers s + \ (\ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ tcbPtr \ set ts) + \ tcbSchedNexts_of s tcbPtr = None \ tcbSchedPrevs_of s tcbPtr = None\ + tcbQueuePrepend q tcbPtr + \\_. sym_heap_sched_pointers\" + supply if_split[split del] + apply (clarsimp simp: tcbQueuePrepend_def) + apply (wpsimp wp: threadSet_wp) + apply (prop_tac "tcbPtr \ the (tcbQueueHead q)") + apply (case_tac "ts = []"; + fastforce dest: heap_path_head simp: list_queue_relation_def tcbQueueEmpty_def) + apply (drule_tac a=tcbPtr and b="the (tcbQueueHead q)" in sym_heap_connect) + apply assumption + apply (clarsimp simp: list_queue_relation_def prev_queue_head_def tcbQueueEmpty_def) + apply (fastforce simp: fun_upd_swap opt_map_red opt_map_upd_triv obj_at'_def projectKOs + tcbQueueEmpty_def) + done + +lemma tcbQueueInsert_sym_heap_sched_pointers: + "\\s. sym_heap_sched_pointers s + \ tcbSchedNexts_of s tcbPtr = None \ tcbSchedPrevs_of s tcbPtr = None\ + tcbQueueInsert tcbPtr afterPtr + \\_. sym_heap_sched_pointers\" + apply (clarsimp simp: tcbQueueInsert_def) + \ \forwards step in order to name beforePtr below\ + apply (rule hoare_seq_ext[OF _ getObject_tcb_sp]) + apply (rule hoare_seq_ext[OF _ assert_sp]) + apply (rule hoare_ex_pre_conj[simplified conj_commute], rename_tac beforePtr) + apply (rule hoare_seq_ext[OF _ assert_sp]) + apply (wpsimp wp: threadSet_wp) + apply normalise_obj_at' + apply (prop_tac "tcbPtr \ afterPtr") + apply (clarsimp simp: list_queue_relation_def opt_map_red obj_at'_def projectKOs) + apply (prop_tac "tcbPtr \ beforePtr") + apply (fastforce dest: sym_heap_None simp: opt_map_def obj_at'_def projectKOs + split: option.splits) + apply (prop_tac "tcbSchedNexts_of s beforePtr = Some afterPtr") + apply (fastforce intro: sym_heapD2 simp: opt_map_def obj_at'_def projectKOs) + apply (fastforce dest: sym_heap_insert_into_middle_of_chain + simp: fun_upd_swap opt_map_red opt_map_upd_triv obj_at'_def projectKOs) + done + +lemma tcbQueueAppend_sym_heap_sched_pointers: + "\\s. sym_heap_sched_pointers s + \ (\ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ tcbPtr \ set ts) + \ tcbSchedNexts_of s tcbPtr = None \ tcbSchedPrevs_of s tcbPtr = None\ + tcbQueueAppend q tcbPtr + \\_. sym_heap_sched_pointers\" + supply if_split[split del] + apply (clarsimp simp: tcbQueueAppend_def) + apply (wpsimp wp: threadSet_wp) + apply (clarsimp simp: tcbQueueEmpty_def list_queue_relation_def queue_end_valid_def + obj_at'_def projectKOs + split: if_splits) + apply fastforce + apply (drule_tac a="last ts" and b=tcbPtr in sym_heap_connect) + apply (fastforce dest: heap_ls_last_None) + apply assumption + apply (simp add: opt_map_red tcbQueueEmpty_def) + apply (subst fun_upd_swap, simp) + apply (fastforce simp: opt_map_red opt_map_upd_triv) + done + +lemma tcbQueued_update_sym_heap_sched_pointers[wp]: + "threadSet (tcbQueued_update f) tcbPtr \sym_heap_sched_pointers\" + by (rule sym_heap_sched_pointers_lift; + wpsimp wp: threadSet_tcbSchedPrevs_of threadSet_tcbSchedNexts_of) + +lemma tcbSchedEnqueue_sym_heap_sched_pointers[wp]: + "\sym_heap_sched_pointers and valid_sched_pointers\ + tcbSchedEnqueue tcbPtr + \\_. sym_heap_sched_pointers\" + unfolding tcbSchedEnqueue_def + apply (wpsimp wp: tcbQueuePrepend_sym_heap_sched_pointers threadGet_wp + simp: addToBitmap_def bitmap_fun_defs) + apply (normalise_obj_at', rename_tac tcb) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (fastforce dest!: spec[where x=tcbPtr] inQ_implies_tcbQueueds_of + simp: valid_sched_pointers_def opt_pred_def opt_map_def obj_at'_def projectKOs) + done + +lemma tcbSchedAppend_sym_heap_sched_pointers[wp]: + "\sym_heap_sched_pointers and valid_sched_pointers\ + tcbSchedAppend tcbPtr + \\_. sym_heap_sched_pointers\" + unfolding tcbSchedAppend_def + apply (wpsimp wp: tcbQueueAppend_sym_heap_sched_pointers threadGet_wp + simp: addToBitmap_def bitmap_fun_defs) + apply (normalise_obj_at', rename_tac tcb) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (fastforce dest!: spec[where x=tcbPtr] inQ_implies_tcbQueueds_of + simp: valid_sched_pointers_def opt_pred_def opt_map_def obj_at'_def projectKOs) + done + +lemma tcbSchedDequeue_sym_heap_sched_pointers[wp]: + "\sym_heap_sched_pointers and valid_sched_pointers\ + tcbSchedDequeue tcbPtr + \\_. sym_heap_sched_pointers\" + unfolding tcbSchedDequeue_def + apply (wpsimp wp: tcbQueueRemove_sym_heap_sched_pointers hoare_vcg_if_lift2 threadGet_wp + simp: bitmap_fun_defs) + apply (fastforce simp: ready_queue_relation_def ksReadyQueues_asrt_def inQ_def opt_pred_def + opt_map_def obj_at'_def projectKOs) + done + +crunches setThreadState + for valid_sched_pointers[wp]: valid_sched_pointers + and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + (simp: crunch_simps wp: crunch_wps threadSet_valid_sched_pointers threadSet_sched_pointers) + 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. (\p. t \ set(ksReadyQueues s p)) \ runnable' st) and (\s. runnable' st \ obj_at' tcbQueued t s \ st_tcb_at' runnable' t s) and sch_act_simple and invs'\ @@ -4255,21 +5615,21 @@ lemma sts_invs_minor': including no_pre apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) - apply (wp sts_valid_queues valid_irq_node_lift irqs_masked_lift - setThreadState_ct_not_inQ + apply (wp valid_irq_node_lift irqs_masked_lift + setThreadState_ct_not_inQ | simp add: cteCaps_of_def o_def)+ apply (clarsimp simp: sch_act_simple_def) apply (intro conjI) - apply clarsimp - defer - apply (clarsimp dest!: st_tcb_at_state_refs_ofD' - elim!: rsubst[where P=sym_refs] - intro!: ext) - apply (clarsimp elim!: st_tcb_ex_cap'') + apply clarsimp + defer + apply (clarsimp dest!: st_tcb_at_state_refs_ofD' + elim!: rsubst[where P=sym_refs] + intro!: ext) + apply (clarsimp elim!: st_tcb_ex_cap'') + apply fastforce + apply fastforce apply (frule tcb_in_valid_state', clarsimp+) - apply (cases st, simp_all add: valid_tcb_state'_def - split: Structures_H.thread_state.split_asm) - done + by (cases st; simp add: valid_tcb_state'_def split: Structures_H.thread_state.split_asm) lemma sts_cap_to'[wp]: "\ex_nonz_cap_to' p\ setThreadState st t \\rv. ex_nonz_cap_to' p\" @@ -4306,12 +5666,56 @@ lemma threadSet_ct_running': apply wp done +lemma tcbQueuePrepend_tcbPriority_obj_at'[wp]: + "tcbQueuePrepend queue tptr \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + unfolding tcbQueuePrepend_def + apply (wpsimp wp: threadSet_wp) + by (auto simp: obj_at'_def projectKOs objBits_simps ps_clear_def split: if_splits) + +lemma tcbQueuePrepend_tcbDomain_obj_at'[wp]: + "tcbQueuePrepend queue tptr \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding tcbQueuePrepend_def + apply (wpsimp wp: threadSet_wp) + by (auto simp: obj_at'_def projectKOs objBits_simps ps_clear_def split: if_splits) + +lemma tcbSchedDequeue_tcbPriority[wp]: + "tcbSchedDequeue t \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + unfolding tcbSchedDequeue_def tcbQueueRemove_def + by (wpsimp wp: hoare_when_weak_wp hoare_drop_imps) + +lemma tcbSchedDequeue_tcbDomain[wp]: + "tcbSchedDequeue t \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding tcbSchedDequeue_def tcbQueueRemove_def + by (wpsimp wp: hoare_when_weak_wp hoare_drop_imps) + +lemma tcbSchedEnqueue_tcbPriority_obj_at'[wp]: + "tcbSchedEnqueue tcbPtr \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + unfolding tcbSchedEnqueue_def setQueue_def + by wpsimp + +lemma tcbSchedEnqueue_tcbDomain_obj_at'[wp]: + "tcbSchedEnqueue tcbPtr \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding tcbSchedEnqueue_def setQueue_def + by wpsimp + +crunches rescheduleRequired + for tcbPriority_obj_at'[wp]: "obj_at' (\tcb. P (tcbPriority tcb)) t'" + and tcbDomain_obj_at'[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t'" + +lemma setThreadState_tcbPriority_obj_at'[wp]: + "setThreadState ts tptr \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + unfolding setThreadState_def + apply (wpsimp wp: threadSet_wp) + apply (fastforce simp: obj_at'_def projectKOs objBits_simps ps_clear_def) + done + lemma setThreadState_tcb_in_cur_domain'[wp]: "\tcb_in_cur_domain' t'\ setThreadState st t \\_. tcb_in_cur_domain' t'\" apply (simp add: tcb_in_cur_domain'_def) apply (rule hoare_pre) apply wps - apply (wp setThreadState_not_st | simp)+ + apply (simp add: setThreadState_def) + apply (wpsimp wp: threadSet_ct_idle_or_in_cur_domain' hoare_drop_imps)+ done lemma asUser_global_refs': "\valid_global_refs'\ asUser t f \\rv. valid_global_refs'\" @@ -4432,10 +5836,13 @@ 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) - (set_eobject ptr etcb) (setObject ptr tcb')" + 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 @@ -4456,20 +5863,34 @@ lemma set_eobject_corres': 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 cte_relation_def tcb_relation_def projectKOs split: if_split_asm)+ + 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 (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 (clarsimp simp: projectKOs) - apply (insert e) - apply (clarsimp simp: other_obj_relation_def etcb_relation_def is_other_obj_relation_type split: Structures_A.kernel_object.splits Structures_H.kernel_object.splits ARM_A.arch_kernel_obj.splits) + 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 lemma set_eobject_corres: @@ -4477,9 +5898,13 @@ lemma set_eobject_corres: 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) - (set_eobject add etcbu) (setObject add tcbu')" + 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) @@ -4506,24 +5931,27 @@ lemma set_eobject_corres: 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) - (ethread_set f t) (threadSet f' t)" + 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+ + 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 simp + apply (clarsimp simp: obj_at'_def) done lemmas ethread_set_corres = diff --git a/proof/refine/ARM/Tcb_R.thy b/proof/refine/ARM/Tcb_R.thy index 6e158808df..cf8ea5ac22 100644 --- a/proof/refine/ARM/Tcb_R.thy +++ b/proof/refine/ARM/Tcb_R.thy @@ -46,14 +46,14 @@ lemma activateThread_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) + 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 + apply (clarsimp simp: ct_in_state_def tcb_at_invs invs_distinct invs_psp_aligned elim!: st_tcb_weakenE) apply (clarsimp simp: tcb_at_invs' ct_in_state'_def elim!: pred_tcb'_weakenE) @@ -197,13 +197,13 @@ lemma setupReplyMaster_weak_sch_act_wf[wp]: apply assumption done -crunches setupReplyMaster - for valid_queues[wp]: "Invariants_H.valid_queues" - and valid_queues'[wp]: "valid_queues'" +crunches 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) (invs' and tcb_at' t) + "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) @@ -212,20 +212,22 @@ lemma restart_corres: 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]) - apply clarsimp + 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_valid_queues sts_st_tcb' - | clarsimp simp: valid_tcb_state'_def)+ - apply (rule_tac Q="\rv. valid_sched and cur_tcb" in hoare_strengthen_post) - apply wp - apply (simp add: valid_sched_def valid_sched_action_def) - apply (rule_tac Q="\rv. invs' and tcb_at' t" in hoare_strengthen_post) - apply wp - apply (clarsimp simp: invs'_def valid_state'_def sch_act_wf_weak valid_pspace'_def) - apply wp+ - apply (simp add: valid_sched_def invs_def tcb_at_is_etcb_at) - apply (clarsimp simp add: invs'_def valid_state'_def sch_act_wf_weak) + 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 lemma restart_invs': @@ -309,12 +311,6 @@ lemma invokeTCB_ReadRegisters_corres: crunch sch_act_simple [wp]: asUser "sch_act_simple" (rule: sch_act_simple_lift) -lemma invs_valid_queues': - "invs' s \ valid_queues' s" - by (clarsimp simp:invs'_def valid_state'_def) - -declare invs_valid_queues'[rule_format, elim!] - lemma einvs_valid_etcbs: "einvs s \ valid_etcbs s" by (clarsimp simp: valid_sched_def) @@ -327,6 +323,11 @@ lemma asUser_postModifyRegisters_corres: apply (rule corres_stateAssert_assume) by simp+ +crunches restart + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + (simp: crunch_simps wp: crunch_wps threadSet_sched_pointers threadSet_valid_sched_pointers) + lemma invokeTCB_WriteRegisters_corres: "corres (dc \ (=)) (einvs and tcb_at dest and ex_nonz_cap_to dest) (invs' and sch_act_simple and tcb_at' dest and ex_nonz_cap_to' dest) @@ -349,10 +350,12 @@ lemma invokeTCB_WriteRegisters_corres: apply simp apply (wp+)[2] apply ((wp hoare_weak_lift_imp restart_invs' - | strengthen valid_sched_weak_strg einvs_valid_etcbs - invs_valid_queues' invs_queues invs_weak_sch_act_wf - | 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] + | 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 @@ -383,6 +386,10 @@ lemma suspend_ResumeCurrentThread_imp_notct[wp]: \\rv s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" by (wpsimp simp: suspend_def) +crunches restart, suspend + for cur_tcb'[wp]: cur_tcb' + (wp: crunch_wps threadSet_cur ignore: threadSet) + 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 @@ -411,6 +418,7 @@ proof - apply simp apply simp apply (simp | wp)+ + apply fastforce+ done have R: "\src src' des des' xs ys. \ src = src'; des = des'; xs = ys \ \ corres dc (tcb_at src and tcb_at des and invs) @@ -433,7 +441,7 @@ proof - apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) apply (rule asUser_setNextPC_corres) apply wp+ - apply simp+ + apply fastforce+ done show ?thesis apply (simp add: invokeTCB_def performTransfer_def) @@ -457,21 +465,18 @@ proof - apply (rule corres_split[OF corres_when[OF refl rescheduleRequired_corres]]) apply (rule_tac P=\ and P'=\ in corres_inst) apply simp - apply ((wp hoare_weak_lift_imp)+)[6] - 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) + apply (solves \wp hoare_weak_lift_imp\)+ + 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_state'_def invs_weak_sch_act_wf) - apply ((wp mapM_x_wp' hoare_weak_lift_imp | simp)+)[2] - apply ((wp mapM_x_wp' hoare_weak_lift_imp | simp)+)[1] - apply (wp mapM_x_wp' hoare_weak_lift_imp | simp)+ - apply ((wp mapM_x_wp' hoare_weak_lift_imp restart_invs' | wpc | clarsimp simp add: if_apply_def2)+)[2] + 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 valid_state'_def dest!: global'_no_ex_cap) - done + dest!: idle_no_ex_cap) + by (fastforce simp: invs'_def valid_state'_def dest!: global'_no_ex_cap) qed lemma readreg_invs': @@ -517,41 +522,10 @@ lemma copyreg_invs': \\rv. invs'\" by (rule hoare_strengthen_post, rule copyreg_invs'', simp) -lemma threadSet_valid_queues_no_state: - "\Invariants_H.valid_queues and (\s. \p. t \ set (ksReadyQueues s p))\ - threadSet f t \\_. Invariants_H.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 setObject_queues_unchanged_tcb - 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 isRunnable_corres: - "corres (\ts runn. runnable ts = runn) (tcb_at t) (tcb_at' t) - (get_thread_state t) (isRunnable t)" + "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) @@ -572,16 +546,6 @@ lemma tcbSchedDequeue_not_queued: apply (wp tg_sp' [where P=\, simplified] | simp)+ done -lemma tcbSchedDequeue_not_in_queue: - "\p. \Invariants_H.valid_queues and tcb_at' t and valid_objs'\ tcbSchedDequeue t - \\rv s. t \ set (ksReadyQueues s p)\" - apply (rule_tac Q="\rv. Invariants_H.valid_queues and obj_at' (Not \ tcbQueued) t" - in hoare_post_imp) - apply (fastforce simp: valid_queues_def valid_queues_no_bitmap_def obj_at'_def projectKOs inQ_def ) - apply (wp tcbSchedDequeue_not_queued tcbSchedDequeue_valid_queues | - simp add: valid_objs'_maxDomain valid_objs'_maxPriority)+ - done - lemma threadSet_ct_in_state': "(\tcb. tcbState (f tcb) = tcbState tcb) \ \ct_in_state' test\ threadSet f t \\rv. ct_in_state' test\" @@ -625,14 +589,19 @@ lemma threadSet_valid_objs_tcbPriority_update: crunch cur[wp]: tcbSchedDequeue cur_tcb' +crunches tcbSchedDequeue + for st_tcb_at'[wp]: "\s. P (st_tcb_at' st tcbPtr s)" + lemma sp_corres2: - "corres dc (valid_etcbs and weak_valid_sched_action and cur_tcb) - (Invariants_H.valid_queues and valid_queues' and cur_tcb' and tcb_at' t - and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_objs' and (\_. x \ maxPriority)) - (set_priority t x) (setPriority t x)" + "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]) + 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]) @@ -644,37 +613,42 @@ lemma sp_corres2: 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) - apply clarsimp - apply ((wp hoare_drop_imps hoare_vcg_if_lift hoare_vcg_all_lift - isRunnable_wp threadSet_pred_tcb_no_state threadSet_valid_queues_no_state - threadSet_valid_queues'_no_state threadSet_cur threadSet_valid_objs_tcbPriority_update - threadSet_weak_sch_act_wf threadSet_ct_in_state'[simplified ct_in_state'_def] - | simp add: etcb_relation_def)+)[1] - apply ((wp hoare_vcg_imp_lift' hoare_vcg_if_lift hoare_vcg_all_lift hoare_vcg_disj_lift - tcbSchedDequeue_not_in_queue tcbSchedDequeue_valid_queues - tcbSchedDequeue_ct_in_state'[simplified ct_in_state'_def] - | simp add: etcb_relation_def)+)[2] + 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 (force simp: state_relation_def elim: valid_objs'_maxDomain valid_objs'_maxPriority) + apply clarsimp done -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)" +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 (clarsimp simp: valid_sched_def valid_sched_action_def) + 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 x) (setMCPriority t x)" +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 exst_same_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' \ @@ -686,17 +660,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) - (tcb_at' t) + 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 - apply (clarsimp simp add: threadset_corresT [OF _ x y e]) + 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] @@ -705,109 +680,40 @@ lemma tcbSchedDequeue_sch_act_simple[wp]: "tcbSchedDequeue t \sch_act_simple\" by (wpsimp simp: sch_act_simple_def) -lemma setP_vq[wp]: - "\\s. Invariants_H.valid_queues s \ tcb_at' t s \ sch_act_wf (ksSchedulerAction s) s \ valid_objs' s \ p \ maxPriority\ - setPriority t p - \\rv. Invariants_H.valid_queues\" - apply (simp add: setPriority_def) - apply (wpsimp ) - apply (wp hoare_vcg_imp_lift') - unfolding st_tcb_at'_def - apply (strengthen not_obj_at'_strengthen) - apply (wp hoare_wp_combs) - apply (wp hoare_vcg_imp_lift') - apply (wp threadSet_valid_queues threadSet_valid_objs_tcbPriority_update) - apply(wp threadSet_weak_sch_act_wf) - apply clarsimp - apply clarsimp - apply (wp hoare_vcg_imp_lift') - apply (wp threadSet_valid_queues threadSet_valid_objs_tcbPriority_update threadSet_sch_act, clarsimp) - apply (wp add: threadSet_valid_queues comb:hoare_drop_imps ) - apply (clarsimp simp: eq_commute[where a=t]) - apply (wp add: threadSet_valid_queues threadSet_valid_objs_tcbPriority_update threadSet_weak_sch_act_wf - hoare_vcg_imp_lift'[where P="\_ s. ksCurThread s \ _"] hoare_drop_imps hoare_vcg_all_lift - tcbSchedDequeue_not_in_queue tcbSchedEnqueue_valid_objs' tcbSchedDequeue_valid_queues - | clarsimp simp: valid_objs'_maxDomain valid_objs'_maxPriority)+ - done - -lemma valid_queues_subsetE': - "\ valid_queues' s; ksPSpace s = ksPSpace s'; - \x. set (ksReadyQueues s x) \ set (ksReadyQueues s' x) \ - \ valid_queues' s'" - by (simp add: valid_queues'_def obj_at'_def - ps_clear_def subset_iff projectKOs) - -crunch vq'[wp]: getCurThread valid_queues' - -lemma setP_vq'[wp]: - "\\s. valid_queues' s \ tcb_at' t s \ sch_act_wf (ksSchedulerAction s) s \ p \ maxPriority\ - setPriority t p - \\rv. valid_queues'\" - apply (simp add: setPriority_def) - apply (wpsimp wp: threadSet_valid_queues' hoare_drop_imps - threadSet_weak_sch_act_wf threadSet_sch_act) - apply (rule_tac Q="\_ s. valid_queues' s \ obj_at' (Not \ tcbQueued) t s \ sch_act_wf (ksSchedulerAction s) s - \ weak_sch_act_wf (ksSchedulerAction s) s" in hoare_strengthen_post, - wp tcbSchedDequeue_valid_queues' tcbSchedDequeue_not_queued) - apply (clarsimp simp: inQ_def) - apply normalise_obj_at' - apply clarsimp - done - -lemma setQueue_invs_bits[wp]: - "\valid_pspace'\ setQueue d p q \\rv. valid_pspace'\" - "\\s. sch_act_wf (ksSchedulerAction s) s\ setQueue d p q \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\\s. sym_refs (state_refs_of' s)\ setQueue d p q \\rv s. sym_refs (state_refs_of' s)\" - "\if_live_then_nonz_cap'\ setQueue d p q \\rv. if_live_then_nonz_cap'\" - "\if_unsafe_then_cap'\ setQueue d p q \\rv. if_unsafe_then_cap'\" - "\cur_tcb'\ setQueue d p q \\rv. cur_tcb'\" - "\valid_global_refs'\ setQueue d p q \\rv. valid_global_refs'\" - "\valid_irq_handlers'\ setQueue d p q \\rv. valid_irq_handlers'\" - by (simp add: setQueue_def tcb_in_cur_domain'_def - | wp sch_act_wf_lift cur_tcb_lift - | fastforce)+ - -lemma setQueue_ex_idle_cap[wp]: - "\\s. ex_nonz_cap_to' (ksIdleThread s) s\ - setQueue d p q - \\rv s. ex_nonz_cap_to' (ksIdleThread s) s\" - by (simp add: setQueue_def, wp, - simp add: ex_nonz_cap_to'_def cte_wp_at_pspaceI) - -lemma tcbPriority_caps_safe: - "\tcb. \x\ran tcb_cte_cases. (\(getF, setF). getF (tcbPriority_update f tcb) = getF tcb) x" - by (rule all_tcbI, rule ball_tcb_cte_casesI, simp+) +lemma tcbSchedNext_update_tcb_cte_cases: + "(a, b) \ ran tcb_cte_cases \ a (tcbPriority_update f tcb) = a tcb" + unfolding tcb_cte_cases_def + by (case_tac tcb; fastforce simp: objBits_simps') -lemma tcbPriority_Queued_caps_safe: - "\tcb. \x\ran tcb_cte_cases. (\(getF, setF). getF (tcbPriority_update f (tcbQueued_update g tcb)) = getF tcb) x" - by (rule all_tcbI, rule ball_tcb_cte_casesI, simp+) +lemma threadSet_priority_invs': + "\invs' and tcb_at' t and K (p \ maxPriority)\ + threadSet (tcbPriority_update (\_. p)) t + \\_. invs'\" + apply (rule hoare_gen_asm) + apply (simp add: invs'_def valid_state'_def split del: if_split) + apply (wp threadSet_valid_pspace' + threadSet_sch_actT_P[where P=False, simplified] + threadSet_state_refs_of'T[where f'=id] + threadSet_iflive'T + threadSet_ifunsafe'T + threadSet_idle'T + valid_irq_node_lift + valid_irq_handlers_lift'' + threadSet_ctes_ofT + threadSet_not_inQ + threadSet_ct_idle_or_in_cur_domain' + threadSet_cur + untyped_ranges_zero_lift + sym_heap_sched_pointers_lift threadSet_valid_sched_pointers + threadSet_tcbSchedPrevs_of threadSet_tcbSchedNexts_of + | clarsimp simp: cteCaps_of_def tcbSchedNext_update_tcb_cte_cases | rule refl)+ + apply (clarsimp simp: o_def) + by (auto simp: obj_at'_def) lemma setP_invs': "\invs' and tcb_at' t and K (p \ maxPriority)\ setPriority t p \\rv. invs'\" - apply (rule hoare_gen_asm) - apply (simp add: setPriority_def) - apply (wp rescheduleRequired_all_invs_but_ct_not_inQ) - apply simp - apply (wp hoare_vcg_conj_lift hoare_vcg_imp_lift') - unfolding st_tcb_at'_def - apply (strengthen not_obj_at'_strengthen, wp) - apply (wp hoare_vcg_imp_lift') - apply (rule_tac Q="\rv s. invs' s" in hoare_post_imp) - apply (clarsimp simp: invs_sch_act_wf' invs'_def invs_queues) - apply (clarsimp simp: valid_state'_def) - apply (wp hoare_drop_imps threadSet_invs_trivial, - simp_all add: inQ_def cong: conj_cong)[1] - apply (wp hoare_drop_imps threadSet_invs_trivial, - simp_all add: inQ_def cong: conj_cong)[1] - apply (wp hoare_drop_imps threadSet_invs_trivial, - simp_all add: inQ_def cong: conj_cong)[1] - apply (rule_tac Q="\_. invs' and obj_at' (Not \ tcbQueued) t - and (\s. \d p. t \ set (ksReadyQueues s (d,p)))" - in hoare_post_imp) - apply (clarsimp simp: obj_at'_def inQ_def) - apply (wp tcbSchedDequeue_not_queued)+ - apply clarsimp - done + unfolding setPriority_def + by (wpsimp wp: rescheduleRequired_invs' threadSet_priority_invs') crunches setPriority, setMCPriority for typ_at'[wp]: "\s. P (typ_at' T p s)" @@ -1109,11 +1015,6 @@ lemma setMCPriority_valid_objs'[wp]: crunch sch_act_simple[wp]: setMCPriority sch_act_simple (wp: ssa_sch_act_simple crunch_wps rule: sch_act_simple_lift simp: crunch_simps) -(* For some reason, when this was embedded in a larger expression clarsimp wouldn't remove it. Adding it as a simp rule does *) -lemma inQ_tc_corres_helper: - "(\d p. (\tcb. tcbQueued tcb \ tcbPriority tcb = p \ tcbDomain tcb = d \ (tcbQueued tcb \ tcbDomain tcb \ d)) \ a \ set (ksReadyQueues s (d, p))) = True" - by clarsimp - abbreviation "valid_option_prio \ case_option True (\(p, auth). p \ maxPriority)" definition valid_tcb_invocation :: "tcbinvocation \ bool" where @@ -1137,108 +1038,87 @@ lemma threadcontrol_corres_helper1: apply (clarsimp simp: is_tcb_def) done -lemma threadcontrol_corres_helper2: - "is_aligned a msg_align_bits \ \invs' and tcb_at' t\ - threadSet (tcbIPCBuffer_update (\_. a)) t - \\x s. Invariants_H.valid_queues s \ valid_queues' s \ weak_sch_act_wf (ksSchedulerAction s) s\" - by (wp threadSet_invs_trivial - | strengthen invs_valid_queues' invs_queues invs_weak_sch_act_wf - | clarsimp simp: inQ_def )+ - -lemma threadcontrol_corres_helper3: +lemma thread_set_ipc_weak_valid_sched_action: "\ 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))) - \\x. weak_valid_sched_action and valid_etcbs \" + thread_set (tcb_ipc_buffer_update f) a + \\x. weak_valid_sched_action\" apply (rule hoare_pre) - apply (wp check_cap_inv | simp add:)+ - by (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 (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 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 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))))) - \\x. Invariants_H.valid_queues and valid_queues' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\" - apply (wp - | strengthen invs_valid_queues' invs_queues invs_weak_sch_act_wf - | clarsimp simp: )+ + \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))))) + \\_ 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 isArchObjectCap_def isNotificationCap_def isEndpointCap_def - isReplyCap_def isIRQControlCap_def tcb_cnode_index_def cte_map_def cte_wp_at'_def + 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 \ tcbDomain (F tcb) = tcbDomain tcb" - assumes a: "\tcb. tcbBoundNotification (F tcb) = tcbBoundNotification 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. \ tcbQueued tcb \ tcbQueued (F tcb)) \ ex_nonz_cap_to' t s \ t \ ksCurThread s) - \ (\tcb. tcbQueued (F tcb) \ ksSchedulerAction s = ResumeCurrentThread \ tcbQueued tcb \ t \ ksCurThread s)\ - threadSet F t - \\rv. invs'\" -proof - - from z have domains: "\tcb. tcbDomain (F tcb) = tcbDomain tcb" by blast - note threadSet_sch_actT_P[where P=False, simplified] - have y: "\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 valid_state'_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_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_cur - untyped_ranges_zero_lift - |clarsimp simp: y z a domains cteCaps_of_def |rule refl)+ - apply (clarsimp simp: obj_at'_def projectKOs pred_tcb_at'_def) - apply (clarsimp simp: cur_tcb'_def valid_irq_node'_def valid_queues'_def o_def) - by (fastforce simp: domains ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def z a) -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\" @@ -1269,6 +1149,12 @@ 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'" @@ -1311,8 +1197,8 @@ lemma transferCaps_corres: (invokeTCB (tcbinvocation.ThreadControl a sl' b' mcp_auth p_auth e' f' g'))" proof - have P: "\t v. corres dc - (tcb_at t) - (tcb_at' t) + (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 () @@ -1322,8 +1208,8 @@ proof - apply (safe, case_tac tcb', simp add: tcb_relation_def split: option.split) done have R: "\t v. corres dc - (tcb_at t) - (tcb_at' t) + (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)" @@ -1336,7 +1222,9 @@ proof - (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) (tcb_at' t) + 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) @@ -1460,23 +1348,33 @@ proof - apply (rule corres_split[OF getCurThread_corres], clarsimp) apply (rule corres_when[OF refl rescheduleRequired_corres]) apply (wpsimp wp: gct_wp)+ - apply (wp hoare_drop_imp) - apply (rule threadcontrol_corres_helper1[unfolded pred_conj_def]) - apply simp - apply (wp hoare_drop_imp) - apply (wp threadcontrol_corres_helper2 | wpc | simp)+ + 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="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_nor) + 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]) @@ -1485,22 +1383,21 @@ proof - 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)+ + | 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 - | clarsimp simp: inQ_def inQ_tc_corres_helper)+ + | 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 (clarsimp simp: emptyable_def) + 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 (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))" @@ -1567,40 +1464,25 @@ proof - apply wp apply wp apply (wpsimp wp: hoare_vcg_const_imp_lift_R hoare_vcg_const_imp_lift - hoare_vcg_all_lift_R hoare_vcg_all_lift as_user_invs cap_delete_deletes - thread_set_ipc_tcb_cap_valid thread_set_tcb_ipc_buffer_cap_cleared_invs - thread_set_cte_wp_at_trivial thread_set_valid_cap cap_delete_valid_cap - reschedule_preserves_valid_sched thread_set_not_state_valid_sched + hoare_vcg_all_lift_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] - simp: ran_tcb_cap_cases) + 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_drop_imps) - apply ((wpsimp wp: hoare_vcg_const_imp_lift hoare_vcg_imp_lift' hoare_vcg_all_lift - threadSet_cte_wp_at' threadSet_invs_trivialT2 cteDelete_invs' - simp: tcb_cte_cases_def), (fastforce+)[6]) - apply wpsimp - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - threadSet_invs_trivialT2 threadSet_cte_wp_at' - simp: tcb_cte_cases_def, (fastforce+)[6]) - apply wpsimp - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - rescheduleRequired_invs' threadSet_cte_wp_at' - simp: tcb_cte_cases_def) - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - rescheduleRequired_invs' threadSet_invs_trivialT2 threadSet_cte_wp_at' - simp: tcb_cte_cases_def, (fastforce+)[6]) - apply wpsimp - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - rescheduleRequired_invs' threadSet_invs_trivialT2 threadSet_cte_wp_at' - simp: tcb_cte_cases_def, (fastforce+)[6]) - apply wpsimp - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - rescheduleRequired_invs' threadSet_cap_to' threadSet_invs_trivialT2 - threadSet_cte_wp_at' hoare_drop_imps - simp: tcb_cte_cases_def) - apply (clarsimp) + 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_lift_R hoare_vcg_all_lift hoare_vcg_const_imp_lift_R hoare_vcg_const_imp_lift threadSet_valid_objs' thread_set_not_state_valid_sched @@ -1613,9 +1495,9 @@ proof - | strengthen tcb_cap_always_valid_strg tcb_at_invs use_no_cap_to_obj_asid_strg - | (erule exE, clarsimp simp: word_bits_def))+) + | (erule exE, clarsimp simp: word_bits_def) | wp (once) hoare_drop_imps)+) apply (strengthen valid_tcb_ipc_buffer_update) - apply (strengthen invs_valid_objs')+ + 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 @@ -1647,7 +1529,7 @@ proof - | 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 + 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 *) @@ -1659,7 +1541,7 @@ proof - 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 arch_cap_fun_lift_def + isCap_simps domIff valid_tcb'_def tcb_cte_cases_def split: option.split_asm dest!: isValidVTableRootD) qed @@ -1739,7 +1621,7 @@ lemma setSchedulerAction_invs'[wp]: apply (simp add: setSchedulerAction_def) apply wp apply (clarsimp simp add: invs'_def valid_state'_def valid_irq_node'_def - valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs cur_tcb'_def + valid_queues_def bitmapQ_defs cur_tcb'_def ct_not_inQ_def) apply (simp add: ct_idle_or_in_cur_domain'_def) done @@ -1869,8 +1751,8 @@ lemma invokeTCB_corres: apply (rule TcbAcc_R.rescheduleRequired_corres) apply (rule corres_trivial, simp) apply (wpsimp wp: hoare_drop_imp)+ - apply (clarsimp simp: valid_sched_weak_strg einvs_valid_etcbs) - apply (clarsimp simp: Tcb_R.invs_valid_queues' Invariants_H.invs_queues) + apply (fastforce dest: valid_sched_valid_queues simp: valid_sched_weak_strg einvs_valid_etcbs) + apply fastforce done lemma tcbBoundNotification_caps_safe[simp]: @@ -1885,6 +1767,10 @@ lemma valid_bound_ntfn_lift: apply (wp typ_at_lifts[OF P])+ done +crunches 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 @@ -1897,7 +1783,7 @@ lemma bindNotification_invs': apply (simp add: bindNotification_def invs'_def valid_state'_def) apply (rule hoare_seq_ext[OF _ get_ntfn_sp']) apply (rule hoare_pre) - apply (wp set_ntfn_valid_pspace' sbn_sch_act' sbn_valid_queues valid_irq_node_lift + 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)+ @@ -2068,7 +1954,7 @@ lemma eq_ucast_word8[simp]: done lemma checkPrio_corres: - "corres (ser \ dc) (tcb_at auth) (tcb_at' auth) + "corres (ser \ dc) (tcb_at auth and pspace_aligned and pspace_distinct) \ (check_prio p auth) (checkPrio p auth)" apply (simp add: check_prio_def checkPrio_def) apply (rule corres_guard_imp) @@ -2091,7 +1977,7 @@ 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 valid_etcbs 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')" @@ -2103,14 +1989,13 @@ lemma decodeSetPriority_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 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; list_all2 (\(c, sl) (c', sl'). cap_relation c c' \ sl' = cte_map sl) extras extras' \ \ corres (ser \ tcbinv_relation) - (cur_tcb and valid_etcbs 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_mcpriority args cap slot extras) (decodeSetMCPriority args cap' extras')" @@ -2122,8 +2007,7 @@ lemma decodeSetMCPriority_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 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\" @@ -2218,7 +2102,8 @@ lemma decodeSetSchedParams_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 valid_etcbs 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_sched_params args cap slot extras) (decodeSetSchedParams args cap' extras')" @@ -2632,8 +2517,8 @@ notes if_cong[cong] shows lemma decodeUnbindNotification_corres: "corres (ser \ tcbinv_relation) - (tcb_at t) - (tcb_at' t) + (tcb_at t and pspace_aligned and pspace_distinct) + \ (decode_unbind_notification (cap.ThreadCap t)) (decodeUnbindNotification (capability.ThreadCap t))" apply (simp add: decode_unbind_notification_def decodeUnbindNotification_def) @@ -2683,7 +2568,8 @@ lemma decodeTCBInvocation_corres: corres_guard_imp[OF decodeBindNotification_corres] corres_guard_imp[OF decodeUnbindNotification_corres] corres_guard_imp[OF decodeSetTLSBase_corres], - simp_all add: valid_cap_simps valid_cap_simps' invs_def valid_sched_def) + 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 diff --git a/proof/refine/ARM/Untyped_R.thy b/proof/refine/ARM/Untyped_R.thy index a0e2af4f1b..11fb780c00 100644 --- a/proof/refine/ARM/Untyped_R.thy +++ b/proof/refine/ARM/Untyped_R.thy @@ -1358,16 +1358,6 @@ crunches insertNewCap crunch exst[wp]: set_cdt "\s. P (exst s)" -(*FIXME: Move to StateRelation*) -lemma state_relation_schact[elim!]: - "(s,s') \ state_relation \ sched_act_relation (scheduler_action s) (ksSchedulerAction s')" - apply (simp add: state_relation_def) - done - -lemma state_relation_queues[elim!]: "(s,s') \ state_relation \ ready_queues_relation (ready_queues s) (ksReadyQueues s')" - apply (simp add: state_relation_def) - done - lemma set_original_symb_exec_l: "corres_underlying {(s, s'). f (kheap s) (exst s) s'} nf 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) @@ -1398,6 +1388,10 @@ lemma updateNewFreeIndex_noop_psp_corres: | simp add: updateTrackedFreeIndex_def getSlotCap_def)+ done +crunches updateMDB, updateNewFreeIndex, setCTE + for rdyq_projs[wp]: + "\s. P (ksReadyQueues s) (tcbSchedNexts_of s) (tcbSchedPrevs_of s) (\d p. inQ d p |< tcbs_of' s)" + lemma insertNewCap_corres: notes if_cong[cong del] if_weak_cong[cong] shows @@ -3607,8 +3601,8 @@ lemma updateFreeIndex_clear_invs': apply (simp add:updateCap_def) apply (wp setCTE_irq_handlers' getCTE_wp) apply (simp add:updateCap_def) - apply (wp irqs_masked_lift valid_queues_lift' cur_tcb_lift ct_idle_or_in_cur_domain'_lift - hoare_vcg_disj_lift untyped_ranges_zero_lift getCTE_wp + apply (wp irqs_masked_lift cur_tcb_lift ct_idle_or_in_cur_domain'_lift + hoare_vcg_disj_lift untyped_ranges_zero_lift getCTE_wp valid_bitmaps_lift | wp (once) hoare_use_eq[where f="gsUntypedZeroRanges"] | simp add: getSlotCap_def | simp add: cte_wp_at_ctes_of)+ @@ -4173,14 +4167,12 @@ context begin interpretation Arch . (*FIXME: arch_split*) lemma resetUntypedCap_corres: "untypinv_relation ui ui' \ corres (dc \ dc) - (invs 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) @@ -5012,7 +5004,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 valid_sched_etcbs) + 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 @@ -5173,9 +5165,6 @@ crunch irq_states' [wp]: insertNewCap valid_irq_states' crunch pde_mappings' [wp]: insertNewCap valid_pde_mappings' (wp: getCTE_wp') -crunch vq'[wp]: insertNewCap valid_queues' - (wp: crunch_wps) - crunch irqs_masked' [wp]: insertNewCap irqs_masked' (wp: crunch_wps rule: irqs_masked_lift) @@ -5247,6 +5236,12 @@ lemma insertNewCap_urz[wp]: apply (auto simp add: cteCaps_of_def untypedZeroRange_def isCap_simps) done +crunches insertNewCap + for tcbSchedNexts_of[wp]: "\s. P (tcbSchedNexts_of s)" + and tcbSchedPrevs_of[wp]: "\s. P (tcbSchedPrevs_of s)" + and valid_sched_pointers[wp]: valid_sched_pointers + (wp: crunch_wps) + lemma insertNewCap_invs': "\invs' and ct_active' and valid_cap' cap @@ -5263,8 +5258,8 @@ lemma insertNewCap_invs': apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) apply (wp insertNewCap_valid_pspace' sch_act_wf_lift - valid_queues_lift cur_tcb_lift tcb_in_cur_domain'_lift - insertNewCap_valid_global_refs' + cur_tcb_lift tcb_in_cur_domain'_lift valid_bitmaps_lift + insertNewCap_valid_global_refs' sym_heap_sched_pointers_lift valid_arch_state_lift' valid_irq_node_lift insertNewCap_valid_irq_handlers) apply (clarsimp simp: cte_wp_at_ctes_of) diff --git a/proof/refine/ARM/VSpace_R.thy b/proof/refine/ARM/VSpace_R.thy index a89cef829b..40e9cecc87 100644 --- a/proof/refine/ARM/VSpace_R.thy +++ b/proof/refine/ARM/VSpace_R.thy @@ -493,7 +493,7 @@ lemma armv_contextSwitch_corres: done lemma handleVMFault_corres: - "corres (fr \ dc) (tcb_at thread) (tcb_at' thread) + "corres (fr \ dc) (tcb_at thread and pspace_aligned and pspace_distinct) \ (handle_vm_fault thread fault) (handleVMFault thread fault)" apply (simp add: ARM_H.handleVMFault_def) apply corres_cases @@ -2021,8 +2021,8 @@ lemma message_info_from_data_eqv: lemma setMessageInfo_corres: "mi' = message_info_map mi \ - corres dc (tcb_at t) (tcb_at' t) - (set_message_info t mi) (setMessageInfo t mi')" + corres dc (tcb_at t and pspace_aligned and pspace_distinct) \ + (set_message_info t mi) (setMessageInfo t mi')" apply (simp add: setMessageInfo_def set_message_info_def) apply (subgoal_tac "wordFromMessageInfo (message_info_map mi) = message_info_to_data mi") @@ -2735,14 +2735,6 @@ crunch norqL1[wp]: storePDE "\s. P (ksReadyQueuesL1Bitmap s)" crunch norqL2[wp]: storePDE "\s. P (ksReadyQueuesL2Bitmap s)" (simp: updateObject_default_def) -lemma storePDE_valid_queues [wp]: - "\Invariants_H.valid_queues\ storePDE p pde \\_. Invariants_H.valid_queues\" - by (wp valid_queues_lift | simp add: pred_tcb_at'_def)+ - -lemma storePDE_valid_queues' [wp]: - "\valid_queues'\ storePDE p pde \\_. valid_queues'\" - by (wp valid_queues_lift') - 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) @@ -2885,7 +2877,17 @@ crunches 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) + (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 @@ -2897,7 +2899,7 @@ lemma storePDE_invs[wp]: apply (wp sch_act_wf_lift valid_global_refs_lift' irqs_masked_lift valid_arch_state_lift' valid_irq_node_lift - cur_tcb_lift valid_irq_handlers_lift'' + cur_tcb_lift valid_irq_handlers_lift'' valid_bitmaps_lift sym_heap_sched_pointers_lift untyped_ranges_zero_lift | simp add: cteCaps_of_def o_def)+ apply clarsimp @@ -2926,14 +2928,6 @@ crunch norqL1[wp]: storePTE "\s. P (ksReadyQueuesL1Bitmap s)" crunch norqL2[wp]: storePTE "\s. P (ksReadyQueuesL2Bitmap s)" (simp: updateObject_default_def) -lemma storePTE_valid_queues [wp]: - "\Invariants_H.valid_queues\ storePTE p pde \\_. Invariants_H.valid_queues\" - by (wp valid_queues_lift | simp add: pred_tcb_at'_def)+ - -lemma storePTE_valid_queues' [wp]: - "\valid_queues'\ storePTE p pde \\_. valid_queues'\" - by (wp valid_queues_lift') - 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) @@ -3070,7 +3064,7 @@ lemma storePTE_invs [wp]: apply (wp sch_act_wf_lift valid_global_refs_lift' irqs_masked_lift valid_arch_state_lift' valid_irq_node_lift cur_tcb_lift valid_irq_handlers_lift'' - untyped_ranges_zero_lift + untyped_ranges_zero_lift valid_bitmaps_lift | simp add: cteCaps_of_def o_def)+ apply clarsimp done @@ -3116,14 +3110,6 @@ 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_valid_queues [wp]: - "\Invariants_H.valid_queues\ setObject p (ap::asidpool) \\_. Invariants_H.valid_queues\" - by (wp valid_queues_lift | simp add: pred_tcb_at'_def)+ - -lemma setASIDPool_valid_queues' [wp]: - "\valid_queues'\ setObject p (ap::asidpool) \\_. valid_queues'\" - by (wp valid_queues_lift') - 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 @@ -3236,6 +3222,10 @@ 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_state'_def valid_pspace'_def) @@ -3244,7 +3234,7 @@ lemma setASIDPool_invs [wp]: valid_arch_state_lift' valid_irq_node_lift cur_tcb_lift valid_irq_handlers_lift'' untyped_ranges_zero_lift - updateObject_default_inv + updateObject_default_inv valid_bitmaps_lift | simp add: cteCaps_of_def | rule setObject_ksPSpace_only)+ apply (clarsimp simp add: setObject_def o_def) diff --git a/proof/refine/ARM/orphanage/Orphanage.thy b/proof/refine/ARM/orphanage/Orphanage.thy index 5ca2f8ef52..c8c0643e00 100644 --- a/proof/refine/ARM/orphanage/Orphanage.thy +++ b/proof/refine/ARM/orphanage/Orphanage.thy @@ -59,8 +59,7 @@ where definition all_queued_tcb_ptrs :: "kernel_state \ machine_word set" where - "all_queued_tcb_ptrs s \ - { tcb_ptr. \ priority. tcb_ptr : set ((ksReadyQueues s) priority) }" + "all_queued_tcb_ptrs s \ { tcb_ptr. obj_at' tcbQueued tcb_ptr s }" lemma st_tcb_at_neg': "(st_tcb_at' (\ ts. \ P ts) t s) = (tcb_at' t s \ \ st_tcb_at' P t s)" @@ -107,8 +106,8 @@ lemma no_orphans_lift: "\ tcb_ptr. \ \s. tcb_ptr = ksCurThread s \ f \ \_ s. tcb_ptr = ksCurThread s \" assumes st_tcb_at'_is_lifted: "\P p. \ \s. st_tcb_at' P p s\ f \ \_ s. st_tcb_at' P p s \" - assumes ksReadyQueues_is_lifted: - "\P. \ \s. P (ksReadyQueues s)\ f \ \_ s. P (ksReadyQueues s) \" + assumes tcbQueued_is_lifted: + "\P tcb_ptr. f \ \s. obj_at' (\tcb. P (tcbQueued tcb)) tcb_ptr s \" assumes ksSchedulerAction_is_lifted: "\P. \ \s. P (ksSchedulerAction s)\ f \ \_ s. P (ksSchedulerAction s) \" shows @@ -119,7 +118,7 @@ lemma no_orphans_lift: apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) apply (rule ksCurThread_is_lifted) apply (wp hoare_vcg_disj_lift) - apply (rule ksReadyQueues_is_lifted) + apply (wpsimp wp: tcbQueued_is_lifted) apply (wp hoare_vcg_disj_lift) apply (rule typ_at'_is_lifted) apply (wp hoare_vcg_disj_lift) @@ -139,13 +138,12 @@ lemma st_tcb_at'_all_active_tcb_ptrs_lift: by (clarsimp simp: all_active_tcb_ptrs_def) (rule st_tcb_at'_is_active_tcb_ptr_lift [OF assms]) -lemma ksQ_all_queued_tcb_ptrs_lift: - assumes "\P p. \\s. P (ksReadyQueues s p)\ f \\rv s. P (ksReadyQueues s p)\" +lemma tcbQueued_all_queued_tcb_ptrs_lift: + assumes "\Q P tcb_ptr. f \\s. Q (obj_at' (\tcb. P (tcbQueued tcb)) tcb_ptr s)\" shows "\\s. P (t \ all_queued_tcb_ptrs s)\ f \\_ s. P (t \ all_queued_tcb_ptrs s)\" apply (clarsimp simp: all_queued_tcb_ptrs_def) apply (rule_tac P=P in P_bool_lift) apply (wp hoare_vcg_ex_lift assms) - apply (clarsimp) apply (wp hoare_vcg_all_lift assms) done @@ -180,6 +178,11 @@ lemma almost_no_orphans_disj: apply (auto intro: pred_tcb_at') done +lemma all_queued_tcb_ptrs_ksReadyQueues_update[simp]: + "tcb_ptr \ all_queued_tcb_ptrs (ksReadyQueues_update f s) = (tcb_ptr \ all_queued_tcb_ptrs s)" + unfolding all_queued_tcb_ptrs_def + by (clarsimp simp: obj_at'_def projectKOs) + lemma no_orphans_update_simps[simp]: "no_orphans (gsCNodes_update f s) = no_orphans s" "no_orphans (gsUserPages_update g s) = no_orphans s" @@ -252,6 +255,12 @@ crunch no_orphans [wp]: removeFromBitmap "no_orphans" crunch almost_no_orphans [wp]: addToBitmap "almost_no_orphans x" crunch almost_no_orphans [wp]: removeFromBitmap "almost_no_orphans x" +lemma setCTE_tcbQueued[wp]: + "setCTE ptr v \\s. Q (obj_at' (\tcb. P (tcbQueued tcb)) t s)\" + apply (simp add: setCTE_def) + apply (rule setObject_cte_obj_at_tcb', simp_all) + done + lemma setCTE_no_orphans [wp]: "\ \s. no_orphans s \ setCTE p cte @@ -265,7 +274,7 @@ lemma setCTE_almost_no_orphans [wp]: setCTE p cte \ \rv s. almost_no_orphans tcb_ptr s \" unfolding almost_no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift setCTE_typ_at' setCTE_pred_tcb_at') + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift setCTE_typ_at' setCTE_pred_tcb_at') done crunch no_orphans [wp]: activateIdleThread "no_orphans" @@ -275,128 +284,131 @@ lemma asUser_no_orphans [wp]: asUser thread f \ \rv s. no_orphans s \" unfolding no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift) + done + +lemma threadSet_all_queued_tcb_ptrs: + "\tcb. tcbQueued (F tcb) = tcbQueued tcb \ threadSet F tptr \\s. P (t \ all_queued_tcb_ptrs s)\" + unfolding almost_no_orphans_disj all_queued_tcb_ptrs_def + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_st_tcb_at2 threadSet_wp) + apply (erule rsubst[where P=P]) + apply (clarsimp simp: obj_at'_def projectKOs ps_clear_upd objBits_simps) done +crunches removeFromBitmap, addToBitmap, setQueue + for all_queued_tcb_ptrs[wp]: "\s. P (t \ all_queued_tcb_ptrs s)" + (wp: tcbQueued_all_queued_tcb_ptrs_lift) + +crunches tcbQueuePrepend, tcbQueueAppend + for all_queued_tcb_ptrs[wp]: "\s. P (t \ all_queued_tcb_ptrs s)" + (wp: threadSet_all_queued_tcb_ptrs ignore: threadSet) + +lemma tcbQueued_update_True_all_queued_tcb_ptrs[wp]: + "\\s. tcb_ptr \ tcb_ptr' \ tcb_ptr' \ all_queued_tcb_ptrs s\ + threadSet (tcbQueued_update (\_. True)) tcb_ptr + \\_ s. tcb_ptr' \ all_queued_tcb_ptrs s\" + apply (wpsimp wp: threadSet_wp) + apply (fastforce simp: all_queued_tcb_ptrs_def obj_at'_def projectKOs ps_clear_upd objBits_simps) + done + +lemma tcbSchedEnqueue_all_queued_tcb_ptrs[wp]: + "\\s. tcb_ptr \ tcb_ptr' \ tcb_ptr \ all_queued_tcb_ptrs s\ + tcbSchedEnqueue tcb_ptr' + \\_ s. tcb_ptr \ all_queued_tcb_ptrs s\" + unfolding tcbSchedEnqueue_def tcbQueuePrepend_def + apply (wpsimp wp: hoare_vcg_imp_lift' threadGet_wp + | wpsimp wp: threadSet_all_queued_tcb_ptrs)+ + apply (clarsimp simp: all_queued_tcb_ptrs_def obj_at'_def projectKOs) + done + +lemmas tcbSchedEnqueue_all_queued_tcb_ptrs'[wp] = + tcbSchedEnqueue_all_queued_tcb_ptrs[simplified all_queued_tcb_ptrs_def, simplified] + +lemma tcbSchedAppend_all_queued_tcb_ptrs[wp]: + "\\s. tcb_ptr \ tcb_ptr' \ tcb_ptr \ all_queued_tcb_ptrs s\ + tcbSchedAppend tcb_ptr' + \\_ s. tcb_ptr \ all_queued_tcb_ptrs s\" + unfolding tcbSchedAppend_def tcbQueueAppend_def + apply (wpsimp wp: hoare_vcg_imp_lift' threadGet_wp + | wpsimp wp: threadSet_all_queued_tcb_ptrs)+ + apply (clarsimp simp: all_queued_tcb_ptrs_def obj_at'_def projectKOs) + done + +lemmas tcbSchedAppend_all_queued_tcb_ptrs'[wp] = + tcbSchedAppend_all_queued_tcb_ptrs[simplified all_queued_tcb_ptrs_def, simplified] + lemma threadSet_no_orphans: - "\tcb. \ is_active_thread_state (tcbState tcb) \ \ is_active_thread_state (tcbState (F tcb)) \ - \ \s. no_orphans s \ - threadSet F tptr - \ \rv s. no_orphans s \" + "\\tcb. \ is_active_thread_state (tcbState tcb) \ \ is_active_thread_state (tcbState (F tcb)); + \tcb. tcbQueued (F tcb) = tcbQueued tcb\ + \ threadSet F tptr \no_orphans\" unfolding no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_st_tcb_at2 | clarsimp)+ - done + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_st_tcb_at2) -lemma threadSet_almost_no_orphans: - "\tcb. \ is_active_thread_state (tcbState tcb) \ \ is_active_thread_state (tcbState (F tcb)) \ - \ \s. almost_no_orphans ptr s \ - threadSet F tptr - \ \rv s. almost_no_orphans ptr s \" - unfolding almost_no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_st_tcb_at2 | clarsimp)+ +lemma tcbQueued_update_True_no_orphans: + "\almost_no_orphans tptr and tcb_at' tptr\ + threadSet (tcbQueued_update (\_. True)) tptr + \\_. no_orphans\" + unfolding no_orphans_disj + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_st_tcb_at2) + apply (fastforce simp: almost_no_orphans_def all_active_tcb_ptrs_def + tcb_at_typ_at' st_tcb_at_neg' is_active_tcb_ptr_def) done -lemma setQueue_no_orphans_enq: - "\ \s. no_orphans s \ set (ksReadyQueues s (d, prio)) \ set qs \ - setQueue d prio qs - \ \_ s. no_orphans s \" - unfolding setQueue_def - apply wp - apply (clarsimp simp: no_orphans_def all_queued_tcb_ptrs_def - split: if_split_asm) +lemma tcbQueued_update_True_almost_no_orphans: + "threadSet (tcbQueued_update (\_. True)) tptr' \almost_no_orphans tptr\" + unfolding almost_no_orphans_disj + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift threadSet_st_tcb_at2) apply fastforce done -lemma setQueue_almost_no_orphans_enq: - "\ \s. almost_no_orphans tcb_ptr s \ set (ksReadyQueues s (d, prio)) \ set qs \ tcb_ptr \ set qs \ - setQueue d prio qs - \ \_ s. no_orphans s \" +lemma threadSet_almost_no_orphans: + "\\tcb. \ is_active_thread_state (tcbState tcb) \ \ is_active_thread_state (tcbState (F tcb)); + \tcb. tcbQueued (F tcb) = tcbQueued tcb\ + \ threadSet F tptr \almost_no_orphans ptr\" + unfolding almost_no_orphans_disj all_queued_tcb_ptrs_def + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_st_tcb_at2) + +lemma setQueue_no_orphans[wp]: + "setQueue d prio qs \no_orphans\" unfolding setQueue_def apply wp - apply (clarsimp simp: no_orphans_def almost_no_orphans_def all_queued_tcb_ptrs_def - split: if_split_asm) - apply fastforce + apply (clarsimp simp: no_orphans_def) done -lemma setQueue_almost_no_orphans_enq_lift: - "\ \s. almost_no_orphans tcb_ptr s \ set (ksReadyQueues s (d, prio)) \ set qs \ - setQueue d prio qs - \ \_ s. almost_no_orphans tcb_ptr s \" +lemma setQueue_almost_no_orphans[wp]: + "setQueue d prio qs \almost_no_orphans tptr\" unfolding setQueue_def apply wp - apply (clarsimp simp: almost_no_orphans_def all_queued_tcb_ptrs_def - split: if_split_asm) - apply fastforce + apply (clarsimp simp: almost_no_orphans_def) done lemma tcbSchedEnqueue_no_orphans[wp]: - "\ \s. no_orphans s \ - tcbSchedEnqueue tcb_ptr - \ \rv s. no_orphans s \" - unfolding tcbSchedEnqueue_def - apply (wp setQueue_no_orphans_enq threadSet_no_orphans | clarsimp simp: unless_def)+ - apply (wp getObject_tcb_wp | clarsimp simp: threadGet_def)+ - apply (drule obj_at_ko_at') - apply auto + "tcbSchedEnqueue tcb_ptr \no_orphans\" + unfolding tcbSchedEnqueue_def tcbQueuePrepend_def + apply (wpsimp wp: tcbQueued_update_True_no_orphans threadSet_almost_no_orphans threadGet_wp) + apply (fastforce simp: no_orphans_strg_almost) done lemma tcbSchedAppend_no_orphans[wp]: - "\ \s. no_orphans s \ - tcbSchedAppend tcb_ptr - \ \rv s. no_orphans s \" - unfolding tcbSchedAppend_def - apply (wp setQueue_no_orphans_enq threadSet_no_orphans | clarsimp simp: unless_def)+ - apply (wp getObject_tcb_wp | clarsimp simp: threadGet_def)+ - apply (drule obj_at_ko_at') - apply auto - done - -lemma ko_at_obj_at': - "ko_at' ko p s \ P ko \ obj_at' P p s" - unfolding obj_at'_def - apply clarsimp - done - -lemma queued_in_queue: - "\valid_queues' s; ko_at' tcb tcb_ptr s; tcbQueued tcb\ \ - \ p. tcb_ptr \ set (ksReadyQueues s p)" - unfolding valid_queues'_def - apply (drule_tac x="tcbDomain tcb" in spec) - apply (drule_tac x="tcbPriority tcb" in spec) - apply (drule_tac x="tcb_ptr" in spec) - apply (drule mp) - apply (rule ko_at_obj_at') - apply (auto simp: inQ_def) + "tcbSchedAppend tcb_ptr \no_orphans\" + unfolding tcbSchedAppend_def tcbQueueAppend_def + apply (wpsimp wp: tcbQueued_update_True_no_orphans threadSet_almost_no_orphans threadGet_wp) + apply (fastforce simp: no_orphans_strg_almost) done lemma tcbSchedEnqueue_almost_no_orphans: - "\ \s. almost_no_orphans tcb_ptr s \ valid_queues' s \ + "\almost_no_orphans tcb_ptr\ tcbSchedEnqueue tcb_ptr - \ \rv s. no_orphans s \" - unfolding tcbSchedEnqueue_def - apply simp - apply (wp setQueue_almost_no_orphans_enq[where tcb_ptr=tcb_ptr] threadSet_no_orphans - | clarsimp)+ - apply (wp getObject_tcb_wp | clarsimp simp: threadGet_def)+ - apply normalise_obj_at' - apply (rule_tac x=ko in exI) - apply (clarsimp simp: subset_insertI) - apply (unfold no_orphans_def almost_no_orphans_def) - apply clarsimp - apply (drule(2) queued_in_queue) - apply (fastforce simp: all_queued_tcb_ptrs_def) + \\_. no_orphans\" + unfolding tcbSchedEnqueue_def tcbQueuePrepend_def + apply (wpsimp wp: tcbQueued_update_True_no_orphans threadSet_almost_no_orphans threadGet_wp) + apply (fastforce simp: no_orphans_def almost_no_orphans_def all_queued_tcb_ptrs_def obj_at'_def) done lemma tcbSchedEnqueue_almost_no_orphans_lift: - "\ \s. almost_no_orphans ptr s \ - tcbSchedEnqueue tcb_ptr - \ \rv s. almost_no_orphans ptr s \" - unfolding tcbSchedEnqueue_def - apply (wp setQueue_almost_no_orphans_enq_lift threadSet_almost_no_orphans | clarsimp simp: unless_def)+ - apply (wp getObject_tcb_wp | clarsimp simp: threadGet_def)+ - apply (drule obj_at_ko_at') - apply auto - done + "tcbSchedEnqueue tcb_ptr \almost_no_orphans ptr\" + unfolding tcbSchedEnqueue_def tcbQueuePrepend_def + by (wpsimp wp: tcbQueued_update_True_almost_no_orphans threadSet_almost_no_orphans) lemma ssa_no_orphans: "\ \s. no_orphans s \ @@ -428,124 +440,70 @@ lemma ssa_almost_no_orphans_lift [wp]: apply auto done -lemma tcbSchedEnqueue_inQueue [wp]: - "\ \s. valid_queues' s \ - tcbSchedEnqueue tcb_ptr - \ \rv s. tcb_ptr \ all_queued_tcb_ptrs s \" - unfolding tcbSchedEnqueue_def all_queued_tcb_ptrs_def - apply (wp | clarsimp simp: unless_def)+ - apply (rule_tac Q="\rv. \" in hoare_post_imp) - apply fastforce - apply (wp getObject_tcb_wp | clarsimp simp: threadGet_def)+ - apply (fastforce simp: obj_at'_def valid_queues'_def inQ_def) - done - -lemma tcbSchedAppend_inQueue [wp]: - "\ \s. valid_queues' s \ - tcbSchedAppend tcb_ptr - \ \rv s. tcb_ptr \ all_queued_tcb_ptrs s \" - unfolding tcbSchedAppend_def all_queued_tcb_ptrs_def - apply (wp | clarsimp simp: unless_def)+ - apply (rule_tac Q="\rv. \" in hoare_post_imp) - apply fastforce - apply (wp getObject_tcb_wp | clarsimp simp: threadGet_def)+ - apply (fastforce simp: obj_at'_def valid_queues'_def inQ_def) - done - lemma rescheduleRequired_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ - rescheduleRequired - \ \rv s. no_orphans s \" + "rescheduleRequired \no_orphans\" unfolding rescheduleRequired_def - apply (wp tcbSchedEnqueue_no_orphans hoare_vcg_all_lift ssa_no_orphans | wpc | clarsimp)+ - apply (wps tcbSchedEnqueue_nosch, wp hoare_weak_lift_imp) - apply (rename_tac word t p) - apply (rule_tac P="word = t" in hoare_gen_asm) - apply (wp hoare_disjI1 | clarsimp)+ - done + by (wpsimp wp: ssa_no_orphans hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift | wpc)+ lemma rescheduleRequired_almost_no_orphans [wp]: - "\ \s. almost_no_orphans tcb_ptr s \ valid_queues' s \ - rescheduleRequired - \ \rv s. almost_no_orphans tcb_ptr s \" + "rescheduleRequired \almost_no_orphans tcb_ptr\" unfolding rescheduleRequired_def - apply (wp tcbSchedEnqueue_almost_no_orphans_lift hoare_vcg_all_lift | wpc | clarsimp)+ - apply (wps tcbSchedEnqueue_nosch, wp hoare_weak_lift_imp) - apply (rename_tac word t p) - apply (rule_tac P="word = t" in hoare_gen_asm) - apply (wp hoare_disjI1 | clarsimp)+ - done + by (wpsimp wp: ssa_almost_no_orphans_lift hoare_vcg_all_lift tcbSchedEnqueue_almost_no_orphans_lift + hoare_vcg_imp_lift' hoare_vcg_disj_lift) lemma setThreadState_current_no_orphans: - "\ \s. no_orphans s \ ksCurThread s = tcb_ptr \ valid_queues' s \ + "\\s. no_orphans s \ ksCurThread s = tcb_ptr\ setThreadState state tcb_ptr - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding setThreadState_def - apply (wp | clarsimp)+ - apply (rule_tac Q="\rv s. valid_queues' s \ no_orphans s" in hoare_post_imp) - apply clarsimp - apply (wp threadSet_valid_queues') - apply (unfold no_orphans_disj all_queued_tcb_ptrs_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state) - apply (auto simp: inQ_def) + apply wpsimp + unfolding no_orphans_disj + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state + threadSet_all_queued_tcb_ptrs + | fastforce)+ done lemma setThreadState_isRestart_no_orphans: - "\ \s. no_orphans s \ st_tcb_at' isRestart tcb_ptr s \ valid_queues' s\ + "\no_orphans and st_tcb_at' isRestart tcb_ptr\ setThreadState state tcb_ptr - \ \rv s. no_orphans s \" + \\_ . no_orphans\" unfolding setThreadState_def - apply (wp | clarsimp)+ - apply (rule_tac Q="\rv s. valid_queues' s \ no_orphans s" in hoare_post_imp) - apply clarsimp - apply (wp threadSet_valid_queues') - apply (unfold no_orphans_disj all_queued_tcb_ptrs_def is_active_thread_state_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state) - apply (auto simp: st_tcb_at_double_neg' st_tcb_at_neg' inQ_def) + apply wpsimp + unfolding no_orphans_disj + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state + threadSet_all_queued_tcb_ptrs + | fastforce)+ + apply (auto simp: is_active_thread_state_def st_tcb_at_double_neg' st_tcb_at_neg') done lemma setThreadState_almost_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s\ - setThreadState state tcb_ptr - \ \rv s. almost_no_orphans tcb_ptr s \" + "\no_orphans\ setThreadState state tcb_ptr \\_. almost_no_orphans tcb_ptr\" unfolding setThreadState_def - apply (wp | clarsimp)+ - apply (rule_tac Q="\rv s. valid_queues' s \ almost_no_orphans tcb_ptr s" in hoare_post_imp) - apply clarsimp - apply (wp threadSet_valid_queues') - apply (unfold no_orphans_disj almost_no_orphans_disj all_queued_tcb_ptrs_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state) - apply (auto simp: inQ_def) + apply wpsimp + apply (unfold no_orphans_disj almost_no_orphans_disj) + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state + threadSet_all_queued_tcb_ptrs + | fastforce)+ done lemma setThreadState_not_active_no_orphans: - "\ is_active_thread_state state \ - \ \s. no_orphans s \ valid_queues' s \ - setThreadState state tcb_ptr - \ \rv s. no_orphans s \" + "\ is_active_thread_state state \ setThreadState state tcb_ptr \no_orphans\" unfolding setThreadState_def - apply (wp | clarsimp)+ - apply (rule_tac Q="\rv s. valid_queues' s \ no_orphans s" in hoare_post_imp) - apply clarsimp - apply (wp threadSet_valid_queues') - apply (unfold no_orphans_disj all_queued_tcb_ptrs_def is_active_thread_state_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state) - apply (auto simp: isRunning_def isRestart_def inQ_def) + apply wpsimp + apply (unfold no_orphans_disj) + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state + threadSet_all_queued_tcb_ptrs + | fastforce)+ done lemma setThreadState_not_active_almost_no_orphans: - "\ is_active_thread_state state \ - \ \s. almost_no_orphans thread s \ valid_queues' s \ - setThreadState state tcb_ptr - \ \rv s. almost_no_orphans thread s \" + "\ is_active_thread_state state \ setThreadState state tcb_ptr \almost_no_orphans thread\" unfolding setThreadState_def - apply (wp | clarsimp)+ - apply (rule_tac Q="\rv s. valid_queues' s \ almost_no_orphans thread s" in hoare_post_imp) - apply clarsimp - apply (wp threadSet_valid_queues') - apply (unfold almost_no_orphans_disj all_queued_tcb_ptrs_def is_active_thread_state_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state) - apply (auto simp: isRunning_def isRestart_def inQ_def) + apply wpsimp + apply (unfold almost_no_orphans_disj) + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state + threadSet_all_queued_tcb_ptrs + | fastforce)+ done lemma activateThread_no_orphans [wp]: @@ -557,60 +515,75 @@ lemma activateThread_no_orphans [wp]: apply (auto simp: ct_in_state'_def pred_tcb_at'_def obj_at'_def isRestart_def) done -lemma setQueue_no_orphans_deq: - "\ \s. \ tcb_ptr. no_orphans s \ \ is_active_tcb_ptr tcb_ptr s \ - queue = [x\((ksReadyQueues s) (d, priority)). x \ tcb_ptr] \ - setQueue d priority queue - \ \rv s. no_orphans s \" - unfolding setQueue_def - apply (wp | clarsimp)+ - apply (fastforce simp: no_orphans_def all_queued_tcb_ptrs_def - all_active_tcb_ptrs_def is_active_tcb_ptr_def) +crunches removeFromBitmap, tcbQueueRemove, setQueue + for almost_no_orphans[wp]: "almost_no_orphans thread" + and no_orphans[wp]: no_orphans + and all_queued_tcb_ptrs[wp]: "\s. tcb_ptr \ all_queued_tcb_ptrs s" + (wp: crunch_wps) + +lemma tcbQueued_update_False_all_queued_tcb_ptrs: + "\\s. tcb_ptr \ tcb_ptr' \ tcb_ptr' \ all_queued_tcb_ptrs s\ + threadSet (tcbQueued_update (\_. False)) tcb_ptr + \\_ s. tcb_ptr' \ all_queued_tcb_ptrs s\" + apply (wpsimp wp: threadSet_wp) + apply (clarsimp simp: all_queued_tcb_ptrs_def obj_at'_def projectKOs ps_clear_upd) done -lemma setQueue_almost_no_orphans_deq [wp]: - "\ \s. almost_no_orphans tcb_ptr s \ - queue = [x\((ksReadyQueues s) (d, priority)). x \ tcb_ptr] \ - setQueue d priority queue - \ \rv s. almost_no_orphans tcb_ptr s \" - unfolding setQueue_def - apply (wp | clarsimp)+ - apply (fastforce simp: almost_no_orphans_def all_queued_tcb_ptrs_def - all_active_tcb_ptrs_def is_active_tcb_ptr_def) +lemma tcbSchedDequeue_all_queued_tcb_ptrs_other: + "\\s. tcb_ptr \ tcb_ptr' \ tcb_ptr' \ all_queued_tcb_ptrs s\ + tcbSchedDequeue tcb_ptr + \\_ s. tcb_ptr' \ all_queued_tcb_ptrs s\" + unfolding tcbSchedDequeue_def + by (wpsimp wp: tcbQueued_update_False_all_queued_tcb_ptrs threadGet_wp) + +lemma tcbQueued_update_False_almost_no_orphans: + "\no_orphans\ + threadSet (tcbQueued_update (\_. False)) tptr + \\_. almost_no_orphans tptr\" + apply (wpsimp wp: threadSet_wp) + apply (clarsimp simp: no_orphans_def almost_no_orphans_def) + apply (rename_tac tcb_ptr) + apply (case_tac "tcb_ptr = tptr") + apply fastforce + apply (fastforce simp: all_queued_tcb_ptrs_def obj_at'_def projectKOs all_active_tcb_ptrs_def + is_active_tcb_ptr_def st_tcb_at'_def ps_clear_upd) done lemma tcbSchedDequeue_almost_no_orphans [wp]: - "\ \s. no_orphans s \ - tcbSchedDequeue thread - \ \rv s. almost_no_orphans thread s \" + "\no_orphans\ tcbSchedDequeue thread \\_. almost_no_orphans thread\" unfolding tcbSchedDequeue_def - apply (wp threadSet_almost_no_orphans | simp cong: if_cong)+ - apply (simp add:no_orphans_strg_almost cong: if_cong) + apply (wpsimp wp: tcbQueued_update_False_almost_no_orphans threadGet_wp) + apply (simp add: no_orphans_strg_almost) done -lemma tcbSchedDequeue_no_orphans [wp]: - "\ \s. no_orphans s \ \ is_active_tcb_ptr tcb_ptr s \ - tcbSchedDequeue tcb_ptr - \ \rv s. no_orphans s \" - unfolding tcbSchedDequeue_def - apply (wp setQueue_no_orphans_deq threadSet_no_orphans | clarsimp)+ - apply (wp getObject_tcb_wp | clarsimp simp: threadGet_def)+ - apply (drule obj_at_ko_at') - apply auto +lemma tcbSchedDequeue_no_orphans[wp]: + "\\s. no_orphans s \ \ is_active_tcb_ptr tcbPtr s \ tcb_at' tcbPtr s\ + tcbSchedDequeue tcbPtr + \\_. no_orphans\" + supply disj_not1[simp del] + unfolding no_orphans_disj almost_no_orphans_disj + apply (rule hoare_allI) + apply (rename_tac tcb_ptr) + apply (case_tac "tcb_ptr = tcbPtr") + apply (rule_tac Q="\_ s. st_tcb_at' (\state. \ is_active_thread_state state) tcbPtr s" + in hoare_post_imp) + apply fastforce + apply wpsimp + apply (clarsimp simp: st_tcb_at'_def obj_at'_def projectKOs is_active_tcb_ptr_def disj_not1) + apply (wpsimp wp: tcbQueued_update_False_all_queued_tcb_ptrs hoare_vcg_disj_lift + simp: tcbSchedDequeue_def) done lemma switchToIdleThread_no_orphans' [wp]: - "\ \s. no_orphans s \ - (is_active_tcb_ptr (ksCurThread s) s - \ ksCurThread s \ all_queued_tcb_ptrs s) \ + "\\s. no_orphans s + \ (is_active_tcb_ptr (ksCurThread s) s \ ksCurThread s \ all_queued_tcb_ptrs s)\ switchToIdleThread - \ \rv s. no_orphans s \" - unfolding switchToIdleThread_def setCurThread_def ARM_H.switchToIdleThread_def + \\_. no_orphans\" + supply disj_not1[simp del] + apply (clarsimp simp: switchToIdleThread_def setCurThread_def ARM_H.switchToIdleThread_def) apply (simp add: no_orphans_disj all_queued_tcb_ptrs_def) - apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift hoare_vcg_disj_lift - | clarsimp)+ - apply (auto simp: no_orphans_disj all_queued_tcb_ptrs_def is_active_tcb_ptr_def - st_tcb_at_neg' tcb_at_typ_at') + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift hoare_drop_imps) + apply (force simp: is_active_tcb_ptr_def st_tcb_at_neg' typ_at_tcb') done crunch no_orphans [wp]: "Arch.switchToThread" "no_orphans" @@ -622,13 +595,9 @@ crunch ksCurThread [wp]: "Arch.switchToThread" "\ s. P (ksCurThread s)" crunch ksIdleThread [wp]: "Arch.switchToThread" "\ s. P (ksIdleThread s)" (ignore: ARM.clearExMonitor) -lemma ArchThreadDecls_H_switchToThread_all_queued_tcb_ptrs [wp]: - "\ \s. P (all_queued_tcb_ptrs s) \ - Arch.switchToThread tcb_ptr - \ \rv s. P (all_queued_tcb_ptrs s) \" - unfolding ARM_H.switchToThread_def all_queued_tcb_ptrs_def - apply (wp | clarsimp)+ - done +crunches Arch.switchToThread + for all_queued_tcb_ptrs[wp]: "\s. P (t \ all_queued_tcb_ptrs s)" + (wp: tcbQueued_all_queued_tcb_ptrs_lift) crunch ksSchedulerAction [wp]: "Arch.switchToThread" "\s. P (ksSchedulerAction s)" (ignore: ARM.clearExMonitor) @@ -646,22 +615,6 @@ lemma setCurThread_no_orphans [wp]: apply auto done -lemma tcbSchedDequeue_all_queued_tcb_ptrs: - "\\s. x \ all_queued_tcb_ptrs s \ x \ t \ - tcbSchedDequeue t \\_ s. x \ all_queued_tcb_ptrs s\" - apply (rule_tac Q="(\s. x \ all_queued_tcb_ptrs s) and K (x \ t)" - in hoare_pre_imp, clarsimp) - apply (rule hoare_gen_asm) - apply (clarsimp simp: tcbSchedDequeue_def all_queued_tcb_ptrs_def) - apply (rule hoare_pre) - apply (wp, clarsimp) - apply (wp hoare_vcg_ex_lift)+ - apply (rename_tac d p) - apply (rule_tac Q="\_ s. x \ set (ksReadyQueues s (d, p))" - in hoare_post_imp, clarsimp) - apply (wp hoare_vcg_all_lift | simp)+ - done - lemma tcbSchedDequeue_all_active_tcb_ptrs[wp]: "\\s. P (t' \ all_active_tcb_ptrs s)\ tcbSchedDequeue t \\_ s. P (t' \ all_active_tcb_ptrs s)\" by (clarsimp simp: all_active_tcb_ptrs_def is_active_tcb_ptr_def) wp @@ -684,8 +637,14 @@ lemma setCurThread_almost_no_orphans: lemmas ArchThreadDecls_H_switchToThread_all_active_tcb_ptrs[wp] = st_tcb_at'_all_active_tcb_ptrs_lift [OF Arch_switchToThread_pred_tcb'] +lemma arch_switch_thread_tcbQueued[wp]: + "Arch.switchToThread t \\s. Q (obj_at' (\tcb. P (tcbQueued tcb)) tcb_ptr s)\" + apply (simp add: ARM_H.switchToThread_def) + apply (wp) + done + lemmas ArchThreadDecls_H_switchToThread_all_queued_tcb_ptrs_lift[wp] = - ksQ_all_queued_tcb_ptrs_lift [OF arch_switch_thread_ksQ] + tcbQueued_all_queued_tcb_ptrs_lift [OF arch_switch_thread_tcbQueued] lemma ThreadDecls_H_switchToThread_no_orphans: "\ \s. no_orphans s \ @@ -695,16 +654,9 @@ lemma ThreadDecls_H_switchToThread_no_orphans: ThreadDecls_H.switchToThread tcb_ptr \ \rv s. no_orphans s \" unfolding Thread_H.switchToThread_def - apply (wp setCurThread_almost_no_orphans - tcbSchedDequeue_almost_no_orphans) - apply (wps tcbSchedDequeue_ct') - apply (wp tcbSchedDequeue_all_queued_tcb_ptrs hoare_convert_imp)+ - apply (wps) - apply (wp)+ - apply (wps) - apply (wp) - apply (clarsimp) - done + by (wpsimp wp: setCurThread_almost_no_orphans hoare_vcg_imp_lift' + tcbSchedDequeue_all_queued_tcb_ptrs_other + | wps)+ lemma findM_failure': "\ \x S. \ \s. P S s \ f x \ \rv s. \ rv \ P (insert x S) s \ \ \ @@ -722,22 +674,6 @@ lemma findM_failure': lemmas findM_failure = findM_failure'[where S="{}", simplified] -lemma tcbSchedEnqueue_inQueue_eq: - "\ valid_queues' and K (tcb_ptr = tcb_ptr') \ - tcbSchedEnqueue tcb_ptr - \ \rv s. tcb_ptr' \ all_queued_tcb_ptrs s \" - apply (rule hoare_gen_asm, simp) - apply wp - done - -lemma tcbSchedAppend_inQueue_eq: - "\ valid_queues' and K (tcb_ptr = tcb_ptr') \ - tcbSchedAppend tcb_ptr - \ \rv s. tcb_ptr' \ all_queued_tcb_ptrs s \" - apply (rule hoare_gen_asm, simp) - apply wp - done - lemma findM_on_success: "\ \x. \ P x \ f x \ \rv s. rv \; \x y. \ P x \ f y \ \rv. P x \ \ \ \ \s. \x \ set xs. P x s \ findM f xs \ \rv s. \ y. rv = Some y \" @@ -750,66 +686,32 @@ lemma findM_on_success: crunch st_tcb' [wp]: switchToThread "\s. P' (st_tcb_at' P t s)" (ignore: ARM.clearExMonitor) -lemma setQueue_deq_not_empty: - "\ \s. (\tcb. tcb \ set (ksReadyQueues s p) \ st_tcb_at' P tcb s) \ - (\tcb_ptr. \ st_tcb_at' P tcb_ptr s \ - queue = [x\((ksReadyQueues s) (d, priority)). x \ tcb_ptr]) \ - setQueue d priority queue - \ \rv s. \tcb. tcb \ set (ksReadyQueues s p) \ st_tcb_at' P tcb s \" - unfolding setQueue_def - apply wp - apply auto - done - -lemma tcbSchedDequeue_not_empty: - "\ \s. (\tcb. tcb \ set (ksReadyQueues s p) \ st_tcb_at' P tcb s) \ \ st_tcb_at' P thread s \ - tcbSchedDequeue thread - \ \rv s. \tcb. tcb \ set (ksReadyQueues s p) \ st_tcb_at' P tcb s \" - unfolding tcbSchedDequeue_def - apply wp - apply (wp hoare_vcg_ex_lift threadSet_pred_tcb_no_state) - apply clarsimp - apply (wp setQueue_deq_not_empty) - apply clarsimp - apply (rule hoare_pre_post, assumption) - apply (clarsimp simp: bitmap_fun_defs) - apply wp - apply clarsimp - apply clarsimp - apply (wp setQueue_deq_not_empty)+ - apply (rule_tac Q="\rv s. \ st_tcb_at' P thread s" in hoare_post_imp) - apply fastforce - apply (wp weak_if_wp | clarsimp)+ - done - lemmas switchToThread_all_active_tcb_ptrs[wp] = st_tcb_at'_all_active_tcb_ptrs_lift [OF switchToThread_st_tcb'] (* ksSchedulerAction s = ChooseNewThread *) lemma chooseThread_no_orphans [wp]: - notes hoare_TrueI[simp] - shows - "\\s. no_orphans s \ all_invs_but_ct_idle_or_in_cur_domain' s \ - (is_active_tcb_ptr (ksCurThread s) s - \ ksCurThread s \ all_queued_tcb_ptrs s)\ + "\\s. no_orphans s \ all_invs_but_ct_idle_or_in_cur_domain' s + \ (is_active_tcb_ptr (ksCurThread s) s \ ksCurThread s \ all_queued_tcb_ptrs s)\ chooseThread - \ \rv s. no_orphans s \" + \\_. no_orphans\" (is "\?PRE\ _ \_\") unfolding chooseThread_def Let_def supply if_split[split del] apply (simp only: return_bind, simp) - apply (rule hoare_seq_ext[where B="\rv s. ?PRE s \ rv = ksCurDomain s"]) - apply (rule_tac B="\rv s. ?PRE s \ curdom = ksCurDomain s \ - rv = ksReadyQueuesL1Bitmap s curdom" in hoare_seq_ext) + apply (intro hoare_seq_ext[OF _ stateAssert_sp]) + apply (rule hoare_seq_ext[where B="\rv s. ?PRE s \ ksReadyQueues_asrt s \ ready_qs_runnable s + \ rv = ksCurDomain s"]) + apply (rule_tac B="\rv s. ?PRE s \ ksReadyQueues_asrt s \ ready_qs_runnable s + \ curdom = ksCurDomain s \ rv = ksReadyQueuesL1Bitmap s curdom" + in hoare_seq_ext) apply (rename_tac l1) apply (case_tac "l1 = 0") (* switch to idle thread *) apply (simp, wp, simp) (* we have a thread to switch to *) - apply (clarsimp simp: bitmap_fun_defs) apply (wp assert_inv ThreadDecls_H_switchToThread_no_orphans) - apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def - valid_queues_def st_tcb_at'_def) + apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def st_tcb_at'_def) apply (fastforce dest!: lookupBitmapPriority_obj_at' elim: obj_at'_weaken simp: all_active_tcb_ptrs_def) apply (wpsimp simp: bitmap_fun_defs) @@ -817,33 +719,6 @@ lemma chooseThread_no_orphans [wp]: apply (wpsimp simp: curDomain_def simp: invs_no_cicd_ksCurDomain_maxDomain')+ done -lemma tcbSchedAppend_in_ksQ: - "\valid_queues' and tcb_at' t\ tcbSchedAppend t - \\r s. \domain priority. t \ set (ksReadyQueues s (domain, priority))\" - apply (rule_tac Q="\s. \d p. valid_queues' s \ - obj_at' (\tcb. tcbPriority tcb = p) t s \ - obj_at' (\tcb. tcbDomain tcb = d) t s" - in hoare_pre_imp) - apply (clarsimp simp: tcb_at'_has_tcbPriority tcb_at'_has_tcbDomain) - apply (rule hoare_vcg_ex_lift)+ - apply (simp add: tcbSchedAppend_def unless_def) - apply wpsimp - apply (rule_tac Q="\rv s. tdom = d \ rv = p \ obj_at' (\tcb. tcbPriority tcb = p) t s - \ obj_at' (\tcb. tcbDomain tcb = d) t s" - in hoare_post_imp, clarsimp) - apply (wp, (wp threadGet_const)+) - apply (rule_tac Q="\rv s. - obj_at' (\tcb. tcbPriority tcb = p) t s \ - obj_at' (\tcb. tcbDomain tcb = d) t s \ - obj_at' (\tcb. tcbQueued tcb = rv) t s \ - (rv \ t \ set (ksReadyQueues s (d, p)))" in hoare_post_imp) - apply (clarsimp simp: o_def elim!: obj_at'_weakenE) - apply (wp threadGet_obj_at' hoare_vcg_imp_lift threadGet_const) - apply clarsimp - apply normalise_obj_at' - apply (drule(1) valid_queues'_ko_atD, simp+) - done - lemma hoare_neg_imps: "\P\ f \\ rv s. \ R rv s\ \ \P\ f \\r s. R r s \ Q r s\" by (auto simp: valid_def) @@ -867,7 +742,7 @@ lemma ThreadDecls_H_switchToThread_ct [wp]: crunch no_orphans [wp]: nextDomain no_orphans (wp: no_orphans_lift simp: Let_def) -crunch ksQ [wp]: nextDomain "\s. P (ksReadyQueues s p)" +crunch tcbQueued[wp]: nextDomain "\s. Q (obj_at' (\tcb. P (tcbQueued tcb)) tcb_ptr s)" (simp: Let_def) crunch st_tcb_at' [wp]: nextDomain "\s. P (st_tcb_at' P' p s)" @@ -879,14 +754,6 @@ crunch ct' [wp]: nextDomain "\s. P (ksCurThread s)" crunch sch_act_not [wp]: nextDomain "sch_act_not t" (simp: Let_def) -lemma tcbSchedEnqueue_in_ksQ': - "\valid_queues' and tcb_at' t and K (t = t')\ - tcbSchedEnqueue t' - \\r s. \domain priority. t \ set (ksReadyQueues s (domain, priority))\" - apply (rule hoare_gen_asm) - apply (wp tcbSchedEnqueue_in_ksQ | clarsimp)+ - done - lemma all_invs_but_ct_idle_or_in_cur_domain'_strg: "invs' s \ all_invs_but_ct_idle_or_in_cur_domain' s" by (clarsimp simp: invs'_to_invs_no_cicd'_def) @@ -899,69 +766,6 @@ lemma obj_at'_static_fix: "\ obj_at' (\(ko::'a::pspace_storable). True) p s ; P \ \ obj_at' (\(ko::'a::pspace_storable). P) p s" by (erule obj_at'_weakenE, simp) -lemma tcbSchedEnqueue_in_ksQ_aqtp[wp]: - "\valid_queues' and tcb_at' t\ tcbSchedEnqueue t - \\r s. t \ all_queued_tcb_ptrs s\" - apply (clarsimp simp: all_queued_tcb_ptrs_def) - apply (rule tcbSchedEnqueue_in_ksQ) - done - -crunch ksReadyQueues[wp]: threadGet "\s. P (ksReadyQueues s)" - -lemma tcbSchedEnqueue_in_ksQ_already_queued: - "\\s. valid_queues' s \ tcb_at' t s \ - (\domain priority. t' \ set (ksReadyQueues s (domain, priority))) \ - tcbSchedEnqueue t - \\r s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))\" - apply (case_tac "t'=t", wpsimp wp: tcbSchedEnqueue_in_ksQ) - apply (wpsimp simp: tcbSchedEnqueue_def unless_def) - apply (rule_tac Q="\_ s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))" - in hoare_post_imp) - apply metis - apply wpsimp+ - done - -lemma tcbSchedAppend_in_ksQ_already_queued: - "\\s. valid_queues' s \ tcb_at' t s \ - (\domain priority. t' \ set (ksReadyQueues s (domain, priority))) \ - tcbSchedAppend t - \\r s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))\" - apply (case_tac "t'=t", wpsimp wp: tcbSchedAppend_in_ksQ) - apply (wpsimp simp: tcbSchedAppend_def unless_def) - apply (rule_tac Q="\_ s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))" - in hoare_post_imp) - apply metis - apply wpsimp+ - done - -lemma tcbSchedEnqueue_in_ksQ'': - "\\s. valid_queues' s \ tcb_at' t s \ - (t' \ t \ (\domain priority. t' \ set (ksReadyQueues s (domain, priority)))) \ - tcbSchedEnqueue t - \\r s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))\" - apply (case_tac "t'=t", wpsimp wp: tcbSchedEnqueue_in_ksQ) - apply clarsimp - apply (wpsimp simp: tcbSchedEnqueue_def unless_def) - apply (rule_tac Q="\_ s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))" - in hoare_post_imp) - apply metis - apply wpsimp+ - done - -lemma tcbSchedAppend_in_ksQ'': - "\\s. valid_queues' s \ tcb_at' t s \ - (t' \ t \ (\domain priority. t' \ set (ksReadyQueues s (domain, priority)))) \ - tcbSchedAppend t - \\r s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))\" - apply (case_tac "t'=t", wpsimp wp: tcbSchedAppend_in_ksQ) - apply clarsimp - apply (wpsimp simp: tcbSchedAppend_def unless_def) - apply (rule_tac Q="\_ s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))" - in hoare_post_imp) - apply metis - apply wpsimp+ - done - crunches setSchedulerAction for pred_tcb_at': "\s. P (pred_tcb_at' proj Q t s)" and ct': "\s. P (ksCurThread s)" @@ -980,12 +784,6 @@ lemma ct_active_st_tcb_at': apply (case_tac st, auto) done -lemma tcbSchedEnqueue_in_ksQ_already_queued_aqtp: - "\\s. valid_queues' s \ tcb_at' t s \ - t' \ all_queued_tcb_ptrs s \ tcbSchedEnqueue t - \\r s. t' \ all_queued_tcb_ptrs s \" - by (clarsimp simp: all_queued_tcb_ptrs_def tcbSchedEnqueue_in_ksQ_already_queued) - (* FIXME move *) lemma invs_switchToThread_runnable': "\ invs' s ; ksSchedulerAction s = SwitchToThread t \ \ st_tcb_at' runnable' t s" @@ -1006,17 +804,16 @@ lemma in_all_active_tcb_ptrsD: done lemma scheduleChooseNewThread_no_orphans: - "\ invs' and no_orphans - and (\s. ksSchedulerAction s = ChooseNewThread - \ (st_tcb_at' runnable' (ksCurThread s) s - \ (\d p. ksCurThread s \ set (ksReadyQueues s (d, p))))) \ + "\invs' and no_orphans + and (\s. ksSchedulerAction s = ChooseNewThread + \ (st_tcb_at' runnable' (ksCurThread s) s \ ksCurThread s \ all_queued_tcb_ptrs s))\ scheduleChooseNewThread - \\_. no_orphans \" + \\_. no_orphans\" unfolding scheduleChooseNewThread_def apply (wp add: ssa_no_orphans hoare_vcg_all_lift) apply (wp hoare_disjI1 chooseThread_nosch)+ apply (wp nextDomain_invs_no_cicd' hoare_vcg_imp_lift - hoare_lift_Pf2 [OF ksQ_all_queued_tcb_ptrs_lift[OF nextDomain_ksQ] + hoare_lift_Pf2 [OF tcbQueued_all_queued_tcb_ptrs_lift[OF nextDomain_tcbQueued] nextDomain_ct'] hoare_lift_Pf2 [OF st_tcb_at'_is_active_tcb_ptr_lift[OF nextDomain_st_tcb_at'] nextDomain_ct'] @@ -1025,24 +822,25 @@ lemma scheduleChooseNewThread_no_orphans: is_active_tcb_ptr_runnable')+ done +lemma setSchedulerAction_tcbQueued[wp]: + "setSchedulerAction sa \\s. Q (obj_at' (\tcb. P (tcbQueued tcb)) tcb_ptr s)\" + by wpsimp + lemma schedule_no_orphans[wp]: notes ssa_wp[wp del] shows - "\ \s. no_orphans s \ invs' s \ - schedule - \ \rv s. no_orphans s \" + "\no_orphans and invs'\ schedule \\_. no_orphans\" proof - have do_switch_to: "\candidate. \\s. no_orphans s \ ksSchedulerAction s = SwitchToThread candidate \ st_tcb_at' runnable' candidate s - \ (st_tcb_at' runnable' (ksCurThread s) s - \ (\d p. ksCurThread s \ set (ksReadyQueues s (d, p)))) \ - do ThreadDecls_H.switchToThread candidate; - setSchedulerAction ResumeCurrentThread - od - \\rv. no_orphans\" + \ (st_tcb_at' runnable' (ksCurThread s) s \ ksCurThread s \ all_queued_tcb_ptrs s) \ + do ThreadDecls_H.switchToThread candidate; + setSchedulerAction ResumeCurrentThread + od + \\_. no_orphans\" apply (wpsimp wp: scheduleChooseNewThread_no_orphans ssa_no_orphans hoare_vcg_all_lift ThreadDecls_H_switchToThread_no_orphans)+ apply (rule_tac Q="\_ s. (t = candidate \ ksCurThread s = candidate) \ @@ -1054,56 +852,43 @@ proof - have abort_switch_to_enq: "\candidate. - \\s. no_orphans s \ invs' s \ valid_queues' s + \\s. no_orphans s \ invs' s \ ksSchedulerAction s = SwitchToThread candidate - \ (st_tcb_at' runnable' (ksCurThread s) s - \ (\d p. ksCurThread s \ set (ksReadyQueues s (d, p)))) \ - do tcbSchedEnqueue candidate; - setSchedulerAction ChooseNewThread; - scheduleChooseNewThread - od - \\rv. no_orphans\" - apply (rule hoare_pre) - apply (wp scheduleChooseNewThread_no_orphans ssa_no_orphans setSchedulerAction_direct) + \ (st_tcb_at' runnable' (ksCurThread s) s \ ksCurThread s \ all_queued_tcb_ptrs s) \ + do tcbSchedEnqueue candidate; + setSchedulerAction ChooseNewThread; + scheduleChooseNewThread + od + \\_. no_orphans\" + apply (wpsimp wp: scheduleChooseNewThread_no_orphans ssa_no_orphans setSchedulerAction_direct) apply (wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_ex_lift - simp: is_active_tcb_ptr_runnable' all_queued_tcb_ptrs_def - | rule hoare_lift_Pf2[where f=ksCurThread, OF setSchedulerAction_ksQ])+ - apply (wp tcbSchedEnqueue_in_ksQ' tcbSchedEnqueue_no_orphans hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift) - apply (wp hoare_lift_Pf2[where f=ksCurThread, OF tcbSchedEnqueue_pred_tcb_at'] - hoare_lift_Pf2[where f=ksCurThread, OF tcbSchedEnqueue_in_ksQ_already_queued] - tcbSchedEnqueue_no_orphans - | strengthen not_pred_tcb_at'_strengthen - | wp (once) hoare_vcg_imp_lift')+ - apply (clarsimp) - apply (frule invs_sch_act_wf', clarsimp simp: pred_tcb_at') - apply (simp add: st_tcb_at_neg' tcb_at_invs') + simp: is_active_tcb_ptr_runnable' all_queued_tcb_ptrs_def + | rule hoare_lift_Pf2[where f=ksCurThread, OF setSchedulerAction_tcbQueued])+ + apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift + | strengthen not_pred_tcb_at'_strengthen + | rule hoare_lift_Pf2[where f=ksCurThread])+ + apply (simp add: st_tcb_at_neg' tcb_at_invs' all_queued_tcb_ptrs_def) done have abort_switch_to_app: "\candidate. - \\s. no_orphans s \ invs' s \ valid_queues' s + \\s. no_orphans s \ invs' s \ ksSchedulerAction s = SwitchToThread candidate \ (st_tcb_at' runnable' (ksCurThread s) s - \ (\d p. ksCurThread s \ set (ksReadyQueues s (d, p))) ) \ - do tcbSchedAppend candidate; - setSchedulerAction ChooseNewThread; - scheduleChooseNewThread - od - \\rv. no_orphans\" - apply (rule hoare_pre) - apply (wp scheduleChooseNewThread_no_orphans ssa_no_orphans setSchedulerAction_direct) + \ ksCurThread s \ all_queued_tcb_ptrs s ) \ + do tcbSchedAppend candidate; + setSchedulerAction ChooseNewThread; + scheduleChooseNewThread + od + \\_. no_orphans\" + apply (wpsimp wp: scheduleChooseNewThread_no_orphans ssa_no_orphans setSchedulerAction_direct) apply (wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_ex_lift - simp: is_active_tcb_ptr_runnable' all_queued_tcb_ptrs_def - | rule hoare_lift_Pf2[where f=ksCurThread, OF setSchedulerAction_ksQ])+ - apply (wp tcbSchedAppend_in_ksQ'' tcbSchedAppend_no_orphans hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift) - apply (wp hoare_lift_Pf2[where f=ksCurThread, OF tcbSchedAppend_pred_tcb_at'] - hoare_lift_Pf2[where f=ksCurThread, OF tcbSchedAppend_in_ksQ_already_queued] - tcbSchedAppend_no_orphans - | strengthen not_pred_tcb_at'_strengthen - | wp (once) hoare_vcg_imp_lift')+ - apply (clarsimp) - apply (frule invs_sch_act_wf', clarsimp simp: pred_tcb_at') - apply (simp add: st_tcb_at_neg' tcb_at_invs') + simp: is_active_tcb_ptr_runnable' all_queued_tcb_ptrs_def + | rule hoare_lift_Pf2[where f=ksCurThread, OF setSchedulerAction_tcbQueued])+ + apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift + | strengthen not_pred_tcb_at'_strengthen + | rule hoare_lift_Pf2[where f=ksCurThread])+ + apply (simp add: st_tcb_at_neg' tcb_at_invs' all_queued_tcb_ptrs_def) done show ?thesis @@ -1111,47 +896,39 @@ proof - supply if_weak_cong[cong] apply (wp, wpc) \ \action = ResumeCurrentThread\ - apply (wp)[1] - \ \action = ChooseNewThread\ - apply (clarsimp simp: when_def scheduleChooseNewThread_def) - apply (wp ssa_no_orphans hoare_vcg_all_lift) - apply (wp hoare_disjI1 chooseThread_nosch) + apply (wp)[1] + \ \action = ChooseNewThread\ + apply (clarsimp simp: when_def scheduleChooseNewThread_def) + apply (wp ssa_no_orphans hoare_vcg_all_lift) + apply (wp hoare_disjI1 chooseThread_nosch) apply (wp nextDomain_invs_no_cicd' hoare_vcg_imp_lift - hoare_lift_Pf2 [OF ksQ_all_queued_tcb_ptrs_lift - [OF nextDomain_ksQ] + hoare_lift_Pf2 [OF tcbQueued_all_queued_tcb_ptrs_lift + [OF nextDomain_tcbQueued] nextDomain_ct'] hoare_lift_Pf2 [OF st_tcb_at'_is_active_tcb_ptr_lift [OF nextDomain_st_tcb_at'] nextDomain_ct'] hoare_vcg_all_lift getDomainTime_wp)[2] - apply ((wp tcbSchedEnqueue_no_orphans tcbSchedEnqueue_in_ksQ' - hoare_drop_imp - | clarsimp simp: all_queued_tcb_ptrs_def - | strengthen all_invs_but_ct_idle_or_in_cur_domain'_strg - | wps tcbSchedEnqueue_ct')+)[1] - apply ((wp tcbSchedEnqueue_no_orphans tcbSchedEnqueue_in_ksQ' + apply wpsimp + apply ((wp tcbSchedEnqueue_no_orphans tcbSchedEnqueue_all_queued_tcb_ptrs' hoare_drop_imp - | clarsimp simp: all_queued_tcb_ptrs_def - | strengthen all_invs_but_ct_idle_or_in_cur_domain'_strg - | wps tcbSchedEnqueue_ct')+)[1] - apply wp[1] + | clarsimp simp: all_queued_tcb_ptrs_def + | strengthen all_invs_but_ct_idle_or_in_cur_domain'_strg + | rule hoare_lift_Pf2[where f=ksCurThread])+)[1] + apply wpsimp \ \action = SwitchToThread candidate\ - apply (clarsimp) + apply clarsimp apply (rename_tac candidate) apply (wpsimp wp: do_switch_to abort_switch_to_enq abort_switch_to_app) (* isHighestPrio *) apply (wp hoare_drop_imps) apply (wp add: tcbSchedEnqueue_no_orphans)+ apply (clarsimp simp: conj_comms cong: conj_cong imp_cong split del: if_split) - apply (wp hoare_lift_Pf2[where f=ksCurThread, OF tcbSchedEnqueue_pred_tcb_at'] - hoare_lift_Pf2[where f=ksCurThread, OF tcbSchedEnqueue_in_ksQ'] - hoare_vcg_imp_lift' + apply (wp hoare_vcg_imp_lift' | strengthen not_pred_tcb_at'_strengthen)+ - - apply (clarsimp simp: comp_def) - apply (frule invs_queues) - apply (clarsimp simp: invs_valid_queues' tcb_at_invs' st_tcb_at_neg' is_active_tcb_ptr_runnable') - apply (fastforce simp: all_invs_but_ct_idle_or_in_cur_domain'_strg invs_switchToThread_runnable') + apply (wps | wpsimp wp: tcbSchedEnqueue_all_queued_tcb_ptrs')+ + apply (fastforce simp: is_active_tcb_ptr_runnable' all_invs_but_ct_idle_or_in_cur_domain'_strg + invs_switchToThread_runnable') done qed @@ -1172,37 +949,33 @@ crunches completeSignal (simp: crunch_simps wp: crunch_wps) lemma possibleSwitchTo_almost_no_orphans [wp]: - "\ \s. almost_no_orphans target s \ valid_queues' s \ st_tcb_at' runnable' target s - \ weak_sch_act_wf (ksSchedulerAction s) s \ + "\\s. almost_no_orphans target s \ st_tcb_at' runnable' target s + \ weak_sch_act_wf (ksSchedulerAction s) s\ possibleSwitchTo target - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding possibleSwitchTo_def - by (wp rescheduleRequired_valid_queues'_weak tcbSchedEnqueue_almost_no_orphans + by (wp tcbSchedEnqueue_almost_no_orphans ssa_almost_no_orphans hoare_weak_lift_imp | wpc | clarsimp | wp (once) hoare_drop_imp)+ lemma possibleSwitchTo_almost_no_orphans': - "\ \s. almost_no_orphans target s \ valid_queues' s \ st_tcb_at' runnable' target s - \ sch_act_wf (ksSchedulerAction s) s \ + "\\s. almost_no_orphans target s \ st_tcb_at' runnable' target s + \ sch_act_wf (ksSchedulerAction s) s \ possibleSwitchTo target - \ \rv s. no_orphans s \" + \\_. no_orphans\" by wp (strengthen sch_act_wf_weak, assumption) +crunches tcbQueueAppend, tcbQueuePrepend + for almost_no_orphans[wp]: "almost_no_orphans tcbPtr" + lemma tcbSchedAppend_almost_no_orphans: - "\ \s. almost_no_orphans thread s \ valid_queues' s \ + "\almost_no_orphans thread\ tcbSchedAppend thread - \ \_ s. no_orphans s \" + \\_. no_orphans\" unfolding tcbSchedAppend_def - apply (wp setQueue_almost_no_orphans_enq[where tcb_ptr=thread] threadSet_no_orphans - | clarsimp simp: unless_def | simp only: subset_insertI)+ - apply (unfold threadGet_def) - apply (wp getObject_tcb_wp | clarsimp)+ - apply (drule obj_at_ko_at', clarsimp) - apply (rule_tac x=ko in exI) - apply (clarsimp simp: almost_no_orphans_def no_orphans_def) - apply (drule queued_in_queue | simp)+ - apply (auto simp: all_queued_tcb_ptrs_def) + apply (wpsimp wp: tcbQueued_update_True_no_orphans threadGet_wp) + apply (fastforce simp: almost_no_orphans_def no_orphans_def all_queued_tcb_ptrs_def obj_at'_def) done lemma no_orphans_is_almost[simp]: @@ -1211,7 +984,6 @@ lemma no_orphans_is_almost[simp]: crunches decDomainTime for no_orphans [wp]: no_orphans - and valid_queues' [wp]: valid_queues' (wp: no_orphans_lift) lemma timerTick_no_orphans [wp]: @@ -1221,28 +993,19 @@ lemma timerTick_no_orphans [wp]: unfolding timerTick_def getDomainTime_def supply if_split[split del] apply (subst threadState_case_if) - apply (wpsimp wp: threadSet_no_orphans threadSet_valid_queues' - threadSet_valid_queues' tcbSchedAppend_almost_no_orphans + apply (wpsimp wp: threadSet_no_orphans tcbSchedAppend_almost_no_orphans threadSet_almost_no_orphans threadSet_no_orphans tcbSchedAppend_sch_act_wf hoare_drop_imp simp: if_apply_def2 | strengthen sch_act_wf_weak)+ - apply (rule_tac Q="\rv s. no_orphans s \ valid_queues' s \ tcb_at' thread s - \ sch_act_wf (ksSchedulerAction s) s" in hoare_post_imp) - apply (clarsimp simp: inQ_def) - apply (wp hoare_drop_imps | clarsimp)+ - apply (auto split: if_split) - done + done lemma handleDoubleFault_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ - handleDoubleFault tptr ex1 ex2 - \ \rv s. no_orphans s \" + "\no_orphans\ handleDoubleFault tptr ex1 ex2 \\_. no_orphans \" unfolding handleDoubleFault_def - apply (wp setThreadState_not_active_no_orphans - | clarsimp simp: is_active_thread_state_def isRestart_def isRunning_def)+ - done + by (wpsimp wp: setThreadState_not_active_no_orphans + simp: is_active_thread_state_def isRestart_def isRunning_def)+ crunches cteInsert, getThreadCallerSlot, getThreadReplySlot for st_tcb' [wp]: "st_tcb_at' (\st. P st) t" @@ -1251,9 +1014,7 @@ crunches cteInsert, getThreadCallerSlot, getThreadReplySlot (wp: crunch_wps) lemma setupCallerCap_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ - setupCallerCap sender receiver gr - \ \rv s. no_orphans s \" + "setupCallerCap sender receiver gr \no_orphans\" unfolding setupCallerCap_def apply (wp setThreadState_not_active_no_orphans hoare_drop_imps | clarsimp simp: is_active_thread_state_def isRestart_def isRunning_def)+ @@ -1268,78 +1029,51 @@ lemma setupCallerCap_almost_no_orphans [wp]: | clarsimp simp: is_active_thread_state_def isRestart_def isRunning_def)+ done +crunches cteInsert, setExtraBadge, setMessageInfo, transferCaps, copyMRs, + doNormalTransfer, doFaultTransfer, copyGlobalMappings, + invalidateHWASIDEntry, invalidateASID, invalidateASIDEntry + for tcbQueued[wp]: "obj_at' (\tcb. P (tcbQueued tcb)) tcb_ptr" + (wp: crunch_wps simp: crunch_simps) + crunches doIPCTransfer, setMRs, setEndpoint for ksReadyQueues [wp]: "\s. P (ksReadyQueues s)" and no_orphans [wp]: "no_orphans" - (wp: transferCapsToSlots_pres1 crunch_wps no_orphans_lift setObject_queues_unchanged_tcb - updateObject_default_inv) + (wp: no_orphans_lift updateObject_default_inv) lemma sendIPC_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s \ + "\\s. no_orphans s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s\ sendIPC blocking call badge canGrant canGrantReply thread epptr - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding sendIPC_def apply (wp hoare_drop_imps setThreadState_not_active_no_orphans sts_st_tcb' possibleSwitchTo_almost_no_orphans' | wpc | clarsimp simp: is_active_thread_state_def isRestart_def isRunning_def)+ - - apply (rule_tac Q="\rv. no_orphans and valid_queues' and valid_objs' and ko_at' rv epptr + apply (rule_tac Q="\rv. no_orphans and valid_objs' and ko_at' rv epptr and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) apply (fastforce simp: valid_objs'_def valid_obj'_def valid_ep'_def obj_at'_def projectKOs) apply (wp get_ep_sp' | clarsimp)+ done lemma sendFaultIPC_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s \ + "\\s. no_orphans s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s\ sendFaultIPC tptr fault - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding sendFaultIPC_def apply (rule hoare_pre) - apply (wp threadSet_valid_queues' threadSet_no_orphans threadSet_valid_objs' + apply (wp threadSet_no_orphans threadSet_valid_objs' threadSet_sch_act | wpc | clarsimp)+ - apply (rule_tac Q'="\handlerCap s. no_orphans s \ valid_queues' s - \ valid_objs' s - \ sch_act_wf (ksSchedulerAction s) s" - in hoare_post_imp_R) - apply (wp | clarsimp simp: inQ_def valid_tcb'_def tcb_cte_cases_def)+ - done - -lemma sendIPC_valid_queues' [wp]: - "\ \s. valid_queues' s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s \ - sendIPC blocking call badge canGrant canGrantReply thread epptr - \ \rv s. valid_queues' s \" - unfolding sendIPC_def - apply (wpsimp wp: hoare_drop_imps) - apply (wpsimp | wp (once) sts_st_tcb' hoare_drop_imps)+ - apply (rule_tac Q="\rv. valid_queues' and valid_objs' and ko_at' rv epptr - and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) - apply (clarsimp) - apply (wp get_ep_sp' | clarsimp)+ - done - -lemma sendFaultIPC_valid_queues' [wp]: - "\ \s. valid_queues' s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s \ - sendFaultIPC tptr fault - \ \rv s. valid_queues' s \" - unfolding sendFaultIPC_def - apply (rule hoare_pre) - apply (wp threadSet_valid_queues' threadSet_valid_objs' threadSet_sch_act - | wpc | clarsimp)+ - apply (rule_tac Q'="\handlerCap s. valid_queues' s \ valid_objs' s - \ sch_act_wf (ksSchedulerAction s) s" - in hoare_post_imp_R) + apply (rule_tac Q'="\_ s. no_orphans s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s" + in hoare_post_imp_R) apply (wp | clarsimp simp: inQ_def valid_tcb'_def tcb_cte_cases_def)+ done -lemma handleFault_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s \ +lemma handleFault_no_orphans[wp]: + "\\s. no_orphans s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s\ handleFault tptr ex1 - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding handleFault_def - apply (rule hoare_pre) - apply (wp | clarsimp)+ - done + by wpsimp lemma replyFromKernel_no_orphans [wp]: "\ \s. no_orphans s \ @@ -1357,32 +1091,24 @@ crunch ksReadyQueues [wp]: createNewCaps "\ s. P (ksReadyQueues s)" crunch inv [wp]: alignError "P" -lemma createObjects_no_orphans [wp]: - "\ \s. no_orphans s \ pspace_aligned' s \ pspace_no_overlap' ptr sz s \ pspace_distinct' s - \ n \ 0 \ range_cover ptr sz (objBitsKO val + gbits) n - \ \ case_option False (is_active_thread_state \ tcbState) (projectKO_opt val) \ +lemma createObjects_no_orphans[wp]: + "\\s. no_orphans s \ pspace_aligned' s \ pspace_no_overlap' ptr sz s \ pspace_distinct' s + \ n \ 0 \ range_cover ptr sz (objBitsKO val + gbits) n + \ \ case_option False (is_active_thread_state \ tcbState) (projectKO_opt val) + \ \ case_option False tcbQueued (projectKO_opt val)\ createObjects ptr n val gbits - \ \rv s. no_orphans s \" + \\_ s. no_orphans s\" apply (clarsimp simp: no_orphans_def all_active_tcb_ptrs_def is_active_tcb_ptr_def all_queued_tcb_ptrs_def) apply (simp only: imp_conv_disj pred_tcb_at'_def createObjects_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift createObjects_orig_obj_at2') + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift createObjects_orig_obj_at2'[where sz=sz]) apply clarsimp - apply (erule(1) impE) - apply clarsimp - apply (drule_tac x = x in spec) - apply (erule impE) - apply (clarsimp simp:obj_at'_def projectKOs split: option.splits) - apply simp done -lemma copyGlobalMappings_no_orphans [wp]: - "\ \s. no_orphans s \ - copyGlobalMappings newPD - \ \rv s. no_orphans s \" +lemma copyGlobalMappings_no_orphans[wp]: + "copyGlobalMappings newPD \no_orphans\" unfolding no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - done + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift) crunch no_orphans [wp]: insertNewCap "no_orphans" (wp: hoare_drop_imps) @@ -1527,45 +1253,47 @@ lemma mapM_x_match: "\I and V xs\ mapM_x m xs \\rv. Q\ \ \I and V xs\ mapM_x m xs \\rv. Q\" by assumption -lemma cancelAllIPC_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ +lemma cancelAllIPC_no_orphans[wp]: + "\\s. no_orphans s \ valid_objs' s \ pspace_aligned' s \ pspace_distinct' s\ cancelAllIPC epptr - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding cancelAllIPC_def apply (wp sts_valid_objs' set_ep_valid_objs' sts_st_tcb' hoare_vcg_const_Ball_lift tcbSchedEnqueue_almost_no_orphans | wpc | rule mapM_x_match, rename_tac list, - rule_tac V="\_. valid_queues' and valid_objs'" + rule_tac V="\_. valid_objs' and pspace_aligned' and pspace_distinct'" and I="no_orphans and (\s. \t\set list. tcb_at' t s)" in mapM_x_inv_wp2 | clarsimp simp: valid_tcb_state'_def)+ - apply (rule_tac Q="\rv. no_orphans and valid_objs' and valid_queues' and ko_at' rv epptr" - in hoare_post_imp) + apply (rule_tac Q="\rv. no_orphans and valid_objs' and pspace_aligned' and pspace_distinct' + and ko_at' rv epptr" + in hoare_post_imp) apply (fastforce simp: valid_obj'_def valid_ep'_def obj_at'_def projectKOs) apply (wp get_ep_sp' | clarsimp)+ done -lemma cancelAllSignals_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ +lemma cancelAllSignals_no_orphans[wp]: + "\\s. no_orphans s \ valid_objs' s \ pspace_aligned' s \ pspace_distinct' s\ cancelAllSignals ntfn - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding cancelAllSignals_def apply (wp sts_valid_objs' set_ntfn_valid_objs' sts_st_tcb' hoare_vcg_const_Ball_lift tcbSchedEnqueue_almost_no_orphans | wpc | clarsimp simp: valid_tcb_state'_def)+ apply (rename_tac list) - apply (rule_tac V="\_. valid_queues' and valid_objs'" + apply (rule_tac V="\_. valid_objs' and pspace_aligned' and pspace_distinct'" and I="no_orphans and (\s. \t\set list. tcb_at' t s)" in mapM_x_inv_wp2) apply simp apply (wp sts_valid_objs' set_ntfn_valid_objs' sts_st_tcb' hoare_vcg_const_Ball_lift tcbSchedEnqueue_almost_no_orphans| clarsimp simp: valid_tcb_state'_def)+ - apply (rule_tac Q="\rv. no_orphans and valid_objs' and valid_queues' and ko_at' rv ntfn" - in hoare_post_imp) + apply (rule_tac Q="\rv. no_orphans and valid_objs' and pspace_aligned' and pspace_distinct' + and ko_at' rv ntfn" + in hoare_post_imp) apply (fastforce simp: valid_obj'_def valid_ntfn'_def obj_at'_def projectKOs) apply (wp get_ntfn_sp' | clarsimp)+ done @@ -1590,78 +1318,63 @@ lemma unbindMaybeNotification_no_orphans[wp]: unfolding unbindMaybeNotification_def by (wp getNotification_wp | simp | wpc)+ -lemma finaliseCapTrue_standin_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ - finaliseCapTrue_standin cap final - \ \rv s. no_orphans s \" +lemma finaliseCapTrue_standin_no_orphans[wp]: + "\no_orphans and valid_objs' and pspace_aligned' and pspace_distinct'\ + finaliseCapTrue_standin cap final + \\_. no_orphans\" unfolding finaliseCapTrue_standin_def - apply (rule hoare_pre) - apply (wp | clarsimp simp: Let_def | wpc)+ - done + by (wpsimp | clarsimp simp: Let_def | wpc)+ -lemma cteDeleteOne_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ +lemma cteDeleteOne_no_orphans[wp]: + "\no_orphans and valid_objs' and pspace_aligned' and pspace_distinct'\ cteDeleteOne slot - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding cteDeleteOne_def - apply (wp assert_inv isFinalCapability_inv weak_if_wp | clarsimp simp: unless_def)+ - done + by (wp assert_inv isFinalCapability_inv weak_if_wp | clarsimp simp: unless_def)+ crunch valid_objs' [wp]: getThreadReplySlot "valid_objs'" -lemma cancelSignal_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ - cancelSignal t ntfn - \ \rv s. no_orphans s \" +lemma cancelSignal_no_orphans[wp]: + "cancelSignal t ntfn \no_orphans\" unfolding cancelSignal_def Let_def - apply (rule hoare_pre) - apply (wp hoare_drop_imps setThreadState_not_active_no_orphans | wpc - | clarsimp simp: is_active_thread_state_def isRestart_def isRunning_def)+ - done + by (wpsimp wp: hoare_drop_imps setThreadState_not_active_no_orphans + simp: is_active_thread_state_def isRestart_def isRunning_def) lemma cancelIPC_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ + "\no_orphans and valid_objs' and pspace_aligned' and pspace_distinct'\ cancelIPC t - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding cancelIPC_def Let_def apply (rule hoare_pre) apply (wp setThreadState_not_active_no_orphans hoare_drop_imps weak_if_wp - threadSet_valid_queues' threadSet_valid_objs' threadSet_no_orphans | wpc + threadSet_valid_objs' threadSet_no_orphans | wpc | clarsimp simp: is_active_thread_state_def isRestart_def isRunning_def inQ_def valid_tcb'_def tcb_cte_cases_def)+ done - lemma asUser_almost_no_orphans: "\almost_no_orphans t\ asUser a f \\_. almost_no_orphans t\" unfolding almost_no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - done - -crunch almost_no_orphans[wp]: asUser "almost_no_orphans t" - (simp: almost_no_orphans_disj all_queued_tcb_ptrs_def wp: hoare_vcg_all_lift hoare_vcg_disj_lift crunch_wps) + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift) -lemma sendSignal_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s\ +lemma sendSignal_no_orphans[wp]: + "\\s. no_orphans s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s + \ pspace_aligned' s \ pspace_distinct' s\ sendSignal ntfnptr badge - \ \_ s. no_orphans s \" + \\_. no_orphans\" unfolding sendSignal_def - apply (rule hoare_pre) - apply (wp sts_st_tcb' gts_wp' getNotification_wp asUser_almost_no_orphans - cancelIPC_weak_sch_act_wf - | wpc | clarsimp simp: sch_act_wf_weak)+ + apply (wp sts_st_tcb' gts_wp' getNotification_wp asUser_almost_no_orphans + cancelIPC_weak_sch_act_wf + | wpc | clarsimp simp: sch_act_wf_weak)+ done -lemma handleInterrupt_no_orphans [wp]: - "\ \s. no_orphans s \ invs' s \ +lemma handleInterrupt_no_orphans[wp]: + "\no_orphans and invs' and pspace_aligned' and pspace_distinct'\ handleInterrupt irq - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding handleInterrupt_def - apply (rule hoare_pre) - apply (wp hoare_drop_imps hoare_vcg_all_lift getIRQState_inv - | wpc | clarsimp simp: invs'_def valid_state'_def maskIrqSignal_def - handleReservedIRQ_def)+ - done + by (wp hoare_drop_imps hoare_vcg_all_lift getIRQState_inv + | wpc | clarsimp simp: invs'_def valid_state'_def maskIrqSignal_def handleReservedIRQ_def)+ lemma updateRestartPC_no_orphans[wp]: "\ \s. no_orphans s \ invs' s \ @@ -1669,20 +1382,6 @@ lemma updateRestartPC_no_orphans[wp]: \ \rv s. no_orphans s \" by (wpsimp simp: updateRestartPC_def asUser_no_orphans) -lemma updateRestartPC_valid_queues'[wp]: - "\ \s. valid_queues' s \ - updateRestartPC t - \ \rv s. valid_queues' s \" - unfolding updateRestartPC_def - apply (rule asUser_valid_queues') - done - -lemma updateRestartPC_no_orphans_invs'_valid_queues'[wp]: - "\\s. no_orphans s \ invs' s \ valid_queues' s \ - updateRestartPC t - \\rv s. no_orphans s \ valid_queues' s \" - by (wpsimp simp: updateRestartPC_def asUser_no_orphans) - lemma suspend_no_orphans [wp]: "\ \s. no_orphans s \ invs' s \ sch_act_simple s \ tcb_at' t s \ suspend t @@ -1696,49 +1395,34 @@ lemma suspend_no_orphans [wp]: apply auto done -lemma storeHWASID_no_orphans [wp]: - "\ \s. no_orphans s \ - storeHWASID asid hw_asid - \ \reply s. no_orphans s \" +lemma storeHWASID_no_orphans[wp]: + "storeHWASID asid hw_asid \no_orphans\" unfolding no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - done + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift) -lemma invalidateHWASIDEntry_no_orphans [wp]: - "\ \s. no_orphans s \ - invalidateHWASIDEntry hwASID - \ \reply s. no_orphans s \" +lemma invalidateHWASIDEntry_no_orphans[wp]: + "invalidateHWASIDEntry hwASID \no_orphans\" unfolding no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - done + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift) -lemma invalidateASID_no_orphans [wp]: - "\ \s. no_orphans s \ - invalidateASID asid - \ \reply s. no_orphans s \" +lemma invalidateASID_no_orphans[wp]: + "invalidateASID asid \no_orphans\" unfolding no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - done + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift) -lemma findFreeHWASID_no_orphans [wp]: - "\ \s. no_orphans s \ - findFreeHWASID - \ \reply s. no_orphans s \" +lemma findFreeHWASID_no_orphans[wp]: + "findFreeHWASID \no_orphans\" unfolding no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - done + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift) crunch ksCurThread [wp]: invalidateASIDEntry "\ s. P (ksCurThread s)" crunch ksReadyQueues[wp]: invalidateASIDEntry "\s. P (ksReadyQueues s)" -lemma invalidateASIDEntry_no_orphans [wp]: - "\ \s. no_orphans s \ - invalidateASIDEntry asid - \ \rv s. no_orphans s \" +lemma invalidateASIDEntry_no_orphans[wp]: + "invalidateASIDEntry asid \no_orphans\" unfolding no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - done + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift) crunch no_orphans [wp]: flushSpace "no_orphans" @@ -1754,21 +1438,15 @@ lemma deleteASIDPool_no_orphans [wp]: apply (wp mapM_wp_inv getObject_inv loadObject_default_inv | clarsimp)+ done -lemma storePTE_no_orphans [wp]: - "\ \s. no_orphans s \ - storePTE ptr val - \ \rv s. no_orphans s \" +lemma storePTE_no_orphans[wp]: + "storePTE ptr val \no_orphans\" unfolding no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - done + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift) lemma storePDE_no_orphans [wp]: - "\ \s. no_orphans s \ - storePDE ptr val - \ \rv s. no_orphans s \" + "storePDE ptr val \no_orphans\" unfolding no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - done + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift) crunches unmapPage for no_orphans [wp]: "no_orphans" @@ -1785,13 +1463,10 @@ lemma flushTable_no_orphans [wp]: crunches unmapPageTable, prepareThreadDelete for no_orphans [wp]: "no_orphans" -lemma setASIDPool_no_orphans [wp]: - "\ \s. no_orphans s \ - setObject p (ap :: asidpool) - \ \rv s. no_orphans s \" +lemma setASIDPool_no_orphans[wp]: + "setObject p (ap :: asidpool) \no_orphans\" unfolding no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - done + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift) lemma deleteASID_no_orphans [wp]: "\ \s. no_orphans s \ @@ -1879,9 +1554,7 @@ lemma cteRevoke_no_orphans [wp]: done lemma cancelBadgedSends_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ - cancelBadgedSends epptr badge - \ \rv s. no_orphans s \" + "cancelBadgedSends epptr badge \no_orphans\" unfolding cancelBadgedSends_def apply (wpsimp wp: filterM_preserved tcbSchedEnqueue_almost_no_orphans gts_wp' sts_st_tcb' | wp (once) hoare_drop_imps)+ @@ -1891,38 +1564,25 @@ crunch no_orphans [wp]: invalidateTLBByASID "no_orphans" crunch no_orphans [wp]: handleFaultReply "no_orphans" -crunch valid_queues' [wp]: handleFaultReply "valid_queues'" - lemma doReplyTransfer_no_orphans[wp]: "\no_orphans and invs' and tcb_at' sender and tcb_at' receiver\ doReplyTransfer sender receiver slot grant \\rv. no_orphans\" unfolding doReplyTransfer_def apply (wp sts_st_tcb' setThreadState_not_active_no_orphans threadSet_no_orphans - threadSet_valid_queues' threadSet_weak_sch_act_wf + threadSet_weak_sch_act_wf | wpc | clarsimp simp: is_active_thread_state_def isRunning_def isRestart_def | wp (once) hoare_drop_imps - | strengthen sch_act_wf_weak invs_valid_queues')+ + | strengthen sch_act_wf_weak)+ apply (rule_tac Q="\rv. invs' and no_orphans" in hoare_post_imp) apply (fastforce simp: inQ_def) apply (wp hoare_drop_imps | clarsimp)+ apply (clarsimp simp:invs'_def valid_state'_def valid_pspace'_def) done -lemma cancelSignal_valid_queues' [wp]: - "\ \s. valid_queues' s \ valid_objs' s \ - cancelSignal t ntfn - \ \rv s. valid_queues' s \" - unfolding cancelSignal_def Let_def - apply (rule hoare_pre) - apply (wp hoare_drop_imps | wpc | clarsimp)+ - done - crunch no_orphans [wp]: setupReplyMaster "no_orphans" (wp: crunch_wps simp: crunch_simps) -crunch valid_queues' [wp]: setupReplyMaster "valid_queues'" - lemma restart_no_orphans [wp]: "\ \s. no_orphans s \ invs' s \ sch_act_simple s \ tcb_at' t s \ restart t @@ -1931,7 +1591,6 @@ lemma restart_no_orphans [wp]: apply (wp tcbSchedEnqueue_almost_no_orphans sts_st_tcb' cancelIPC_weak_sch_act_wf | clarsimp simp: o_def if_apply_def2 | strengthen no_orphans_strg_almost - | strengthen invs_valid_queues' | wp (once) hoare_drop_imps)+ apply auto done @@ -1953,8 +1612,7 @@ lemma writereg_no_orphans: apply simp apply (rule hoare_pre) by (wp hoare_vcg_if_lift hoare_vcg_conj_lift restart_invs' hoare_weak_lift_imp - | strengthen invs_valid_queues' | clarsimp simp: invs'_def valid_state'_def dest!: global'_no_ex_cap )+ - + | strengthen | clarsimp simp: invs'_def valid_state'_def dest!: global'_no_ex_cap)+ lemma copyreg_no_orphans: "\ \s. no_orphans s \ invs' s \ sch_act_simple s \ tcb_at' src s @@ -1969,7 +1627,7 @@ lemma copyreg_no_orphans: | wpc | clarsimp split del: if_splits)+ apply (wp hoare_weak_lift_imp hoare_vcg_conj_lift hoare_drop_imp mapM_x_wp' restart_invs' restart_no_orphans asUser_no_orphans suspend_nonz_cap_to_tcb - | strengthen invs_valid_queues' | wpc | simp add: if_apply_def2)+ + | wpc | simp add: if_apply_def2)+ apply (fastforce simp: invs'_def valid_state'_def dest!: global'_no_ex_cap) done @@ -1991,22 +1649,19 @@ lemma almost_no_orphans_no_orphans': "\ almost_no_orphans t s; ksCurThread s = t\ \ no_orphans s" by (auto simp: almost_no_orphans_def no_orphans_def all_active_tcb_ptrs_def) -lemma setPriority_no_orphans [wp]: - "\ \s. no_orphans s \ invs' s \ tcb_at' tptr s \ +lemma setPriority_no_orphans[wp]: + "\no_orphans and invs' and tcb_at' tptr\ setPriority tptr prio - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding setPriority_def apply wpsimp - apply (rule_tac Q="\rv s. almost_no_orphans tptr s \ valid_queues' s \ weak_sch_act_wf (ksSchedulerAction s) s" in hoare_post_imp) + apply (rule_tac Q="\_ s. almost_no_orphans tptr s \ weak_sch_act_wf (ksSchedulerAction s) s" in hoare_post_imp) apply clarsimp apply (clarsimp simp: is_active_tcb_ptr_runnable' pred_tcb_at'_def obj_at'_def almost_no_orphans_no_orphans elim!: almost_no_orphans_no_orphans') - apply (wp threadSet_almost_no_orphans threadSet_valid_queues' | clarsimp simp: inQ_def)+ + apply (wp threadSet_almost_no_orphans | clarsimp simp: inQ_def)+ apply (wpsimp wp: threadSet_weak_sch_act_wf) apply (wp tcbSchedDequeue_almost_no_orphans| clarsimp)+ - apply (rule_tac Q="\rv. obj_at' (Not \ tcbQueued) tptr and invs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) - apply (clarsimp simp: obj_at'_def inQ_def) - apply (wp tcbSchedDequeue_not_queued | clarsimp)+ done lemma setMCPriority_no_orphans[wp]: @@ -2058,7 +1713,6 @@ lemma tc_no_orphans: checkCap_inv[where P=no_orphans] checkCap_inv[where P="tcb_at' a"] threadSet_cte_wp_at' hoare_vcg_all_lift_R hoare_vcg_all_lift threadSet_no_orphans hoare_vcg_const_imp_lift_R hoare_weak_lift_imp hoare_drop_imp threadSet_ipcbuffer_invs - | strengthen invs_valid_queues' | (simp add: locateSlotTCB_def locateSlotBasic_def objBits_def objBitsKO_def tcbIPCBufferSlot_def tcb_cte_cases_def, wp hoare_return_sp) @@ -2089,13 +1743,12 @@ lemma invokeTCB_no_orphans [wp]: done lemma invokeCNode_no_orphans [wp]: - "\ \s. no_orphans s \ invs' s \ valid_cnode_inv' cinv s \ sch_act_simple s \ + "\no_orphans and invs' and valid_cnode_inv' cinv and sch_act_simple\ invokeCNode cinv - \ \rv. no_orphans \" + \\_. no_orphans\" unfolding invokeCNode_def apply (rule hoare_pre) apply (wp hoare_drop_imps unless_wp | wpc | clarsimp split del: if_split)+ - apply (simp add: invs_valid_queues') done lemma invokeIRQControl_no_orphans [wp]: @@ -2238,17 +1891,15 @@ lemma arch_performInvocation_no_orphans [wp]: done lemma setDomain_no_orphans [wp]: - "\no_orphans and valid_queues and valid_queues' and cur_tcb'\ - setDomain tptr newdom + "\no_orphans and cur_tcb' and tcb_at' tptr\ + setDomain tptr newdom \\_. no_orphans\" apply (simp add: setDomain_def when_def) apply (wp tcbSchedEnqueue_almost_no_orphans hoare_vcg_imp_lift threadSet_almost_no_orphans - threadSet_valid_queues'_no_state threadSet_st_tcb_at2 hoare_vcg_disj_lift + threadSet_st_tcb_at2 hoare_vcg_disj_lift threadSet_no_orphans - | clarsimp simp: st_tcb_at_neg2 not_obj_at')+ - apply (auto simp: tcb_at_typ_at' st_tcb_at_neg' is_active_tcb_ptr_runnable' - cur_tcb'_def obj_at'_def - dest: pred_tcb_at') + | clarsimp simp: st_tcb_at_neg2 not_obj_at')+ + apply (fastforce simp: tcb_at_typ_at' is_active_tcb_ptr_runnable') done crunch no_orphans[wp]: InterruptDecls_H.invokeIRQHandler no_orphans @@ -2277,8 +1928,6 @@ lemma K_bind_hoareE [wp]: "\P\ f \Q\,\E\ \ \P\ K_bind f x \Q\,\E\" by simp -crunch valid_queues' [wp]: replyFromKernel "valid_queues'" - lemma handleInvocation_no_orphans [wp]: "\ \s. no_orphans s \ invs' s \ vs_valid_duplicates' (ksPSpace s) \ ct_active' s \ ksSchedulerAction s = ResumeCurrentThread \ @@ -2296,20 +1945,12 @@ lemma handleInvocation_no_orphans [wp]: ct_in_state'_set setThreadState_st_tcb hoare_vcg_all_lift | simp add: split_def split del: if_split)+ - apply (wps setThreadState_ct') - apply (wp sts_ksQ - setThreadState_current_no_orphans sts_invs_minor' - ct_in_state'_set setThreadState_st_tcb - | simp add: split_def split del: if_split)+ apply (clarsimp simp: if_apply_def2) - apply (frule(1) ct_not_ksQ) by (auto simp: ct_in_state'_def pred_tcb_at'_def obj_at'_def invs'_def cur_tcb'_def valid_state'_def valid_idle'_def) lemma receiveSignal_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ - receiveSignal thread cap isBlocking - \ \rv s. no_orphans s \" + "receiveSignal thread cap isBlocking \no_orphans\" unfolding receiveSignal_def apply (wp hoare_drop_imps setThreadState_not_active_no_orphans | wpc | clarsimp simp: is_active_thread_state_def isRunning_def isRestart_def @@ -2327,7 +1968,7 @@ lemma receiveIPC_no_orphans [wp]: hoare_vcg_all_lift sts_st_tcb' | wpc | clarsimp simp: is_active_thread_state_def isRunning_def isRestart_def - doNBRecvFailedTransfer_def invs_valid_queues' + doNBRecvFailedTransfer_def | strengthen sch_act_wf_weak)+ done @@ -2418,7 +2059,8 @@ theorem callKernel_no_orphans [wp]: callKernel e \ \rv s. no_orphans s \" unfolding callKernel_def - by (wpsimp wp: weak_if_wp schedule_invs' hoare_drop_imps) + by (wpsimp wp: weak_if_wp schedule_invs' hoare_drop_imps + | strengthen invs_pspace_aligned' invs_pspace_distinct')+ end diff --git a/proof/refine/ARM_HYP/ADT_H.thy b/proof/refine/ARM_HYP/ADT_H.thy index f4ef312901..5deb5ff44c 100644 --- a/proof/refine/ARM_HYP/ADT_H.thy +++ b/proof/refine/ARM_HYP/ADT_H.thy @@ -482,7 +482,7 @@ proof - apply (intro conjI impI allI) apply (erule pspace_dom_relatedE[OF _ pspace_relation]) apply clarsimp - apply (case_tac ko, simp_all add: other_obj_relation_def) + 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) @@ -495,7 +495,7 @@ proof - apply (clarsimp split: if_split_asm)+ apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko, simp_all add: other_obj_relation_def) + 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) @@ -508,7 +508,7 @@ proof - apply (clarsimp split: if_split_asm)+ apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko, simp_all add: other_obj_relation_def) + 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) @@ -517,7 +517,7 @@ proof - apply (clarsimp split: if_split_asm)+ apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko, simp_all add: other_obj_relation_def) + 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) @@ -543,7 +543,7 @@ proof - 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: other_obj_relation_def) + 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) @@ -569,7 +569,7 @@ proof - 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: other_obj_relation_def) + 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) @@ -596,7 +596,7 @@ proof - 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: other_obj_relation_def + 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) @@ -660,7 +660,7 @@ proof - (* mapping architecture-specific objects *) apply clarsimp apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko, simp_all add: other_obj_relation_def) + 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) @@ -804,7 +804,7 @@ shows apply (case_tac "ksPSpace s' x", clarsimp) apply (erule_tac x=x in allE, clarsimp) apply clarsimp - apply (case_tac a, simp_all add: other_obj_relation_def) + 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) @@ -848,7 +848,7 @@ lemma TCB_implies_KOTCB: apply (clarsimp simp add: pspace_relation_def pspace_dom_def dom_def UNION_eq Collect_eq) apply (erule_tac x=a in allE)+ - apply (clarsimp simp add: other_obj_relation_def + apply (clarsimp simp add: tcb_relation_cut_def split: Structures_H.kernel_object.splits) apply (drule iffD1) apply (fastforce simp add: dom_def image_def) @@ -1638,7 +1638,7 @@ definition domain_index_internal = ksDomScheduleIdx s, cur_domain_internal = ksCurDomain s, domain_time_internal = ksDomainTime s, - ready_queues_internal = curry (ksReadyQueues 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: @@ -1646,12 +1646,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 absEkheap_correct - absCDTList_correct[THEN fun_cong] state_relation_def invs_def valid_state_def - ready_queues_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) + 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 diff --git a/proof/refine/ARM_HYP/ArchAcc_R.thy b/proof/refine/ARM_HYP/ArchAcc_R.thy index 81edd38ee9..66b7ea8871 100644 --- a/proof/refine/ARM_HYP/ArchAcc_R.thy +++ b/proof/refine/ARM_HYP/ArchAcc_R.thy @@ -934,12 +934,16 @@ lemma setObject_PD_corres [corres]: apply (drule(1) ekheap_kheap_dom) apply clarsimp apply (drule_tac x=p in bspec, erule domI) - apply (simp add: other_obj_relation_def + apply (simp add: tcb_relation_cut_def split: Structures_A.kernel_object.splits) - apply (rule conjI) + 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 + apply (extract_conjunct \match conclusion in "ready_queues_relation_2 _ _ _ _ _" \ -\) + apply (prop_tac "typ_at' (koTypeOf (injectKO pde')) p b") + apply (simp add: typ_at'_def ko_wp_at'_def) + subgoal by (fastforce dest: tcbs_of'_non_tcb_update) apply (simp add: map_to_ctes_upd_other) apply (simp add: fun_upd_def) apply (simp add: caps_of_state_after_update obj_at_def swp_cte_at_caps_of) @@ -1010,12 +1014,15 @@ lemma setObject_PT_corres [corres]: apply (drule(1) ekheap_kheap_dom) apply clarsimp apply (drule_tac x=p in bspec, erule domI) - apply (simp add: other_obj_relation_def - split: Structures_A.kernel_object.splits) - apply (rule conjI) + 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 + apply (extract_conjunct \match conclusion in "ready_queues_relation_2 _ _ _ _ _" \ -\) + apply (prop_tac "typ_at' (koTypeOf (injectKO pte')) p b") + apply (simp add: typ_at'_def ko_wp_at'_def) + subgoal by (fastforce dest: tcbs_of'_non_tcb_update) apply (simp add: map_to_ctes_upd_other) apply (simp add: fun_upd_def) apply (simp add: caps_of_state_after_update obj_at_def swp_cte_at_caps_of) @@ -1683,5 +1690,166 @@ lemma dmo_clearMemory_invs'[wp]: apply fastforce done +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) + + \\TCB\ + apply (clarsimp simp: tcbBlockSizeBits_def elim!: is_aligned_weaken) + + \\PageTable\ + apply (clarsimp simp: archObjSize_def pteBits_def) + apply (rule is_aligned_add) + apply (erule is_aligned_weaken) + apply (simp add: vspace_bits_defs) + apply (rule is_aligned_shift) + + \\PageDirectory\ + apply (clarsimp simp: archObjSize_def vspace_bits_defs) + 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 (rule pbfs_atleast_pageBits) + apply (fastforce intro: is_aligned_shift is_aligned_mult_triv2) + + \\other_obj_relation\ + apply (simp add: other_obj_relation_def) + by (clarsimp simp: 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) + +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 bit_simps 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_def2) + 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=tcbBlockSizeBits in exI) + apply (simp add: tcbBlockSizeBits_def) + apply (rule_tac x=pteBits in exI) + apply (simp add: bit_simps is_aligned_shift mask_def vspace_bits_defs) + apply word_bitwise + apply (rule_tac x=pdeBits in exI) + apply (simp add: bit_simps is_aligned_shift mask_def vspace_bits_defs) + 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 + pbfs_atleast_pageBits[simplified bit_simps] archObjSize_def pteBits_def + pdeBits_def) + apply (simp add: vspace_bits_defs) + apply (simp add: vspace_bits_defs) + apply (cases ko; simp add: other_obj_relation_def objBits_defs + split: kernel_object.splits) + apply (rename_tac ako', case_tac ako'; + clarsimp simp: archObjSize_def vspace_bits_defs vcpu_bits_def + split: arch_kernel_object.splits) + done + +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 (rule ps_clearI, assumption) + apply (case_tac ko'; simp add: objBits_simps objBits_defs obj_at_simps) + apply (simp split: arch_kernel_object.splits + add: obj_at_simps pteBits_def pdeBits_def vspace_bits_defs vcpu_bits_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_def2 objBits_simps) + apply (rule_tac n=cte_level_bits in is_aligned_add_step_le'; assumption?) + apply (rule is_aligned_add; (rule is_aligned_shift)?) + apply (erule is_aligned_weaken, simp add: cte_level_bits_def) + apply (rule is_aligned_add; (rule is_aligned_shift)?) + apply (erule is_aligned_weaken, simp add: cte_level_bits_def) + apply (simp add: cte_level_bits_def cteSizeBits_def) + apply (clarsimp simp: pte_relation_def objBits_simps archObjSize_def) + apply (rule_tac n=pteBits in is_aligned_add_step_le'; + simp add: vspace_bits_defs vcpu_bits_def) + apply (clarsimp simp: pde_relation_def objBits_simps archObjSize_def) + apply (rule_tac n=pdeBits in is_aligned_add_step_le'; simp add: vspace_bits_defs vcpu_bits_def) + 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 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) + done + end end diff --git a/proof/refine/ARM_HYP/Arch_R.thy b/proof/refine/ARM_HYP/Arch_R.thy index 8a1d041ee0..aa18bcee18 100644 --- a/proof/refine/ARM_HYP/Arch_R.thy +++ b/proof/refine/ARM_HYP/Arch_R.thy @@ -338,7 +338,7 @@ lemma performASIDControlInvocation_corres: apply (simp add:pageBits_def) apply clarsimp apply (drule(1) cte_cap_in_untyped_range) - apply (fastforce simp:cte_wp_at_ctes_of) + apply (fastforce simp: cte_wp_at_ctes_of) apply assumption+ apply fastforce apply simp @@ -1286,8 +1286,9 @@ lemma invokeVCPUWriteReg_corres: done lemma archThreadSet_VCPU_Some_corres[corres]: - "corres dc (tcb_at t) (tcb_at' t) - (arch_thread_set (tcb_vcpu_update (\_. Some v)) t) (archThreadSet (atcbVCPUPtr_update (\_. Some v)) t)" + "corres dc (tcb_at t and pspace_aligned and pspace_distinct) \ + (arch_thread_set (tcb_vcpu_update (\_. Some v)) t) + (archThreadSet (atcbVCPUPtr_update (\_. Some v)) t)" apply (rule archThreadSet_corres) apply (simp add: arch_tcb_relation_def) done @@ -1325,7 +1326,7 @@ lemma associateVCPUTCB_corres: apply (clarsimp simp: vcpu_relation_def) apply (rule conjI) apply (frule (1) sym_refs_vcpu_tcb, fastforce) - apply (clarsimp simp: obj_at_def)+ + apply (fastforce simp: obj_at_def)+ apply (wpsimp)+ apply (rule_tac Q="\_. invs' and tcb_at' t" in hoare_strengthen_post) apply wpsimp @@ -1524,7 +1525,7 @@ lemma tcbSchedEnqueue_vs_entry_align[wp]: "\\s. ko_wp_at' (\ko. P (vs_entry_align ko)) p s\ tcbSchedEnqueue pa \\rv. ko_wp_at' (\ko. P (vs_entry_align ko)) p\" - apply (clarsimp simp: tcbSchedEnqueue_def setQueue_def) + apply (clarsimp simp: tcbSchedEnqueue_def tcbQueuePrepend_def setQueue_def) by (wp unless_wp | simp)+ crunch vs_entry_align[wp]: @@ -2252,7 +2253,7 @@ lemma assoc_invs': cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift valid_pde_mappings_lift' setObject_typ_at' cur_tcb_lift - setVCPU_valid_arch' + setVCPU_valid_arch' valid_bitmaps_lift sym_heap_sched_pointers_lift simp: objBits_simps archObjSize_def vcpu_bits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb valid_arch_tcb'_def | wp (once) hoare_vcg_imp_lift)+ diff --git a/proof/refine/ARM_HYP/Bits_R.thy b/proof/refine/ARM_HYP/Bits_R.thy index 942850eb3a..67b738cbce 100644 --- a/proof/refine/ARM_HYP/Bits_R.thy +++ b/proof/refine/ARM_HYP/Bits_R.thy @@ -76,6 +76,10 @@ lemma projectKO_tcb: "(projectKO_opt ko = Some t) = (ko = KOTCB t)" by (cases ko) (auto simp: projectKO_opts_defs) +lemma tcb_of'_TCB[simp]: + "tcb_of' (KOTCB tcb) = Some tcb" + by (simp add: projectKO_tcb) + lemma projectKO_cte: "(projectKO_opt ko = Some t) = (ko = KOCTE t)" by (cases ko) (auto simp: projectKO_opts_defs) diff --git a/proof/refine/ARM_HYP/CNodeInv_R.thy b/proof/refine/ARM_HYP/CNodeInv_R.thy index efa6b06484..6d3fce26d2 100644 --- a/proof/refine/ARM_HYP/CNodeInv_R.thy +++ b/proof/refine/ARM_HYP/CNodeInv_R.thy @@ -5062,8 +5062,6 @@ crunch irq_states'[wp]: cteSwap "valid_irq_states'" crunch pde_mappings'[wp]: cteSwap "valid_pde_mappings'" -crunch vq'[wp]: cteSwap "valid_queues'" - crunch ksqsL1[wp]: cteSwap "\s. P (ksReadyQueuesL1Bitmap s)" crunch ksqsL2[wp]: cteSwap "\s. P (ksReadyQueuesL2Bitmap s)" @@ -5078,6 +5076,12 @@ crunch ct_not_inQ[wp]: cteSwap "ct_not_inQ" crunch ksDomScheduleIdx [wp]: cteSwap "\s. P (ksDomScheduleIdx s)" +crunches cteSwap + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + and valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift) + lemma cteSwap_invs'[wp]: "\invs' and valid_cap' c and valid_cap' c' and ex_cte_cap_to' c1 and ex_cte_cap_to' c2 and @@ -5538,6 +5542,10 @@ lemma updateCap_untyped_ranges_zero_simple: crunch tcb_in_cur_domain'[wp]: updateCap "tcb_in_cur_domain' t" (wp: crunch_wps simp: crunch_simps rule: tcb_in_cur_domain'_lift) +crunches updateCap + for valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift) + lemma make_zombie_invs': "\\s. invs' s \ s \' cap \ cte_wp_at' (\cte. isFinal (cteCap cte) sl (cteCaps_of s)) sl s \ @@ -5555,7 +5563,8 @@ lemma make_zombie_invs': \ bound_tcb_at' ((=) None) p s \ obj_at' (Not \ tcbQueued) p s \ ko_wp_at' (Not \ hyp_live') p s - \ (\pr. p \ set (ksReadyQueues s pr)))) sl 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_state'_def valid_pspace'_def valid_mdb'_def @@ -5593,7 +5602,9 @@ lemma make_zombie_invs': apply (subgoal_tac "st_tcb_at' ((=) Inactive) p' s \ obj_at' (Not \ tcbQueued) p' s \ bound_tcb_at' ((=) None) p' s - \ ko_wp_at' (Not \ hyp_live') p' s") + \ ko_wp_at' (Not \ hyp_live') 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 live'_def hyp_live'_def) subgoal by (auto dest!: isCapDs)[1] apply (clarsimp simp: cte_wp_at_ctes_of disj_ac @@ -8590,6 +8601,15 @@ lemma cteMove_urz [wp]: apply auto done +crunches updateMDB + for valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift) + +(* FIXME: arch_split *) +lemma haskell_assert_inv: + "haskell_assert Q L \P\" + by wpsimp + lemma cteMove_invs' [wp]: "\\x. invs' x \ ex_cte_cap_to' word2 x \ cte_wp_at' (\c. weak_derived' (cteCap c) capability) word1 x \ @@ -8667,6 +8687,10 @@ crunch ksDomSchedule[wp]: updateCap "\s. P (ksDomSchedule s)" crunch ksDomScheduleIdx[wp]: updateCap "\s. P (ksDomScheduleIdx s)" crunch ksDomainTime[wp]: updateCap "\s. P (ksDomainTime s)" +crunches updateCap + for rdyq_projs[wp]: + "\s. P (ksReadyQueues s) (tcbSchedNexts_of s) (tcbSchedPrevs_of s) (\d p. inQ d p |< tcbs_of' s)" + lemma corres_null_cap_update: "cap_relation cap cap' \ corres dc (invs and cte_wp_at ((=) cap) slot) diff --git a/proof/refine/ARM_HYP/CSpace1_R.thy b/proof/refine/ARM_HYP/CSpace1_R.thy index d6e54b253a..9f1e49f37e 100644 --- a/proof/refine/ARM_HYP/CSpace1_R.thy +++ b/proof/refine/ARM_HYP/CSpace1_R.thy @@ -236,7 +236,7 @@ lemma pspace_relation_cte_wp_at: apply (clarsimp elim!: cte_wp_at_weakenE') apply clarsimp apply (drule(1) pspace_relation_absD) - apply (clarsimp simp: other_obj_relation_def) + apply (clarsimp simp: tcb_relation_cut_def) apply (simp split: kernel_object.split_asm) apply (drule(2) aligned_distinct_obj_atI'[where 'a=tcb]) apply simp @@ -1636,10 +1636,10 @@ lemma cte_map_pulls_tcb_to_abstract: \ \tcb'. kheap s x = Some (TCB tcb') \ tcb_relation tcb' tcb \ (z = (x, tcb_cnode_index (unat ((y - x) >> cte_level_bits))))" apply (rule pspace_dom_relatedE, assumption+) - apply (erule(1) obj_relation_cutsE, simp_all split: if_split_asm) - apply (clarsimp simp: other_obj_relation_def - split: Structures_A.kernel_object.split_asm - ARM_A.arch_kernel_obj.split_asm) + apply (erule(1) obj_relation_cutsE; + clarsimp simp: other_obj_relation_def + split: Structures_A.kernel_object.split_asm + ARM_A.arch_kernel_obj.split_asm if_split_asm) apply (drule tcb_cases_related2) apply clarsimp apply (frule(1) cte_wp_at_tcbI [OF _ _ TrueI, where t="(a, b)" for a b, simplified]) @@ -1655,8 +1655,7 @@ lemma pspace_relation_update_tcbs: del: dom_fun_upd) apply (erule conjE) apply (rule ballI, drule(1) bspec) - apply (rule conjI, simp add: other_obj_relation_def) - apply (clarsimp split: Structures_A.kernel_object.split_asm) + apply (clarsimp simp: tcb_relation_cut_def split: Structures_A.kernel_object.split_asm) apply (drule bspec, fastforce) apply clarsimp apply (erule(1) obj_relation_cutsE, simp_all split: if_split_asm) @@ -1878,6 +1877,27 @@ lemma descendants_of_eq': apply simp done +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 + +lemma setObject_cte_tcbSchedNexts_of_use_valid_ksPSpace: + assumes step: "(x, s\ksPSpace := ps\) \ fst (setObject p (cte :: cte) s)" + 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_inQ_of_use_valid_ksPSpace: + assumes step: "(x, s\ksPSpace := ps\) \ fst (setObject p (cte :: cte) s)" + 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))) \ @@ -1891,7 +1911,12 @@ lemma updateCap_stuff: ksSchedulerAction s'' = ksSchedulerAction s' \ (ksArchState s'' = ksArchState s') \ (pspace_aligned' s' \ pspace_aligned' s'') \ - (pspace_distinct' s' \ pspace_distinct' s'')" using assms + (pspace_distinct' s' \ pspace_distinct' s'') \ + 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) @@ -1900,8 +1925,11 @@ lemma updateCap_stuff: apply (frule setCTE_pspace_only) apply (clarsimp simp: setCTE_def) apply (intro conjI impI) - apply (erule(1) use_valid [OF _ setObject_aligned]) - apply (erule(1) use_valid [OF _ setObject_distinct]) + 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 *) @@ -1918,16 +1946,16 @@ lemma pspace_relation_cte_wp_atI': apply (simp split: if_split_asm) apply (erule(1) pspace_dom_relatedE) apply (erule(1) obj_relation_cutsE, simp_all split: if_split_asm) + apply (subgoal_tac "n = x - y", clarsimp) + apply (drule tcb_cases_related2, clarsimp) + apply (intro exI, rule conjI) + apply (erule(1) cte_wp_at_tcbI[where t="(a, b)" for a b, simplified]) + apply fastforce + apply simp + apply clarsimp apply (simp add: other_obj_relation_def split: Structures_A.kernel_object.split_asm ARM_A.arch_kernel_obj.split_asm) - apply (subgoal_tac "n = x - y", clarsimp) - apply (drule tcb_cases_related2, clarsimp) - apply (intro exI, rule conjI) - apply (erule(1) cte_wp_at_tcbI[where t="(a, b)" for a b, simplified]) - apply fastforce - apply simp - apply clarsimp done lemma pspace_relation_cte_wp_atI: @@ -2452,7 +2480,7 @@ lemma updateCap_corres: apply (clarsimp simp: in_set_cap_cte_at_swp pspace_relations_def) apply (drule updateCap_stuff) apply simp - apply (rule conjI) + apply (extract_conjunct \match conclusion in "ghost_relation _ _ _" \ -\) apply (clarsimp simp: ghost_relation_typ_at set_cap_a_type_inv data_at_def) apply (rule conjI) prefer 2 @@ -2540,9 +2568,9 @@ lemma updateMDB_pspace_relation: apply (clarsimp simp: tcb_ctes_clear cte_level_bits_def objBits_defs) apply clarsimp apply (rule pspace_dom_relatedE, assumption+) - apply (rule obj_relation_cutsE, assumption+, simp_all split: if_split_asm)[1] - apply (clarsimp split: Structures_A.kernel_object.split_asm - ARM_A.arch_kernel_obj.split_asm + apply (rule obj_relation_cutsE, assumption+; + clarsimp split: Structures_A.kernel_object.split_asm + ARM_A.arch_kernel_obj.split_asm if_split_asm simp: other_obj_relation_def) apply (frule(1) tcb_cte_cases_aligned_helpers(1)) apply (frule(1) tcb_cte_cases_aligned_helpers(2)) @@ -2604,6 +2632,25 @@ lemma updateMDB_ctes_of: crunch aligned[wp]: updateMDB "pspace_aligned'" crunch pdistinct[wp]: updateMDB "pspace_distinct'" +crunch tcbSchedPrevs_of[wp]: updateMDB "\s. P (tcbSchedPrevs_of s)" +crunch tcbSchedNexts_of[wp]: updateMDB "\s. P (tcbSchedNexts_of s)" +crunch inQ_opt_pred[wp]: updateMDB "\s. P (inQ d p |< tcbs_of' s)" +crunch inQ_opt_pred'[wp]: updateMDB "\s. P (\d p. inQ d p |< tcbs_of' s)" +crunch ksReadyQueues[wp]: updateMDB "\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 + +crunches 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')" @@ -2626,7 +2673,11 @@ lemma updateMDB_the_lot: ksDomScheduleIdx s'' = ksDomScheduleIdx s' \ ksDomSchedule s'' = ksDomSchedule s' \ ksCurDomain s'' = ksCurDomain s' \ - ksDomainTime s'' = ksDomainTime s'" + ksDomainTime s'' = ksDomainTime s' \ + 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) @@ -2635,9 +2686,8 @@ using assms apply (erule use_valid) apply wp apply simp - 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: @@ -3833,6 +3883,9 @@ lemma updateUntypedCap_descendants_of: apply (clarsimp simp:mdb_next_rel_def mdb_next_def split:if_splits) done +crunches setCTE + for tcbQueued[wp]: "\s. P (tcbQueued |< tcbs_of' s)" + lemma setCTE_UntypedCap_corres: "\cap_relation cap (cteCap cte); is_untyped_cap cap; idx' = idx\ \ corres dc (cte_wp_at ((=) cap) src and valid_objs and @@ -3862,10 +3915,19 @@ lemma setCTE_UntypedCap_corres: apply assumption apply (clarsimp simp: pspace_relations_def) apply (subst conj_assoc[symmetric]) + apply clarsimp 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) @@ -5143,11 +5205,15 @@ lemma updateMDB_the_lot': ksDomScheduleIdx s'' = ksDomScheduleIdx s' \ ksDomSchedule s'' = ksDomSchedule s' \ ksCurDomain s'' = ksCurDomain s' \ - ksDomainTime s'' = ksDomainTime s'" + ksDomainTime s'' = ksDomainTime s' \ + 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 + done lemma cte_map_inj_eq': "\(cte_map p = cte_map p'); @@ -5249,7 +5315,6 @@ lemma cteInsert_corres: 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 "ksReadyQueues t = p" for p t)+ apply (thin_tac "ksSchedulerAction t = p" for p t)+ apply (clarsimp simp: pspace_relations_def) apply (rule conjI) diff --git a/proof/refine/ARM_HYP/CSpace_R.thy b/proof/refine/ARM_HYP/CSpace_R.thy index e56496a8d4..385412c497 100644 --- a/proof/refine/ARM_HYP/CSpace_R.thy +++ b/proof/refine/ARM_HYP/CSpace_R.thy @@ -1099,43 +1099,6 @@ lemma bitmapQ_no_L2_orphans_lift: apply (rule hoare_vcg_prop, assumption) done -lemma valid_queues_lift_asm: - assumes tat1: "\d p tcb. \obj_at' (inQ d p) tcb and Q \ f \\_. obj_at' (inQ d p) tcb\" - and tat2: "\tcb. \st_tcb_at' runnable' tcb and Q \ f \\_. st_tcb_at' runnable' tcb\" - and prq: "\P. \\s. P (ksReadyQueues s) \ f \\_ s. P (ksReadyQueues s)\" - and prqL1: "\P. \\s. P (ksReadyQueuesL1Bitmap s)\ f \\_ s. P (ksReadyQueuesL1Bitmap s)\" - and prqL2: "\P. \\s. P (ksReadyQueuesL2Bitmap s)\ f \\_ s. P (ksReadyQueuesL2Bitmap s)\" - shows "\Invariants_H.valid_queues and Q\ f \\_. Invariants_H.valid_queues\" - proof - - have tat: "\d p tcb. \obj_at' (inQ d p) tcb and st_tcb_at' runnable' tcb and Q\ f - \\_. obj_at' (inQ d p) tcb and st_tcb_at' runnable' tcb\" - apply (rule hoare_chain [OF hoare_vcg_conj_lift [OF tat1 tat2]]) - apply (fastforce)+ - done - have tat_combined: "\d p tcb. \obj_at' (inQ d p and runnable' \ tcbState) tcb and Q\ f - \\_. obj_at' (inQ d p and runnable' \ tcbState) tcb\" - apply (rule hoare_chain [OF tat]) - apply (fastforce simp add: obj_at'_and pred_tcb_at'_def o_def)+ - done - show ?thesis unfolding valid_queues_def valid_queues_no_bitmap_def - by (wp tat_combined prq prqL1 prqL2 valid_bitmapQ_lift bitmapQ_no_L2_orphans_lift - bitmapQ_no_L1_orphans_lift hoare_vcg_all_lift hoare_vcg_conj_lift hoare_Ball_helper) - simp_all - qed - -lemmas valid_queues_lift = valid_queues_lift_asm[where Q="\_. True", simplified] - -lemma valid_queues_lift': - assumes tat: "\d p tcb. \\s. \ obj_at' (inQ d p) tcb s\ f \\_ s. \ obj_at' (inQ d p) tcb s\" - and prq: "\P. \\s. P (ksReadyQueues s)\ f \\_ s. P (ksReadyQueues s)\" - shows "\valid_queues'\ f \\_. valid_queues'\" - unfolding valid_queues'_def imp_conv_disj - by (wp hoare_vcg_all_lift hoare_vcg_disj_lift tat prq) - -lemma setCTE_norq [wp]: - "\\s. P (ksReadyQueues s)\ setCTE ptr cte \\r s. P (ksReadyQueues s) \" - by (clarsimp simp: valid_def dest!: setCTE_pspace_only) - lemma setCTE_norqL1 [wp]: "\\s. P (ksReadyQueuesL1Bitmap s)\ setCTE ptr cte \\r s. P (ksReadyQueuesL1Bitmap s) \" by (clarsimp simp: valid_def dest!: setCTE_pspace_only) @@ -2795,12 +2758,6 @@ lemma setCTE_inQ[wp]: apply (simp_all add: inQ_def) done -lemma setCTE_valid_queues'[wp]: - "\valid_queues'\ setCTE p cte \\rv. valid_queues'\" - apply (simp only: valid_queues'_def imp_conv_disj) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - done - crunch inQ[wp]: cteInsert "\s. P (obj_at' (inQ d p) t s)" (wp: crunch_wps) @@ -3317,6 +3274,13 @@ lemma cteInsert_untyped_ranges_zero[wp]: apply blast done +crunches cteInsert + 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 (\s. src \ dest) and (\s. cte_wp_at' (is_derived' (ctes_of s) src cap \ cteCap) src s) @@ -3325,20 +3289,9 @@ lemma cteInsert_invs: cteInsert cap src dest \\rv. invs'\" apply (simp add: invs'_def valid_state'_def valid_pspace'_def) - (* FIXME: wp_cleanup - apply (wp cur_tcb_lift tcb_in_cur_domain'_lift sch_act_wf_lift - valid_irq_node_lift valid_queues_lift' irqs_masked_lift - cteInsert_norq | simp add: st_tcb_at'_def)+ - apply (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' irqs_masked_lift - cteInsert_norq | simp add: pred_tcb_at'_def)+ - apply (auto simp: invs'_def valid_state'_def valid_pspace'_def - cte_wp_at_ctes_of - elim: valid_capAligned is_derived_badge_derived') - *) - 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' irqs_masked_lift cteInsert_norq - simp: st_tcb_at'_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 @@ -3646,10 +3599,13 @@ lemma corres_caps_decomposition: "\P. \\s. P (new_ups' s)\ g \\rv s. P (gsUserPages s)\" "\P. \\s. P (new_cns s)\ f \\rv s. P (cns_of_heap (kheap s))\" "\P. \\s. P (new_cns' s)\ g \\rv s. P (gsCNodes s)\" - "\P. \\s. P (new_queues s)\ f \\rv s. P (ready_queues s)\" + "\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_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)\" @@ -3665,7 +3621,9 @@ lemma corres_caps_decomposition: "\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 (new_queues s) (new_rqs' s')" + \ ready_queues_relation_2 (new_ready_queues s) (new_ksReadyQueues s') + (new_tcbSchedNexts_of s') (new_tcbSchedPrevs_of s') + (\d p. new_inQs d p s')" "\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 \ @@ -3732,7 +3690,7 @@ proof - 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 u abs_irq_together)+ + apply (wpsimp 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 pspace_relations_def swp_cte_at))+ done @@ -4223,6 +4181,9 @@ crunches setupReplyMaster 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]: @@ -4251,7 +4212,8 @@ lemma setupReplyMaster_invs'[wp]: 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 valid_queues_lift' hoare_vcg_disj_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 @@ -4512,8 +4474,8 @@ lemma arch_update_setCTE_invs: 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 + 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) @@ -5883,7 +5845,7 @@ lemma cteInsert_simple_invs: apply (rule hoare_pre) 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' irqs_masked_lift + 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 @@ -6022,6 +5984,21 @@ lemma arch_update_updateCap_invs: apply clarsimp 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 @@ -6053,6 +6030,8 @@ lemma updateCap_same_master: apply 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 @@ -6279,8 +6258,9 @@ lemma updateFreeIndex_forward_invs': apply (simp add:updateCap_def) apply (wp setCTE_irq_handlers' getCTE_wp) apply (simp add:updateCap_def) - apply (wp irqs_masked_lift valid_queues_lift' cur_tcb_lift ct_idle_or_in_cur_domain'_lift + apply (wp irqs_masked_lift cur_tcb_lift ct_idle_or_in_cur_domain'_lift hoare_vcg_disj_lift untyped_ranges_zero_lift getCTE_wp + sym_heap_sched_pointers_lift valid_bitmaps_lift | wp (once) hoare_use_eq[where f="gsUntypedZeroRanges"] | simp add: getSlotCap_def)+ apply (clarsimp simp: cte_wp_at_ctes_of fun_upd_def[symmetric]) diff --git a/proof/refine/ARM_HYP/Detype_R.thy b/proof/refine/ARM_HYP/Detype_R.thy index 3e7c738bc2..ae8efc27c8 100644 --- a/proof/refine/ARM_HYP/Detype_R.thy +++ b/proof/refine/ARM_HYP/Detype_R.thy @@ -608,8 +608,9 @@ context delete_locale begin interpretation Arch . (*FIXME: arch_split*) lemma valid_objs: "valid_objs' s'" and pa: "pspace_aligned' s'" and pd: "pspace_distinct' s'" - and vq: "valid_queues s'" - and vq': "valid_queues' s'" + and vbm: "valid_bitmaps s'" + and sym_sched: "sym_heap_sched_pointers s'" + and vsp: "valid_sched_pointers s'" and sym_refs: "sym_refs (state_refs_of' s')" and sym_hyp_refs: "sym_refs (state_hyp_refs_of' s')" and iflive: "if_live_then_nonz_cap' s'" @@ -844,7 +845,6 @@ lemma sym_refs_TCB_hyp_live': apply (simp add: ko_wp_at'_def) apply (clarsimp simp: hyp_refs_of_rev' hyp_live'_def arch_live'_def) done - end context begin interpretation Arch . (*FIXME: arch_split*) @@ -933,6 +933,73 @@ crunches doMachineOp for deletionIsSafe_delete_locale[wp]: "deletionIsSafe_delete_locale base magnitude" (simp: deletionIsSafe_delete_locale_def) +lemma detype_tcbSchedNexts_of: + "\pspace_aligned' s'; pspace_distinct' s'; \p. p \ S \ \ ko_wp_at' live' p s'\ + \ ((\x. if x \ S then None else ksPSpace s' x) |> tcb_of' |> tcbSchedNext) + = tcbSchedNexts_of s'" + supply projectKOs[simp] + using pspace_alignedD' pspace_distinctD' + apply (clarsimp simp: opt_map_def) + apply (rule ext) + apply (rename_tac s) + apply (clarsimp simp: ko_wp_at'_def live'_def split: option.splits) + apply (drule_tac x=s in spec) + apply force + done + +lemma detype_tcbSchedPrevs_of: + "\pspace_aligned' s'; pspace_distinct' s'; \p. p \ S \ \ ko_wp_at' live' p s'\ + \ ((\x. if x \ S then None else ksPSpace s' x) |> tcb_of' |> tcbSchedPrev) + = tcbSchedPrevs_of s'" + supply projectKOs[simp] + using pspace_alignedD' pspace_distinctD' + using pspace_alignedD' pspace_distinctD' + apply (clarsimp simp: opt_map_def) + apply (rule ext) + apply (rename_tac s) + apply (clarsimp simp: ko_wp_at'_def live'_def split: option.splits) + apply (drule_tac x=s in spec) + apply force + done + +lemma detype_inQ: + "\pspace_aligned' s'; pspace_distinct' s'; \p. p \ S \ \ ko_wp_at' live' p s'\ + \ \d p. (inQ d p |< ((\x. if x \ S then None else ksPSpace s' x) |> tcb_of')) + = (inQ d p |< tcbs_of' s')" + supply projectKOs[simp] + using pspace_alignedD' pspace_distinctD' + using pspace_alignedD' pspace_distinctD' + apply (clarsimp simp: opt_map_def) + apply (rule ext) + apply (rename_tac s) + apply (clarsimp simp: inQ_def opt_pred_def ko_wp_at'_def live'_def split: option.splits) + apply (drule_tac x=s in spec) + apply force + done + +lemma detype_ready_queues_relation: + "\pspace_aligned' s'; pspace_distinct' s'; + \p. p \ {lower..upper} \ \ ko_wp_at' live' p s'; + ready_queues_relation s s'; upper = upper'\ + \ ready_queues_relation_2 + (ready_queues (detype {lower..upper'} s)) + (ksReadyQueues s') + ((\x. if lower \ x \ x \ upper then None + else ksPSpace s' x) |> + tcb_of' |> + tcbSchedNext) + ((\x. if lower \ x \ x \ upper then None + else ksPSpace s' x) |> + tcb_of' |> + tcbSchedPrev) + (\d p. inQ d p |< ((\x. if lower \ x \ x \ upper then None else ksPSpace s' x) |> tcb_of'))" + apply (clarsimp simp: detype_ext_def ready_queues_relation_def Let_def) + apply (frule (1) detype_tcbSchedNexts_of[where S="{lower..upper}"]; simp) + apply (frule (1) detype_tcbSchedPrevs_of[where S="{lower..upper}"]; simp) + apply (frule (1) detype_inQ[where S="{lower..upper}"]; simp) + apply (fastforce simp add: detype_def detype_ext_def wrap_ext_det_ext_ext_def) + done + lemma deleteObjects_corres: "is_aligned base magnitude \ magnitude \ 2 \ corres dc @@ -953,20 +1020,19 @@ lemma deleteObjects_corres: apply (rule corres_stateAssert_implied[where P'=\, simplified]) prefer 2 apply clarsimp - 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 p_assoc_help invs_valid_pspace)[1] - apply (simp add:valid_cap_simps) + 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 (fastforce simp: sch_act_simple_def schact_is_rct_def state_relation_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: valid_cap_simps) apply (simp add: bind_assoc[symmetric]) apply (rule corres_stateAssert_implied2) defer @@ -992,7 +1058,8 @@ lemma deleteObjects_corres: untyped_children_in_mdb s \ if_unsafe_then_cap s \ valid_global_refs s" and Q'="\_ s. s \' capability.UntypedCap d base magnitude idx \ - valid_pspace' s" in corres_underlying_split) + 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]) apply (rule corres_split[OF _ cNodeNoPartialOverlap]) @@ -1005,33 +1072,36 @@ 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, rule state.equality; simp add: detype_ext_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 add: null_filter'_def + map_to_ctes_delete[simplified field_simps]) 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 (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 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 (fastforce simp add: detype_def detype_ext_def intro!: ekheap_relation_detype) + 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 (erule state_relation_ready_queues_relation) apply (clarsimp simp: state_relation_def ghost_relation_of_heap detype_def) apply (drule_tac t="gsUserPages s'" in sym) @@ -1044,13 +1114,31 @@ lemma deleteObjects_corres: 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' live' p s' \ p = idle_thread_ptr \ p \ base_bits" + apply (case_tac "ko_wp_at' live' 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 invs_valid_idle'[OF invs]) + 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 mask_eq_exp_minus_1) + by fastforce + +lemma untyped_range_live_idle': + "p \ base_bits \ \ (ko_wp_at' live' p s' \ p = idle_thread_ptr)" + using live_idle_untyped_range' by blast + lemma valid_obj': - "\ valid_obj' obj s'; ko_wp_at' ((=) obj) p s' \ \ valid_obj' obj state'" + "\ 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 (rename_tac endpoint) apply (case_tac endpoint, simp_all add: valid_ep'_def)[1] @@ -1077,11 +1165,23 @@ lemma valid_obj': apply (erule(2) cte_wp_at_tcbI') apply fastforce apply simp - apply (rename_tac tcb) - apply (simp only: conj_assoc[symmetric], rule conjI) - apply (case_tac "tcbState tcb"; - clarsimp simp: valid_tcb_state'_def valid_bound_ntfn'_def - dest!: refs_notRange split: option.splits) + 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 live'_def) + 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 live'_def) using sym_hyp_refs apply (clarsimp simp add: valid_arch_tcb'_def split: option.split_asm) apply (drule (1) sym_refs_TCB_hyp_live'[rotated]) @@ -1111,6 +1211,40 @@ lemma valid_obj': apply clarsimp done +lemma tcbSchedNexts_of_pspace': + "\pspace_aligned' s'; pspace_distinct' s'; pspace_distinct' state'\ + \ (pspace' |> tcb_of' |> tcbSchedNext) = tcbSchedNexts_of s'" + supply projectKOs[simp] + apply (rule ext) + apply (rename_tac p) + apply (case_tac "p \ base_bits") + apply (frule untyped_range_live_idle') + apply (clarsimp simp: opt_map_def) + apply (case_tac "ksPSpace s' p"; clarsimp) + apply (rename_tac obj) + apply (case_tac "tcb_of' obj"; clarsimp) + apply (clarsimp simp: ko_wp_at'_def obj_at'_def live'_def) + apply (fastforce simp: pspace_alignedD' pspace_distinctD') + apply (clarsimp simp: opt_map_def split: option.splits) + done + +lemma tcbSchedPrevs_of_pspace': + "\pspace_aligned' s'; pspace_distinct' s'; pspace_distinct' state'\ + \ (pspace' |> tcb_of' |> tcbSchedPrev) = tcbSchedPrevs_of s'" + supply projectKOs[simp] + apply (rule ext) + apply (rename_tac p) + apply (case_tac "p \ base_bits") + apply (frule untyped_range_live_idle') + apply (clarsimp simp: opt_map_def) + apply (case_tac "ksPSpace s' p"; clarsimp) + apply (rename_tac obj) + apply (case_tac "tcb_of' obj"; clarsimp) + apply (clarsimp simp: ko_wp_at'_def obj_at'_def live'_def) + apply (fastforce simp: pspace_alignedD' pspace_distinctD') + apply (clarsimp simp: opt_map_def split: option.splits) + done + lemma st_tcb: "\P p. \ st_tcb_at' P p s'; \ P Inactive; \ P IdleThreadState \ \ st_tcb_at' P p state'" by (fastforce simp: pred_tcb_at'_def obj_at'_real_def projectKOs live'_def hyp_live'_def @@ -1318,17 +1452,18 @@ proof (simp add: invs'_def valid_state'_def valid_pspace'_def show "pspace_aligned' ?s" using pa by (simp add: pspace_aligned'_def dom_def) - show "pspace_distinct' ?s" using pd + show pspace_distinct'_state': "pspace_distinct' ?s" using pd by (clarsimp simp add: pspace_distinct'_def ps_clear_def dom_if_None Diff_Int_distrib) - show "valid_objs' ?s" using valid_objs + show "valid_objs' ?s" using valid_objs sym_sched apply (clarsimp simp: valid_objs'_def ran_def) 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 + apply (frule pspace_alignedD'[OF _ pa]) + apply (frule pspace_distinctD'[OF _ pd]) + apply (clarsimp simp: ko_wp_at'_def) + apply fastforce done from sym_refs show "sym_refs (state_refs_of' ?s)" @@ -1349,19 +1484,6 @@ proof (simp add: invs'_def valid_state'_def valid_pspace'_def apply (simp add: hyp_refs_notRange[simplified] state_hyp_refs_ko_wp_at_eq) done - 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 live'_def) - apply (clarsimp dest!: ex_nonz_cap_notRange) - done - - from vq' show "valid_queues' ?s" - by (simp add: valid_queues'_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) @@ -1612,6 +1734,20 @@ proof (simp add: invs'_def valid_state'_def valid_pspace'_def apply simp done + from vbm + show "valid_bitmaps state'" + by (simp add: valid_bitmaps_def bitmapQ_defs) + + from sym_sched + show "sym_heap (pspace' |> tcb_of' |> tcbSchedNext) (pspace' |> tcb_of' |> tcbSchedPrev)" + using pa pd pspace_distinct'_state' + by (fastforce simp: tcbSchedNexts_of_pspace' tcbSchedPrevs_of_pspace') + + from vsp show "valid_sched_pointers_2 (pspace' |> tcb_of' |> tcbSchedPrev) + (pspace' |> tcb_of' |> tcbSchedNext) + (tcbQueued |< (pspace' |> tcb_of'))" + by (clarsimp simp: valid_sched_pointers_def opt_pred_def opt_map_def) + qed (clarsimp) lemma (in delete_locale) delete_ko_wp_at': @@ -4692,7 +4828,6 @@ lemma createTCBs_tcb_at': apply simp apply simp apply (clarsimp simp: retype_obj_at_disj') - apply (clarsimp simp: projectKO_opt_tcb) apply (clarsimp simp: new_cap_addrs_def image_def) apply (drule_tac x = "unat x" in bspec) apply (simp add:objBits_simps' shiftl_t2n) diff --git a/proof/refine/ARM_HYP/Finalise_R.thy b/proof/refine/ARM_HYP/Finalise_R.thy index 877efd9b00..5cb7aa4f61 100644 --- a/proof/refine/ARM_HYP/Finalise_R.thy +++ b/proof/refine/ARM_HYP/Finalise_R.thy @@ -76,20 +76,10 @@ crunch ksRQL1[wp]: emptySlot "\s. P (ksReadyQueuesL1Bitmap s)" crunch ksRQL2[wp]: emptySlot "\s. P (ksReadyQueuesL2Bitmap s)" crunch obj_at'[wp]: postCapDeletion "obj_at' P p" -lemmas postCapDeletion_valid_queues[wp] = - valid_queues_lift [OF postCapDeletion_obj_at' - postCapDeletion_pred_tcb_at' - postCapDeletion_ksRQ] - crunch inQ[wp]: clearUntypedFreeIndex "\s. P (obj_at' (inQ d p) t s)" crunch tcbDomain[wp]: clearUntypedFreeIndex "obj_at' (\tcb. P (tcbDomain tcb)) t" crunch tcbPriority[wp]: clearUntypedFreeIndex "obj_at' (\tcb. P (tcbPriority tcb)) t" -lemma emptySlot_queues [wp]: - "\Invariants_H.valid_queues\ emptySlot sl opt \\rv. Invariants_H.valid_queues\" - unfolding emptySlot_def - by (wp | wpcw | wp valid_queues_lift | simp)+ - crunch nosch[wp]: emptySlot "\s. P (ksSchedulerAction s)" crunch ksCurDomain[wp]: emptySlot "\s. P (ksCurDomain s)" @@ -1166,8 +1156,7 @@ definition "removeable' sl \ \s cap. (\p. p \ sl \ cte_wp_at' (\cte. capMasterCap (cteCap cte) = capMasterCap cap) p s) \ ((\p \ cte_refs' cap (irq_node' s). p \ sl \ cte_wp_at' (\cte. cteCap cte = NullCap) p s) - \ (\p \ zobj_refs' cap. ko_wp_at' (Not \ live') p s) - \ (\t \ threadCapRefs cap. \p. t \ set (ksReadyQueues s p)))" + \ (\p \ zobj_refs' cap. ko_wp_at' (Not \ live') p s))" lemma not_Final_removeable: "\ isFinal cap sl (cteCaps_of s) @@ -1358,11 +1347,6 @@ crunch irq_states' [wp]: emptySlot valid_irq_states' crunch no_0_obj' [wp]: emptySlot no_0_obj' (wp: crunch_wps) -crunch valid_queues'[wp]: setInterruptState "valid_queues'" - (simp: valid_queues'_def) - -crunch valid_queues'[wp]: emptySlot "valid_queues'" - crunch pde_mappings'[wp]: emptySlot "valid_pde_mappings'" end @@ -1452,6 +1436,13 @@ lemma emptySlot_untyped_ranges[wp]: crunch valid_arch'[wp]: emptySlot valid_arch_state' (wp: crunch_wps) +crunches emptySlot + 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)\ @@ -2242,6 +2233,14 @@ lemma ntfn_q_refs_of'_mult: "ntfn_q_refs_of' ntfn = (case ntfn of Structures_H.WaitingNtfn q \ set q | _ \ {}) \ {NTFNSignal}" by (cases ntfn, simp_all) +crunches 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]: "\invs'\ unbindNotification tcb \\rv. invs'\" apply (simp add: unbindNotification_def invs'_def valid_state'_def) @@ -2250,8 +2249,8 @@ lemma unbindNotification_invs[wp]: apply clarsimp apply (rule hoare_seq_ext[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 + 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 (clarsimp elim!: obj_atE' @@ -2293,7 +2292,7 @@ lemma unbindMaybeNotification_invs[wp]: apply (simp add: unbindMaybeNotification_def invs'_def valid_state'_def) apply (rule hoare_seq_ext[OF _ get_ntfn_sp']) apply (rule hoare_pre) - apply (wp sbn'_valid_pspace'_inv sbn_sch_act' sbn_valid_queues valid_irq_node_lift + 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)+ @@ -2563,14 +2562,6 @@ lemma archThreadSet_valid_arch_state'[wp]: apply (clarsimp simp: pred_conj_def) done -lemma archThreadSet_valid_queues'[wp]: - "archThreadSet f t \valid_queues'\" - unfolding valid_queues'_def - apply (rule hoare_lift_Pf[where f=ksReadyQueues]; wp?) - apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift) - apply auto - done - lemma archThreadSet_ct_not_inQ[wp]: "archThreadSet f t \ct_not_inQ\" unfolding ct_not_inQ_def @@ -2600,6 +2591,54 @@ lemma archThreadSet_tcb_at'[wp]: unfolding archThreadSet_def by (wpsimp wp: getObject_tcb_wp simp: obj_at'_def) +lemma setObject_tcb_tcbs_of'[wp]: + "\\s. P ((tcbs_of' s) (t \ tcb))\ + setObject t tcb + \\_ s. P (tcbs_of' s)\" + unfolding setObject_def + apply (wpsimp simp: updateObject_default_def) + apply (erule rsubst[where P=P]) + apply (rule ext) + apply (clarsimp simp: opt_map_def split: option.splits) + done + +lemma archThreadSet_tcbSchedPrevs_of[wp]: + "archThreadSet f t \\s. P (tcbSchedPrevs_of s)\" + supply projectKOs[simp] + unfolding archThreadSet_def + apply (wp getObject_tcb_wp) + apply normalise_obj_at' + apply (erule rsubst[where P=P]) + apply (rule ext) + apply (clarsimp simp: opt_map_def obj_at'_def split: option.splits) + done + +lemma archThreadSet_tcbSchedNexts_of[wp]: + "archThreadSet f t \\s. P (tcbSchedNexts_of s)\" + supply projectKOs[simp] + unfolding archThreadSet_def + apply (wp getObject_tcb_wp) + apply normalise_obj_at' + apply (erule rsubst[where P=P]) + apply (rule ext) + apply (clarsimp simp: opt_map_def obj_at'_def split: option.splits) + done + +lemma archThreadSet_tcbQueued[wp]: + "archThreadSet f t \\s. P (tcbQueued |< tcbs_of' s)\" + supply projectKOs[simp] + unfolding archThreadSet_def + apply (wp getObject_tcb_wp) + apply normalise_obj_at' + apply (erule rsubst[where P=P]) + apply (rule ext) + apply (clarsimp simp: opt_pred_def opt_map_def obj_at'_def split: option.splits) + done + +lemma archThreadSet_valid_sched_pointers[wp]: + "archThreadSet f t \valid_sched_pointers\" + by (wp_pre, wps, wp, assumption) + lemma dissoc_invs': "\invs' and (\s. \p. (\a. armHSCurVCPU (ksArchState s) = Some (p, a)) \ p \ v) and ko_at' vcpu v and K (vcpuTCBPtr vcpu = Some t) and @@ -2618,7 +2657,8 @@ lemma dissoc_invs': cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift valid_pde_mappings_lift' setObject_typ_at' cur_tcb_lift - setVCPU_valid_arch' archThreadSet_if_live' + setVCPU_valid_arch' archThreadSet_if_live' valid_bitmaps_lift + sym_heap_sched_pointers_lift simp: objBits_simps archObjSize_def vcpu_bits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb valid_arch_tcb'_def | clarsimp simp: live'_def hyp_live'_def arch_live'_def)+ @@ -2665,7 +2705,7 @@ lemma when_assert_eq: lemma dissociateVCPUTCB_invs'[wp]: "dissociateVCPUTCB vcpu tcb \invs'\" unfolding dissociateVCPUTCB_def setVCPU_archThreadSet_None_eq when_assert_eq - apply ( wpsimp wp: dissoc_invs' getVCPU_wp | wpsimp wp: getObject_tcb_wp simp: archThreadGet_def)+ + apply (wpsimp wp: dissoc_invs' getVCPU_wp | wpsimp wp: getObject_tcb_wp simp: archThreadGet_def)+ apply (drule tcb_ko_at') apply clarsimp apply (rule exI, rule conjI, assumption) @@ -2714,7 +2754,6 @@ lemma asUser_unlive[wp]: apply (rename_tac tcb) apply (rule_tac x=tcb in exI) apply (clarsimp simp: obj_at'_def projectKOs) - apply (rule_tac x=tcb in exI, rule conjI; clarsimp simp: o_def) apply (clarsimp simp: ko_wp_at'_def live'_def hyp_live'_def) done @@ -2807,7 +2846,6 @@ lemma cteDeleteOne_isFinal: 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 setQueue_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF setQueue_ctes_of] lemmas threadSet_cteCaps_of = ctes_of_cteCaps_of_lift [OF threadSet_ctes_of] crunch isFinal: setSchedulerAction "\s. isFinal cap slot (cteCaps_of s)" @@ -2904,18 +2942,6 @@ lemma unbindNotification_valid_objs'_helper': by (clarsimp simp: valid_bound_tcb'_def valid_ntfn'_def split: option.splits ntfn.splits) -lemma typ_at'_valid_tcb'_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_tcb' tcb s\ f \\rv s. valid_tcb' tcb s\" - including no_pre - apply (simp add: valid_tcb'_def valid_arch_tcb'_def) - apply (case_tac "atcbVCPUPtr (tcbArch tcb)"; - case_tac "tcbState tcb"; - case_tac "tcbBoundNotification tcb") - apply (simp add: valid_tcb_state'_def split_def valid_bound_ntfn'_def - | wp hoare_vcg_const_Ball_lift typ_at_lifts[OF P] P)+ - done - lemmas setNotification_valid_tcb' = typ_at'_valid_tcb'_lift [OF setNotification_typ_at'] lemma unbindNotification_valid_objs'[wp]: @@ -3068,10 +3094,6 @@ lemma unbindNotification_bound_tcb_at': apply (wp setBoundNotification_bound_tcb gbn_wp' | wpc | simp)+ done -crunches unbindNotification, unbindMaybeNotification - for valid_queues[wp]: "Invariants_H.valid_queues" - (wp: sbn_valid_queues) - crunches unbindNotification, unbindMaybeNotification for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" @@ -3145,6 +3167,54 @@ lemma prepareThreadDelete_hyp_unlive[wp]: end +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\" + supply projectKOs[simp] + apply (clarsimp simp: tcbQueueRemove_def) + apply (wpsimp wp: threadSet_wp getTCB_wp) + by (fastforce dest!: heap_ls_last_None + simp: list_queue_relation_def prev_queue_head_def queue_end_valid_def + obj_at'_def opt_map_def ps_clear_def objBits_simps + split: if_splits) + +lemma tcbSchedDequeue_tcbSchedNext_tcbSchedPrev_None_obj_at': + "\valid_sched_pointers\ + tcbSchedDequeue t + \\_ s. obj_at' (\tcb. tcbSchedNext tcb = None \ tcbSchedPrev tcb = None) t s\" + supply projectKOs[simp] + 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 + split: option.splits) + +crunches updateRestartPC, cancelIPC + for valid_sched_pointers[wp]: valid_sched_pointers + (simp: crunch_simps wp: crunch_wps) + +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') + +context begin interpretation Arch . (*FIXME: arch_split*) + +lemma archThreadSet_tcbSchedPrevNext[wp]: + "archThreadSet f t' \obj_at' (\tcb. P (tcbSchedNext tcb) (tcbSchedPrev tcb)) t\" + unfolding archThreadSet_def + apply (wpsimp wp: setObject_tcb_strongest getObject_tcb_wp) + apply normalise_obj_at' + apply auto + done + +crunches prepareThreadDelete + for tcbSchedPrevNext[wp]: "obj_at' (\tcb. P (tcbSchedNext tcb) (tcbSchedPrev tcb)) t" + (wp: threadGet_wp getVCPU_wp archThreadGet_wp crunch_wps simp: crunch_simps) + +end + 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))) @@ -3165,21 +3235,22 @@ lemma (in delete_one_conc_pre) finaliseCap_replaceable: \ obj_at' (Not \ tcbQueued) p s \ bound_tcb_at' ((=) None) p s \ ko_wp_at' (Not \ hyp_live') p s - \ (\pr. p \ set (ksReadyQueues s pr))))\" + \ 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 (wp prepares_delete_helper'' [OF cancelAllIPC_unlive] prepares_delete_helper'' [OF cancelAllSignals_unlive] - suspend_isFinal prepareThreadDelete_unqueued prepareThreadDelete_nonq + suspend_isFinal prepareThreadDelete_unqueued prepareThreadDelete_inactive prepareThreadDelete_isFinal - suspend_makes_inactive suspend_nonq + 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]], @@ -3187,24 +3258,12 @@ lemma (in delete_one_conc_pre) finaliseCap_replaceable: | wpc)+ apply clarsimp apply (frule cte_wp_at_valid_objs_valid_cap', clarsimp+) - apply (rule conjI) - apply (case_tac "cteCap cte", + apply (case_tac "cteCap cte", simp_all add: isCap_simps capRange_def final_matters'_def objBits_simps not_Final_removeable finaliseCap_def, simp_all add: removeable'_def)[1] - (* 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)+)[2] - apply (rule impI) - 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) + apply fastforce+ done lemma cteDeleteOne_cte_wp_at_preserved: @@ -3253,7 +3312,9 @@ lemma cancelIPC_cte_wp_at': apply (clarsimp simp: cteCaps_of_def cte_wp_at_ctes_of x) done -crunch cte_wp_at'[wp]: tcbSchedDequeue "cte_wp_at' P p" +crunches tcbSchedDequeue + for cte_wp_at'[wp]: "cte_wp_at' P p" + (wp: crunch_wps) lemma suspend_cte_wp_at': assumes x: "\cap final. P cap \ finaliseCap cap final True = fail" @@ -3381,25 +3442,6 @@ crunch sch_act_not[wp]: cteDeleteOne "sch_act_not t" (simp: crunch_simps case_Null_If unless_def wp: crunch_wps getObject_inv loadObject_default_inv) -lemma cancelAllIPC_mapM_x_valid_queues: - "\Invariants_H.valid_queues and valid_objs' and (\s. \t\set q. tcb_at' t s)\ - mapM_x (\t. do - y \ setThreadState Structures_H.thread_state.Restart t; - tcbSchedEnqueue t - od) q - \\rv. Invariants_H.valid_queues\" - apply (rule_tac R="\_ s. (\t\set q. tcb_at' t s) \ valid_objs' s" - in hoare_post_add) - apply (rule hoare_pre) - apply (rule mapM_x_wp') - apply (rule hoare_name_pre_state) - apply (wp hoare_vcg_const_Ball_lift - tcbSchedEnqueue_valid_queues tcbSchedEnqueue_not_st - sts_valid_queues sts_st_tcb_at'_cases setThreadState_not_st - | simp - | ((elim conjE)?, drule (1) bspec, clarsimp elim!: obj_at'_weakenE simp: valid_tcb_state'_def))+ - done - lemma cancelAllIPC_mapM_x_weak_sch_act: "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ mapM_x (\t. do @@ -3413,13 +3455,15 @@ lemma cancelAllIPC_mapM_x_weak_sch_act: done lemma cancelAllIPC_mapM_x_valid_objs': - "\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 (wpsimp wp: mapM_x_wp' sts_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 @@ -3430,18 +3474,12 @@ lemma cancelAllIPC_mapM_x_tcbDomain_obj_at': tcbSchedEnqueue t od) q \\_. obj_at' (\tcb. P (tcbDomain tcb)) t'\" -apply (wp mapM_x_wp' tcbSchedEnqueue_not_st setThreadState_oa_queued | simp)+ -done + by (wpsimp wp: mapM_x_wp') 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) -apply (wp tcbSchedEnqueue_not_st - | wpc - | simp)+ -done + "rescheduleRequired \obj_at' (\tcb. Q (tcbDomain tcb) (tcbPriority tcb)) t\" + unfolding rescheduleRequired_def tcbSchedEnqueue_def tcbQueuePrepend_def + by wpsimp lemma cancelAllIPC_tcbDomain_obj_at': "\obj_at' (\tcb. P (tcbDomain tcb)) t'\ @@ -3455,21 +3493,6 @@ apply (wp hoare_vcg_conj_lift hoare_vcg_const_Ball_lift | simp)+ done -lemma cancelAllIPC_valid_queues[wp]: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - cancelAllIPC ep_ptr - \\rv. Invariants_H.valid_queues\" - apply (simp add: cancelAllIPC_def ep'_Idle_case_helper) - apply (wp hoare_vcg_conj_lift hoare_vcg_const_Ball_lift - cancelAllIPC_mapM_x_valid_queues cancelAllIPC_mapM_x_valid_objs' cancelAllIPC_mapM_x_weak_sch_act - set_ep_valid_objs' getEndpoint_wp) - apply (clarsimp simp: valid_ep'_def) - apply (drule (1) ko_at_valid_objs') - apply (auto simp: valid_obj'_def valid_ep'_def valid_tcb'_def projectKOs - split: endpoint.splits - elim: valid_objs_valid_tcbE) - done - lemma cancelAllSignals_tcbDomain_obj_at': "\obj_at' (\tcb. P (tcbDomain tcb)) t'\ cancelAllSignals epptr @@ -3483,44 +3506,9 @@ apply (wp hoare_vcg_conj_lift hoare_vcg_const_Ball_lift done lemma unbindMaybeNotification_tcbDomain_obj_at': - "\obj_at' (\tcb. P (tcbDomain tcb)) t'\ - unbindMaybeNotification r - \\_. obj_at' (\tcb. P (tcbDomain tcb)) t'\" - apply (simp add: unbindMaybeNotification_def) - apply (wp setBoundNotification_oa_queued getNotification_wp gbn_wp' | wpc | simp)+ - done - -lemma cancelAllSignals_valid_queues[wp]: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - cancelAllSignals ntfn - \\rv. Invariants_H.valid_queues\" - apply (simp add: cancelAllSignals_def) - apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) - apply (case_tac "ntfnObj ntfna", simp_all) - apply (wp, simp)+ - apply (wp hoare_vcg_conj_lift hoare_vcg_const_Ball_lift - cancelAllIPC_mapM_x_valid_queues cancelAllIPC_mapM_x_valid_objs' cancelAllIPC_mapM_x_weak_sch_act - set_ntfn_valid_objs' - | simp)+ - apply (clarsimp simp: valid_ep'_def) - apply (drule (1) ko_at_valid_objs') - apply (auto simp: valid_obj'_def valid_ntfn'_def valid_tcb'_def projectKOs - split: endpoint.splits - elim: valid_objs_valid_tcbE) - done - -lemma finaliseCapTrue_standin_valid_queues[wp]: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - finaliseCapTrue_standin cap final - \\_. Invariants_H.valid_queues\" - apply (simp add: finaliseCapTrue_standin_def Let_def) - apply (safe) - apply (wp | clarsimp | wpc)+ - done - - -crunch valid_queues[wp]: isFinalCapability "Invariants_H.valid_queues" - (simp: crunch_simps) + "unbindMaybeNotification r \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding unbindMaybeNotification_def + by (wpsimp wp: getNotification_wp gbn_wp' simp: setBoundNotification_def)+ crunch sch_act[wp]: isFinalCapability "\s. sch_act_wf (ksSchedulerAction s) s" (simp: crunch_simps) @@ -3529,96 +3517,6 @@ crunch weak_sch_act[wp]: isFinalCapability "\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. \obj_at' (inQ d p) tcb\ f \\_. obj_at' (inQ d p) tcb\" - and prq: "\P. \\s. P (ksReadyQueues s)\ f \\_ s. P (ksReadyQueues s)\" - shows "\valid_inQ_queues\ f \\_. valid_inQ_queues\" - proof - - show ?thesis - apply (clarsimp simp: valid_def valid_inQ_queues_def) - apply safe - apply (rule use_valid [OF _ tat], assumption) - apply (drule spec, drule spec, erule conjE, erule bspec) - apply (rule ccontr) - apply (erule notE[rotated], erule(1) use_valid [OF _ prq]) - apply (erule use_valid [OF _ prq]) - apply simp - done - qed - -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)+ - -crunch valid_inQ_queues[wp]: emptySlot valid_inQ_queues - (simp: crunch_simps) - -lemma cancelAllIPC_mapM_x_valid_inQ_queues: - "\valid_inQ_queues\ - mapM_x (\t. do - y \ setThreadState Structures_H.thread_state.Restart t; - tcbSchedEnqueue t - od) q - \\rv. valid_inQ_queues\" - apply (rule mapM_x_wp_inv) - apply (wp sts_valid_queues [where st="Structures_H.thread_state.Restart", simplified] - setThreadState_st_tcb) - done - -lemma cancelAllIPC_valid_inQ_queues[wp]: - "\valid_inQ_queues\ - cancelAllIPC ep_ptr - \\rv. valid_inQ_queues\" - apply (simp add: cancelAllIPC_def ep'_Idle_case_helper) - apply (wp cancelAllIPC_mapM_x_valid_inQ_queues) - apply (wp hoare_conjI hoare_drop_imp | simp)+ - done - -lemma cancelAllSignals_valid_inQ_queues[wp]: - "\valid_inQ_queues\ - cancelAllSignals ntfn - \\rv. valid_inQ_queues\" - apply (simp add: cancelAllSignals_def) - apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) - apply (case_tac "ntfnObj ntfna", simp_all) - apply (wp, simp)+ - apply (wp cancelAllIPC_mapM_x_valid_inQ_queues)+ - apply (simp) - done - -crunches unbindNotification, unbindMaybeNotification - for valid_inQ_queues[wp]: "valid_inQ_queues" - -lemma finaliseCapTrue_standin_valid_inQ_queues[wp]: - "\valid_inQ_queues\ - finaliseCapTrue_standin cap final - \\_. valid_inQ_queues\" - apply (simp add: finaliseCapTrue_standin_def Let_def) - apply (safe) - apply (wp | clarsimp | wpc)+ - done - -crunch valid_inQ_queues[wp]: isFinalCapability valid_inQ_queues - (simp: crunch_simps) - -lemma cteDeleteOne_valid_inQ_queues[wp]: - "\valid_inQ_queues\ - cteDeleteOne sl - \\_. valid_inQ_queues\" - apply (simp add: cteDeleteOne_def unless_def) - apply (wpsimp wp: hoare_drop_imp hoare_vcg_all_lift) - done - crunch ksCurDomain[wp]: cteDeleteOne "\s. P (ksCurDomain s)" (wp: crunch_wps simp: crunch_simps unless_def) @@ -3848,10 +3746,8 @@ lemma vcpuFinalise_corres [corres]: apply (frule sym_refs_vcpu_tcb) apply (simp add: vcpu_relation_def) apply fastforce - apply (clarsimp simp: obj_at_def vcpu_relation_def) + apply (fastforce simp: obj_at_def vcpu_relation_def) apply clarsimp - apply (drule ko_at_valid_objs', fastforce, simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_vcpu'_def typ_at_tcb') done lemma arch_finaliseCap_corres: @@ -3908,6 +3804,9 @@ lemma unbindNotification_corres: apply (clarsimp simp: ntfn_relation_def split:Structures_A.ntfn.splits) apply (rule setBoundNotification_corres) apply (wp gbn_wp' gbn_wp)+ + apply clarsimp + apply (frule invs_psp_aligned) + apply (frule invs_distinct) 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 @@ -3934,6 +3833,9 @@ lemma unbindMaybeNotification_corres: apply (clarsimp simp: ntfn_relation_def split: Structures_A.ntfn.splits) apply (rule setBoundNotification_corres) apply (wp get_simple_ko_wp getNotification_wp)+ + apply clarsimp + apply (frule invs_psp_aligned) + apply (frule invs_distinct) 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 @@ -4105,12 +4007,6 @@ lemma arch_recycleCap_improve_cases: \ isASIDControlCap cap \ \ (if isASIDPoolCap cap then v else undefined) = v" by (cases cap, simp_all add: isCap_simps) -crunch queues[wp]: copyGlobalMappings "Invariants_H.valid_queues" - (wp: crunch_wps ignore: storePDE) - -crunch queues'[wp]: copyGlobalMappings "Invariants_H.valid_queues'" - (wp: crunch_wps ignore: storePDE) - crunch ifunsafe'[wp]: copyGlobalMappings "if_unsafe_then_cap'" (wp: crunch_wps ignore: storePDE) @@ -4210,178 +4106,6 @@ lemma cteCaps_of_ctes_of_lift: lemmas final_matters'_simps = final_matters'_def [split_simps capability.split arch_capability.split] -definition set_thread_all :: "obj_ref \ Structures_A.tcb \ etcb - \ unit det_ext_monad" where - "set_thread_all ptr tcb etcb \ - do s \ get; - kh \ return $ (kheap s)(ptr \ (TCB tcb)); - ekh \ return $ (ekheap s)(ptr \ etcb); - put (s\kheap := kh, ekheap := ekh\) - od" - -definition thread_gets_the_all :: "obj_ref \ (Structures_A.tcb \ etcb) det_ext_monad" where - "thread_gets_the_all tptr \ - do tcb \ gets_the $ get_tcb tptr; - etcb \ gets_the $ get_etcb tptr; - return $ (tcb, etcb) od" - -definition thread_set_all :: "(Structures_A.tcb \ Structures_A.tcb) \ (etcb \ etcb) - \ obj_ref \ unit det_ext_monad" where - "thread_set_all f g tptr \ - do (tcb, etcb) \ thread_gets_the_all tptr; - set_thread_all tptr (f tcb) (g etcb) - od" - -lemma set_thread_all_corres: - fixes ob' :: "'a :: pspace_storable" - assumes x: "updateObject ob' = updateObject_default ob'" - assumes z: "\s. obj_at' P ptr s - \ map_to_ctes ((ksPSpace s) (ptr \ injectKO ob')) = map_to_ctes (ksPSpace s)" - assumes b: "\ko. P ko \ objBits ko = objBits ob'" - assumes P: "\(v::'a::pspace_storable). (1 :: word32) < 2 ^ (objBits v)" - assumes e: "etcb_relation etcb tcb'" - assumes is_t: "injectKO (ob' :: 'a :: pspace_storable) = KOTCB tcb'" - shows "other_obj_relation (TCB tcb) (injectKO (ob' :: 'a :: pspace_storable)) \ - corres dc (obj_at (same_caps (TCB tcb)) ptr and is_etcb_at ptr) - (obj_at' (P :: 'a \ bool) ptr) - (set_thread_all ptr tcb etcb) (setObject ptr ob')" - apply (rule corres_no_failI) - apply (rule no_fail_pre) - apply wp - apply (rule x) - apply (clarsimp simp: b elim!: obj_at'_weakenE) - apply (unfold set_thread_all_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 - updateObject_default_def in_magnitude_check [OF _ P]) - apply (clarsimp simp add: state_relation_def z) - apply (simp add: trans_state_update'[symmetric] trans_state_update[symmetric] - del: trans_state_update) - apply (clarsimp simp add: swp_def fun_upd_def obj_at_def is_etcb_at_def) - apply (subst cte_wp_at_after_update,fastforce simp add: obj_at_def) - apply (subst caps_of_state_after_update,fastforce simp add: obj_at_def) - apply clarsimp - 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 - split: Structures_A.kernel_object.splits if_split_asm) - - apply (fold fun_upd_def) - apply (simp only: pspace_relation_def dom_fun_upd2 simp_thms) - apply (subst pspace_dom_update) - apply assumption - apply simp - 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: is_other_obj_relation_type) - apply (drule(1) bspec) - apply clarsimp - apply (frule_tac ko'="TCB tcb'" and x'=ptr in obj_relation_cut_same_type, - (fastforce simp add: is_other_obj_relation_type)+)[1] - 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 (clarsimp simp: projectKOs) - apply (insert e is_t) - by (clarsimp simp: other_obj_relation_def etcb_relation_def is_other_obj_relation_type split: Structures_A.kernel_object.splits Structures_H.kernel_object.splits ARM_A.arch_kernel_obj.splits) - -lemma tcb_update_all_corres': - assumes tcbs: "tcb_relation tcb tcb' \ tcb_relation tcbu tcbu'" - assumes tables: "\(getF, v) \ ran tcb_cap_cases. getF tcbu = getF tcb" - assumes tables': "\(getF, v) \ ran tcb_cte_cases. getF tcbu' = getF tcb'" - assumes r: "r () ()" - assumes e: "etcb_relation etcb tcb' \ etcb_relation etcbu tcbu'" - shows "corres r (ko_at (TCB tcb) add and (\s. ekheap s add = Some etcb)) - (ko_at' tcb' add) - (set_thread_all add tcbu etcbu) (setObject add tcbu')" - apply (rule_tac F="tcb_relation tcb tcb' \ 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 (force simp: projectKOs other_obj_relation_def ekheap_relation_def e) - apply (erule conjE) - apply (rule corres_guard_imp) - apply (rule corres_rel_imp) - apply (rule set_thread_all_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 simp: is_etcb_at_def 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 mask_def objBits_defs) - apply (subst if_not_P) - apply (fastforce dest: bspec [OF tables', OF ranI]) - apply simp - done - -lemma thread_gets_the_all_corres: - shows "corres (\(tcb, etcb) tcb'. tcb_relation tcb tcb' \ etcb_relation etcb tcb') - (tcb_at t and is_etcb_at t) (tcb_at' t) - (thread_gets_the_all t) (getObject t)" - apply (rule corres_no_failI) - apply wp - apply (clarsimp simp add: gets_def get_def return_def bind_def get_tcb_def thread_gets_the_all_def threadGet_def ethread_get_def gets_the_def assert_opt_def get_etcb_def is_etcb_at_def tcb_at_def liftM_def split: option.splits Structures_A.kernel_object.splits) - 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 ko) - apply (simp_all add: fail_def return_def) - apply (clarsimp simp add: state_relation_def pspace_relation_def ekheap_relation_def) - apply (drule bspec) - apply clarsimp - apply blast - apply (drule bspec, erule domI) - apply (clarsimp simp add: other_obj_relation_def - lookupAround2_known1) - done - -lemma thread_set_all_corresT: - assumes x: "\tcb tcb'. tcb_relation tcb tcb' \ - tcb_relation (f tcb) (f' tcb')" - 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" - assumes e: "\etcb tcb'. etcb_relation etcb tcb' \ - etcb_relation (g etcb) (f' tcb')" - shows "corres dc (tcb_at t and valid_etcbs) - (tcb_at' t) - (thread_set_all f g t) (threadSet f' t)" - apply (simp add: thread_set_all_def threadSet_def bind_assoc) - apply (rule corres_guard_imp) - apply (rule corres_split[OF thread_gets_the_all_corres]) - apply (simp add: split_def) - apply (rule tcb_update_all_corres') - apply (erule x) - apply (rule y) - apply (clarsimp simp: bspec_split [OF spec [OF z]]) - apply fastforce - apply (erule e) - apply (simp add: thread_gets_the_all_def, wp+) - apply clarsimp - apply (frule(1) tcb_at_is_etcb_at) - apply (clarsimp simp add: tcb_at_def get_etcb_def obj_at_def) - apply (drule get_tcb_SomeD) - apply fastforce - apply simp - done - -lemmas thread_set_all_corres = - thread_set_all_corresT [OF _ _ all_tcbI, OF _ ball_tcb_cap_casesI ball_tcb_cte_casesI] - crunch idle_thread[wp]: deleteCallerCap "\s. P (ksIdleThread s)" (wp: crunch_wps) crunch sch_act_simple: deleteCallerCap sch_act_simple @@ -4399,89 +4123,6 @@ lemma setEndpoint_sch_act_not_ct[wp]: setEndpoint ptr val \\_ s. sch_act_not (ksCurThread s) s\" by (rule hoare_weaken_pre, wps setEndpoint_ct', wp, simp) -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 - -lemma cancelAllIPC_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - cancelAllIPC epptr - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - (is "\?PRE\ _ \\_. ?POST\") - apply (simp add: cancelAllIPC_def) - apply (wp, wpc, wp) - apply (wps rescheduleRequired_ct') - apply (wp rescheduleRequired_ksQ') - apply (clarsimp simp: forM_x_def) - apply (wp cancelAll_ct_not_ksQ_helper mapM_x_wp_inv) - apply (wp hoare_lift_Pf2 [OF setEndpoint_ksQ setEndpoint_ct'])+ - apply (wps rescheduleRequired_ct') - apply (wp rescheduleRequired_ksQ') - apply (clarsimp simp: forM_x_def) - apply (wp cancelAll_ct_not_ksQ_helper mapM_x_wp_inv) - apply (wp hoare_lift_Pf2 [OF setEndpoint_ksQ setEndpoint_ct'])+ - prefer 2 - apply assumption - apply (rule_tac Q="\ep. ?PRE and ko_at' ep epptr" in hoare_post_imp) - apply (clarsimp) - apply (rule conjI) - apply ((clarsimp simp: invs'_def valid_state'_def - sch_act_sane_def - | drule(1) ct_not_in_epQueue)+)[2] - apply (wp get_ep_sp') - done - -lemma cancelAllSignals_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - cancelAllSignals ntfnptr - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - (is "\?PRE\ _ \\_. ?POST\") - apply (simp add: cancelAllSignals_def) - apply (wp, wpc, wp+) - apply (wps rescheduleRequired_ct') - apply (wp rescheduleRequired_ksQ') - apply clarsimp - apply (wp cancelAll_ct_not_ksQ_helper mapM_x_wp_inv) - apply (wp hoare_lift_Pf2 [OF setNotification_ksQ setNotification_ksCurThread]) - apply (wps setNotification_ksCurThread, wp) - prefer 2 - apply assumption - apply (rule_tac Q="\ep. ?PRE and ko_at' ep ntfnptr" in hoare_post_imp) - apply ((clarsimp simp: invs'_def valid_state'_def sch_act_sane_def - | drule(1) ct_not_in_ntfnQueue)+)[1] - apply (wp get_ntfn_sp') - done - -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 hoare_seq_ext[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 setNotification_ksCurThread, wp) - apply clarsimp - done - lemma sbn_ct_in_state'[wp]: "\ct_in_state' P\ setBoundNotification ntfn t \\_. ct_in_state' P\" apply (simp add: ct_in_state'_def) @@ -4514,37 +4155,6 @@ lemma unbindMaybeNotification_sch_act_sane[wp]: apply (wp setNotification_sch_act_sane sbn_sch_act_sane | wpc | clarsimp)+ done -lemma finaliseCapTrue_standin_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - finaliseCapTrue_standin cap final - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - apply (simp add: finaliseCapTrue_standin_def Let_def) - apply (safe) - apply (wp cancelAllIPC_ct_not_ksQ cancelAllSignals_ct_not_ksQ - hoare_drop_imps unbindMaybeNotification_ct_not_ksQ - | wpc - | clarsimp simp: isNotificationCap_def isReplyCap_def split:capability.splits)+ - done - -lemma cteDeleteOne_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - cteDeleteOne slot - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - apply (simp add: cteDeleteOne_def unless_def split_def) - apply (rule hoare_seq_ext [OF _ getCTE_sp]) - apply (case_tac "\final. finaliseCap (cteCap cte) final True = fail") - apply (simp add: finaliseCapTrue_standin_simple_def) - apply wp - apply (clarsimp) - apply (wp emptySlot_cteCaps_of hoare_lift_Pf2 [OF emptySlot_ksRQ emptySlot_ct]) - apply (simp add: cteCaps_of_def) - apply (wp (once) hoare_drop_imps) - apply (wp finaliseCapTrue_standin_ct_not_ksQ isFinalCapability_inv)+ - apply (clarsimp) - done - end end diff --git a/proof/refine/ARM_HYP/Init_R.thy b/proof/refine/ARM_HYP/Init_R.thy index b12f9a916d..589a07a9a6 100644 --- a/proof/refine/ARM_HYP/Init_R.thy +++ b/proof/refine/ARM_HYP/Init_R.thy @@ -96,7 +96,7 @@ definition zeroed_intermediate_state :: ksDomSchedule = [], ksCurDomain = 0, ksDomainTime = 0, - ksReadyQueues = K [], + ksReadyQueues = K (TcbQueue None None), ksReadyQueuesL1Bitmap = K 0, ksReadyQueuesL2Bitmap = K 0, ksCurThread = 0, @@ -117,9 +117,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: ekheap_relation_def) - apply (clarsimp simp: ready_queues_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_HYP/InterruptAcc_R.thy b/proof/refine/ARM_HYP/InterruptAcc_R.thy index 174dad753f..cb47389eab 100644 --- a/proof/refine/ARM_HYP/InterruptAcc_R.thy +++ b/proof/refine/ARM_HYP/InterruptAcc_R.thy @@ -52,14 +52,14 @@ lemma setIRQState_invs[wp]: apply (simp add: setIRQState_def setInterruptState_def getInterruptState_def) apply (wp dmo_maskInterrupt) apply (clarsimp simp: invs'_def valid_state'_def cur_tcb'_def - Invariants_H.valid_queues_def valid_queues'_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 split: option.splits) + bitmapQ_defs valid_bitmaps_def + split: option.splits) apply (rule conjI, clarsimp) apply (clarsimp simp: irqs_masked'_def ct_not_inQ_def) apply (rule conjI) @@ -154,8 +154,8 @@ lemma invs'_irq_state_independent [simp, intro!]: 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_queues_no_bitmap_def - valid_queues'_def valid_pde_mappings'_def + irqs_masked'_def bitmapQ_defs valid_bitmaps_def + 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 diff --git a/proof/refine/ARM_HYP/Interrupt_R.thy b/proof/refine/ARM_HYP/Interrupt_R.thy index b2007e80ef..dc1c9600a0 100644 --- a/proof/refine/ARM_HYP/Interrupt_R.thy +++ b/proof/refine/ARM_HYP/Interrupt_R.thy @@ -604,13 +604,6 @@ lemma decDomainTime_corres: apply (clarsimp simp:state_relation_def) done -lemma tcbSchedAppend_valid_objs': - "\valid_objs'\tcbSchedAppend t \\r. valid_objs'\" - apply (simp add:tcbSchedAppend_def) - apply (wpsimp wp: unless_wp threadSet_valid_objs' threadGet_wp) - apply (clarsimp simp add:obj_at'_def typ_at'_def) - done - lemma thread_state_case_if: "(case state of Structures_A.thread_state.Running \ f | _ \ g) = (if state = Structures_A.thread_state.Running then f else g)" @@ -621,35 +614,27 @@ lemma threadState_case_if: (if state = Structures_H.thread_state.Running then f else g)" by (case_tac state,auto) -lemma tcbSchedAppend_invs_but_ct_not_inQ': - "\invs' and st_tcb_at' runnable' t \ - tcbSchedAppend t \\_. all_invs_but_ct_not_inQ'\" - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp 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 - | fastforce elim!: st_tcb_ex_cap'' split: thread_state.split_asm)+ - done +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 timerTick_corres: - "corres dc (cur_tcb and valid_sched) - invs' - timer_tick timerTick" - supply if_weak_cong[cong] + "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="\ and (cur_tcb and valid_sched)" and Q'="\ and invs'" in corres_guard_imp) + 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_split[where r' = dc]) apply (rule corres_if[where Q = \ and Q' = \]) apply (case_tac state,simp_all)[1] - apply (simp add: Let_def) apply (rule_tac r'="(=)" in corres_split[OF ethreadget_corres]) apply (simp add:etcb_relation_def) apply (rename_tac ts ts') @@ -659,55 +644,53 @@ lemma timerTick_corres: apply (rule ethread_set_corres, simp+) apply (clarsimp simp: etcb_relation_def) apply simp - apply (rule corres_split) - apply (rule ethread_set_corres; simp) - apply (simp add: etcb_relation_def) - apply (rule corres_split[OF tcbSchedAppend_corres]) + 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)[1] - apply (rule hoare_strengthen_post) - apply (rule tcbSchedAppend_invs_but_ct_not_inQ', - clarsimp simp: sch_act_wf_weak) - apply (wp threadSet_timeslice_invs threadSet_valid_queues - threadSet_valid_queues' threadSet_pred_tcb_at_state)+ - apply simp - apply simp - apply (rule corres_when,simp) + 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 (simp add:dec_domain_time_def) - apply wp+ - apply (simp add:decDomainTime_def) - apply wp - apply (wp|wpc|unfold Let_def|simp)+ - apply (wp hoare_weak_lift_imp threadSet_timeslice_invs threadSet_valid_queues threadSet_valid_queues' - threadSet_pred_tcb_at_state threadSet_weak_sch_act_wf tcbSchedAppend_valid_objs' - rescheduleRequired_weak_sch_act_wf tcbSchedAppend_valid_queues| simp)+ - apply (strengthen sch_act_wf_weak) - apply (clarsimp simp:conj_comms) - apply (wp tcbSchedAppend_valid_queues tcbSchedAppend_sch_act_wf) - apply simp - apply (wp threadSet_valid_queues threadSet_pred_tcb_at_state threadSet_sch_act - threadSet_tcbDomain_triv threadSet_valid_queues' threadSet_valid_objs'| simp)+ - apply (wp threadGet_wp gts_wp gts_wp')+ - apply (clarsimp simp: cur_tcb_def tcb_at_is_etcb_at valid_sched_def valid_sched_action_def) - prefer 2 - apply clarsimp - apply (clarsimp simp add:cur_tcb_def valid_sched_def - valid_sched_action_def valid_etcbs_def is_tcb_def - is_etcb_at_def st_tcb_at_def obj_at_def - dest!:get_tcb_SomeD) - apply (clarsimp simp: invs'_def valid_state'_def - sch_act_wf_weak - cur_tcb'_def inQ_def - ct_in_state'_def obj_at'_def) - apply (clarsimp simp:st_tcb_at'_def - valid_idle'_def ct_idle_or_in_cur_domain'_def - obj_at'_def projectKO_eq) - apply simp + 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 lemma corres_return_VGICMaintenance [corres]: @@ -802,7 +785,7 @@ lemma virqSetEOIIRQEN_eq[simp]: lemma vgic_maintenance_corres [corres]: "corres dc einvs - (\s. invs' s \ sch_act_not (ksCurThread s) s \ (\p. ksCurThread s \ set (ksReadyQueues s p))) + (\s. invs' s \ sch_act_not (ksCurThread s) s) vgic_maintenance vgicMaintenance" proof - (* hoare_lift_Pf-style rules match too often, slowing down proof unless specialised *) @@ -813,7 +796,6 @@ proof - note wplr' = vilr'[where P="sch_act_not"] vilr'[where P="ex_nonz_cap_to'"] vilr'[where P="st_tcb_at' simple'"] - vilr'[where P="\t s. t \ set (ksReadyQueues s x)" for x] show ?thesis unfolding vgic_maintenance_def vgicMaintenance_def isRunnable_def Let_def apply (rule corres_guard_imp) @@ -867,13 +849,12 @@ proof - in hoare_post_imp) apply (clarsimp cong: imp_cong conj_cong simp: not_pred_tcb runnable_eq pred_conj_def) apply (strengthen st_tcb_ex_cap'[where P=active], clarsimp) - apply (clarsimp simp: pred_tcb_at_def obj_at_def) + apply (clarsimp simp: pred_tcb_at_def obj_at_def invs_psp_aligned invs_distinct) apply wp apply clarsimp apply (rule_tac Q="\rv x. tcb_at' rv x \ invs' x - \ sch_act_not rv x - \ (\d p. rv \ set (ksReadyQueues x (d, p)))" + \ sch_act_not rv x" in hoare_post_imp) apply (rename_tac rv s) apply clarsimp @@ -903,7 +884,7 @@ qed lemma vppiEvent_corres: "corres dc einvs - (\s. invs' s \ sch_act_not (ksCurThread s) s \ (\p. ksCurThread s \ set (ksReadyQueues s p))) + (\s. invs' s \ sch_act_not (ksCurThread s) s) (vppi_event irq) (vppiEvent irq)" unfolding vppi_event_def vppiEvent_def isRunnable_def supply [[simproc del: defined_all]] @@ -941,13 +922,13 @@ lemma vppiEvent_corres: (ARM_A.VPPIEvent irq)))" in hoare_post_imp) apply (clarsimp cong: imp_cong conj_cong simp: not_pred_tcb runnable_eq pred_conj_def) - apply (strengthen st_tcb_ex_cap'[where P=active], clarsimp) + apply (strengthen st_tcb_ex_cap'[where P=active], + clarsimp simp: invs_psp_aligned invs_distinct) apply wp apply (clarsimp cong: imp_cong conj_cong simp: pred_conj_def) apply (rule_tac Q="\rv x. tcb_at' rv x \ invs' x - \ sch_act_not rv x - \ (\d p. rv \ set (ksReadyQueues x (d, p)))" in hoare_post_imp) + \ sch_act_not rv x" in hoare_post_imp) apply (rename_tac rv s) apply (strengthen st_tcb_ex_cap''[where P=active']) apply (strengthen invs_iflive') @@ -975,8 +956,7 @@ lemma vppiEvent_corres: lemma handle_reserved_irq_corres[corres]: "corres dc einvs - (\s. invs' s \ (irq \ non_kernel_IRQs \ - sch_act_not (ksCurThread s) s \ (\p. ksCurThread s \ set (ksReadyQueues s p)))) + (\s. invs' s \ (irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s)) (handle_reserved_irq irq) (handleReservedIRQ irq)" apply (clarsimp simp: handle_reserved_irq_def handleReservedIRQ_def irqVPPIEventIndex_def irq_vppi_event_index_def non_kernel_IRQs_def IRQ_def irqVGICMaintenance_def @@ -984,17 +964,13 @@ lemma handle_reserved_irq_corres[corres]: apply (rule conjI; clarsimp) apply (rule corres_guard_imp, rule vppiEvent_corres) apply (fastforce intro: vgic_maintenance_corres simp: unat_arith_simps)+ - apply (rule conjI; clarsimp) - apply (rule corres_guard_imp) - apply (fastforce intro: vgic_maintenance_corres simp: unat_arith_simps)+ done lemma handleInterrupt_corres: "corres dc - (einvs) + einvs (invs' and (\s. intStateIRQTable (ksInterruptState s) irq \ IRQInactive) and - (\s. irq \ non_kernel_IRQs \ - sch_act_not (ksCurThread s) s \ (\p. ksCurThread s \ set (ksReadyQueues s p)))) + (\s. irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s)) (handle_interrupt irq) (handleInterrupt irq)" (is "corres dc _ (invs' and _ and ?P') _ _") apply (simp add: handle_interrupt_def handleInterrupt_def) @@ -1038,7 +1014,7 @@ lemma handleInterrupt_corres: apply (rule corres_machine_op) apply (rule corres_eq_trivial, (simp add: no_fail_ackInterrupt)+) apply wp+ - apply clarsimp + apply fastforce apply clarsimp apply corresKsimp done @@ -1062,15 +1038,6 @@ lemma updateTimeSlice_valid_pspace[wp]: apply (auto simp:tcb_cte_cases_def) done -lemma updateTimeSlice_valid_queues[wp]: - "\\s. Invariants_H.valid_queues s \ - threadSet (tcbTimeSlice_update (\_. ts')) thread - \\r s. Invariants_H.valid_queues s\" - apply (wp threadSet_valid_queues,simp) - apply (clarsimp simp:obj_at'_def inQ_def) - done - - lemma dom_upd_eq: "f t = Some y \ dom (\a. if a = t then Some x else f a) = dom f" by (auto split: if_split_asm) @@ -1097,29 +1064,29 @@ crunch ct[wp]: tcbSchedAppend cur_tcb' (wp: cur_tcb_lift crunch_wps) lemma timerTick_invs'[wp]: - "\invs'\ timerTick \\rv. invs'\" + "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 - tcbSchedAppend_invs_but_ct_not_inQ' - simp: tcb_cte_cases_def) - apply (rule_tac Q="\rv. invs'" in hoare_post_imp) - apply (clarsimp simp add:invs'_def valid_state'_def) + 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' - del: tcbSchedAppend_sch_act_wf)+ - apply (rule hoare_strengthen_post[OF tcbSchedAppend_invs_but_ct_not_inQ']) - apply (wpsimp simp: valid_pspace'_def sch_act_wf_weak)+ - apply (wpsimp wp: threadSet_pred_tcb_no_state threadSet_tcbDomain_triv - threadSet_valid_objs' threadSet_timeslice_invs)+ - apply (wp threadGet_wp) + 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 (clarsimp simp: invs'_def st_tcb_at'_def obj_at'_def valid_state'_def) + apply (auto simp: invs'_def st_tcb_at'_def obj_at'_def valid_state'_def cong: conj_cong) done lemma resetTimer_invs'[wp]: @@ -1149,8 +1116,9 @@ lemma runnable'_eq: by (cases st; simp) lemma vgicMaintenance_invs'[wp]: - "\invs' and (\s. sch_act_not (ksCurThread s) s \ (\p. ksCurThread s \ set (ksReadyQueues s p)))\ - vgicMaintenance \\y. invs'\" + "\invs' and (\s. sch_act_not (ksCurThread s) s)\ + vgicMaintenance + \\_. invs'\" supply if_split[split del] apply (clarsimp simp: vgicMaintenance_def get_gic_vcpu_ctrl_lr_def set_gic_vcpu_ctrl_lr_def get_gic_vcpu_ctrl_misr_def get_gic_vcpu_ctrl_eisr1_def get_gic_vcpu_ctrl_eisr0_def @@ -1161,8 +1129,7 @@ lemma vgicMaintenance_invs'[wp]: apply (clarsimp cong: imp_cong conj_cong simp: pred_conj_def) apply (rule_tac Q="\_ s. tcb_at' (ksCurThread s) s \ invs' s - \ sch_act_not (ksCurThread s) s - \ (\d p. (ksCurThread s) \ set (ksReadyQueues s (d, p)))" + \ sch_act_not (ksCurThread s) s" in hoare_post_imp) apply (clarsimp cong: imp_cong conj_cong simp: not_pred_tcb') apply (clarsimp simp: st_tcb_at'_def obj_at'_def runnable'_eq) @@ -1185,7 +1152,7 @@ lemma vgicMaintenance_invs'[wp]: done lemma vppiEvent_invs'[wp]: - "\invs' and (\s. sch_act_not (ksCurThread s) s \ (\p. ksCurThread s \ set (ksReadyQueues s p)))\ + "\invs' and (\s. sch_act_not (ksCurThread s) s)\ vppiEvent irq \\y. invs'\" supply if_split[split del] apply (clarsimp simp: vppiEvent_def doMachineOp_bind) @@ -1195,8 +1162,7 @@ lemma vppiEvent_invs'[wp]: apply (clarsimp cong: imp_cong conj_cong simp: pred_conj_def) apply (rule_tac Q="\_ s. tcb_at' (ksCurThread s) s \ invs' s - \ sch_act_not (ksCurThread s) s - \ (\d p. (ksCurThread s) \ set (ksReadyQueues s (d, p)))" + \ sch_act_not (ksCurThread s) s" in hoare_post_imp) apply (clarsimp cong: imp_cong conj_cong simp: not_pred_tcb') apply (clarsimp simp: st_tcb_at'_def obj_at'_def runnable'_eq) @@ -1211,8 +1177,7 @@ lemma vppiEvent_invs'[wp]: done lemma hint_invs[wp]: - "\invs' and (\s. irq \ non_kernel_IRQs \ - sch_act_not (ksCurThread s) s \ (\p. ksCurThread s \ set (ksReadyQueues s p)))\ + "\invs' and (\s. irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s)\ handleInterrupt irq \\rv. invs'\" apply (simp add: handleInterrupt_def getSlotCap_def cong: irqstate.case_cong) apply (rule conjI; rule impI) diff --git a/proof/refine/ARM_HYP/InvariantUpdates_H.thy b/proof/refine/ARM_HYP/InvariantUpdates_H.thy index c15fac0053..46a234c70a 100644 --- a/proof/refine/ARM_HYP/InvariantUpdates_H.thy +++ b/proof/refine/ARM_HYP/InvariantUpdates_H.thy @@ -38,8 +38,9 @@ lemma invs'_machine: proof - show ?thesis apply (cases "ksSchedulerAction s") - 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_queues_def valid_queues_no_bitmap_def bitmapQ_defs + 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 @@ -56,12 +57,13 @@ lemma invs_no_cicd'_machine: 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_queues_def valid_queues_no_bitmap_def bitmapQ_defs - vms ct_not_inQ_def - state_refs_of'_def ps_clear_def - valid_irq_node'_def mask - cong: option.case_cong) + 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) done qed @@ -98,14 +100,9 @@ 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_queues_ksSchedulerAction_update[simp]: - "valid_queues (ksSchedulerAction_update f s) = valid_queues s" - unfolding valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs - by simp - -lemma valid_queues'_ksSchedulerAction_update[simp]: - "valid_queues' (ksSchedulerAction_update f s) = valid_queues' s" - by (simp add: valid_queues'_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'" @@ -140,45 +137,25 @@ lemma tcb_in_cur_domain_ct[simp]: "tcb_in_cur_domain' t (ksCurThread_update f s) = tcb_in_cur_domain' t s" by (fastforce simp: tcb_in_cur_domain'_def) -lemma valid_queues'_ksCurDomain[simp]: - "valid_queues' (ksCurDomain_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) - -lemma valid_queues'_ksDomScheduleIdx[simp]: - "valid_queues' (ksDomScheduleIdx_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) +lemma valid_bitmaps_ksCurDomain[simp]: + "valid_bitmaps (ksCurDomain_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) -lemma valid_queues'_ksDomSchedule[simp]: - "valid_queues' (ksDomSchedule_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) +lemma valid_bitmaps_ksDomScheduleIdx[simp]: + "valid_bitmaps (ksDomScheduleIdx_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) -lemma valid_queues'_ksDomainTime[simp]: - "valid_queues' (ksDomainTime_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) +lemma valid_bitmaps_ksDomSchedule[simp]: + "valid_bitmaps (ksDomSchedule_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) -lemma valid_queues'_ksWorkUnitsCompleted[simp]: - "valid_queues' (ksWorkUnitsCompleted_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) +lemma valid_bitmaps_ksDomainTime[simp]: + "valid_bitmaps (ksDomainTime_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) -lemma valid_queues_ksCurDomain[simp]: - "valid_queues (ksCurDomain_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_ksDomScheduleIdx[simp]: - "valid_queues (ksDomScheduleIdx_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_ksDomSchedule[simp]: - "valid_queues (ksDomSchedule_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_ksDomainTime[simp]: - "valid_queues (ksDomainTime_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_ksWorkUnitsCompleted[simp]: - "valid_queues (ksWorkUnitsCompleted_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) +lemma valid_bitmaps_ksWorkUnitsCompleted[simp]: + "valid_bitmaps (ksWorkUnitsCompleted_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) lemma valid_irq_node'_ksCurDomain[simp]: "valid_irq_node' w (ksCurDomain_update f s) = valid_irq_node' w s" @@ -255,6 +232,10 @@ lemma valid_mdb_interrupts'[simp]: "valid_mdb' (ksInterruptState_update f s) = valid_mdb' s" by (simp add: valid_mdb'_def) +lemma valid_mdb'_ksReadyQueues_update[simp]: + "valid_mdb' (ksReadyQueues_update f s) = valid_mdb' s" + by (simp add: valid_mdb'_def) + lemma vms_ksReadyQueues_update[simp]: "valid_machine_state' (ksReadyQueues_update f s) = valid_machine_state' s" by (simp add: valid_machine_state'_def) @@ -279,10 +260,10 @@ lemma ct_in_state_ksSched[simp]: lemma invs'_wu[simp]: "invs' (ksWorkUnitsCompleted_update f s) = invs' s" - apply (simp add: invs'_def cur_tcb'_def valid_state'_def Invariants_H.valid_queues_def - valid_queues'_def valid_irq_node'_def valid_machine_state'_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 valid_queues_no_bitmap_def) + bitmapQ_defs) done lemma valid_arch_state'_interrupt[simp]: @@ -334,9 +315,8 @@ lemma sch_act_simple_ksReadyQueuesL2Bitmap[simp]: lemma ksDomainTime_invs[simp]: "invs' (ksDomainTime_update f s) = invs' s" - 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) + 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" @@ -364,9 +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 valid_state'_def valid_queues_def valid_queues'_def - valid_irq_node'_def cur_tcb'_def ct_idle_or_in_cur_domain'_def - tcb_in_cur_domain'_def valid_queues_no_bitmap_def - bitmapQ_no_L2_orphans_def bitmapQ_no_L1_orphans_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 \ No newline at end of file diff --git a/proof/refine/ARM_HYP/Invariants_H.thy b/proof/refine/ARM_HYP/Invariants_H.thy index 7d3acef6cc..60be16f4ba 100644 --- a/proof/refine/ARM_HYP/Invariants_H.thy +++ b/proof/refine/ARM_HYP/Invariants_H.thy @@ -11,6 +11,7 @@ imports "AInvs.Deterministic_AI" "AInvs.AInvs" "Lib.AddUpdSimps" + "Lib.Heap_List" begin context Arch begin @@ -162,6 +163,21 @@ definition abbreviation "cte_at' \ cte_wp_at' \" +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 tcbSchedPrevs_of :: "kernel_state \ obj_ref \ obj_ref option" where + "tcbSchedPrevs_of s \ tcbs_of' s |> tcbSchedPrev" + +abbreviation tcbSchedNexts_of :: "kernel_state \ obj_ref \ obj_ref option" where + "tcbSchedNexts_of s \ tcbs_of' s |> tcbSchedNext" + +abbreviation sym_heap_sched_pointers :: "global.kernel_state \ bool" where + "sym_heap_sched_pointers s \ sym_heap (tcbSchedNexts_of s) (tcbSchedPrevs_of s)" + definition tcb_cte_cases :: "word32 \ ((tcb \ cte) \ ((cte \ cte) \ tcb \ tcb))" where @@ -236,13 +252,14 @@ where then refs_of' ko else {}))" - primrec live0' :: "Structures_H.kernel_object \ bool" where "live0' (KOTCB tcb) = - (bound (tcbBoundNotification 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))" | "live0' (KOCTE cte) = False" | "live0' (KOEndpoint ep) = (ep \ IdleEP)" | "live0' (KONotification ntfn) = (bound (ntfnBoundTCB ntfn) \ (\ts. ntfnObj ntfn = WaitingNtfn ts))" @@ -315,14 +332,14 @@ where definition live' :: "kernel_object \ bool" where "live' ko \ case ko of - (KOTCB tcb) => live0' ko \ hyp_live' ko - | (KOCTE cte) => False - | (KOEndpoint ep) => live0' ko - | (KONotification ntfn) => live0' ko - | (KOUserData) => False - | (KOUserDataDevice) => False - | (KOKernelData) => False - | (KOArch ako) => hyp_live' ko" + KOTCB tcb => live0' ko \ hyp_live' ko + | KOCTE cte => False + | KOEndpoint ep => live0' ko + | KONotification ntfn => live0' ko + | KOUserData => False + | KOUserDataDevice => False + | KOKernelData => False + | KOArch ako => hyp_live' ko" context begin interpretation Arch . (*FIXME: arch_split*) primrec @@ -579,6 +596,11 @@ definition where "valid_arch_tcb' \ \t s. \v. atcbVCPUPtr t = Some v \ vcpu_at' v s " +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' :: "Structures_H.tcb \ kernel_state \ bool" where @@ -589,6 +611,8 @@ where \ tcbDomain t \ maxDomain \ tcbPriority t \ maxPriority \ tcbMCP t \ maxPriority + \ opt_tcb_at' (tcbSchedPrev t) s + \ opt_tcb_at' (tcbSchedNext t) s \ valid_arch_tcb' (tcbArch t) s" definition @@ -1012,10 +1036,15 @@ where | "runnable' (Structures_H.BlockedOnSend a b c d e) = False" | "runnable' (Structures_H.BlockedOnNotification x) = False" -definition - inQ :: "domain \ priority \ tcb \ bool" -where - "inQ d p tcb \ tcbQueued tcb \ tcbPriority tcb = p \ tcbDomain tcb = d" +definition inQ :: "domain \ priority \ tcb \ bool" where + "inQ d p tcb \ tcbQueued tcb \ tcbPriority tcb = p \ tcbDomain tcb = d" + +lemma inQ_implies_tcbQueueds_of: + "(inQ domain priority |< tcbs_of' s') tcbPtr \ (tcbQueued |< tcbs_of' s') tcbPtr" + by (clarsimp simp: opt_map_def opt_pred_def inQ_def split: option.splits) + +defs ready_qs_runnable_def: + "ready_qs_runnable s \ \t. obj_at' tcbQueued t s \ st_tcb_at' runnable' t s" definition (* for given domain and priority, the scheduler bitmap indicates a thread is in the queue *) @@ -1025,15 +1054,6 @@ where "bitmapQ d p s \ ksReadyQueuesL1Bitmap s d !! prioToL1Index p \ ksReadyQueuesL2Bitmap s (d, invertL1Index (prioToL1Index p)) !! unat (p && mask wordRadix)" - -definition - valid_queues_no_bitmap :: "kernel_state \ bool" -where - "valid_queues_no_bitmap \ \s. - (\d p. (\t \ set (ksReadyQueues s (d, p)). obj_at' (inQ d p and runnable' \ tcbState) t s) - \ distinct (ksReadyQueues s (d, p)) - \ (d > maxDomain \ p > maxPriority \ ksReadyQueues s (d,p) = []))" - 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 @@ -1057,31 +1077,62 @@ where \d i. ksReadyQueuesL1Bitmap s d !! i \ ksReadyQueuesL2Bitmap s (d, invertL1Index i) \ 0 \ i < l2BitmapSize" -definition - valid_bitmapQ :: "kernel_state \ bool" -where - "valid_bitmapQ \ \s. (\d p. bitmapQ d p s \ ksReadyQueues s (d,p) \ [])" +definition valid_bitmapQ :: "kernel_state \ bool" where + "valid_bitmapQ \ \s. \d p. bitmapQ d p s \ \ tcbQueueEmpty (ksReadyQueues s (d,p))" -definition - valid_queues :: "kernel_state \ bool" -where - "valid_queues \ \s. valid_queues_no_bitmap s \ valid_bitmapQ s \ - bitmapQ_no_L2_orphans s \ bitmapQ_no_L1_orphans s" +definition valid_bitmaps :: "kernel_state \ bool" where + "valid_bitmaps \ \s. valid_bitmapQ s \ bitmapQ_no_L2_orphans s \ bitmapQ_no_L1_orphans s" -definition - (* when a thread gets added to / removed from a queue, but before bitmap updated *) - valid_bitmapQ_except :: "domain \ priority \ kernel_state \ bool" -where +lemma valid_bitmaps_valid_bitmapQ[elim!]: + "valid_bitmaps s \ valid_bitmapQ s" + by (simp add: valid_bitmaps_def) + +lemma valid_bitmaps_bitmapQ_no_L2_orphans[elim!]: + "valid_bitmaps s \ bitmapQ_no_L2_orphans s" + by (simp add: valid_bitmaps_def) + +lemma valid_bitmaps_bitmapQ_no_L1_orphans[elim!]: + "valid_bitmaps s \ bitmapQ_no_L1_orphans s" + by (simp add: valid_bitmaps_def) + +lemma valid_bitmaps_lift: + assumes prq: "\P. f \\s. P (ksReadyQueues s)\" + assumes prqL1: "\P. f \\s. P (ksReadyQueuesL1Bitmap s)\" + assumes prqL2: "\P. f \\s. P (ksReadyQueuesL2Bitmap s)\" + shows "f \valid_bitmaps\" + unfolding valid_bitmaps_def valid_bitmapQ_def bitmapQ_def + bitmapQ_no_L1_orphans_def bitmapQ_no_L2_orphans_def + apply (rule hoare_pre) + apply (wps assms | wpsimp)+ + done + +(* when a thread gets added to / removed from a queue, but before bitmap updated *) +definition valid_bitmapQ_except :: "domain \ priority \ kernel_state \ bool" where "valid_bitmapQ_except d' p' \ \s. - (\d p. (d \ d' \ p \ p') \ (bitmapQ d p s \ ksReadyQueues s (d,p) \ []))" + \d p. (d \ d' \ p \ p') \ (bitmapQ d p s \ \ tcbQueueEmpty (ksReadyQueues s (d,p)))" lemmas bitmapQ_defs = valid_bitmapQ_def valid_bitmapQ_except_def bitmapQ_def bitmapQ_no_L2_orphans_def bitmapQ_no_L1_orphans_def -definition - valid_queues' :: "kernel_state \ bool" -where - "valid_queues' \ \s. \d p t. obj_at' (inQ d p) t s \ t \ set (ksReadyQueues s (d, p))" +\ \ + The tcbSchedPrev and tcbSchedNext fields of a TCB are used only to indicate membership in + one of the ready queues. \ +definition valid_sched_pointers_2 :: + "(obj_ref \ obj_ref) \ (obj_ref \ obj_ref) \ (obj_ref \ bool) \ bool " + where + "valid_sched_pointers_2 prevs nexts ready \ + \ptr. prevs ptr \ None \ nexts ptr \ None \ ready ptr" + +abbreviation valid_sched_pointers :: "kernel_state \ bool" where + "valid_sched_pointers s \ + valid_sched_pointers_2 (tcbSchedPrevs_of s) (tcbSchedNexts_of s) (tcbQueued |< tcbs_of' s)" + +lemmas valid_sched_pointers_def = valid_sched_pointers_2_def + +lemma valid_sched_pointersD: + "\valid_sched_pointers s; \ (tcbQueued |< tcbs_of' s) t\ + \ tcbSchedPrevs_of s t = None \ tcbSchedNexts_of s t = None" + by (fastforce simp: valid_sched_pointers_def in_opt_pred opt_map_red) 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" @@ -1316,7 +1367,7 @@ definition valid_state' :: "kernel_state \ bool" where "valid_state' \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s - \ valid_queues s \ sym_refs (state_refs_of' s) \sym_refs (state_hyp_refs_of' s) + \ sym_refs (state_refs_of' s) \sym_refs (state_hyp_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 @@ -1325,7 +1376,9 @@ where \ valid_irq_states' s \ valid_machine_state' s \ irqs_masked' s - \ valid_queues' 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 @@ -1378,6 +1431,11 @@ definition abbreviation "active' st \ st = Structures_H.Running \ st = Structures_H.Restart" +lemma runnable_eq_active': "runnable' = active'" + apply (rule ext) + apply (case_tac st, simp_all) + done + abbreviation "simple' st \ st = Structures_H.Inactive \ st = Structures_H.Running \ @@ -1393,11 +1451,12 @@ abbreviation abbreviation(input) "all_invs_but_sym_refs_ct_not_inQ' \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s - \ valid_queues s \ if_live_then_nonz_cap' s \ if_unsafe_then_cap' 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 - \ cur_tcb' s \ valid_queues' s \ ct_idle_or_in_cur_domain' s \ valid_pde_mappings' 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" @@ -1405,12 +1464,13 @@ abbreviation(input) abbreviation(input) "all_invs_but_ct_not_inQ' \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s - \ valid_queues s \ sym_refs (state_refs_of' s) \ sym_refs (state_hyp_refs_of' s) + \ sym_refs (state_refs_of' s) \ sym_refs (state_hyp_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 - \ cur_tcb' s \ valid_queues' s \ ct_idle_or_in_cur_domain' s \ valid_pde_mappings' 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" @@ -1426,12 +1486,13 @@ lemma all_invs_but_not_ct_inQ_check': definition "all_invs_but_ct_idle_or_in_cur_domain' \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s - \ valid_queues s \ sym_refs (state_refs_of' s) \ sym_refs (state_hyp_refs_of' s) + \ sym_refs (state_refs_of' s) \ sym_refs (state_hyp_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 - \ cur_tcb' s \ valid_queues' s \ ct_not_inQ s \ valid_pde_mappings' 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" @@ -3292,9 +3353,9 @@ lemma sch_act_wf_arch [simp]: "sch_act_wf sa (ksArchState_update f s) = sch_act_wf sa s" by (cases sa) (simp_all add: ct_in_state'_def tcb_in_cur_domain'_def) -lemma valid_queues_arch [simp]: - "valid_queues (ksArchState_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) +lemma valid_bitmaps_arch[simp]: + "valid_bitmaps (ksArchState_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) lemma if_unsafe_then_cap_arch' [simp]: "if_unsafe_then_cap' (ksArchState_update f s) = if_unsafe_then_cap' s" @@ -3312,22 +3373,14 @@ lemma sch_act_wf_machine_state [simp]: "sch_act_wf sa (ksMachineState_update f s) = sch_act_wf sa s" by (cases sa) (simp_all add: ct_in_state'_def tcb_in_cur_domain'_def) -lemma valid_queues_machine_state [simp]: - "valid_queues (ksMachineState_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_arch' [simp]: - "valid_queues' (ksArchState_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) - -lemma valid_queues_machine_state' [simp]: - "valid_queues' (ksMachineState_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) - lemma valid_irq_node'_machine_state [simp]: "valid_irq_node' x (ksMachineState_update f s) = valid_irq_node' x s" by (simp add: valid_irq_node'_def) +lemma valid_bitmaps_machine_state[simp]: + "valid_bitmaps (ksMachineState_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) + (* these should be reasonable safe for automation because of the 0 pattern *) lemma no_0_ko_wp' [elim!]: "\ ko_wp_at' Q 0 s; no_0_obj' s \ \ P" @@ -3405,19 +3458,6 @@ lemma typ_at_aligned': "\ typ_at' tp p s \ \ is_aligned p (objBitsT tp)" by (clarsimp simp add: typ_at'_def ko_wp_at'_def objBitsT_koTypeOf) -lemma valid_queues_obj_at'D: - "\ t \ set (ksReadyQueues s (d, p)); valid_queues s \ - \ obj_at' (inQ d p) t s" - apply (unfold valid_queues_def valid_queues_no_bitmap_def) - apply (elim conjE) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE) - apply (clarsimp) - done - lemma obj_at'_and: "obj_at' (P and P') t s = (obj_at' P t s \ obj_at' P' t s)" by (rule iffI, (clarsimp simp: obj_at'_def)+) @@ -3459,21 +3499,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 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 \ st_tcb_at' runnable' t s) \ - distinct (ksReadyQueues s (d, p)) \ (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_queues_running: - assumes Q: "t \ set(ksReadyQueues s (d, p))" "valid_queues s" - shows "st_tcb_at' runnable' t s" - using assms by (clarsimp simp add: valid_queues_def valid_queues_no_bitmap_def') - 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) @@ -3558,8 +3583,16 @@ lemma invs_sch_act_wf' [elim!]: "invs' s \ sch_act_wf (ksSchedulerAction s) s" by (simp add: invs'_def valid_state'_def) -lemma invs_queues [elim!]: - "invs' s \ valid_queues s" +lemma invs_valid_bitmaps[elim!]: + "invs' s \ valid_bitmaps s" + by (simp add: invs'_def valid_state'_def) + +lemma invs_sym_heap_sched_pointers[elim!]: + "invs' s \ sym_heap_sched_pointers s" + by (simp add: invs'_def valid_state'_def) + +lemma invs_valid_sched_pointers[elim!]: + "invs' s \ valid_sched_pointers s" by (simp add: invs'_def valid_state'_def) lemma invs_valid_idle'[elim!]: @@ -3574,21 +3607,9 @@ 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 valid_queues_valid_bitmapQ: - "valid_queues s \ valid_bitmapQ s" - by (simp add: valid_queues_def) - -lemma valid_queues_valid_queues_no_bitmap: - "valid_queues s \ valid_queues_no_bitmap s" - by (simp add: valid_queues_def) - -lemma valid_queues_bitmapQ_no_L1_orphans: - "valid_queues s \ bitmapQ_no_L1_orphans s" - by (simp add: valid_queues_def) - lemma invs'_bitmapQ_no_L1_orphans: "invs' s \ bitmapQ_no_L1_orphans s" - by (drule invs_queues, simp add: valid_queues_def) + by (simp add: invs'_def valid_state'_def valid_bitmaps_def) lemma invs_ksCurDomain_maxDomain' [elim!]: "invs' s \ ksCurDomain s \ maxDomain" @@ -3613,34 +3634,24 @@ lemma invs_no_0_obj'[elim!]: lemma invs'_gsCNodes_update[simp]: "invs' (gsCNodes_update f s') = invs' s'" - apply (clarsimp simp: invs'_def valid_state'_def valid_queues_def valid_queues_no_bitmap_def - bitmapQ_defs - valid_queues'_def 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'") - apply (simp_all add: ct_in_state'_def tcb_in_cur_domain'_def ct_idle_or_in_cur_domain'_def ct_not_inQ_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_state'_def valid_queues_def valid_queues_no_bitmap_def - bitmapQ_defs - valid_queues'_def 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'") - apply (simp_all add: ct_in_state'_def ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def ct_not_inQ_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_queues_tcb_in_cur_domain': - "\ ksReadyQueues s (d, p) = x # xs; invs' s; d = ksCurDomain s\ - \ tcb_in_cur_domain' x s" -apply (subgoal_tac "x \ set (ksReadyQueues s (d, p))") - apply (drule (1) valid_queues_obj_at'D[OF _ invs_queues]) - apply (auto simp: inQ_def tcb_in_cur_domain'_def elim: obj_at'_weakenE) -done - lemma pred_tcb'_neq_contra: "\ pred_tcb_at' proj P p s; pred_tcb_at' proj Q p s; \st. P st \ Q st \ \ False" by (clarsimp simp: pred_tcb_at'_def obj_at'_def) @@ -3654,7 +3665,7 @@ lemma invs'_ksDomScheduleIdx: unfolding invs'_def valid_state'_def by clarsimp lemma valid_bitmap_valid_bitmapQ_exceptE: - "\ valid_bitmapQ_except d p s ; (bitmapQ d p s \ ksReadyQueues s (d,p) \ []) ; + "\ valid_bitmapQ_except d p s; bitmapQ d p s \ \ tcbQueueEmpty (ksReadyQueues s (d,p)); bitmapQ_no_L2_orphans s \ \ valid_bitmapQ s" unfolding valid_bitmapQ_def valid_bitmapQ_except_def diff --git a/proof/refine/ARM_HYP/IpcCancel_R.thy b/proof/refine/ARM_HYP/IpcCancel_R.thy index cdd9069ccc..56a9bac792 100644 --- a/proof/refine/ARM_HYP/IpcCancel_R.thy +++ b/proof/refine/ARM_HYP/IpcCancel_R.thy @@ -48,25 +48,6 @@ lemma set_ep_pred_tcb_at' [wp]: apply (simp add: updateObject_default_def in_monad projectKOs) done -(* valid_queues is too strong *) -definition valid_inQ_queues :: "KernelStateData_H.kernel_state \ bool" where - "valid_inQ_queues \ - \s. \d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) \ distinct (ksReadyQueues s (d, p))" - -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_inQ_queues_ksReadyQueuesL1Bitmap_upd[simp]: - "valid_inQ_queues (ksReadyQueuesL1Bitmap_update f s) = valid_inQ_queues s" - unfolding valid_inQ_queues_def - by simp - -lemma valid_inQ_queues_ksReadyQueuesL2Bitmap_upd[simp]: - "valid_inQ_queues (ksReadyQueuesL2Bitmap_update f s) = valid_inQ_queues s" - unfolding valid_inQ_queues_def - by simp - defs capHasProperty_def: "capHasProperty ptr P \ cte_wp_at' (\c. P (cteCap c)) ptr" end @@ -83,11 +64,6 @@ locale delete_one_conc_pre = "\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_queues: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - cteDeleteOne sl \\rv. Invariants_H.valid_queues\" - assumes delete_one_inQ_queues: - "\valid_inQ_queues\ cteDeleteOne sl \\rv. valid_inQ_queues\" assumes delete_one_sch_act_simple: "\sch_act_simple\ cteDeleteOne sl \\rv. sch_act_simple\" assumes delete_one_sch_act_not: @@ -339,6 +315,8 @@ lemma cancelSignal_corres: 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 (rule conjI, fastforce) + apply (rule conjI, fastforce) apply (erule pspace_valid_objsE) apply fastforce apply (clarsimp simp: valid_obj_def valid_tcb_def valid_tcb_state_def) @@ -547,12 +525,12 @@ lemma (in delete_one) cancelIPC_ReplyCap_corres: and Q'="\_. invs' and st_tcb_at' awaiting_reply' t" in corres_underlying_split) apply (rule corres_guard_imp) - apply (rule threadset_corresT) + 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: tcb_cte_cases_def cteSizeBits_def) apply (simp add: exst_same_def) - apply (clarsimp simp: st_tcb_at_tcb_at) + apply (fastforce simp: st_tcb_at_tcb_at) apply clarsimp defer apply (wp thread_set_invs_trivial thread_set_no_change_tcb_state @@ -587,7 +565,7 @@ lemma (in delete_one) cancelIPC_ReplyCap_corres: 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) + elim!: reply_mdbNext_is_descendantD) apply (simp add: when_def getSlotCap_def capHasProperty_def del: split_paired_Ex) apply (rule corres_guard_imp) @@ -639,7 +617,7 @@ lemma (in delete_one) cancel_ipc_corres: apply (rule hoare_strengthen_post) apply (rule gts_sp'[where P="\"]) apply (clarsimp elim!: pred_tcb'_weakenE) - apply simp + apply fastforce apply simp done @@ -671,16 +649,15 @@ lemma sch_act_simple_not_t[simp]: "sch_act_simple s \ sch_act_no context begin interpretation Arch . (*FIXME: arch_split*) +crunches setNotification + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_bitmaps[wp]: valid_bitmaps + (wp: valid_bitmaps_lift) + lemma cancelSignal_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. \ Invariants_H.valid_queues s; st_tcb_at' (Not \ runnable') t s \ - \ \x. t \ set (ksReadyQueues s x)" - 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\" @@ -691,9 +668,9 @@ lemma cancelSignal_invs': show ?thesis 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 setNotification_ksQ] sts_valid_queues + hoare_vcg_all_lift setThreadState_ct_not_inQ NTFNSN - hoare_vcg_all_lift setNotification_ksQ + hoare_vcg_all_lift | simp add: valid_tcb_state'_def list_case_If split del: if_split)+ prefer 2 apply assumption @@ -701,8 +678,6 @@ lemma cancelSignal_invs': apply (rule get_ntfn_sp') apply (rename_tac rv s) apply (clarsimp simp: pred_tcb_at') - apply (frule NIQ) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) apply (rule conjI) apply (clarsimp simp: valid_ntfn'_def) apply (case_tac "ntfnObj rv", simp_all add: isWaitingNtfn_def) @@ -744,6 +719,7 @@ lemma cancelSignal_invs': 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") @@ -827,17 +803,18 @@ lemma tcb_bound_refs'_not_NTFNBound[simp]: "(t, NTFNBound) \ tcb_bound_refs' n" by (simp add: tcb_bound_refs'_def) +crunches 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 NIQ: "\s. \ Invariants_H.valid_queues s; st_tcb_at' (Not \ runnable') t s \ - \ \x. t \ set (ksReadyQueues s x)" - 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 EPSCHN: "\eeptr ep'. \\s. sch_act_not (ksCurThread s) s\ setEndpoint eeptr ep' \\_ s. sch_act_not (ksCurThread s) s\" @@ -861,21 +838,20 @@ proof - apply (subst P) apply (wp valid_irq_node_lift valid_global_refs_lift' irqs_masked_lift sts_sch_act' - hoare_vcg_all_lift [OF setEndpoint_ksQ] - sts_valid_queues setThreadState_ct_not_inQ EPSCHN - hoare_vcg_all_lift setNotification_ksQ getEndpoint_wp + setThreadState_ct_not_inQ EPSCHN + hoare_vcg_all_lift getEndpoint_wp | simp add: valid_tcb_state'_def split del: if_split | wpc)+ 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 (frule NIQ) - apply (erule pred_tcb'_weakenE, fastforce) apply (clarsimp, rule conjI) apply (auto simp: pred_tcb_at'_def obj_at'_def)[1] apply (rule conjI) @@ -1063,31 +1039,6 @@ apply (wp hoare_vcg_conj_lift delete_one_ksCurDomain | simp add: getThreadReplySlot_def o_def if_fun_split)+ done -(* FIXME move *) -lemma tcbSchedEnqueue_not_st: - "(\tcb st qd. P (tcb\tcbState := st, tcbQueued := qd\) \ P tcb) - \ \obj_at' P t'\ tcbSchedEnqueue t \\_. obj_at' P t'\" -apply (simp add: tcbSchedEnqueue_def unless_def) -apply (wp threadGet_wp | simp)+ -apply (clarsimp simp: obj_at'_def) -apply (case_tac obja) -apply fastforce -done - -(* FIXME move *) -lemma setThreadState_not_st: - "(\tcb st qd. P (tcb\tcbState := st, tcbQueued := qd\) \ P tcb) - \ \obj_at' P t'\ setThreadState st t \\_. obj_at' P t'\" -apply (simp add: setThreadState_def rescheduleRequired_def) -apply (wp hoare_vcg_conj_lift tcbSchedEnqueue_not_st - | wpc - | rule hoare_drop_imps - | simp)+ -apply (clarsimp simp: obj_at'_def) -apply (case_tac obj) -apply fastforce -done - (* FIXME move *) lemma setBoundNotification_not_ntfn: "(\tcb ntfn. P (tcb\tcbBoundNotification := ntfn\) \ P tcb) @@ -1099,15 +1050,6 @@ lemma setBoundNotification_not_ntfn: | simp)+ done -(* FIXME move *) -lemma setThreadState_tcb_in_cur_domain'[wp]: - "\tcb_in_cur_domain' t'\ setThreadState st t \\_. tcb_in_cur_domain' t'\" -apply (simp add: tcb_in_cur_domain'_def) -apply (rule hoare_pre) -apply wps -apply (wp setThreadState_not_st | simp)+ -done - 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) @@ -1116,22 +1058,22 @@ lemma setBoundNotification_tcb_in_cur_domain'[wp]: apply (wp setBoundNotification_not_ntfn | simp)+ done -lemma cancelSignal_tcb_obj_at': - "(\tcb st qd. P (tcb\tcbState := st, tcbQueued := qd\) \ P tcb) - \ \obj_at' P t'\ cancelSignal t word \\_. obj_at' P t'\" -apply (simp add: cancelSignal_def setNotification_def) -apply (wp setThreadState_not_st getNotification_wp | wpc | simp)+ -done +lemma setThreadState_tcbDomain_obj_at'[wp]: + "setThreadState ts t \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding setThreadState_def + by wpsimp + +crunches 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 (simp add: cancelIPC_def Let_def) -apply (wp hoare_vcg_conj_lift - setThreadState_not_st delete_one_tcbDomain_obj_at' cancelSignal_tcb_obj_at' - | wpc - | rule hoare_drop_imps - | simp add: getThreadReplySlot_def o_def if_fun_split)+ -done + "cancelIPC t \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding cancelIPC_def Let_def + by (wp hoare_vcg_conj_lift delete_one_tcbDomain_obj_at' + | wpc + | rule hoare_drop_imps + | simp add: getThreadReplySlot_def o_def if_fun_split)+ lemma (in delete_one_conc_pre) cancelIPC_tcb_in_cur_domain': "\tcb_in_cur_domain' t'\ cancelIPC t \\_. tcb_in_cur_domain' t'\" @@ -1234,189 +1176,48 @@ lemma setNotification_weak_sch_act_wf[wp]: lemmas ipccancel_weak_sch_act_wfs = weak_sch_act_wf_lift[OF _ setCTE_pred_tcb_at'] -lemma tcbSchedDequeue_corres': - "corres dc (is_etcb_at t) (tcb_at' t and valid_inQ_queues) (tcb_sched_action (tcb_sched_dequeue) t) (tcbSchedDequeue t)" - apply (simp only: tcbSchedDequeue_def tcb_sched_action_def) - apply (rule corres_symb_exec_r[OF _ _ threadGet_inv, where Q'="\rv. tcb_at' t and valid_inQ_queues and obj_at' (\obj. tcbQueued obj = rv) t"]) - defer - apply (wp threadGet_obj_at', simp, simp) - apply (wp, simp) - apply (case_tac queued) - defer - apply (simp add: unless_def when_def) - apply (rule corres_no_failI) - apply (wp) - apply (clarsimp simp: in_monad ethread_get_def get_etcb_def set_tcb_queue_def is_etcb_at_def state_relation_def gets_the_def gets_def get_def return_def bind_def assert_opt_def get_tcb_queue_def modify_def put_def) - apply (subgoal_tac "t \ set (ready_queues a (tcb_domain y) (tcb_priority y))") - prefer 2 - apply (force simp: tcb_sched_dequeue_def valid_inQ_queues_def - ready_queues_relation_def obj_at'_def inQ_def projectKO_eq project_inject) - apply (simp add: ready_queues_relation_def) - apply (simp add: unless_def when_def) - apply (rule corres_guard_imp) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres, simp add: etcb_relation_def) - apply (simp split del: if_split) - apply (rule corres_split_eqr) - apply (rule ethreadget_corres, simp add: etcb_relation_def) - apply (rule corres_split_eqr[OF getQueue_corres]) - apply (simp split del: if_split) - apply (subst bind_return_unit, rule corres_split[where r'=dc]) - apply (simp add: tcb_sched_dequeue_def) - apply (rule setQueue_corres) - apply (rule corres_split_noop_rhs) - apply (clarsimp, rule removeFromBitmap_corres_noop) - apply (simp add: dc_def[symmetric]) - apply (rule threadSet_corres_noop, simp_all add: tcb_relation_def exst_same_def)[1] - apply (wp | simp)+ - done - -lemma setQueue_valid_inQ_queues: - "\valid_inQ_queues - and (\s. \t \ set ts. obj_at' (inQ d p) t s) - and K (distinct ts)\ - setQueue d p ts - \\_. valid_inQ_queues\" - apply (simp add: setQueue_def valid_inQ_queues_def) - apply wp - apply clarsimp - done - -lemma threadSet_valid_inQ_queues: - "\valid_inQ_queues and (\s. \d p. (\tcb. (inQ d p tcb) \ \(inQ d p (f tcb))) - \ obj_at' (\tcb. (inQ d p tcb) \ \(inQ d p (f tcb))) t s - \ t \ set (ksReadyQueues s (d, p)))\ - threadSet f t - \\rv. valid_inQ_queues\" - apply (simp add: threadSet_def) - apply wp - apply (simp add: valid_inQ_queues_def pred_tcb_at'_def) - apply (wp setObject_queues_unchanged_tcb - hoare_Ball_helper - hoare_vcg_all_lift - setObject_tcb_strongest)[1] - apply (wp getObject_tcb_wp) - apply (clarsimp simp: valid_inQ_queues_def pred_tcb_at'_def) - apply (clarsimp simp: obj_at'_def projectKOs) - apply (fastforce) - done - -(* reorder the threadSet before the setQueue, useful for lemmas that don't refer to bitmap *) -lemma setQueue_after_addToBitmap: - "(setQueue d p q >>= (\rv. (when P (addToBitmap d p)) >>= (\rv. threadSet f t))) = - (when P (addToBitmap d p) >>= (\rv. (threadSet f t) >>= (\rv. setQueue d p q)))" - 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 (simp add: threadSet_def getObject_def setObject_def - loadObject_default_def bitmap_fun_defs - split_def projectKO_def2 alignCheck_assert - magnitudeCheck_assert updateObject_default_def) - apply (intro oblivious_bind, simp_all) - apply (clarsimp simp: bind_assoc) - done - -lemma tcbSchedEnqueue_valid_inQ_queues[wp]: - "\valid_inQ_queues\ tcbSchedEnqueue t \\_. valid_inQ_queues\" - apply (simp add: tcbSchedEnqueue_def setQueue_after_addToBitmap) - apply (rule hoare_pre) - apply (rule_tac B="\rv. valid_inQ_queues and obj_at' (\obj. tcbQueued obj = rv) t" - in hoare_seq_ext) - apply (rename_tac queued) - apply (case_tac queued, simp_all add: unless_def)[1] - apply (wp setQueue_valid_inQ_queues threadSet_valid_inQ_queues threadGet_wp - hoare_vcg_const_Ball_lift - | simp add: inQ_def bitmap_fun_defs - | fastforce simp: valid_inQ_queues_def inQ_def obj_at'_def)+ - done - - (* prevents wp from splitting on the when; stronger technique than hoare_when_weak_wp - FIXME: possible to replace with hoare_when_weak_wp? - *) -definition - "removeFromBitmap_conceal d p q t \ when (null [x\q . x \ t]) (removeFromBitmap d p)" - -lemma removeFromBitmap_conceal_valid_inQ_queues[wp]: - "\ valid_inQ_queues \ removeFromBitmap_conceal d p q t \ \_. valid_inQ_queues \" - unfolding valid_inQ_queues_def removeFromBitmap_conceal_def - by (wp|clarsimp simp: bitmap_fun_defs)+ - -lemma rescheduleRequired_valid_inQ_queues[wp]: - "\valid_inQ_queues\ rescheduleRequired \\_. valid_inQ_queues\" - apply (simp add: rescheduleRequired_def) - apply wpsimp - done - -lemma sts_valid_inQ_queues[wp]: - "\valid_inQ_queues\ setThreadState st t \\rv. valid_inQ_queues\" - apply (simp add: setThreadState_def) - apply (wp threadSet_valid_inQ_queues [THEN hoare_strengthen_post]) - apply (clarsimp simp: sch_act_simple_def Invariants_H.valid_queues_def inQ_def)+ - done - lemma updateObject_ep_inv: "\P\ updateObject (obj::endpoint) ko p q n \\rv. P\" by simp (rule updateObject_default_inv) -lemma sbn_valid_inQ_queues[wp]: - "\valid_inQ_queues\ setBoundNotification ntfn t \\rv. valid_inQ_queues\" - apply (simp add: setBoundNotification_def) - apply (wp threadSet_valid_inQ_queues [THEN hoare_strengthen_post]) - apply (clarsimp simp: sch_act_simple_def Invariants_H.valid_queues_def inQ_def)+ +lemma asUser_tcbQueued_inv[wp]: + "\obj_at' (\tcb. P (tcbQueued tcb)) t'\ asUser t m \\_. obj_at' (\tcb. P (tcbQueued tcb)) t'\" + 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 setEndpoint_valid_inQ_queues[wp]: - "\valid_inQ_queues\ setEndpoint ptr ep \\rv. valid_inQ_queues\" - apply (unfold setEndpoint_def) - apply (rule setObject_ep_pre) - apply (simp add: valid_inQ_queues_def) - apply (wp hoare_Ball_helper hoare_vcg_all_lift setObject_queues_unchanged[OF updateObject_ep_inv]) - apply simp - done +context begin interpretation Arch . -lemma set_ntfn_valid_inQ_queues[wp]: - "\valid_inQ_queues\ setNotification ptr ntfn \\rv. valid_inQ_queues\" - apply (unfold setNotification_def) - apply (rule setObject_ntfn_pre) - apply (simp add: valid_inQ_queues_def) - apply (wpsimp wp: hoare_Ball_helper hoare_vcg_all_lift simp: updateObject_default_def in_monad) - done +crunches cancel_ipc + for pspace_aligned[wp]: "pspace_aligned :: det_state \ _" + and pspace_distinct[wp]: "pspace_distinct :: det_state \ _" + (simp: crunch_simps wp: crunch_wps) -crunch valid_inQ_queues[wp]: cancelSignal valid_inQ_queues - (simp: updateObject_tcb_inv crunch_simps wp: crunch_wps) +end -lemma (in delete_one_conc_pre) cancelIPC_valid_inQ_queues[wp]: - "\valid_inQ_queues\ cancelIPC t \\_. valid_inQ_queues\" - apply (simp add: cancelIPC_def Let_def getThreadReplySlot_def) - apply (wp hoare_drop_imps delete_one_inQ_queues threadSet_valid_inQ_queues | wpc | simp add:if_apply_def2 Fun.comp_def)+ - apply (clarsimp simp: valid_inQ_queues_def inQ_def)+ - done +crunches asUser + for valid_sched_pointers[wp]: valid_sched_pointers + (wp: crunch_wps) -lemma valid_queues_inQ_queues: - "Invariants_H.valid_queues s \ valid_inQ_queues s" - by (force simp: Invariants_H.valid_queues_def valid_inQ_queues_def obj_at'_def - valid_queues_no_bitmap_def) +crunches set_thread_state + for in_correct_ready_q[wp]: in_correct_ready_q + (wp: crunch_wps ignore_del: set_thread_state_ext) -lemma asUser_tcbQueued_inv[wp]: - "\obj_at' (\tcb. P (tcbQueued tcb)) t'\ asUser t m \\_. obj_at' (\tcb. P (tcbQueued tcb)) t'\" - 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 +crunches set_thread_state_ext + for ready_qs_distinct[wp]: ready_qs_distinct + (wp: crunch_wps ignore_del: set_thread_state_ext) -lemma asUser_valid_inQ_queues[wp]: - "\ valid_inQ_queues \ asUser t f \\rv. valid_inQ_queues \" - unfolding valid_inQ_queues_def Ball_def - apply (wpsimp wp: hoare_vcg_all_lift) - defer - apply (wp asUser_ksQ) - apply assumption - apply (simp add: inQ_def[abs_def] obj_at'_conj) - apply (rule hoare_convert_imp) - apply (wp asUser_ksQ) - apply wp - done +lemma set_thread_state_ready_qs_distinct[wp]: + "set_thread_state ref ts \ready_qs_distinct\" + unfolding set_thread_state_def + apply (wpsimp wp: set_object_wp) + by (clarsimp simp: ready_qs_distinct_def) + +lemma as_user_ready_qs_distinct[wp]: + "as_user tptr f \ready_qs_distinct\" + unfolding as_user_def + apply (wpsimp wp: set_object_wp) + by (clarsimp simp: ready_qs_distinct_def) lemma (in delete_one) suspend_corres: "corres dc (einvs and tcb_at t) (invs' and tcb_at' t) @@ -1439,25 +1240,28 @@ lemma (in delete_one) suspend_corres: apply (rule corres_return_trivial) apply (rule corres_split_nor[OF setThreadState_corres]) apply simp - apply (rule tcbSchedDequeue_corres') + apply (rule tcbSchedDequeue_corres) apply (wpsimp simp: update_restart_pc_def updateRestartPC_def)+ - apply (rule hoare_post_imp[where Q = "\rv s. tcb_at t s \ is_etcb_at t s"]) - apply simp + 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 = "\_ 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 = "\rv s. tcb_at' t s \ valid_inQ_queues s"]) - apply (wpsimp simp: valid_queues_inQ_queues) - apply wp+ - apply (force simp: valid_sched_def tcb_at_is_etcb_at) - apply (clarsimp simp add: invs'_def valid_state'_def valid_queues_inQ_queues) + 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 context begin interpretation Arch . lemma archThreadGet_corres: "(\a a'. arch_tcb_relation a a' \ f a = f' a') \ - corres (=) (tcb_at t) (tcb_at' t) (arch_thread_get f t) (archThreadGet f' t)" + corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ + (arch_thread_get f t) (archThreadGet f' t)" unfolding arch_thread_get_def archThreadGet_def - apply (corresKsimp corres: get_tcb_corres) + apply (corresKsimp corres: getObject_TCB_corres) apply (clarsimp simp: tcb_relation_def) done @@ -1466,7 +1270,8 @@ lemma tcb_vcpu_relation: unfolding arch_tcb_relation_def by auto lemma archThreadGet_VCPU_corres[corres]: - "corres (=) (tcb_at t) (tcb_at' t) (arch_thread_get tcb_vcpu t) (archThreadGet atcbVCPUPtr t)" + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ + (arch_thread_get tcb_vcpu t) (archThreadGet atcbVCPUPtr t)" by (rule archThreadGet_corres) (erule tcb_vcpu_relation) lemma when_fail_assert: @@ -1498,16 +1303,19 @@ lemma tcb_ko_at': lemma archThreadSet_corres: "(\a a'. arch_tcb_relation a a' \ arch_tcb_relation (f a) (f' a')) \ - corres dc (tcb_at t) (tcb_at' t) (arch_thread_set f t) (archThreadSet f' t)" + corres dc (tcb_at t and pspace_aligned and pspace_distinct) \ + (arch_thread_set f t) (archThreadSet f' t)" apply (simp add: arch_thread_set_def archThreadSet_def) - apply (corresK corres: get_tcb_corres setObject_update_TCB_corres') + apply (corresK corres: getObject_TCB_corres setObject_update_TCB_corres') apply wpsimp+ apply (auto simp add: tcb_relation_def tcb_cap_cases_def tcb_cte_cases_def exst_same_def)+ done lemma archThreadSet_VCPU_None_corres[corres]: - "t = t' \ corres dc (tcb_at t) (tcb_at' t') - (arch_thread_set (tcb_vcpu_update Map.empty) t) (archThreadSet (atcbVCPUPtr_update Map.empty) t')" + "t = t' \ + corres dc (tcb_at t and pspace_aligned and pspace_distinct) \ + (arch_thread_set (tcb_vcpu_update Map.empty) t) + (archThreadSet (atcbVCPUPtr_update Map.empty) t')" apply simp apply (rule archThreadSet_corres) apply (simp add: arch_tcb_relation_def) @@ -1523,13 +1331,15 @@ lemmas corresK_as_user' = asUser_corres'[atomized, THEN corresK_lift_rule, THEN mp] lemma asUser_sanitiseRegister_corres[corres]: - "b=b' \ t = t' \ corres dc (tcb_at t) (tcb_at' t') - (as_user t (do cpsr \ getRegister CPSR; - setRegister CPSR (sanitise_register b CPSR cpsr) - od)) - (asUser t' (do cpsr \ getRegister CPSR; - setRegister CPSR (sanitiseRegister b' CPSR cpsr) - od))" + "b=b' \ t = t' \ + corres dc + (tcb_at t and pspace_aligned and pspace_distinct) \ + (as_user t (do cpsr \ getRegister CPSR; + setRegister CPSR (sanitise_register b CPSR cpsr) + od)) + (asUser t' (do cpsr \ getRegister CPSR; + setRegister CPSR (sanitiseRegister b' CPSR cpsr) + od))" unfolding sanitiseRegister_def sanitise_register_def apply (corresKsimp corresK: corresK_as_user') done @@ -1548,23 +1358,22 @@ lemma imp_drop_strg: lemma dissociateVCPUTCB_corres [@lift_corres_args, corres]: "corres dc (obj_at (\ko. \tcb. ko = TCB tcb \ tcb_vcpu (tcb_arch tcb) = Some v) t and - obj_at (\ko. \vcpu. ko = ArchObj (VCPU vcpu) \ vcpu_tcb vcpu = Some t) v) - (tcb_at' t and vcpu_at' v and no_0_obj') + obj_at (\ko. \vcpu. ko = ArchObj (VCPU vcpu) \ vcpu_tcb vcpu = Some t) v and + pspace_aligned and pspace_distinct) + (vcpu_at' v and no_0_obj') (dissociate_vcpu_tcb v t) (dissociateVCPUTCB v t)" unfolding dissociate_vcpu_tcb_def dissociateVCPUTCB_def - apply (clarsimp simp: bind_assoc when_fail_assert opt_case_when) - apply (corresKsimp corres: getObject_vcpu_corres setObject_VCPU_corres get_tcb_corres) - apply (wpsimp wp: arch_thread_get_wp - simp: archThreadSet_def tcb_ko_at' tcb_at_typ_at' - | strengthen imp_drop_strg[where Q="tcb_at t s" for s] - imp_drop_strg[where Q="vcpu_at' v s \ typ_at' TCBT t s" for s] - | corresK_rv)+ - apply (corresKsimp wp: get_vcpu_wp getVCPU_wp getObject_tcb_wp arch_thread_get_wp corres_rv_wp_left - simp: archThreadGet_def tcb_ko_at')+ + apply (clarsimp simp: when_fail_assert opt_case_when) + apply (corresKsimp corres: getObject_vcpu_corres setObject_VCPU_corres getObject_TCB_corres) + apply (wpsimp wp: arch_thread_get_wp + simp: archThreadSet_def tcb_ko_at' tcb_at_typ_at' + | corresK_rv)+ + apply (corresKsimp wp: get_vcpu_wp getVCPU_wp getObject_tcb_wp arch_thread_get_wp + simp: archThreadGet_def tcb_ko_at')+ apply (clarsimp simp: typ_at_tcb' typ_at_to_obj_at_arches) apply normalise_obj_at' apply (clarsimp simp: obj_at_def is_tcb vcpu_relation_def tcb_relation_def - arch_tcb_relation_def vgic_map_def ) + arch_tcb_relation_def vgic_map_def obj_at'_def) done lemma sym_refs_tcb_vcpu: @@ -1586,6 +1395,9 @@ lemma prepareThreadDelete_corres: apply (wp arch_thread_get_wp) apply (wpsimp wp: getObject_tcb_wp simp: archThreadGet_def) apply clarsimp + apply (frule invs_psp_aligned) + apply (frule invs_distinct) + apply clarsimp apply (rule conjI) apply clarsimp apply (frule (1) sym_refs_tcb_vcpu, fastforce) @@ -1613,265 +1425,8 @@ lemma (in delete_one_conc_pre) cancelIPC_it[wp]: apply (wp hoare_drop_imps delete_one_it | wpc | simp add:if_apply_def2 Fun.comp_def)+ done -crunch ksQ: threadGet "\s. P (ksReadyQueues s p)" - -lemma tcbSchedDequeue_notksQ: - "\\s. t' \ set(ksReadyQueues s p)\ - tcbSchedDequeue t - \\_ s. t' \ set(ksReadyQueues s p)\" - 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+ - apply clarsimp - apply (rule_tac Q="\_ s. t' \ set(ksReadyQueues s p)" in hoare_post_imp) - apply (wp | clarsimp)+ - done - -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 B="\rv s. (rv = ResumeCurrentThread \ rv = ChooseNewThread) - \ ?OAQ t' p s" in hoare_seq_ext) - including classic_wp_pre - apply (wp | clarsimp)+ - apply (case_tac x) - apply (wp | clarsimp)+ - done - -lemma setThreadState_oa_queued: - "\\s. P' (obj_at' (\tcb. P (tcbQueued tcb) (tcbDomain tcb) (tcbPriority tcb)) t' s) \ - setThreadState st 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 \ setThreadState st t \\_. ?Q R \" - apply (simp add: setThreadState_def) - apply (wp rescheduleRequired_oa_queued) - apply (simp add: sch_act_simple_def) - apply (rule_tac Q="\_. ?Q R" in hoare_post_imp, clarsimp) - apply (wp threadSet_obj_at'_strongish) - apply (clarsimp) - done - show "\\s. \ ?Q P s\ setThreadState st t \\_ s. \ ?Q P s\" - by (simp add: not_obj_at' comp_def, wp hoare_convert_imp pos) - qed - -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 tcbSchedDequeue_ksQ_distinct[wp]: - "\\s. distinct (ksReadyQueues s p)\ - tcbSchedDequeue t - \\_ s. distinct (ksReadyQueues s p)\" - 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+ - apply (rule_tac Q="\_ s. distinct (ksReadyQueues s p)" in hoare_post_imp) - apply (clarsimp | wp)+ - done - -lemma sts_valid_queues_partial: - "\Invariants_H.valid_queues and sch_act_simple\ - setThreadState st t - \\_ s. \t' d p. - (t' \ set(ksReadyQueues s (d, p)) \ - (obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t' s - \ (t' \ t \ st_tcb_at' runnable' t' s))) - \ distinct (ksReadyQueues s (d, p))\" - (is "\_\ _ \\_ s. \t' d p. ?OA t' d p s \ ?DISTINCT d p s \") - apply (rule_tac Q="\_ s. (\t' d p. ?OA t' d p s) \ (\d p. ?DISTINCT d p s)" - in hoare_post_imp) - apply (clarsimp) - apply (rule hoare_conjI) - apply (rule_tac Q="\s. \t' d p. - ((t'\set(ksReadyQueues s (d, p)) - \ \ (sch_act_simple s)) - \ (obj_at'(\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t' s - \ st_tcb_at' runnable' t' s))" in hoare_pre_imp) - apply (fastforce simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def - pred_tcb_at'_def obj_at'_def inQ_def) - apply (rule hoare_vcg_all_lift)+ - apply (rule hoare_convert_imp) - including classic_wp_pre - apply (wp sts_ksQ setThreadState_oa_queued hoare_impI sts_pred_tcb_neq' - | clarsimp)+ - apply (rule_tac Q="\s. \d p. ?DISTINCT d p s \ sch_act_simple s" in hoare_pre_imp) - apply (clarsimp simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def) - apply (wp hoare_vcg_all_lift sts_ksQ) - apply (clarsimp) - done - -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 Q="(\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) - done - -lemma sts_invs_minor'_no_valid_queues: - "\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 \ obj_at' tcbQueued t s \ st_tcb_at' runnable' t s) - and sch_act_simple - and invs'\ - setThreadState st t - \\_ s. (\t' d p. - (t' \ set(ksReadyQueues s (d, p)) \ - (obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t' s - \ (t' \ t \ st_tcb_at' runnable' t' s))) - \ distinct (ksReadyQueues s (d, p)) \ (maxDomain < d \ maxPriority < p \ ksReadyQueues s (d, p) = [])) \ - valid_bitmapQ s \ - bitmapQ_no_L2_orphans s \ - bitmapQ_no_L1_orphans s \ - valid_pspace' s \ - sch_act_wf (ksSchedulerAction s) s \ - sym_refs (state_refs_of' s) \ - sym_refs (state_hyp_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 \ - valid_queues' 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 \ - cur_tcb' s \ - tcb_at' t s\" - apply (simp add: invs'_def valid_state'_def valid_queues_def) - apply (wp sts_valid_queues_partial sts_ksQ - setThreadState_oa_queued sts_st_tcb_at'_cases - irqs_masked_lift - valid_irq_node_lift - setThreadState_ct_not_inQ - sts_valid_bitmapQ_sch_act_simple - sts_valid_bitmapQ_no_L2_orphans_sch_act_simple - sts_valid_bitmapQ_no_L1_orphans_sch_act_simple - hoare_vcg_conj_lift hoare_vcg_imp_lift hoare_vcg_all_lift)+ - apply (clarsimp simp: disj_imp) - apply (intro conjI) - apply (clarsimp simp: valid_queues_def) - apply (rule conjI, clarsimp) - apply (drule valid_queues_no_bitmap_objD, assumption) - apply (clarsimp simp: inQ_def comp_def) - apply (rule conjI) - apply (erule obj_at'_weaken) - apply (simp add: inQ_def) - apply (clarsimp simp: st_tcb_at'_def) - apply (erule obj_at'_weaken) - apply (simp add: inQ_def) - apply (simp add: valid_queues_no_bitmap_def) - apply clarsimp - apply (clarsimp simp: st_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 (fastforce simp: valid_tcb_state'_def - split: Structures_H.thread_state.splits) - apply (clarsimp dest!: st_tcb_at_state_refs_ofD' - elim!: rsubst[where P=sym_refs] - intro!: ext) - apply (fastforce simp: valid_queues_def inQ_def pred_tcb_at' pred_tcb_at'_def - elim!: st_tcb_ex_cap'' obj_at'_weakenE)+ - done - crunch ct_idle_or_in_cur_domain'[wp]: tcbSchedDequeue ct_idle_or_in_cur_domain' - -lemma tcbSchedDequeue_invs'_no_valid_queues: - "\\s. (\t' d p. - (t' \ set(ksReadyQueues s (d, p)) \ - (obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t' s - \ (t' \ t \ st_tcb_at' runnable' t' s))) - \ distinct (ksReadyQueues s (d, p)) \ (maxDomain < d \ maxPriority < p \ ksReadyQueues s (d, p) = [])) \ - valid_bitmapQ s \ - bitmapQ_no_L2_orphans s \ - bitmapQ_no_L1_orphans s \ - valid_pspace' s \ - sch_act_wf (ksSchedulerAction s) s \ - sym_refs (state_refs_of' s) \ - sym_refs (state_hyp_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 \ - valid_queues' 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 \ - cur_tcb' s \ - tcb_at' t s\ - tcbSchedDequeue t - \\_. invs' \" - apply (simp add: invs'_def valid_state'_def) - apply (wp tcbSchedDequeue_valid_queues_weak valid_irq_handlers_lift - valid_irq_node_lift valid_irq_handlers_lift' - tcbSchedDequeue_irq_states irqs_masked_lift cur_tcb_lift - untyped_ranges_zero_lift - | clarsimp simp add: cteCaps_of_def valid_queues_def o_def)+ - apply (rule conjI) - apply (fastforce simp: obj_at'_def inQ_def st_tcb_at'_def valid_queues_no_bitmap_except_def) - apply (rule conjI, clarsimp simp: correct_queue_def) - apply (fastforce simp: valid_pspace'_def intro: obj_at'_conjI - elim: valid_objs'_maxDomain valid_objs'_maxPriority) - done - -lemmas sts_tcbSchedDequeue_invs' = - sts_invs_minor'_no_valid_queues - tcbSchedDequeue_invs'_no_valid_queues + (wp: crunch_wps) lemma asUser_sch_act_simple[wp]: "\sch_act_simple\ asUser s t \\_. sch_act_simple\" @@ -1883,11 +1438,14 @@ lemma (in delete_one_conc) suspend_invs'[wp]: "\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 (wp sts_tcbSchedDequeue_invs') - apply (simp add: updateRestartPC_def | strengthen no_refs_simple_strg')+ - prefer 2 - apply (wpsimp wp: hoare_drop_imps hoare_vcg_imp_lift' - | strengthen no_refs_simple_strg')+ + 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]: @@ -1932,109 +1490,6 @@ lemma (in delete_one_conc_pre) suspend_st_tcb_at': lemmas (in delete_one_conc_pre) suspend_makes_simple' = suspend_st_tcb_at' [where P=simple', simplified] -lemma valid_queues_not_runnable'_not_ksQ: - assumes "Invariants_H.valid_queues s" and "st_tcb_at' (Not \ runnable') t s" - shows "\d p. t \ set (ksReadyQueues s (d, p))" - using assms - apply - - apply (clarsimp simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def pred_tcb_at'_def) - apply (erule_tac x=d in allE) - apply (erule_tac x=p in allE) - apply (clarsimp) - apply (drule(1) bspec) - apply (clarsimp simp: obj_at'_def) - done - -declare valid_queues_not_runnable'_not_ksQ[OF ByAssum, simp] - -lemma cancelSignal_queues[wp]: - "\Invariants_H.valid_queues and st_tcb_at' (Not \ runnable') t\ - cancelSignal t ae \\_. Invariants_H.valid_queues \" - apply (simp add: cancelSignal_def) - apply (wp sts_valid_queues) - apply (rule_tac Q="\_ s. \p. t \ set (ksReadyQueues s p)" in hoare_post_imp, simp) - apply (wp hoare_vcg_all_lift) - apply (wpc) - apply (wp)+ - apply (rule_tac Q="\_ s. Invariants_H.valid_queues s \ (\p. t \ set (ksReadyQueues s p))" in hoare_post_imp) - apply (clarsimp) - apply (wp) - apply (clarsimp) - done - -lemma (in delete_one_conc_pre) cancelIPC_queues[wp]: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - cancelIPC t \\rv. Invariants_H.valid_queues\" - apply (simp add: cancelIPC_def Let_def getThreadReplySlot_def - cong: Structures_H.thread_state.case_cong list.case_cong) - apply (rule hoare_seq_ext [OF _ gts_sp']) - apply (rule hoare_pre) - apply (wpc - | wp hoare_vcg_conj_lift delete_one_queues threadSet_valid_queues - threadSet_valid_objs' sts_valid_queues setEndpoint_ksQ - hoare_vcg_all_lift threadSet_sch_act threadSet_weak_sch_act_wf - | simp add: o_def if_apply_def2 inQ_def - | rule hoare_drop_imps - | clarsimp simp: valid_tcb'_def tcb_cte_cases_def - elim!: pred_tcb'_weakenE)+ - apply (fastforce dest: valid_queues_not_runnable'_not_ksQ elim: pred_tcb'_weakenE) - done - -(* FIXME: move to Schedule_R *) -lemma tcbSchedDequeue_nonq[wp]: - "\Invariants_H.valid_queues and tcb_at' t and K (t = t')\ - tcbSchedDequeue t \\_ s. \d p. t' \ set (ksReadyQueues s (d, p))\" - apply (rule hoare_gen_asm) - apply (simp add: tcbSchedDequeue_def) - apply (wp threadGet_wp|simp)+ - apply (fastforce simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def obj_at'_def projectKOs inQ_def) - done - -lemma sts_ksQ_oaQ: - "\Invariants_H.valid_queues\ - setThreadState st t - \\_ s. t \ set (ksReadyQueues s (d, p)) \ - obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t s\" - (is "\_\ _ \\_. ?POST\") - proof - - have RR: "\sch_act_simple and ?POST\ rescheduleRequired \\_. ?POST\" - apply (simp add: rescheduleRequired_def) - apply (wp) - apply (clarsimp) - apply (rule_tac - Q="(\s. action = ResumeCurrentThread \ action = ChooseNewThread) and ?POST" - in hoare_pre_imp, assumption) - apply (case_tac action) - apply (clarsimp)+ - apply (wp) - apply (clarsimp simp: sch_act_simple_def) - done - show ?thesis - apply (simp add: setThreadState_def) - apply (wp RR) - apply (rule_tac Q="\_. ?POST" in hoare_post_imp) - apply (clarsimp simp add: sch_act_simple_def) - apply (wp hoare_convert_imp) - apply (clarsimp simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (fastforce dest: bspec elim!: obj_at'_weakenE simp: inQ_def) - done - qed - -lemma (in delete_one_conc_pre) suspend_nonq: - "\Invariants_H.valid_queues and valid_objs' and tcb_at' t - and (\s. weak_sch_act_wf (ksSchedulerAction s) s) - and (\s. t \ ksIdleThread s) and K (t = t')\ - suspend t - \\rv s. \d p. t' \ set (ksReadyQueues s (d, p))\" - apply (rule hoare_gen_asm) - apply (simp add: suspend_def unless_def) - unfolding updateRestartPC_def - apply (wp hoare_allI tcbSchedDequeue_t_notksQ sts_ksQ_oaQ) - apply wpsimp+ - done - lemma suspend_makes_inactive: "\K (t = t')\ suspend t \\rv. st_tcb_at' ((=) Inactive) t'\" apply (cases "t = t'", simp_all) @@ -2045,31 +1500,21 @@ lemma suspend_makes_inactive: declare threadSet_sch_act_sane [wp] declare sts_sch_act_sane [wp] -lemma tcbSchedEnqueue_ksQset_weak: - "\\s. t' \ set (ksReadyQueues s p)\ - tcbSchedEnqueue t - \\_ s. t' \ set (ksReadyQueues s p)\" (is "\?PRE\ _ \_\") - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wp hoare_vcg_conj_lift hoare_vcg_imp_lift hoare_vcg_if_lift) - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, ((wp | clarsimp)+))+ - done - 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 tcbSchedEnqueue_ct', wp, simp) + by (rule hoare_weaken_pre, wps, wp, simp) lemma sts_sch_act_not_ct[wp]: "\\s. sch_act_not (ksCurThread s) s\ setThreadState st t \\_ s. sch_act_not (ksCurThread s) s\" - by (rule hoare_weaken_pre, wps tcbSchedEnqueue_ct', wp, simp) + by (rule hoare_weaken_pre, wps, wp, simp) text \Cancelling all IPC in an endpoint or notification object\ lemma ep_cancel_corres_helper: - "corres dc ((\s. \t \ set list. tcb_at t s) and valid_etcbs) - ((\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') + "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 @@ -2078,28 +1523,34 @@ lemma ep_cancel_corres_helper: 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 (rule corres_guard_imp [OF setThreadState_corres]) - apply simp - apply (simp add: valid_tcb_state_def) - apply simp - apply (wp sts_valid_queues)+ - apply (force simp: tcb_at_is_etcb_at) - apply (fastforce elim: obj_at'_weakenE) - apply ((wp hoare_vcg_const_Ball_lift | simp)+)[1] - apply (rule hoare_pre) - apply (wp hoare_vcg_const_Ball_lift - weak_sch_act_wf_lift_linear sts_st_tcb' setThreadState_not_st - sts_valid_queues tcbSchedEnqueue_not_st - | simp)+ - apply (auto elim: obj_at'_weakenE simp: valid_tcb_state'_def) + 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 +crunches 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 ep_cancel_corres: "corres dc (invs and valid_sched and ep_at ep) (invs' and ep_at' ep) (cancel_all_ipc ep) (cancelAllIPC ep)" @@ -2107,10 +1558,10 @@ proof - have P: "\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_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 - \ Invariants_H.valid_queues s \ valid_queues' s \ valid_objs' 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; @@ -2132,22 +1583,23 @@ proof - 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 R="\_ s. \x\set list. tcb_at' x s \ valid_objs' s" + apply (rule_tac R="\_ 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 (rule hoare_name_pre_state) - apply ((wp hoare_vcg_const_Ball_lift mapM_x_wp' - sts_valid_queues setThreadState_not_st sts_st_tcb' tcbSchedEnqueue_not_st - | clarsimp - | fastforce elim: obj_at'_weakenE simp: valid_tcb_state'_def)+)[2] - apply (rule hoare_name_pre_state) + 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 elim!: valid_objs_valid_tcbE))+ + | (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 (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 @@ -2174,7 +1626,10 @@ lemma set_ntfn_tcb_obj_at' [wp]: lemma cancelAllSignals_corres: "corres dc (invs and valid_sched and ntfn_at ntfn) (invs' and ntfn_at' ntfn) (cancel_all_signals ntfn) (cancelAllSignals ntfn)" + supply projectKOs[simp] apply (simp add: cancel_all_signals_def cancelAllSignals_def) + 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+ @@ -2185,22 +1640,27 @@ lemma cancelAllSignals_corres: 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 setThreadState_not_st + weak_sch_act_wf_lift_linear set_thread_state_runnable_weak_valid_sched_action | simp)+ apply (rename_tac list) - apply (rule_tac R="\_ s. (\x\set list. tcb_at' x s) \ valid_objs' s" + apply (rule_tac R="\_ 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_queues setThreadState_not_st - simp: valid_tcb_state'_def) + 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')+ + 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 + | erule obj_at_valid_objsE | drule ko_at_valid_objs' + | fastforce)+ done lemma ep'_Idle_case_helper: @@ -2239,6 +1699,11 @@ proof - done qed +lemma tcbSchedEnqueue_valid_pspace'[wp]: + "tcbSchedEnqueue tcbPtr \valid_pspace'\" + unfolding valid_pspace'_def + by wpsimp + lemma cancel_all_invs'_helper: "\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} @@ -2254,8 +1719,7 @@ lemma cancel_all_invs'_helper: apply clarsimp 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_valid_queues sts_st_tcb' setThreadState_not_st + 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 @@ -2264,7 +1728,7 @@ lemma cancel_all_invs'_helper: elim!: rsubst[where P=sym_refs] dest!: set_mono_suffix intro!: ext - | (drule (1) bspec, clarsimp simp: valid_pspace'_def valid_tcb'_def elim!: valid_objs_valid_tcbE))+ + | (drule (1) bspec, clarsimp simp: valid_pspace'_def valid_tcb'_def))+ done lemma ep_q_refs_max: @@ -2280,22 +1744,10 @@ lemma ep_q_refs_max: | case_tac ntfnptr)+ done -crunch ct' [wp]: setEndpoint "\s. P (ksCurThread s)" - (wp: setObject_ep_ct) - -crunch ct' [wp]: setNotification "\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'\" + "rescheduleRequired \invs'\" apply (simp add: rescheduleRequired_def) - apply (wp ssa_invs' | simp add: invs'_update_cnt | wpc)+ - apply (clarsimp simp: invs'_def valid_state'_def) + apply (wpsimp wp: ssa_invs') done lemma invs_rct_ct_activatable': @@ -2422,6 +1874,7 @@ lemma rescheduleRequired_all_invs_but_ct_not_inQ: lemma cancelAllIPC_invs'[wp]: "\invs'\ cancelAllIPC ep_ptr \\rv. invs'\" apply (simp add: cancelAllIPC_def ep'_Idle_case_helper cong del: if_cong) + apply (rule hoare_seq_ext[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' getEndpoint_wp @@ -2445,6 +1898,7 @@ lemma cancelAllIPC_invs'[wp]: lemma cancelAllSignals_invs'[wp]: "\invs'\ cancelAllSignals ntfn \\rv. invs'\" apply (simp add: cancelAllSignals_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) apply (case_tac "ntfnObj ntfna", simp_all) apply (wp, simp) @@ -2479,12 +1933,14 @@ crunch valid_objs'[wp]: tcbSchedEnqueue valid_objs' (simp: unless_def valid_tcb'_def tcb_cte_cases_def) lemma cancelAllIPC_valid_objs'[wp]: - "\valid_objs'\ cancelAllIPC ep \\rv. valid_objs'\" + "\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 hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ep_sp']) apply (rule hoare_pre) apply (wp set_ep_valid_objs' setSchedulerAction_valid_objs') - apply (rule_tac Q="\rv s. valid_objs' s \ (\x\set (epQueue ep). tcb_at' x s)" + 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) @@ -2501,8 +1957,9 @@ lemma cancelAllIPC_valid_objs'[wp]: done lemma cancelAllSignals_valid_objs'[wp]: - "\valid_objs'\ cancelAllSignals ntfn \\rv. valid_objs'\" + "\valid_objs' and pspace_aligned' and pspace_distinct'\ cancelAllSignals ntfn \\rv. valid_objs'\" apply (simp add: cancelAllSignals_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) apply (case_tac "ntfnObj ntfna", simp_all) apply (wp, simp) @@ -2555,19 +2012,17 @@ 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\" - apply (simp add: setThreadState_def setQueue_def - rescheduleRequired_def tcbSchedEnqueue_def - unless_def bitmap_fun_defs - cong: scheduler_action.case_cong cong del: if_cong - | wp | wpcw)+ - done + 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 unless_def) + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_def) apply (wp | simp add: setQueue_def bitmap_fun_defs)+ done @@ -2601,19 +2056,42 @@ lemma setObject_ko_wp_at': objBits_def[symmetric] ps_clear_upd in_magnitude_check v projectKOs) -lemma rescheduleRequired_unlive: - "\\s. ko_wp_at' (Not \ live') p s \ ksSchedulerAction s \ SwitchToThread p\ - rescheduleRequired +lemma threadSet_unlive_other: + "\ko_wp_at' (Not \ live') p and K (p \ t)\ + threadSet f t \\rv. ko_wp_at' (Not \ live') p\" - apply (simp add: rescheduleRequired_def) - apply (wp | simp | wpc)+ - apply (simp add: tcbSchedEnqueue_def unless_def - threadSet_def setQueue_def threadGet_def) - apply (wp setObject_ko_wp_at getObject_tcb_wp - | simp add: objBits_simps' bitmap_fun_defs split del: if_split)+ - apply (clarsimp simp: o_def) - apply (drule obj_at_ko_at') - apply clarsimp + by (clarsimp simp: threadSet_def valid_def getObject_def + setObject_def in_monad loadObject_default_def + ko_wp_at'_def split_def in_magnitude_check + objBits_simps' updateObject_default_def + ps_clear_upd live'_def projectKOs) + +lemma tcbSchedEnqueue_unlive_other: + "\ko_wp_at' (Not \ live') p and K (p \ t)\ + tcbSchedEnqueue t + \\_. ko_wp_at' (Not \ live') p\" + supply projectKOs[simp] + 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 live'_def + split: option.splits) + done + +lemma rescheduleRequired_unlive[wp]: + "\\s. ko_wp_at' (Not \ live') p s \ ksSchedulerAction s \ SwitchToThread p\ + rescheduleRequired + \\_. ko_wp_at' (Not \ live') p\" + supply comp_apply[simp del] + unfolding rescheduleRequired_def + apply (wpsimp wp: tcbSchedEnqueue_unlive_other) done lemmas setEndpoint_ko_wp_at' @@ -2623,6 +2101,7 @@ lemma cancelAllIPC_unlive: "\valid_objs' and (\s. sch_act_wf (ksSchedulerAction s) s)\ cancelAllIPC ep \\rv. ko_wp_at' (Not \ live') ep\" apply (simp add: cancelAllIPC_def ep'_Idle_case_helper) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ep_sp']) apply (rule hoare_pre) apply (wp cancelAll_unlive_helper setEndpoint_ko_wp_at' @@ -2642,6 +2121,7 @@ lemma cancelAllSignals_unlive: \ obj_at' (\ko. ntfnBoundTCB ko = None) ntfnptr s\ cancelAllSignals ntfnptr \\rv. ko_wp_at' (Not \ live') ntfnptr\" apply (simp add: cancelAllSignals_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) apply (case_tac "ntfnObj ntfn", simp_all add: setNotification_def) apply wp @@ -2709,25 +2189,21 @@ lemma cancelBadgedSends_filterM_helper': apply (rule hoare_pre) 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' sts_valid_queues setThreadState_not_st - tcbSchedEnqueue_not_st - untyped_ranges_zero_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 + apply (clarsimp simp: valid_pspace'_def cong: conj_cong) apply (intro conjI) - apply (clarsimp simp: valid_pspace'_def valid_tcb'_def elim!: valid_objs_valid_tcbE dest!: st_tcb_ex_cap'') - apply (fastforce dest!: 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) - apply (fastforce elim!: obj_atE' - simp: state_refs_of'_def projectKOs tcb_bound_refs'_def - subsetD symreftype_inverse' - split: if_split_asm)+ - done + by (fastforce elim!: obj_atE' + simp: state_refs_of'_def projectKOs tcb_bound_refs'_def + subsetD symreftype_inverse' + split: if_split_asm)+ lemmas cancelBadgedSends_filterM_helper = spec [where x=Nil, OF cancelBadgedSends_filterM_helper', simplified] @@ -2737,7 +2213,8 @@ lemma cancelBadgedSends_invs[wp]: shows "\invs'\ cancelBadgedSends epptr badge \\rv. invs'\" apply (simp add: cancelBadgedSends_def) - apply (rule hoare_seq_ext [OF _ get_ep_sp']) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) + apply (rule hoare_seq_ext [OF _ get_ep_sp'], rename_tac ep) apply (case_tac ep, simp_all) apply ((wp | simp)+)[2] apply (subst bind_assoc [where g="\_. rescheduleRequired", @@ -2771,10 +2248,21 @@ crunches tcb_sched_action and state_hyp_refs_of[wp]: "\s. P (state_hyp_refs_of s)" (ignore_del: tcb_sched_action) +lemma setEndpoint_valid_tcbs'[wp]: + "setEndpoint ePtr val \valid_tcbs'\" + supply projectKOs[simp] + unfolding setEndpoint_def + apply (wpsimp wp: setObject_valid_tcbs'[where P=\]) + apply (clarsimp simp: updateObject_default_def monad_simps) + apply fastforce + done + lemma cancelBadgedSends_corres: "corres dc (invs and valid_sched and ep_at epptr) (invs' and ep_at' epptr) (cancel_badged_sends epptr bdg) (cancelBadgedSends epptr bdg)" 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 Q'=invs']) @@ -2784,10 +2272,16 @@ lemma cancelBadgedSends_corres: apply (rule corres_guard_imp) apply (rule corres_split_nor[OF setEndpoint_corres]) apply (simp add: ep_relation_def) - apply (rule corres_split_eqr[OF _ _ _ hoare_post_add[where R="\_. valid_objs'"]]) + apply (rule corres_split_eqr[OF _ _ _ hoare_post_add + [where R="\_. 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" - and Q'="\xs s. (\x \ set xs. tcb_at' x s) \ weak_sch_act_wf (ksSchedulerAction s) s \ Invariants_H.valid_queues s \ valid_queues' s \ valid_objs' 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) @@ -2798,55 +2292,53 @@ lemma cancelBadgedSends_corres: 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]) + apply (rule corres_split[OF tcbSchedEnqueue_corres], simp) apply (rule corres_trivial) apply simp apply wp+ apply simp - apply (wp sts_valid_queues gts_st_tcb_at)+ + 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: is_tcb_def) - apply simp + 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_queues + 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 (wp gts_st_tcb_at hoare_vcg_imp_lift mapM_wp' - sts_st_tcb' sts_valid_queues - set_thread_state_runnable_weak_valid_sched_action - | clarsimp simp: valid_tcb_state'_def)+ - apply (wp hoare_vcg_const_Ball_lift weak_sch_act_wf_lift_linear set_ep_valid_objs' - | simp)+ + 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 (drule ko_at_valid_objs', clarsimp) - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ep'_def invs_weak_sch_act_wf - invs'_def valid_state'_def) + apply (fastforce simp: valid_ep'_def) done +crunches 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 (simp add: threadGet_def| wp getObject_tcb_wp)+ - apply (rule hoare_strengthen_post, rule hoare_post_taut) - apply (fastforce simp: obj_at'_def projectKOs) - apply (rule hoare_post_taut) - apply wp+ - done + unfolding suspend_def + by (wpsimp simp: comp_def wp: tcbSchedDequeue_not_tcbQueued) crunch no_vcpu[wp]: vcpuInvalidateActive "obj_at' (P::'a:: no_vcpu \ bool) t" @@ -2888,7 +2380,6 @@ crunch ksQ[wp]: dissociateVCPUTCB "\s. P (ksReadyQueues s)" crunch unqueued: prepareThreadDelete "obj_at' (Not \ tcbQueued) t" crunch inactive: prepareThreadDelete "st_tcb_at' ((=) Inactive) t'" -crunch nonq: prepareThreadDelete " \s. \d p. t' \ set (ksReadyQueues s (d, p))" end end diff --git a/proof/refine/ARM_HYP/Ipc_R.thy b/proof/refine/ARM_HYP/Ipc_R.thy index 52cdaa3108..4803ed08d1 100644 --- a/proof/refine/ARM_HYP/Ipc_R.thy +++ b/proof/refine/ARM_HYP/Ipc_R.thy @@ -13,9 +13,9 @@ context begin interpretation Arch . (*FIXME: arch_split*) lemmas lookup_slot_wrapper_defs'[simp] = lookupSourceSlot_def lookupTargetSlot_def lookupPivotSlot_def -lemma getMessageInfo_corres: "corres ((=) \ message_info_map) - (tcb_at t) (tcb_at' t) - (get_message_info t) (getMessageInfo t)" +lemma getMessageInfo_corres: + "corres ((=) \ message_info_map) (tcb_at t and pspace_aligned and pspace_distinct) \ + (get_message_info t) (getMessageInfo t)" apply (rule corres_guard_imp) apply (unfold get_message_info_def getMessageInfo_def fun_app_def) apply (simp add: ARM_HYP_H.msgInfoRegister_def @@ -766,14 +766,6 @@ lemma tcts_sch_act[wp]: \\rv s. sch_act_wf (ksSchedulerAction s) s\" by (wp sch_act_wf_lift tcb_in_cur_domain'_lift transferCapsToSlots_pres1) -lemma tcts_vq[wp]: - "\Invariants_H.valid_queues\ transferCapsToSlots ep buffer n caps slots mi \\rv. Invariants_H.valid_queues\" - by (wp valid_queues_lift transferCapsToSlots_pres1) - -lemma tcts_vq'[wp]: - "\valid_queues'\ transferCapsToSlots ep buffer n caps slots mi \\rv. valid_queues'\" - by (wp valid_queues_lift' transferCapsToSlots_pres1) - crunches setExtraBadge for state_refs_of'[wp]: "\s. P (state_refs_of' s)" and state_hyp_refs_of'[wp]: "\s. P (state_hyp_refs_of' s)" @@ -995,6 +987,11 @@ crunch ksDomScheduleIdx[wp]: setExtraBadge "\s. P (ksDomScheduleIdx s)" crunch ksDomSchedule[wp]: transferCapsToSlots "\s. P (ksDomSchedule s)" crunch ksDomScheduleIdx[wp]: transferCapsToSlots "\s. P (ksDomScheduleIdx s)" +crunches transferCapsToSlots + 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) lemma transferCapsToSlots_invs[wp]: "\\s. invs' s \ distinct slots @@ -1237,18 +1234,12 @@ lemma set_mrs_valid_objs' [wp]: crunch valid_objs'[wp]: copyMRs valid_objs' (wp: crunch_wps simp: crunch_simps) -crunch valid_queues'[wp]: asUser "Invariants_H.valid_queues'" - (simp: crunch_simps wp: hoare_drop_imps) - - lemma setMRs_invs_bits[wp]: "\valid_pspace'\ setMRs t buf mrs \\rv. valid_pspace'\" "\\s. sch_act_wf (ksSchedulerAction s) s\ setMRs t buf mrs \\rv s. sch_act_wf (ksSchedulerAction s) s\" "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ setMRs t buf mrs \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" - "\Invariants_H.valid_queues\ setMRs t buf mrs \\rv. Invariants_H.valid_queues\" - "\valid_queues'\ setMRs t buf mrs \\rv. valid_queues'\" "\\s. P (state_refs_of' s)\ setMRs t buf mrs \\rv s. P (state_refs_of' s)\" @@ -1268,8 +1259,6 @@ lemma copyMRs_invs_bits[wp]: "\valid_pspace'\ copyMRs s sb r rb n \\rv. valid_pspace'\" "\\s. sch_act_wf (ksSchedulerAction s) s\ copyMRs s sb r rb n \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\Invariants_H.valid_queues\ copyMRs s sb r rb n \\rv. Invariants_H.valid_queues\" - "\valid_queues'\ copyMRs s sb r rb n \\rv. valid_queues'\" "\\s. P (state_refs_of' s)\ copyMRs s sb r rb n \\rv s. P (state_refs_of' s)\" @@ -1531,15 +1520,15 @@ lemma msgFromLookupFailure_map[simp]: by (cases lf, simp_all add: lookup_failure_map_def msgFromLookupFailure_def) lemma asUser_getRestartPC_corres: - "corres (=) (tcb_at t) (tcb_at' t) - (as_user t getRestartPC) (asUser t getRestartPC)" + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ + (as_user t getRestartPC) (asUser t getRestartPC)" apply (rule asUser_corres') apply (rule corres_Id, simp, simp) apply (rule no_fail_getRestartPC) done lemma asUser_mapM_getRegister_corres: - "corres (=) (tcb_at t) (tcb_at' t) + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ (as_user t (mapM getRegister regs)) (asUser t (mapM getRegister regs))" apply (rule asUser_corres') @@ -1549,9 +1538,8 @@ lemma asUser_mapM_getRegister_corres: done lemma makeArchFaultMessage_corres: - "corres (=) (tcb_at t) (tcb_at' t) - (make_arch_fault_msg f t) - (makeArchFaultMessage (arch_fault_map f) t)" + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ + (make_arch_fault_msg f t) (makeArchFaultMessage (arch_fault_map f) t)" apply (cases f; clarsimp simp: makeArchFaultMessage_def ucast_nat_def split: arch_fault.split) apply (rule corres_guard_imp) apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) @@ -1560,7 +1548,7 @@ lemma makeArchFaultMessage_corres: done lemma makeFaultMessage_corres: - "corres (=) (tcb_at t) (tcb_at' t) + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ (make_fault_msg ft t) (makeFaultMessage (fault_map ft) t)" apply (cases ft, simp_all add: makeFaultMessage_def split del: if_split) @@ -1632,7 +1620,8 @@ lemmas threadget_fault_corres = lemma doFaultTransfer_corres: "corres dc (obj_at (\ko. \tcb ft. ko = TCB tcb \ tcb_fault tcb = Some ft) sender - and tcb_at receiver and case_option \ in_user_frame recv_buf) + and 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) @@ -1641,7 +1630,8 @@ lemma doFaultTransfer_corres: ARM_HYP_H.badgeRegister_def badge_register_def) apply (rule_tac Q="\fault. K (\f. fault = Some f) and tcb_at sender and tcb_at receiver and - case_option \ in_user_frame recv_buf" + case_option \ in_user_frame recv_buf and + pspace_aligned and pspace_distinct" and Q'="\fault'. tcb_at' sender and tcb_at' receiver and case_option \ valid_ipc_buffer_ptr' recv_buf" in corres_underlying_split) @@ -1779,10 +1769,6 @@ crunch vp[wp]: doIPCTransfer "valid_pspace'" (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' wp: transferCapsToSlots_vp simp:ball_conj_distrib ) crunch sch_act_wf[wp]: doIPCTransfer "\s. sch_act_wf (ksSchedulerAction s) s" (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch vq[wp]: doIPCTransfer "Invariants_H.valid_queues" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch vq'[wp]: doIPCTransfer "valid_queues'" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) crunch state_refs_of[wp]: doIPCTransfer "\s. P (state_refs_of' s)" (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) crunch state_hyp_refs_of[wp]: doIPCTransfer "\s. P (state_hyp_refs_of' s)" @@ -1860,17 +1846,21 @@ crunch nosch[wp]: doIPCTransfer "\s. P (ksSchedulerAction s)" simp: split_def zipWithM_x_mapM) lemma arch_getSanitiseRegisterInfo_corres: - "corres (=) (tcb_at t) (tcb_at' t) + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ (arch_get_sanitise_register_info t) (getSanitiseRegisterInfo t)" unfolding arch_get_sanitise_register_info_def getSanitiseRegisterInfo_def apply (fold archThreadGet_def) by (corresKsimp corres: archThreadGet_VCPU_corres) +crunches arch_get_sanitise_register_info + for pspace_aligned[wp]: pspace_aligned + and pspace_distinct[wp]: pspace_distinct + crunch tcb_at'[wp]: getSanitiseRegisterInfo "tcb_at' t" lemma handle_fault_reply_registers_corres: - "corres (=) (tcb_at t) (tcb_at' t) + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ (do t' \ arch_get_sanitise_register_info t; y \ as_user t (zipWithM_x @@ -1886,7 +1876,6 @@ lemma handle_fault_reply_registers_corres: msg_template msg); return (label = 0) od)" - apply (rule corres_guard_imp) apply (rule corres_split[OF arch_getSanitiseRegisterInfo_corres]) apply (rule corres_split) @@ -1900,7 +1889,7 @@ lemma handle_fault_reply_registers_corres: lemma handleFaultReply_corres: "ft' = fault_map ft \ - corres (=) (tcb_at t) (tcb_at' t) + 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) @@ -1950,16 +1939,6 @@ lemma getThreadCallerSlot_inv: "\P\ getThreadCallerSlot t \\_. P\" by (simp add: getThreadCallerSlot_def, wp) -lemma deleteCallerCap_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - deleteCallerCap t - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - apply (simp add: deleteCallerCap_def getSlotCap_def getThreadCallerSlot_def locateSlot_conv) - apply (wp getThreadCallerSlot_inv cteDeleteOne_ct_not_ksQ getCTE_wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - done - crunch tcb_at'[wp]: unbindNotification "tcb_at' x" lemma finaliseCapTrue_standin_tcb_at' [wp]: @@ -2119,39 +2098,11 @@ crunch weak_sch_act_wf[wp]: emptySlot "\s. weak_sch_act_wf (ksSchedulerA crunches archThreadGet, 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 sch_act_wf[wp]: unbindNotification "\s. sch_act_wf (ksSchedulerAction s) s" (wp: sbn_sch_act') -crunch valid_queues'[wp]: cteDeleteOne valid_queues' - (simp: crunch_simps unless_def inQ_def - wp: crunch_wps sts_st_tcb' getObject_inv loadObject_default_inv - threadSet_valid_queues' rescheduleRequired_valid_queues'_weak) - -lemma cancelSignal_valid_queues'[wp]: - "\valid_queues'\ cancelSignal t ntfn \\rv. valid_queues'\" - apply (simp add: cancelSignal_def) - apply (rule hoare_pre) - apply (wp getNotification_wp| wpc | simp)+ - done - -lemma cancelIPC_valid_queues'[wp]: - "\valid_queues' and (\s. sch_act_wf (ksSchedulerAction s) s) \ cancelIPC t \\rv. valid_queues'\" - apply (simp add: cancelIPC_def Let_def getThreadReplySlot_def locateSlot_conv liftM_def) - apply (rule hoare_seq_ext[OF _ gts_sp']) - apply (case_tac state, simp_all) defer 2 - apply (rule hoare_pre) - apply ((wp getEndpoint_wp getCTE_wp | wpc | simp)+)[8] - apply (wp cteDeleteOne_valid_queues') - apply (rule_tac Q="\_. valid_queues' and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) - apply (clarsimp simp: capHasProperty_def cte_wp_at_ctes_of) - apply (wp threadSet_valid_queues' threadSet_sch_act| simp)+ - apply (clarsimp simp: inQ_def) - done - crunches archThreadGet, handleFaultReply for valid_objs'[wp]: valid_objs' @@ -2160,6 +2111,17 @@ lemma cte_wp_at_is_reply_cap_toI: \ cte_wp_at (is_reply_cap_to t) ptr s" by (fastforce simp: cte_wp_at_reply_cap_to_ex_rights) +crunches handle_fault_reply + for pspace_alignedp[wp]: pspace_aligned + and pspace_distinct[wp]: pspace_distinct + +crunches cteDeleteOne, doIPCTransfer, handleFaultReply + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + and pspace_aligned'[wp]: pspace_aligned' + and pspace_distinct'[wp]: pspace_distinct' + (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) + lemma doReplyTransfer_corres: "corres dc (einvs and tcb_at receiver and tcb_at sender @@ -2171,7 +2133,8 @@ lemma doReplyTransfer_corres: 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)+) + 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 @@ -2205,8 +2168,12 @@ lemma doReplyTransfer_corres: apply (rule corres_split[OF setThreadState_corres]) apply simp apply (rule possibleSwitchTo_corres) - apply (wp set_thread_state_runnable_valid_sched set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' sts_st_tcb' sts_valid_queues sts_valid_objs' delete_one_tcbDomain_obj_at' - | simp add: valid_tcb_state'_def)+ + 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]) @@ -2215,12 +2182,16 @@ lemma doReplyTransfer_corres: apply (fastforce) apply (clarsimp simp:is_cap_simps) apply (wp weak_valid_sched_action_lift)+ - apply (rule_tac Q="\_. valid_queues' and valid_objs' and cur_tcb' and tcb_at' receiver and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp, simp add: sch_act_wf_weak) + 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) + apply (clarsimp simp: invs_psp_aligned invs_distinct) apply (rule conjI, erule invs_valid_objs) apply (rule conjI, clarsimp)+ apply (rule conjI) @@ -2244,36 +2215,38 @@ lemma doReplyTransfer_corres: 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 P="valid_sched and cur_tcb and tcb_at receiver" - and P'="tcb_at' receiver and cur_tcb' + 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 Invariants_H.valid_queues and valid_queues' and valid_objs'" - in corres_inst) + 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_queues | simp | force simp: valid_sched_def valid_sched_action_def valid_tcb_state'_def)+ + 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_valid_queues threadSet_valid_queues' - threadSet_tcbDomain_triv threadSet_valid_objs' - | simp add: valid_tcb_state'_def)+ - apply (wp threadSet_cur weak_sch_act_wf_lift_linear threadSet_pred_tcb_no_state - thread_set_not_state_valid_sched threadSet_valid_queues threadSet_valid_queues' - | simp add: runnable_def inQ_def valid_tcb'_def)+ - apply (rule_tac Q="\_. valid_sched and cur_tcb and tcb_at sender and tcb_at receiver and valid_objs and pspace_aligned" + 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) + 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\) @@ -2485,7 +2458,7 @@ proof - apply (rule setEndpoint_corres) apply (simp add: ep_relation_def) apply wp+ - apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def) + 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) @@ -2495,7 +2468,7 @@ proof - apply (rule setEndpoint_corres) apply (simp add: ep_relation_def) apply wp+ - apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def) + 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) @@ -2534,10 +2507,12 @@ proof - 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 setThreadState_valid_queues' sts_valid_queues sts_weak_sch_act_wf + 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) + 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) @@ -2602,11 +2577,13 @@ proof - 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 setThreadState_valid_queues' sts_valid_queues sts_weak_sch_act_wf + 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)+)[1] + | 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) @@ -2687,14 +2664,15 @@ lemma sendSignal_corres: apply (rule possibleSwitchTo_corres) apply wp apply (wp set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' - sts_valid_queues sts_st_tcb' hoare_disjI2 + 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 (clarsimp simp: invs'_def valid_state'_def sch_act_wf_weak - valid_tcb_state'_def) + 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)+ @@ -2720,23 +2698,23 @@ lemma sendSignal_corres: apply (rule corres_split[OF asUser_setRegister_corres]) apply (rule possibleSwitchTo_corres) apply ((wp | simp)+)[1] - apply (rule_tac Q="\_. Invariants_H.valid_queues and valid_queues' and - (\s. sch_act_wf (ksSchedulerAction s) s) and + apply (rule_tac Q="\_. (\s. sch_act_wf (ksSchedulerAction s) s) and cur_tcb' and - st_tcb_at' runnable' (hd list) and valid_objs'" - in hoare_post_imp, clarsimp simp: pred_tcb_at' elim!: sch_act_wf_weak) + st_tcb_at' runnable' (hd list) and valid_objs' and + sym_heap_sched_pointers and valid_sched_pointers and + pspace_aligned' and pspace_distinct'" + in hoare_post_imp, clarsimp simp: pred_tcb_at') apply (wp | simp)+ apply (wp sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action | simp)+ - apply (wp sts_st_tcb_at'_cases sts_valid_queues setThreadState_valid_queues' - setThreadState_st_tcb + 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 (clarsimp 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 (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) @@ -2754,16 +2732,14 @@ lemma sendSignal_corres: apply (wp cur_tcb_lift | 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_queues setThreadState_valid_queues' - setThreadState_st_tcb - | 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 (clarsimp 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 (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] @@ -2794,38 +2770,6 @@ lemma possibleSwitchTo_sch_act[wp]: apply (auto simp: obj_at'_def projectKOs tcb_in_cur_domain'_def) done -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\" - apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs) - apply (wp hoare_drop_imps | wpc | simp)+ - apply (auto simp: valid_tcb'_def weak_sch_act_wf_def - dest: pred_tcb_at' - elim!: valid_objs_valid_tcbE) - done - -lemma possibleSwitchTo_ksQ': - "\(\s. t' \ set (ksReadyQueues s p) \ sch_act_not t' s) and K(t' \ t)\ - possibleSwitchTo t - \\_ s. t' \ set (ksReadyQueues s p)\" - apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs) - apply (wp hoare_weak_lift_imp rescheduleRequired_ksQ' tcbSchedEnqueue_ksQ threadGet_wp - | wpc - | simp split del: if_split)+ - apply (auto simp: obj_at'_def) - done - -lemma possibleSwitchTo_valid_queues'[wp]: - "\valid_queues' and (\s. sch_act_wf (ksSchedulerAction s) s) - and st_tcb_at' runnable' t\ - possibleSwitchTo t - \\rv. valid_queues'\" - apply (simp add: possibleSwitchTo_def curDomain_def) - apply (wp hoare_weak_lift_imp threadGet_wp | wpc | simp)+ - apply (auto simp: obj_at'_def) - done - crunch st_refs_of'[wp]: possibleSwitchTo "\s. P (state_refs_of' s)" (wp: crunch_wps) @@ -2840,16 +2784,12 @@ crunch st_hyp_refs_of'[wp]: possibleSwitchTo "\s. P (state_hyp_refs_of' (wp: crunch_wps) lemma possibleSwitchTo_iflive[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' t - and (\s. sch_act_wf (ksSchedulerAction s) s)\ - possibleSwitchTo t + "\if_live_then_nonz_cap' and ex_nonz_cap_to' t and (\s. sch_act_wf (ksSchedulerAction s) s) + and pspace_aligned' and pspace_distinct'\ + possibleSwitchTo t \\rv. if_live_then_nonz_cap'\" - apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs) - apply (wp | wpc | simp)+ - apply (simp only: imp_conv_disj, wp hoare_vcg_all_lift hoare_vcg_disj_lift) - apply (wp threadGet_wp)+ - apply (auto simp: obj_at'_def projectKOs) - done + unfolding possibleSwitchTo_def curDomain_def + by (wpsimp wp: threadGet_wp) crunches possibleSwitchTo for ifunsafe[wp]: if_unsafe_then_cap' @@ -2877,10 +2817,6 @@ crunches sendSignal, setBoundNotification rule: irqs_masked_lift) end -lemma sts_running_valid_queues: - "runnable' st \ \ Invariants_H.valid_queues \ setThreadState st t \\_. Invariants_H.valid_queues \" - by (wp sts_valid_queues, clarsimp) - 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) @@ -2893,24 +2829,21 @@ lemma setThreadState_nonqueued_state_update: \ st \ {Inactive, Running, Restart, IdleThreadState} \ (st \ Inactive \ ex_nonz_cap_to' t s) \ (t = ksIdleThread s \ idle' st) - - \ (\ runnable' st \ sch_act_simple s) - \ (\ runnable' st \ (\p. t \ set (ksReadyQueues s p)))\ - setThreadState st t \\rv. invs'\" + \ (\ 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 - sts_valid_queues - setThreadState_ct_not_inQ) + 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 (drule simple_st_tcb_at_state_refs_ofD') apply (drule bound_tcb_at_state_refs_ofD') - apply (rule conjI, fastforce) - 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 (rule conjI) + apply clarsimp + apply (erule delta_sym_refs) + apply (fastforce split: if_split_asm) + apply (fastforce simp: symreftype_inverse' tcb_bound_refs'_def split: if_split_asm) + apply fastforce done lemma cteDeleteOne_reply_cap_to'[wp]: @@ -2987,16 +2920,14 @@ lemma cancelAllIPC_not_rct[wp]: \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" apply (simp add: cancelAllIPC_def) apply (wp | wpc)+ + apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) + apply simp + apply (rule mapM_x_wp_inv) + apply (wp)+ apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) apply simp apply (rule mapM_x_wp_inv) - apply (wp)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wp)+ - apply (wp hoare_vcg_all_lift hoare_drop_imp) - apply (simp_all) + apply (wpsimp wp: hoare_vcg_all_lift hoare_drop_imp)+ done lemma cancelAllSignals_not_rct[wp]: @@ -3005,12 +2936,10 @@ lemma cancelAllSignals_not_rct[wp]: \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" apply (simp add: cancelAllSignals_def) apply (wp | wpc)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wp)+ - apply (wp hoare_vcg_all_lift hoare_drop_imp) - apply (simp_all) + 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 not_rct[wp]: finaliseCapTrue_standin "\s. ksSchedulerAction s \ ResumeCurrentThread" @@ -3095,7 +3024,6 @@ lemma sai_invs'[wp]: 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 - sts_valid_queues [where st="Structures_H.thread_state.Running", simplified] set_ntfn_valid_objs' cur_tcb_lift sts_st_tcb' hoare_convert_imp [OF setNotification_nosch] | simp split del: if_split)+ @@ -3182,7 +3110,7 @@ lemma replyFromKernel_corres: apply simp apply (rule setMessageInfo_corres) apply (wp hoare_case_option_wp hoare_valid_ipc_buffer_ptr_typ_at' - | clarsimp)+ + | fastforce)+ done lemma rfk_invs': @@ -3195,7 +3123,7 @@ lemma rfk_invs': crunch nosch[wp]: replyFromKernel "\s. P (ksSchedulerAction s)" lemma completeSignal_corres: - "corres dc (ntfn_at ntfnptr and tcb_at tcb and pspace_aligned and valid_objs + "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)" @@ -3220,10 +3148,8 @@ lemma completeSignal_corres: lemma doNBRecvFailedTransfer_corres: - "corres dc (tcb_at thread) - (tcb_at' thread) - (do_nbrecv_failed_transfer thread) - (doNBRecvFailedTransfer thread)" + "corres dc (tcb_at thread and pspace_aligned and pspace_distinct) \ + (do_nbrecv_failed_transfer thread) (doNBRecvFailedTransfer thread)" unfolding do_nbrecv_failed_transfer_def doNBRecvFailedTransfer_def by (simp add: badgeRegister_def badge_register_def, rule asUser_setRegister_corres) @@ -3310,11 +3236,11 @@ lemma receiveIPC_corres: 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 Invariants_H.valid_queues - and valid_queues' and valid_pspace' and valid_objs' - and (\s. weak_sch_act_wf (ksSchedulerAction s) s)" + 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]) @@ -3323,17 +3249,18 @@ lemma receiveIPC_corres: apply (rule corres_split[OF setThreadState_corres]) apply simp apply (rule possibleSwitchTo_corres) - apply (wp sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action - | simp)+ - apply (wp sts_st_tcb_at'_cases sts_valid_queues setThreadState_valid_queues' - setThreadState_st_tcb + 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 (clarsimp simp: st_tcb_at_tcb_at st_tcb_def2 valid_sched_def - valid_sched_action_def) + 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" - in hoare_post_imp, erule sch_act_wf_weak) + 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 @@ -3356,13 +3283,13 @@ lemma receiveIPC_corres: apply wp+ apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, simp) apply simp - apply (clarsimp simp: valid_tcb_state_def) + apply (clarsimp simp: valid_tcb_state_def invs_distinct) apply (clarsimp simp add: valid_tcb_state'_def) apply (wp get_simple_ko_wp[where f=Notification] getNotification_wp gbn_wp gbn_wp' hoare_vcg_all_lift hoare_vcg_imp_lift hoare_vcg_if_lift | wpc | simp add: ep_at_def2[symmetric, simplified] | clarsimp)+ apply (clarsimp simp: valid_cap_def invs_psp_aligned invs_valid_objs pred_tcb_at_def - valid_obj_def valid_tcb_def valid_bound_ntfn_def + valid_obj_def valid_tcb_def valid_bound_ntfn_def invs_distinct dest!: invs_valid_objs elim!: obj_at_valid_objsE split: option.splits) @@ -3373,7 +3300,7 @@ lemma receiveIPC_corres: done lemma receiveSignal_corres: - "\ is_ntfn_cap cap; cap_relation cap cap' \ \ + "\ 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)" @@ -3400,6 +3327,8 @@ lemma receiveSignal_corres: apply (simp add: ntfn_relation_def) apply wp+ apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, simp+) + apply (clarsimp simp: invs_distinct) + apply simp \ \WaitingNtfn\ apply (simp add: ntfn_relation_def) apply (rule corres_guard_imp) @@ -3410,7 +3339,8 @@ lemma receiveSignal_corres: apply (simp add: ntfn_relation_def) apply wp+ apply (rule corres_guard_imp) - apply (rule doNBRecvFailedTransfer_corres, simp+) + apply (rule doNBRecvFailedTransfer_corres; simp) + apply (clarsimp simp: invs_distinct)+ \ \ActiveNtfn\ apply (simp add: ntfn_relation_def) apply (rule corres_guard_imp) @@ -3480,7 +3410,7 @@ lemma sendFaultIPC_corres: | 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 (simp add: valid_cap_def) + apply (clarsimp simp: valid_cap_def invs_distinct) apply (clarsimp simp: valid_cap'_def inQ_def) apply auto[1] apply (clarsimp simp: lookup_failure_map_def) @@ -3498,14 +3428,16 @@ lemma gets_the_noop_corres: done lemma handleDoubleFault_corres: - "corres dc (tcb_at thread) - (tcb_at' thread and (\s. weak_sch_act_wf (ksSchedulerAction s) s)) + "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_underlying_split [OF setThreadState_corres]) + rule corres_split[OF setThreadState_corres]) apply simp apply (rule corres_noop2) apply (simp add: exs_valid_def return_def) @@ -3514,7 +3446,7 @@ lemma handleDoubleFault_corres: apply (rule asUser_inv) apply (rule getRestartPC_inv) apply (wp no_fail_getRestartPC)+ - apply (wp|simp)+ + apply (wp|simp)+ done crunch tcb' [wp]: sendFaultIPC "tcb_at' t" (wp: crunch_wps) @@ -3563,30 +3495,6 @@ crunch sch_act_wf: setupCallerCap "\s. sch_act_wf (ksSchedulerAction s) s" (wp: crunch_wps ssa_sch_act sts_sch_act rule: sch_act_wf_lift) -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 vq[wp]: cteInsert "Invariants_H.valid_queues" - (wp: crunch_wps) - -crunch vq[wp]: getThreadCallerSlot "Invariants_H.valid_queues" - (wp: crunch_wps) - -crunch vq[wp]: getThreadReplySlot "Invariants_H.valid_queues" - (wp: crunch_wps) - -lemma setupCallerCap_vq[wp]: - "\Invariants_H.valid_queues and (\s. \p. send \ set (ksReadyQueues s p))\ - setupCallerCap send recv grant \\_. Invariants_H.valid_queues\" - apply (simp add: setupCallerCap_def) - apply (wp crunch_wps sts_valid_queues) - apply (fastforce simp: valid_queues_def obj_at'_def inQ_def) - done - -crunch vq'[wp]: setupCallerCap "valid_queues'" - (wp: crunch_wps) - 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)" @@ -3630,7 +3538,7 @@ lemma setupCallerCap_vp[wp]: declare haskell_assert_inv[wp del] lemma setupCallerCap_iflive[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' sender\ + "\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 @@ -3642,7 +3550,7 @@ lemma setupCallerCap_iflive[wp]: lemma setupCallerCap_ifunsafe[wp]: "\if_unsafe_then_cap' and valid_objs' and - ex_nonz_cap_to' rcvr and tcb_at' rcvr\ + 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 @@ -3664,13 +3572,11 @@ lemma setupCallerCap_global_refs'[wp]: \\rv. valid_global_refs'\" unfolding setupCallerCap_def getThreadCallerSlot_def getThreadReplySlot_def locateSlot_conv - apply (wp getSlotCap_cte_wp_at - | simp add: o_def unique_master_reply_cap' - | strengthen eq_imp_strg - | wp (once) getCTE_wp | clarsimp simp: cte_wp_at_ctes_of)+ - (* at setThreadState *) - apply (rule_tac Q="\_. valid_global_refs'" in hoare_post_imp, wpsimp+) - done + 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 valid_arch'[wp]: setupCallerCap "valid_arch_state'" (wp: hoare_drop_imps) @@ -3851,12 +3757,21 @@ lemmas possibleSwitchToTo_cteCaps_of[wp] crunch hyp_refs'[wp]: possibleSwitchTo "\s. P (state_hyp_refs_of' s)" +crunches asUser + for valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift wp: crunch_wps) + +crunches setupCallerCap, possibleSwitchTo, doIPCTransfer + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + and valid_bitmaps[wp]: valid_bitmaps + (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) + (* t = ksCurThread s *) lemma ri_invs' [wp]: "\invs' and sch_act_not t and ct_in_state' simple' and st_tcb_at' simple' t - and (\s. \p. t \ set (ksReadyQueues s p)) and ex_nonz_cap_to' t and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s)\ receiveIPC t cap isBlocking @@ -3874,7 +3789,7 @@ lemma ri_invs' [wp]: apply (rule hoare_pre, wpc, wp valid_irq_node_lift) apply (simp add: valid_ep'_def del: fun_upd_apply) apply (wp sts_sch_act' hoare_vcg_const_Ball_lift valid_irq_node_lift - sts_valid_queues setThreadState_ct_not_inQ + setThreadState_ct_not_inQ asUser_urz | simp add: doNBRecvFailedTransfer_def cteCaps_of_def del: fun_upd_apply)+ apply (clarsimp simp: valid_tcb_state'_def pred_tcb_at' o_def) @@ -3895,7 +3810,6 @@ lemma ri_invs' [wp]: 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 (thin_tac "\a b. t \ set (ksReadyQueues one (a, b))") \ \causes slowdown\ apply (safe ; solves \auto\) apply fastforce apply fastforce @@ -3906,7 +3820,7 @@ lemma ri_invs' [wp]: apply (rule hoare_pre, wpc, wp valid_irq_node_lift) apply (simp add: valid_ep'_def del: fun_upd_apply) apply (wp sts_sch_act' valid_irq_node_lift - sts_valid_queues setThreadState_ct_not_inQ + setThreadState_ct_not_inQ asUser_urz | simp add: doNBRecvFailedTransfer_def cteCaps_of_def del: fun_upd_apply)+ apply (clarsimp simp: pred_tcb_at' valid_tcb_state'_def o_def state_hyp_refs_of'_ep) @@ -3930,9 +3844,8 @@ lemma ri_invs' [wp]: 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' sts_valid_queues - setThreadState_ct_not_inQ possibleSwitchTo_valid_queues - possibleSwitchTo_valid_queues' + 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 @@ -3950,8 +3863,6 @@ lemma ri_invs' [wp]: st_tcb_at_refs_of_rev' conj_ac split del: if_split cong: if_cong) - apply (frule_tac t=sender in valid_queues_not_runnable'_not_ksQ) - apply (erule pred_tcb'_weakenE, clarsimp) apply (subgoal_tac "sch_act_not sender s") prefer 2 apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) @@ -3986,7 +3897,6 @@ lemma ri_invs' [wp]: lemma rai_invs'[wp]: "\invs' and sch_act_not t and st_tcb_at' simple' t - and (\s. \p. t \ set (ksReadyQueues s p)) and ex_nonz_cap_to' t and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s) and (\s. \ntfnptr. isNotificationCap cap @@ -4003,7 +3913,7 @@ lemma rai_invs'[wp]: apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) apply (wp valid_irq_node_lift sts_sch_act' typ_at_lifts - sts_valid_queues setThreadState_ct_not_inQ + setThreadState_ct_not_inQ asUser_urz | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def live'_def | wpc)+ apply (clarsimp simp: pred_tcb_at' valid_tcb_state'_def) @@ -4021,7 +3931,7 @@ lemma rai_invs'[wp]: apply (clarsimp split: if_split_asm) apply (fastforce simp: tcb_bound_refs'_def symreftype_inverse' split: if_split_asm) - apply (clarsimp dest!: global'_no_ex_cap) + 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) @@ -4041,7 +3951,7 @@ lemma rai_invs'[wp]: apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) apply (wp hoare_vcg_const_Ball_lift valid_irq_node_lift sts_sch_act' - sts_valid_queues setThreadState_ct_not_inQ typ_at_lifts + setThreadState_ct_not_inQ typ_at_lifts asUser_urz | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def live'_def | wpc)+ apply (clarsimp simp: valid_tcb_state'_def) @@ -4069,7 +3979,7 @@ lemma rai_invs'[wp]: 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 (clarsimp dest!: global'_no_ex_cap) + apply (fastforce dest!: global'_no_ex_cap) done lemma getCTE_cap_to_refs[wp]: @@ -4098,7 +4008,6 @@ lemma cteInsert_invs_bits[wp]: "\\s. sch_act_wf (ksSchedulerAction s) s\ cteInsert a b c \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\Invariants_H.valid_queues\ cteInsert a b c \\rv. Invariants_H.valid_queues\" "\cur_tcb'\ cteInsert a b c \\rv. cur_tcb'\" "\\s. P (state_refs_of' s)\ cteInsert a b c @@ -4138,9 +4047,12 @@ crunch irqs_masked'[wp]: possibleSwitchTo "irqs_masked'" crunch urz[wp]: possibleSwitchTo "untyped_ranges_zero'" (simp: crunch_simps unless_def wp: crunch_wps) +crunches possibleSwitchTo + for pspace_aligned'[wp]: pspace_aligned' + and pspace_distinct'[wp]: pspace_distinct' + lemma si_invs'[wp]: "\invs' and st_tcb_at' simple' t - and (\s. \p. t \ set (ksReadyQueues s p)) and sch_act_not t and ex_nonz_cap_to' ep and ex_nonz_cap_to' t\ sendIPC bl call ba cg cgr t ep @@ -4159,8 +4071,8 @@ lemma si_invs'[wp]: 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 sts_valid_queues setThreadState_ct_not_inQ - possibleSwitchTo_ksQ' possibleSwitchTo_ct_not_inQ hoare_vcg_all_lift sts_ksQ' + 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"] @@ -4215,8 +4127,7 @@ lemma si_invs'[wp]: apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre, wp valid_irq_node_lift) apply (simp add: valid_ep'_def del: fun_upd_apply) - apply (wp valid_irq_node_lift sts_sch_act' sts_valid_queues - setThreadState_ct_not_inQ) + apply (wp valid_irq_node_lift sts_sch_act' setThreadState_ct_not_inQ) apply (clarsimp simp: valid_tcb_state'_def pred_tcb_at' state_hyp_refs_of'_ep simp del: fun_upd_apply) apply (rule conjI, clarsimp elim!: obj_at'_weakenE) @@ -4236,8 +4147,7 @@ lemma si_invs'[wp]: apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre, wp valid_irq_node_lift) apply (simp add: valid_ep'_def del: fun_upd_apply) - apply (wp hoare_vcg_const_Ball_lift valid_irq_node_lift sts_sch_act' - sts_valid_queues setThreadState_ct_not_inQ) + 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' state_hyp_refs_of'_ep simp del: fun_upd_apply) apply (rule conjI, clarsimp elim!: obj_at'_weakenE) @@ -4265,19 +4175,15 @@ lemma si_invs'[wp]: lemma sfi_invs_plus': "\invs' and st_tcb_at' simple' t and sch_act_not t - and (\s. \p. t \ set (ksReadyQueues s p)) and ex_nonz_cap_to' t\ - sendFaultIPC t f - \\rv. invs'\, \\rv. invs' and st_tcb_at' simple' t - and (\s. \p. t \ set (ksReadyQueues s p)) - and sch_act_not t and (\s. ksIdleThread s \ t)\" + sendFaultIPC t f + \\_. invs'\, \\_. invs' and st_tcb_at' simple' t and sch_act_not t and (\s. ksIdleThread s \ t)\" apply (simp add: sendFaultIPC_def) apply (wp threadSet_invs_trivial threadSet_pred_tcb_no_state threadSet_cap_to' | wpc | simp)+ apply (rule_tac Q'="\rv s. invs' s \ sch_act_not t s \ st_tcb_at' simple' t s - \ (\p. t \ set (ksReadyQueues s p)) \ ex_nonz_cap_to' t s \ t \ ksIdleThread s \ (\r\zobj_refs' rv. ex_nonz_cap_to' r s)" @@ -4289,32 +4195,32 @@ lemma sfi_invs_plus': apply (subst(asm) global'_no_ex_cap, auto) done +crunches send_fault_ipc + for pspace_aligned[wp]: "pspace_aligned :: det_ext state \ _" + and pspace_distinct[wp]: "pspace_distinct :: det_ext state \ _" + (simp: crunch_simps wp: crunch_wps) + lemma handleFault_corres: "fr f f' \ - corres dc (einvs and st_tcb_at active thread and ex_nonz_cap_to thread - and (%_. valid_fault f)) + 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 (\s. \p. thread \ set(ksReadyQueues s p)) and st_tcb_at' simple' thread and ex_nonz_cap_to' thread) (handle_fault thread f) (handleFault thread f')" apply (simp add: handle_fault_def handleFault_def) apply (rule corres_guard_imp) apply (subst return_bind [symmetric], rule corres_split[where P="tcb_at thread", - OF gets_the_noop_corres [where x="()"]]) + OF gets_the_noop_corres [where x="()"]]) apply (simp add: tcb_at_def) apply (rule corres_split_catch) apply (rule_tac F="valid_fault f" in corres_gen_asm) apply (rule sendFaultIPC_corres, assumption) apply simp apply (rule handleDoubleFault_corres) - apply wp+ - apply (rule hoare_post_impErr, rule sfi_invs_plus', simp_all)[1] - apply clarsimp - apply wp+ - apply (clarsimp simp: st_tcb_at_tcb_at st_tcb_def2 invs_def - valid_state_def valid_idle_def) - apply auto + apply wpsimp+ + apply (clarsimp simp: st_tcb_at_tcb_at st_tcb_def2 invs_def valid_state_def valid_idle_def) + apply auto done lemma sts_invs_minor'': @@ -4322,17 +4228,13 @@ lemma sts_invs_minor'': \ (st \ Inactive \ \ idle' st \ st' \ Inactive \ \ idle' st')) t and (\s. t = ksIdleThread s \ idle' st) - and (\s. (\p. t \ set (ksReadyQueues s p)) \ runnable' st) - and (\s. runnable' st \ obj_at' tcbQueued t s - \ st_tcb_at' runnable' t s) 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' sts_valid_queues - setThreadState_ct_not_inQ) + apply (wp valid_irq_node_lift sts_sch_act' setThreadState_ct_not_inQ) apply clarsimp apply (rule conjI) apply fastforce @@ -4347,12 +4249,11 @@ lemma sts_invs_minor'': apply (clarsimp dest!: st_tcb_at_state_refs_ofD' elim!: rsubst[where P=sym_refs] intro!: ext) - apply (clarsimp elim!: st_tcb_ex_cap'') + apply (fastforce elim!: st_tcb_ex_cap'') done lemma hf_invs' [wp]: "\invs' and sch_act_not t - and (\s. \p. t \ set(ksReadyQueues s p)) and st_tcb_at' simple' t and ex_nonz_cap_to' t and (\s. t \ ksIdleThread s)\ handleFault t f \\r. invs'\" diff --git a/proof/refine/ARM_HYP/KHeap_R.thy b/proof/refine/ARM_HYP/KHeap_R.thy index 6eec9c3cba..3406c39d83 100644 --- a/proof/refine/ARM_HYP/KHeap_R.thy +++ b/proof/refine/ARM_HYP/KHeap_R.thy @@ -14,8 +14,46 @@ lemma lookupAround2_known1: "m x = Some y \ fst (lookupAround2 x m) = Some (x, y)" by (fastforce simp: lookupAround2_char1) +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 + context begin interpretation Arch . (*FIXME: arch_split*) +lemma setObject_modify_variable_size: + fixes v :: "'a :: pspace_storable" shows + "\obj_at' (P :: 'a \ bool) p s; updateObject v = updateObject_default v; + (1 :: machine_word) < 2 ^ objBits v; obj_at' (\obj. objBits v = objBits obj) p s\ + \ setObject p v s = modify (ksPSpace_update (\ps. ps (p \ injectKO v))) s" + supply projectKOs[simp] + apply (clarsimp simp: setObject_def split_def exec_gets obj_at'_def lookupAround2_known1 + assert_opt_def updateObject_default_def bind_assoc) + apply (simp add: projectKO_def alignCheck_assert) + apply (simp add: project_inject objBits_def) + apply (clarsimp simp only: koTypeOf_injectKO) + apply (frule in_magnitude_check[where s'=s]) + apply blast + apply fastforce + apply (simp add: magnitudeCheck_assert in_monad bind_def gets_def oassert_opt_def + get_def return_def) + apply (simp add: simpler_modify_def) + done + +lemma setObject_modify: + fixes v :: "'a :: pspace_storable" shows + "\obj_at' (P :: 'a \ bool) p s; updateObject v = updateObject_default v; + (1 :: machine_word) < 2 ^ objBits v; \ko. P ko \ objBits ko = objBits v \ + \ setObject p v s = modify (ksPSpace_update (\ps. ps (p \ injectKO v))) s" + apply (rule setObject_modify_variable_size) + apply fastforce + apply fastforce + apply fastforce + unfolding obj_at'_def + by fastforce + lemma obj_at_getObject: assumes R: "\a b n ko s obj::'a::pspace_storable. @@ -151,8 +189,7 @@ lemma corres_get_tcb [corres]: apply (drule bspec) apply clarsimp apply blast - apply (clarsimp simp add: other_obj_relation_def - lookupAround2_known1) + apply (clarsimp simp: tcb_relation_cut_def lookupAround2_known1) done lemma lookupAround2_same1[simp]: @@ -460,6 +497,40 @@ lemma setObject_tcb_strongest: ps_clear_upd) done +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 opt_pred_def projectKO_opts_defs projectKOs + split: if_split_asm + Structures_H.kernel_object.split_asm + +lemma setObject_endpoint_tcbs_of'[wp]: + "setObject c (endpoint :: endpoint) \\s. P' (tcbs_of' s)\" + by setObject_easy_cases + +lemma setObject_notification_tcbs_of'[wp]: + "setObject c (notification :: notification) \\s. P' (tcbs_of' s)\" + by setObject_easy_cases + +lemma setObject_cte_tcbSchedNexts_of[wp]: + "setObject c (cte :: cte) \\s. P' (tcbSchedNexts_of s)\" + by setObject_easy_cases + +lemma setObject_cte_tcbSchedPrevs_of[wp]: + "setObject c (cte :: cte) \\s. P' (tcbSchedPrevs_of s)\" + by setObject_easy_cases + +lemma setObject_cte_tcbQueued[wp]: + "setObject c (cte :: cte) \\s. P' (tcbQueued |< tcbs_of' s)\" + supply inQ_def[simp] + by setObject_easy_cases + +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 getObject_obj_at': assumes x: "\q n ko. loadObject p q n ko = (loadObject_default p q n ko :: ('a :: pspace_storable) kernel)" @@ -960,7 +1031,7 @@ lemma obj_relation_cut_same_type: \ (a_type ko = AArch AVCPU \ a_type ko' = AArch AVCPU)" apply (rule ccontr) apply (simp add: obj_relation_cuts_def2 a_type_def) - apply (auto simp: other_obj_relation_def cte_relation_def + apply (auto simp: other_obj_relation_def tcb_relation_cut_def cte_relation_def pte_relation_def pde_relation_def split: Structures_A.kernel_object.split_asm if_split_asm Structures_H.kernel_object.split_asm @@ -978,6 +1049,16 @@ 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\ + \ tcbs_of' (s'\ksPSpace := (ksPSpace s')(ptr \ ko)\) = tcbs_of' s'" + by (fastforce simp: typ_at'_def ko_wp_at'_def opt_map_def projectKO_opts_defs + split: kernel_object.splits) + +lemma typ_at'_koTypeOf: + "ko_at' ob' ptr b \ typ_at' (koTypeOf (injectKO ob')) ptr b" + by (auto simp: typ_at'_def ko_wp_at'_def obj_at'_def project_inject projectKOs) + lemma setObject_other_corres: fixes ob' :: "'a :: pspace_storable" assumes x: "updateObject ob' = updateObject_default ob'" @@ -986,12 +1067,12 @@ lemma setObject_other_corres: 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)" + assumes P: "\v::'a::pspace_storable. (1 :: machine_word) < 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) (obj_at' (P :: 'a \ bool) ptr) (set_object ptr ob) (setObject ptr ob')" - supply image_cong_simp [cong del] + supply image_cong_simp [cong del] projectKOs[simp del] apply (rule corres_no_failI) apply (rule no_fail_pre) apply wp @@ -1002,11 +1083,12 @@ lemma setObject_other_corres: put_def return_def modify_def get_object_def x projectKOs obj_at_def updateObject_default_def in_magnitude_check [OF _ P]) + apply (rename_tac ko) apply (clarsimp simp add: state_relation_def z) apply (clarsimp simp add: caps_of_state_after_update cte_wp_at_after_update swp_def fun_upd_def obj_at_def) apply (subst conj_assoc[symmetric]) - apply (rule conjI[rotated]) + apply (extract_conjunct \match conclusion in "ghost_relation _ _ _" \ -\) apply (clarsimp simp add: ghost_relation_def) apply (erule_tac x=ptr in allE)+ apply (clarsimp simp: obj_at_def a_type_def @@ -1016,40 +1098,46 @@ lemma setObject_other_corres: apply (simp only: pspace_relation_def pspace_dom_update dom_fun_upd2 simp_thms) apply (elim conjE) apply (frule bspec, erule domI) + apply (prop_tac "typ_at' (koTypeOf (injectKO ob')) ptr b") + subgoal + by (clarsimp simp: typ_at'_def ko_wp_at'_def obj_at'_def projectKO_opts_defs + 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 clarsimp apply (rule conjI) apply (rule ballI, drule(1) bspec) apply (drule domD) apply (clarsimp simp: is_other_obj_relation_type t) apply (drule(1) bspec) apply clarsimp - apply (frule_tac ko'=koa and x'=ptr in obj_relation_cut_same_type, + apply (frule_tac ko'=ko and x'=ptr in obj_relation_cut_same_type, (fastforce simp add: is_other_obj_relation_type t)+) - apply (erule disjE) - apply (simp add: is_other_obj_relation_type t) - apply (erule disjE) - apply (insert t, - clarsimp simp: is_other_obj_relation_type_CapTable a_type_def) - apply (erule disjE) - apply (insert t, - clarsimp simp: is_other_obj_relation_type_UserData a_type_def) - apply (erule disjE) - apply (insert t, - clarsimp simp: is_other_obj_relation_type_DeviceData a_type_def) - apply (simp add: is_other_obj_relation_type t) - 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) - by (clarsimp simp: is_other_obj_relation_type t exst_same_def - split: Structures_A.kernel_object.splits Structures_H.kernel_object.splits - ARM_A.arch_kernel_obj.splits)+ + apply (insert t) + apply ((erule disjE + | 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)[1] + 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 @@ -1143,14 +1231,14 @@ lemma typ_at'_valid_obj'_lift: 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, + 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 valid_bound_ntfn'_def - valid_arch_tcb'_def - split: option.splits, - wpsimp wp: P) + 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) @@ -1432,32 +1520,6 @@ lemma set_ep_bitmapQ_no_L2_orphans[wp]: apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp add: bitmapQ_def)+ done -lemma set_ep_valid_queues[wp]: - "\Invariants_H.valid_queues\ setEndpoint epptr ep \\rv. Invariants_H.valid_queues\" - apply (simp add: Invariants_H.valid_queues_def) - apply (wp hoare_vcg_conj_lift) - apply (simp add: setEndpoint_def valid_queues_no_bitmap_def) - apply (wp hoare_Ball_helper hoare_vcg_all_lift) - apply (rule obj_at_setObject2) - apply (clarsimp simp: updateObject_default_def in_monad) - apply (wp updateObject_default_inv set_ep_valid_bitmapQ[unfolded setEndpoint_def] - | simp add: valid_queues_no_bitmap_def)+ - done - -lemma set_ep_valid_queues'[wp]: - "\valid_queues'\ setEndpoint epptr ep \\rv. valid_queues'\" - apply (unfold setEndpoint_def) - apply (simp only: valid_queues'_def imp_conv_disj - obj_at'_real_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - apply (rule setObject_ko_wp_at) - apply simp - apply (simp add: objBits_simps') - apply simp - apply (wp updateObject_default_inv | simp)+ - apply (clarsimp simp: projectKOs ko_wp_at'_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\" @@ -1723,34 +1785,6 @@ lemma set_ntfn_bitmapQ_no_L2_orphans[wp]: apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp)+ done -lemma set_ntfn_valid_queues[wp]: - "\Invariants_H.valid_queues\ setNotification p ntfn \\rv. Invariants_H.valid_queues\" - apply (simp add: Invariants_H.valid_queues_def) - apply (rule hoare_pre) - apply (wp hoare_vcg_conj_lift) - apply (simp add: setNotification_def valid_queues_no_bitmap_def) - apply (wp hoare_Ball_helper hoare_vcg_all_lift) - apply (rule obj_at_setObject2) - apply (clarsimp simp: updateObject_default_def in_monad) - apply (wp updateObject_default_inv set_ep_valid_bitmapQ[unfolded setEndpoint_def] - | simp add: valid_queues_no_bitmap_def)+ - done - -lemma set_ntfn_valid_queues'[wp]: - "\valid_queues'\ setNotification p ntfn \\rv. valid_queues'\" - apply (unfold setNotification_def) - apply (rule setObject_ntfn_pre) - apply (simp only: valid_queues'_def imp_conv_disj - obj_at'_real_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - apply (rule setObject_ko_wp_at) - apply simp - apply (simp add: objBits_simps') - apply simp - apply (wp updateObject_default_inv | simp)+ - apply (clarsimp simp: projectKOs ko_wp_at'_def) - 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)))\ @@ -2203,6 +2237,21 @@ lemma setNotification_ct_idle_or_in_cur_domain'[wp]: crunch gsUntypedZeroRanges[wp]: setNotification "\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)\" + assumes nexts: "\P. f \\s. P (tcbSchedNexts_of s)\" + shows "f \sym_heap_sched_pointers\" + by (rule_tac f=tcbSchedPrevs_of in hoare_lift_Pf2; wpsimp wp: assms) + +crunches setNotification + for tcbSchedNexts_of[wp]: "\s. P (tcbSchedNexts_of s)" + and tcbSchedPrevs_of[wp]: "\s. P (tcbSchedPrevs_of s)" + and valid_sched_pointers[wp]: valid_sched_pointers + and ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" + and ksReadyQueuesL1Bitmap[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" + and ksReadyQueuesL2Bitmap[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" + (simp: updateObject_default_def) + lemma set_ntfn_minor_invs': "\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)) @@ -2212,11 +2261,14 @@ lemma set_ntfn_minor_invs': and (\s. ptr \ ksIdleThread s) \ setNotification ptr val \\rv. invs'\" - apply (clarsimp simp add: invs'_def valid_state'_def cteCaps_of_def) - apply (wp irqs_masked_lift valid_irq_node_lift untyped_ranges_zero_lift; simp add: o_def) - by (clarsimp elim!: rsubst[where P=sym_refs] - intro!: ext - dest!: obj_at_state_refs_ofD') + 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\" @@ -2254,6 +2306,30 @@ lemma idle_is_global [intro!]: "ksIdleThread s \ global_refs' s" by (simp add: global_refs'_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" + supply projectKOs[simp] + apply (simp add: obj_at'_def project_inject pspace_distinct'_def pspace_aligned'_def) + apply (drule bspec, erule domI)+ + apply (clarsimp simp: objBits_simps' word_bits_def + split: kernel_object.splits arch_kernel_object.splits) + done + +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 + +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) + lemma valid_globals_cte_wpD': "\ valid_global_refs' s; cte_wp_at' P p s \ \ \cte. P cte \ ksIdleThread s \ capRange (cteCap cte)" @@ -2297,20 +2373,17 @@ crunch typ_at'[wp]: doMachineOp "\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'\" - by (simp add: doMachineOp_def split_def - valid_pspace'_def valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs - | wp cur_tcb_lift sch_act_wf_lift tcb_in_cur_domain'_lift + "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 \\s. P (state_hyp_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 obj_at'[wp]: doMachineOp "\s. P (obj_at' P' p s)" diff --git a/proof/refine/ARM_HYP/PageTableDuplicates.thy b/proof/refine/ARM_HYP/PageTableDuplicates.thy index 44902c2764..a06d10e158 100644 --- a/proof/refine/ARM_HYP/PageTableDuplicates.thy +++ b/proof/refine/ARM_HYP/PageTableDuplicates.thy @@ -77,11 +77,6 @@ crunches threadSet, setBoundNotification for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" (wp: setObject_ksInterrupt updateObject_default_inv) -lemma tcbSchedEnqueue_valid_duplicates'[wp]: - "\\s. vs_valid_duplicates' (ksPSpace s)\ - tcbSchedEnqueue a \\rv s. vs_valid_duplicates' (ksPSpace s)\" - by (simp add:tcbSchedEnqueue_def unless_def setQueue_def | wp | wpc)+ - crunch valid_duplicates'[wp]: rescheduleRequired "\s. vs_valid_duplicates' (ksPSpace s)" (wp: setObject_ksInterrupt updateObject_default_inv) diff --git a/proof/refine/ARM_HYP/Refine.thy b/proof/refine/ARM_HYP/Refine.thy index 01918758a6..21d902ed9b 100644 --- a/proof/refine/ARM_HYP/Refine.thy +++ b/proof/refine/ARM_HYP/Refine.thy @@ -82,7 +82,7 @@ lemma typ_at_UserDataI: apply (subst mask_lower_twice [where n = pageBits, OF pbfs_atleast_pageBits, symmetric]) apply (clarsimp simp: obj_relation_cuts_def2 pte_relation_def cte_relation_def other_obj_relation_def - pde_relation_def + pde_relation_def tcb_relation_cut_def split: Structures_A.kernel_object.split_asm Structures_H.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) @@ -113,7 +113,7 @@ lemma typ_at_DeviceDataI: apply (subst mask_lower_twice [where n = pageBits, OF pbfs_atleast_pageBits, symmetric]) apply (clarsimp simp: obj_relation_cuts_def2 pte_relation_def cte_relation_def other_obj_relation_def - pde_relation_def + pde_relation_def tcb_relation_cut_def split: Structures_A.kernel_object.split_asm Structures_H.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) @@ -578,7 +578,7 @@ lemma kernel_corres': apply simp apply (rule handleInterrupt_corres[simplified dc_def]) apply simp - apply (wp hoare_drop_imps hoare_vcg_all_lift)[1] + apply (wpsimp wp: hoare_drop_imps hoare_vcg_all_lift simp: schact_is_rct_def)[1] apply simp apply (rule_tac Q="\irq s. irq \ Some ` non_kernel_IRQs \ invs' s \ (\irq'. irq = Some irq' \ @@ -656,7 +656,7 @@ lemma entry_corres: apply (rule corres_split[OF getCurThread_corres]) apply (rule corres_split) apply simp - apply (rule threadset_corresT) + 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) @@ -668,7 +668,8 @@ lemma entry_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, simp add: invs_def cur_tcb_def) + apply (rule hoare_strengthen_post, rule akernel_invs_det_ext, + simp add: invs_def valid_state_def valid_pspace_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 thread_set_not_state_valid_sched hoare_weak_lift_imp @@ -679,7 +680,7 @@ lemma entry_corres: hoare_weak_lift_imp hoare_vcg_disj_lift | simp add: ct_in_state'_def atcbContextSet_def | (wps, wp threadSet_st_tcb_at2))+ - apply (clarsimp simp: invs_def cur_tcb_def) + apply (fastforce simp: invs_def cur_tcb_def) apply (clarsimp simp: ct_in_state'_def) done diff --git a/proof/refine/ARM_HYP/Retype_R.thy b/proof/refine/ARM_HYP/Retype_R.thy index c29f7ab34c..616184c2f0 100644 --- a/proof/refine/ARM_HYP/Retype_R.thy +++ b/proof/refine/ARM_HYP/Retype_R.thy @@ -313,7 +313,7 @@ lemma state_relation_null_filterE: null_filter (caps_of_state t) = null_filter (caps_of_state s); null_filter' (ctes_of t') = null_filter' (ctes_of s'); pspace_relation (kheap t) (ksPSpace t'); - ekheap_relation (ekheap t) (ksPSpace 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'; @@ -1002,7 +1002,7 @@ lemma retype_ekheap_relation: apply (intro impI conjI) apply clarsimp apply (drule_tac x=a in bspec,force) - apply (clarsimp simp add: other_obj_relation_def split: if_split_asm) + apply (clarsimp simp: 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_HYP_H.object_type.splits @@ -1183,6 +1183,11 @@ lemma update_gs_id: by (simp add: no_gs_types_def update_gs_def split: Structures_A.apiobject_type.splits aobject_type.splits) +lemma ksReadyQueues_update_gs[simp]: + "ksReadyQueues (update_gs tp us addrs s) = ksReadyQueues s" + by (simp add: update_gs_def + split: aobject_type.splits Structures_A.apiobject_type.splits) + lemma update_gs_simps[simp]: "update_gs Structures_A.apiobject_type.CapTableObject us ptrs = gsCNodes_update (\cns x. if x \ ptrs then Some us else cns x)" @@ -1197,6 +1202,144 @@ lemma update_gs_simps[simp]: else ups x)" by (simp_all add: update_gs_def) +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 - + 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_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 "\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 (fastforce simp: ptr_add_def p_assoc_help) + done +qed + +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 + "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 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_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 + "tcbSchedNexts_of + (s'\ksPSpace := foldr (\addr. data_map_insert addr ko) (new_cap_addrs m ptr ko) (ksPSpace s')\) + = tcbSchedNexts_of s'" +proof - + 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 + 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 + by (cases ty; + fastforce simp: 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" @@ -1225,7 +1368,7 @@ lemma retype_state_relation: \ state_relation" (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) + 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 ko] num_r]) @@ -1416,6 +1559,16 @@ lemma retype_state_relation: else cns x" in exI, simp) apply (rule_tac x=id in exI, simp)+ done + + have rdyqrel: "ready_queues_relation s s'" + using sr by (simp add: state_relation_def) + + thus "ready_queues_relation_2 (ready_queues s) (ksReadyQueues s') + (?ps' |> tcb_of' |> tcbSchedNext) (?ps' |> tcb_of' |> tcbSchedPrev) + (\d p. inQ d p |< (?ps' |> tcb_of'))" + using retype_ready_queues_relation[OF _ vs' pn' ko cover num_r] + by (clarsimp simp: ready_queues_relation_def Let_def) + qed lemma new_cap_addrs_fold': @@ -2431,7 +2584,6 @@ qed lemma other_objs_default_relation: "\ case ty of Structures_A.EndpointObject \ ko = injectKO (makeObject :: endpoint) | Structures_A.NotificationObject \ ko = injectKO (makeObject :: Structures_H.notification) - | Structures_A.TCBObject \ ko = injectKO (makeObject :: tcb) | _ \ False \ \ obj_relation_retype (default_object ty dev n) ko" apply (rule obj_relation_retype_other_obj) @@ -2452,6 +2604,13 @@ lemma other_objs_default_relation: split: Structures_A.apiobject_type.split_asm) done +lemma tcb_relation_retype: + "obj_relation_retype (default_object Structures_A.TCBObject dev n) (KOTCB makeObject)" + by (clarsimp simp: default_object_def obj_relation_retype_def tcb_relation_def default_tcb_def + makeObject_tcb makeObject_cte new_context_def newContext_def tcb_relation_cut_def + fault_rel_optionation_def initContext_def default_priority_def + default_arch_tcb_def newArchTCB_def arch_tcb_relation_def objBits_simps') + lemma captable_relation_retype: "n < word_bits \ obj_relation_retype (default_object Structures_A.CapTableObject dev n) (KOCTE makeObject)" @@ -3152,10 +3311,10 @@ proof (intro conjI impI) apply (rule_tac ptr="x + xa" in cte_wp_at_tcbI', assumption+) apply fastforce apply simp - apply (rename_tac thread_state mcp priority bool option nat cptr vptr bound user_context) - apply (case_tac thread_state, simp_all add: valid_tcb_state'_def - valid_bound_ntfn'_def obj_at_disj' - split: option.splits)[2] + 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 (clarsimp simp add: valid_arch_tcb'_def typ_at_to_obj_at_arches obj_at_disj') apply (simp add: valid_cte'_def) apply (frule pspace_alignedD' [OF _ ad(1)]) @@ -3930,16 +4089,6 @@ lemma sch_act_wf_lift_asm: apply auto done -lemma valid_queues_lift_asm': - assumes tat: "\d p t. \\s. \ obj_at' (inQ d p) t s \ Q d p s\ f \\_ s. \ obj_at' (inQ d p) t s\" - and prq: "\P. \\s. P (ksReadyQueues s)\ f \\_ s. P (ksReadyQueues s)\" - shows "\\s. valid_queues' s \ (\d p. Q d p s)\ f \\_. valid_queues'\" - apply (simp only: valid_queues'_def imp_conv_disj) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift - tat prq) - apply simp - done - lemma createObjects'_ct[wp]: "\\s. P (ksCurThread s)\ createObjects' p n v us \\rv s. P (ksCurThread s)\" by (rule createObjects_pspace_only, simp) @@ -4356,35 +4505,150 @@ crunch ksMachine[wp]: createObjects "\s. P (ksMachineState s)" crunch cur_domain[wp]: createObjects "\s. P (ksCurDomain s)" (simp: unless_def) -lemma createNewCaps_valid_queues': - "\valid_queues' and pspace_no_overlap' ptr sz - 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_queues'\" - apply (wp valid_queues_lift_asm' [OF createNewCaps_obj_at2]) - apply (clarsimp simp: projectKOs) - apply (simp add: makeObjectKO_def - split: object_type.split_asm - apiobject_type.split_asm) - apply (clarsimp simp: inQ_def) - apply (auto simp: makeObject_tcb - split: object_type.splits apiobject_type.splits) +lemma createObjects_valid_bitmaps: + "createObjects' ptr n val gbits \valid_bitmaps\" + apply (clarsimp simp: createObjects'_def alignError_def split_def) + apply (wp case_option_wp[where P="\_. P" and P'=P for P, simplified] assert_inv + | clarsimp simp del: fun_upd_apply)+ + apply (clarsimp simp: valid_bitmaps_def valid_bitmapQ_def bitmapQ_def bitmapQ_no_L2_orphans_def + bitmapQ_no_L1_orphans_def) done -lemma createNewCaps_valid_queues: - "\valid_queues and pspace_no_overlap' ptr sz - 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_queues\" - apply (rule hoare_gen_asm) - apply (wpsimp wp: valid_queues_lift_asm createNewCaps_obj_at2[where sz=sz]) - apply (clarsimp simp: projectKO_opts_defs) - apply (simp add: inQ_def) - apply (wpsimp wp: createNewCaps_pred_tcb_at'[where sz=sz])+ +lemma valid_bitmaps_gsCNodes_update[simp]: + "valid_bitmaps (gsCNodes_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) + +lemma valid_bitmaps_gsUserPages_update[simp]: + "valid_bitmaps (gsUserPages_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) + +crunches curDomain, copyGlobalMappings + for valid_bitmaps[wp]: valid_bitmaps + and sched_pointers[wp]: "\s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)" + and valid_sched_pointers[wp]: valid_sched_pointers + +lemma createNewCaps_valid_bitmaps: + "\\s. valid_pspace' s \ pspace_no_overlap' ptr sz s \ valid_bitmaps s\ + createNewCaps ty ptr n us dev + \\_. valid_bitmaps\" + unfolding createNewCaps_def + apply (clarsimp simp: 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 (wpsimp wp: createObjects_valid_bitmaps) + by (wpsimp wp: createObjects_valid_bitmaps[simplified o_def] mapM_x_wp + | simp add: makeObject_tcb objBits_def createObjects_def + | intro conjI impI)+ + +lemma createObjects_sched_queues: + "\\s. n \ 0 + \ range_cover ptr sz (objBitsKO val + gbits) n + \ P (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ (case val of KOTCB tcb \ tcbSchedNext tcb = None \ tcbSchedPrev tcb = None + | _ \ True) + \ pspace_aligned' s \ pspace_distinct' s + \ pspace_no_overlap' ptr sz s\ + createObjects' ptr n val gbits + \\_ s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" + (is "\ \s. _ \ _ \ ?Pre s \ _ \\_. _\") +proof (rule hoare_grab_asm)+ + 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 \\_ s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" + proof - + have shiftr_not_zero:" 1 \ ((of_nat n)::machine_word) << gbits" + using range_cover_not_zero_shift[OF not_0 cover,where gbits = gbits] + by (simp add:word_le_sub1) + show ?thesis + supply projectKOs[simp] + apply (clarsimp simp: createObjects'_def unless_def alignError_def split_def) + apply (wp | clarsimp simp del: fun_upd_apply)+ + 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 (clarsimp simp: foldr_upd_app_if) + apply (rule_tac a="tcbSchedNexts_of s" and b="tcbSchedPrevs_of s" + in rsubst2[rotated, OF sym sym, where P=P]) + apply (rule ext) + apply (clarsimp simp: opt_map_def) + apply (frule (3) retype_ksPSpace_None[simplified mult.commute]) + apply (fastforce intro: cover) + apply fastforce + apply (clarsimp split: kernel_object.splits option.splits) + apply (rule ext) + apply (clarsimp simp: opt_map_def) + apply (frule (3) retype_ksPSpace_None[simplified mult.commute]) + apply (fastforce intro: cover) + apply fastforce + apply (clarsimp split: kernel_object.splits option.splits) + apply simp + done + qed +qed + +lemma createNewCaps_sched_queues: + assumes cover: "range_cover ptr sz (APIType_capBits ty us) n" + assumes not_0: "n \ 0" + shows + "\\s. valid_pspace' s \ pspace_no_overlap' ptr sz s + \ P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\ + createNewCaps ty ptr n us dev + \\_ s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" + unfolding createNewCaps_def + apply (clarsimp simp: ARM_HYP_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 (wp, simp) + apply (insert cover not_0) + apply (wpsimp wp: mapM_x_wp' createObjects_sched_queues threadSet_sched_pointers + simp: curDomain_def createObjects_def) + apply (simp add: valid_pspace'_def makeObject_tcb) + by (wp createObjects_sched_queues mapM_x_wp' + | clarsimp simp: objBits_simps APIType_capBits_def createObjects_def + vspace_bits_defs archObjSize_def + | intro conjI impI + | force)+ + + +lemma createObjects_valid_sched_pointers: + "\\s. valid_sched_pointers s + \ (case val of KOTCB tcb \ tcbSchedNext tcb = None \ tcbSchedPrev tcb = None + | _ \ True)\ + createObjects' ptr n val gbits + \\_. valid_sched_pointers\" + supply projectKOs[simp] + apply (clarsimp simp: createObjects'_def unless_def alignError_def split_def) + apply (wp case_option_wp[where P="\_. P" and P'=P for P, simplified] assert_inv + | clarsimp simp del: fun_upd_apply)+ + apply (clarsimp simp: valid_sched_pointers_def foldr_upd_app_if opt_pred_def opt_map_def comp_def) + apply (cases "tcb_of' val"; clarsimp) done +lemma createNewCaps_valid_sched_pointers: + "\\s. valid_pspace' s \ pspace_no_overlap' ptr sz s \ valid_sched_pointers s\ + createNewCaps ty ptr n us dev + \\_. valid_sched_pointers\" + unfolding createNewCaps_def + apply (clarsimp simp: 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 (wpsimp wp: createObjects_valid_sched_pointers) + by (wpsimp wp: createObjects_valid_sched_pointers[simplified o_def] mapM_x_wp + threadSet_valid_sched_pointers + | simp add: makeObject_tcb objBits_def createObjects_def + | intro conjI impI)+ + lemma mapM_x_threadSet_valid_pspace: "\valid_pspace' and K (curdom \ maxDomain)\ mapM_x (threadSet (tcbDomain_update (\_. curdom))) addrs \\y. valid_pspace'\" @@ -4782,12 +5046,13 @@ proof (rule hoare_gen_asm, erule conjE) createNewCaps_valid_arch_state valid_irq_node_lift_asm [unfolded pred_conj_def, OF _ createNewCaps_obj_at'] createNewCaps_irq_handlers' createNewCaps_vms - createNewCaps_valid_queues - createNewCaps_valid_queues' createNewCaps_pred_tcb_at' cnc_ct_not_inQ createNewCaps_ct_idle_or_in_cur_domain' createNewCaps_sch_act_wf createNewCaps_urz[where sz=sz] + createNewCaps_sched_queues[OF cover not_0] + createNewCaps_valid_sched_pointers + createNewCaps_valid_bitmaps | simp)+ using not_0 apply (clarsimp simp: valid_pspace'_def) @@ -4860,35 +5125,6 @@ lemma createObjects_sch: apply (wp sch_act_wf_lift_asm createObjects_pred_tcb_at' createObjects_orig_obj_at3 | force)+ done -lemma createObjects_queues: - "\\s. valid_queues 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. valid_queues\" - apply (wpsimp wp: valid_queues_lift_asm [unfolded pred_conj_def, OF createObjects_orig_obj_at3] - createObjects_pred_tcb_at' [unfolded pred_conj_def]) - apply fastforce - apply wp+ - apply fastforce - done - -lemma createObjects_queues': - assumes no_tcb: "\t. projectKO_opt val \ Some (t::tcb)" - shows - "\\s. valid_queues' 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. valid_queues'\" - apply (simp add: createObjects_def) - apply (wp valid_queues_lift_asm') - apply (wp createObjects_orig_obj_at2') - apply clarsimp - apply assumption - apply wp - apply (clarsimp simp: no_tcb split: option.splits) - apply fastforce - done - lemma createObjects_no_cte_ifunsafe': assumes no_cte: "\c. projectKO_opt val \ Some (c::cte)" assumes no_tcb: "\t. projectKO_opt val \ Some (t::tcb)" @@ -5134,7 +5370,7 @@ proof - 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 (wp createObjects_sch) apply (rule hoare_vcg_conj_lift) apply (simp add: createObjects_def) apply (wp createObjects_state_refs_of'') @@ -5144,30 +5380,37 @@ proof - 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] - assms | simp add: objBits_def )+ + apply (wp createObjects_no_cte_ifunsafe' + 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 + apply (wp irqs_masked_lift 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_pspace_domain_valid co_ct_not_inQ - createObjects_ct_idle_or_in_cur_domain' - createObjects_untyped_ranges_zero'[OF moKO] - | simp)+ + createObjects_no_cte_irq_handlers assms + | simp)+ + apply (rule hoare_vcg_conj_lift) + apply (simp add: createObjects_def) + apply (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 (wp createObjects_idle') + apply (wpsimp wp: createObjects_valid_bitmaps) + apply (wp createObjects_cur' + 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 (simp add: conj_comms) 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 (clarsimp simp: invs'_def no_tcb valid_state'_def no_cte split: option.splits) - done + apply (fastforce simp: no_cte no_tcb split_def split: option.splits) + apply (clarsimp simp: invs'_def no_tcb valid_state'_def no_cte split: option.splits) + by (auto simp: invs'_def no_tcb valid_state'_def no_cte live'_def + split: option.splits kernel_object.splits) qed lemma corres_retype_update_gsI: @@ -5203,7 +5446,7 @@ lemma gcd_corres: "corres (=) \ \ (gets cur_domain) curDomain" 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. 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 @@ -5214,7 +5457,7 @@ lemma retype_region2_extra_ext_mapM_x_corres: 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. tcb_at' t s" + and P'="\s. \t \ set addrs. obj_at' (Not \ tcbQueued) t s" in corres_mapM_x) apply simp apply (rule corres_guard_imp) @@ -5222,8 +5465,10 @@ lemma retype_region2_extra_ext_mapM_x_corres: apply (case_tac tcb') apply simp apply fastforce - 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 @@ -5255,10 +5500,11 @@ lemma retype_region2_obj_at: apply (auto simp: obj_at_def default_object_def is_tcb_def) done -lemma createObjects_tcb_at': +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\ - createObjects ptr n (KOTCB makeObject) 0 \\ptrs s. \addr\set ptrs. tcb_at' addr 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 @@ -5335,7 +5581,7 @@ lemma corres_retype_region_createNewCaps: apply (rule corres_retype[where 'a = tcb], simp_all add: obj_bits_api_def objBits_simps' pageBits_def APIType_map2_def makeObjectKO_def - other_objs_default_relation)[1] + tcb_relation_retype)[1] apply (fastforce simp: range_cover_def) apply (rule corres_split_nor) apply (simp add: APIType_map2_def) @@ -5346,7 +5592,7 @@ lemma corres_retype_region_createNewCaps: apply wp apply wp apply ((wp retype_region2_obj_at | 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 ((wp createObjects_Not_tcbQueued[where sz=sz] | simp add: APIType_map2_def objBits_simps' obj_bits_api_def)+)[1] apply simp apply simp apply (subst retype_region2_extra_ext_trivial) diff --git a/proof/refine/ARM_HYP/Schedule_R.thy b/proof/refine/ARM_HYP/Schedule_R.thy index 709d465cbd..b89f389787 100644 --- a/proof/refine/ARM_HYP/Schedule_R.thy +++ b/proof/refine/ARM_HYP/Schedule_R.thy @@ -15,11 +15,6 @@ declare hoare_weak_lift_imp[wp_split del] (* Levity: added (20090713 10:04:12) *) declare sts_rel_idle [simp] -lemma invs_no_cicd'_queues: - "invs_no_cicd' s \ valid_queues s" - unfolding invs_no_cicd'_def - by simp - 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)" @@ -133,12 +128,17 @@ lemma arch_switchToThread_corres: and valid_vs_lookup and valid_global_objs and unique_table_refs o caps_of_state and st_tcb_at runnable t and (\s. sym_refs (state_hyp_refs_of s))) - (valid_arch_state' and valid_pspace' and st_tcb_at' runnable' t - and (\s. sym_refs (state_hyp_refs_of' s))) + (valid_arch_state' and no_0_obj' and (\s. sym_refs (state_hyp_refs_of' s))) (arch_switch_to_thread t) (Arch.switchToThread t)" + apply (rule_tac Q'="tcb_at' t" in corres_cross_add_guard) + apply (fastforce intro!: tcb_at_cross 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 (simp add: arch_switch_to_thread_def ARM_HYP_H.switchToThread_def) apply (rule corres_guard_imp) - apply (rule corres_split[OF get_tcb_corres]) + apply (rule corres_split[OF getObject_TCB_corres]) apply (rule corres_split[OF vcpuSwitch_corres']) apply (clarsimp simp: tcb_relation_def arch_tcb_relation_def) apply (rule corres_split[OF setVMRoot_corres]) @@ -170,327 +170,280 @@ lemma schedule_choose_new_thread_sched_act_rct[wp]: unfolding schedule_choose_new_thread_def by wp +\ \This proof shares many similarities with the proof of @{thm tcbSchedEnqueue_corres}\ lemma tcbSchedAppend_corres: - notes trans_state_update'[symmetric, simp del] - shows - "corres dc (is_etcb_at t) (tcb_at' t and Invariants_H.valid_queues and valid_queues') (tcb_sched_action (tcb_sched_append) t) (tcbSchedAppend t)" - apply (simp only: tcbSchedAppend_def tcb_sched_action_def) - apply (rule corres_symb_exec_r [OF _ _ threadGet_inv, 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, simp) - apply (rule no_fail_pre, wp, simp) - apply (case_tac queued) - apply (simp add: unless_def when_def) - apply (rule corres_no_failI) - apply wp+ - apply (clarsimp simp: in_monad ethread_get_def gets_the_def bind_assoc - assert_opt_def exec_gets is_etcb_at_def get_etcb_def get_tcb_queue_def - set_tcb_queue_def simpler_modify_def) - - apply (subgoal_tac "tcb_sched_append t (ready_queues a (tcb_domain y) (tcb_priority y)) - = (ready_queues a (tcb_domain y) (tcb_priority y))") - apply (simp add: state_relation_def ready_queues_relation_def) - apply (clarsimp simp: tcb_sched_append_def state_relation_def - valid_queues'_def ready_queues_relation_def - ekheap_relation_def etcb_relation_def - obj_at'_def inQ_def projectKO_eq project_inject) - apply (drule_tac x=t in bspec,clarsimp) + "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_append tcb_ptr) (tcbSchedAppend tcbPtr)" + supply if_split[split del] + heap_path_append[simp del] fun_upd_apply[simp del] distinct_append[simp del] + projectKOs[simp] + 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_append_def get_tcb_queue_def + tcbSchedAppend_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]; 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) + 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 (clarsimp simp: unless_def when_def cong: if_cong) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres) - apply (simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres) - apply (simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply simp - apply (rule getQueue_corres) - apply (rule corres_split_noop_rhs2) - apply (simp add: tcb_sched_append_def) - apply (intro conjI impI) - apply (rule corres_guard_imp) - apply (rule setQueue_corres) - prefer 3 - apply (rule_tac P=\ and Q="K (t \ set queuea)" in corres_assume_pre) - apply simp - apply simp - apply simp - apply (rule corres_split_noop_rhs2) - apply (rule addToBitmap_if_null_noop_corres) - apply (rule threadSet_corres_noop, simp_all add: tcb_relation_def exst_same_def)[1] - apply wp+ - apply (wp getObject_tcb_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 - - -crunches tcbSchedEnqueue, tcbSchedAppend, tcbSchedDequeue - for valid_pspace'[wp]: valid_pspace' - and valid_arch_state'[wp]: valid_arch_state' - and pred_tcb_at'[wp]: "pred_tcb_at' proj P t" - (wp: threadSet_pred_tcb_no_state simp: unless_def tcb_to_itcb'_def) - -lemma removeFromBitmap_valid_queues_no_bitmap_except[wp]: -" \ valid_queues_no_bitmap_except t \ - removeFromBitmap d p - \\_. valid_queues_no_bitmap_except t \" - unfolding bitmapQ_defs valid_queues_no_bitmap_except_def - by (wp| clarsimp simp: bitmap_fun_defs)+ - -lemma removeFromBitmap_bitmapQ: - "\ \s. True \ removeFromBitmap d p \\_ s. \ bitmapQ d p s \" - unfolding bitmapQ_defs bitmap_fun_defs - by (wp| clarsimp simp: bitmap_fun_defs)+ - -lemma removeFromBitmap_valid_bitmapQ[wp]: -" \ valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - (\s. ksReadyQueues s (d,p) = []) \ - removeFromBitmap d p - \\_. valid_bitmapQ \" -proof - - have "\ valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - (\s. ksReadyQueues s (d,p) = []) \ - removeFromBitmap d p - \\_. valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - (\s. \ bitmapQ d p s \ ksReadyQueues s (d,p) = []) \" - by (rule hoare_pre) - (wp removeFromBitmap_valid_queues_no_bitmap_except removeFromBitmap_valid_bitmapQ_except - removeFromBitmap_bitmapQ, simp) - thus ?thesis - by - (erule hoare_strengthen_post; fastforce elim: valid_bitmap_valid_bitmapQ_exceptE) -qed + 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)?) -(* this should be the actual weakest precondition to establish valid_queues - under tagging a thread as not queued *) -lemma threadSet_valid_queues_dequeue_wp: - "\ valid_queues_no_bitmap_except t and - valid_bitmapQ and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - (\s. \d p. t \ set (ksReadyQueues s (d,p))) \ - threadSet (tcbQueued_update (\_. False)) t - \\rv. valid_queues \" - unfolding threadSet_def - apply (rule hoare_seq_ext[OF _ getObject_tcb_sp]) - apply (rule hoare_pre) - apply (simp add: valid_queues_def valid_queues_no_bitmap_except_def valid_queues_no_bitmap_def) - apply (wp setObject_queues_unchanged_tcb hoare_Ball_helper hoare_vcg_all_lift - setObject_tcb_strongest) - apply (clarsimp simp: valid_queues_no_bitmap_except_def obj_at'_def valid_queues_no_bitmap_def) - done + \ \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']) -(* FIXME move *) -lemmas obj_at'_conjI = obj_at_conj' - -lemma setQueue_valid_queues_no_bitmap_except_dequeue_wp: - "\d p ts t. - \ \s. valid_queues_no_bitmap_except t s \ - (\t' \ set ts. obj_at' (inQ d p and runnable' \ tcbState) t' s) \ - t \ set ts \ distinct ts \ p \ maxPriority \ d \ maxDomain \ - setQueue d p ts - \\rv. valid_queues_no_bitmap_except t \" - unfolding setQueue_def valid_queues_no_bitmap_except_def null_def - by wp force - -definition (* if t is in a queue, it should be tagged with right priority and domain *) - "correct_queue t s \ \d p. t \ set(ksReadyQueues s (d, p)) \ - (obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t s)" - -lemma valid_queues_no_bitmap_correct_queueI[intro]: - "valid_queues_no_bitmap s \ correct_queue t s" - unfolding correct_queue_def valid_queues_no_bitmap_def - by (fastforce simp: obj_at'_def inQ_def) - - -lemma tcbSchedDequeue_valid_queues_weak: - "\ valid_queues_no_bitmap_except t and valid_bitmapQ and - bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - correct_queue t and - obj_at' (\tcb. tcbDomain tcb \ maxDomain \ tcbPriority tcb \ maxPriority) t \ - tcbSchedDequeue t - \\_. Invariants_H.valid_queues\" -proof - - show ?thesis - unfolding tcbSchedDequeue_def null_def valid_queues_def - apply wp (* stops on threadSet *) - apply (rule hoare_post_eq[OF _ threadSet_valid_queues_dequeue_wp], - simp add: valid_queues_def) - apply (wp hoare_vcg_if_lift hoare_vcg_conj_lift hoare_vcg_imp_lift)+ - apply (wp hoare_vcg_imp_lift setQueue_valid_queues_no_bitmap_except_dequeue_wp - setQueue_valid_bitmapQ threadGet_const_tcb_at hoare_vcg_if_lift)+ - (* wp done *) - apply (normalise_obj_at') - apply (clarsimp simp: correct_queue_def) - apply (normalise_obj_at') - apply (fastforce simp add: valid_queues_no_bitmap_except_def valid_queues_no_bitmap_def elim: obj_at'_weaken)+ - done -qed - -lemma tcbSchedDequeue_valid_queues: - "\Invariants_H.valid_queues - and obj_at' (\tcb. tcbDomain tcb \ maxDomain) t - and obj_at' (\tcb. tcbPriority tcb \ maxPriority) t\ - tcbSchedDequeue t - \\_. Invariants_H.valid_queues\" - apply (rule hoare_pre, rule tcbSchedDequeue_valid_queues_weak) - apply (fastforce simp: valid_queues_def valid_queues_no_bitmap_def obj_at'_def inQ_def) - done - -lemma tcbSchedAppend_valid_queues'[wp]: - (* most of this is identical to tcbSchedEnqueue_valid_queues' in TcbAcc_R *) - "\valid_queues' and tcb_at' t\ tcbSchedAppend t \\_. valid_queues'\" - apply (simp add: tcbSchedAppend_def) - apply (rule hoare_pre) - apply (rule_tac B="\rv. valid_queues' and obj_at' (\obj. tcbQueued obj = rv) t" - in hoare_seq_ext) - 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 wpsimp + apply (wpsimp wp: hoare_vcg_if_lift hoare_vcg_ex_lift) + apply (corres corres: addToBitmap_if_null_noop_corres) + + apply (rule corres_from_valid_det) + apply (fastforce intro: det_wp_modify det_wp_pre simp: set_tcb_queue_def) + apply (wpsimp simp: tcbQueueAppend_def wp: hoare_vcg_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'_tcbQueueEnd_ksReadyQueues simp: obj_at'_def) + + apply (rename_tac s rv t) + apply (clarsimp simp: state_relation_def) + apply (intro hoare_vcg_conj_lift_pre_fix; + (solves \frule singleton_eqD, frule set_tcb_queue_projs_inv, wpsimp simp: swp_def\)?) + + \ \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 simp: setQueue_def tcbQueueAppend_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) + 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 obj_at'_tcbQueueEnd_ksReadyQueues) + apply fast + apply fast + apply fastforce + apply fastforce + apply (cut_tac xs="ready_queues s d p" in heap_path_head') + apply (force dest!: spec simp: list_queue_relation_def) + 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) + apply (metis inQ_def option.simps(5) tcb_of'_TCB) + apply (intro conjI impI; clarsimp) + + \ \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 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_def)+ - apply (clarsimp simp: obj_at'_def inQ_def projectKOs valid_queues'_def) - apply (wp getObject_tcb_wp | simp add: threadGet_def)+ - apply (clarsimp simp: obj_at'_def) - done - -lemma threadSet_valid_queues'_dequeue: (* threadSet_valid_queues' is too weak for dequeue *) - "\\s. (\d p t'. obj_at' (inQ d p) t' s \ t' \ t \ t' \ set (ksReadyQueues s (d, p))) \ - obj_at' (inQ d p) t s \ - threadSet (tcbQueued_update (\_. False)) t - \\rv. valid_queues' \" - unfolding valid_queues'_def - apply (rule hoare_pre) - apply (wp hoare_vcg_all_lift) - apply (simp only: imp_conv_disj not_obj_at') - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - apply (simp add: not_obj_at') - apply (clarsimp simp: typ_at_tcb') - apply normalise_obj_at' - apply (fastforce elim: obj_at'_weaken simp: inQ_def) - done - -lemma setQueue_ksReadyQueues_lift: - "\ \s. P (s\ksReadyQueues := (ksReadyQueues s)((d, p) := ts)\) ts \ - setQueue d p ts - \ \_ s. P s (ksReadyQueues s (d,p))\" - unfolding setQueue_def - by (wp, clarsimp simp: fun_upd_def snd_def) - -lemma tcbSchedDequeue_valid_queues'[wp]: - "\valid_queues' and tcb_at' t\ - tcbSchedDequeue t \\_. valid_queues'\" - unfolding tcbSchedDequeue_def - apply (rule_tac B="\rv. valid_queues' and obj_at' (\obj. tcbQueued obj = rv) t" - in hoare_seq_ext) - prefer 2 - apply (wp threadGet_const_tcb_at) - apply (fastforce simp: obj_at'_def) + 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 (tcbQueueEnd (ksReadyQueues s' (tcb_domain etcb, tcb_priority etcb))) + \ set (ready_queues s d p)") + apply (erule orthD2) + apply (drule_tac x="tcb_domain etcb" in spec) + apply (drule_tac x="tcb_priority etcb" in spec) + apply clarsimp + apply (drule_tac x="the (tcbQueueEnd (ksReadyQueues s' (tcb_domain etcb, tcb_priority etcb)))" + in spec) + subgoal by (auto simp: in_opt_pred opt_map_red) + 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"; + clarsimp 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 split: if_splits) + apply (case_tac "t = the (tcbQueueEnd (ksReadyQueues s' (tcb_domain etcb, tcb_priority etcb)))") + apply (clarsimp simp: inQ_def opt_pred_def fun_upd_apply) + 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 tcb \ p = tcb_priority tcb\ apply clarsimp - apply (rename_tac queued) - apply (case_tac queued, simp_all) - apply wp - apply (rule_tac d=tdom and p=prio in threadSet_valid_queues'_dequeue) - apply (rule hoare_pre_post, assumption) - apply (wp | clarsimp simp: bitmap_fun_defs)+ - apply (wp hoare_vcg_all_lift setQueue_ksReadyQueues_lift) - apply clarsimp - apply (wp threadGet_obj_at' threadGet_const_tcb_at)+ - apply clarsimp - apply (rule context_conjI, clarsimp simp: obj_at'_def) - apply (clarsimp simp: valid_queues'_def obj_at'_def projectKOs inQ_def|wp)+ + 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) + apply (frule valid_tcbs'_maxPriority[where t=tcbPtr], simp add: obj_at'_def) + 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) + apply (intro conjI; clarsimp) + + \ \the ready queue was originally empty\ + apply (force simp: inQ_def in_opt_pred fun_upd_apply opt_map_def obj_at'_def + queue_end_valid_def prev_queue_head_def + split: if_splits option.splits) + + \ \the ready queue was not originally empty\ + apply (drule (2) heap_ls_append[where new=tcbPtr]) + apply (rule conjI) + apply (clarsimp simp: fun_upd_apply queue_end_valid_def opt_map_def split: if_splits) + apply (rule conjI) + apply (clarsimp simp: fun_upd_apply queue_end_valid_def) + apply (rule conjI) + apply (subst opt_map_upd_triv) + apply (clarsimp simp: opt_map_def fun_upd_apply queue_end_valid_def split: if_splits) + apply (clarsimp simp: prev_queue_head_def fun_upd_apply split: if_splits) + by (clarsimp simp: inQ_def in_opt_pred fun_upd_apply queue_end_valid_def split: if_splits) + +lemma tcbQueueAppend_valid_objs'[wp]: + "\\s. valid_objs' s \ tcb_at' tcbPtr s \ (\end. tcbQueueEnd queue = Some end \ tcb_at' end s)\ + tcbQueueAppend queue tcbPtr + \\_. valid_objs'\" + unfolding tcbQueueAppend_def + apply (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') + apply (clarsimp simp: tcbQueueEmpty_def valid_bound_tcb'_def split: option.splits) + done + +lemma tcbSchedAppend_valid_objs'[wp]: + "\valid_objs' and pspace_aligned' and pspace_distinct'\ + tcbSchedAppend tcbPtr + \\_. valid_objs'\" + apply (clarsimp simp: tcbSchedAppend_def setQueue_def) + apply (wpsimp wp: threadSet_valid_objs' threadGet_wp hoare_vcg_all_lift) + apply (normalise_obj_at', rename_tac tcb "end") + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (frule tcbQueueHead_iff_tcbQueueEnd) + apply (force dest!: obj_at'_tcbQueueEnd_ksReadyQueues simp: tcbQueueEmpty_def obj_at'_def) done -crunch tcb_at'[wp]: tcbSchedAppend "tcb_at' t" - (simp: unless_def) - -crunch state_refs_of'[wp]: tcbSchedAppend "\s. P (state_refs_of' s)" - (wp: refl simp: crunch_simps unless_def) -crunch state_refs_of'[wp]: tcbSchedDequeue "\s. P (state_refs_of' s)" - (wp: refl simp: crunch_simps) +crunches tcbSchedAppend, tcbSchedDequeue + for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" + (wp: threadSet_pred_tcb_no_state simp: unless_def tcb_to_itcb'_def) -crunch state_hyp_refs_of'[wp]: tcbSchedAppend "\s. P (state_hyp_refs_of' s)" - (wp: refl simp: crunch_simps unless_def) -crunch state_hyp_refs_of'[wp]: tcbSchedDequeue "\s. P (state_hyp_refs_of' s)" - (wp: refl simp: crunch_simps) +(* FIXME move *) +lemmas obj_at'_conjI = obj_at_conj' -crunch cap_to'[wp]: tcbSchedEnqueue "ex_nonz_cap_to' p" - (simp: unless_def) -crunch cap_to'[wp]: tcbSchedAppend "ex_nonz_cap_to' p" - (simp: unless_def) -crunch cap_to'[wp]: tcbSchedDequeue "ex_nonz_cap_to' p" +crunches tcbSchedAppend, tcbSchedDequeue, tcbSchedEnqueue + for tcb_at'[wp]: "tcb_at' t" + and cap_to'[wp]: "ex_nonz_cap_to' p" + and ifunsafe'[wp]: if_unsafe_then_cap' + (wp: crunch_wps simp: crunch_simps) lemma tcbSchedAppend_iflive'[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' tcb\ - tcbSchedAppend tcb \\_. if_live_then_nonz_cap'\" - apply (simp add: tcbSchedAppend_def unless_def) - apply (wp threadSet_iflive' hoare_drop_imps | simp add: crunch_simps)+ + "\if_live_then_nonz_cap' and pspace_aligned' and pspace_distinct'\ + tcbSchedAppend tcbPtr + \\_. if_live_then_nonz_cap'\" + supply projectKOs[simp] + unfolding tcbSchedAppend_def + apply (wpsimp wp: tcbQueueAppend_if_live_then_nonz_cap' threadGet_wp simp: bitmap_fun_defs) + apply (frule_tac p=tcbPtr in if_live_then_nonz_capE') + apply (fastforce simp: ko_wp_at'_def st_tcb_at'_def obj_at'_def runnable_eq_active' live'_def) + apply (clarsimp simp: tcbQueueEmpty_def) + apply (erule if_live_then_nonz_capE') + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (fastforce dest!: obj_at'_tcbQueueEnd_ksReadyQueues + simp: ko_wp_at'_def inQ_def obj_at'_def tcbQueueEmpty_def live'_def) done lemma tcbSchedDequeue_iflive'[wp]: - "\if_live_then_nonz_cap'\ tcbSchedDequeue tcb \\_. if_live_then_nonz_cap'\" + "\if_live_then_nonz_cap' and valid_objs' and sym_heap_sched_pointers\ + tcbSchedDequeue tcbPtr + \\_. if_live_then_nonz_cap'\" + supply projectKOs[simp] apply (simp add: tcbSchedDequeue_def) - apply (wp threadSet_iflive' hoare_when_weak_wp | simp add: crunch_simps)+ - apply ((wp | clarsimp simp: bitmap_fun_defs)+)[1] (* deal with removeFromBitmap *) - apply (wp threadSet_iflive' hoare_when_weak_wp | simp add: crunch_simps)+ - apply (rule_tac Q="\rv. \" in hoare_post_imp, fastforce) - apply (wp | simp add: crunch_simps)+ + apply (wpsimp wp: tcbQueueRemove_if_live_then_nonz_cap' threadGet_wp) + apply (fastforce elim: if_live_then_nonz_capE' simp: obj_at'_def ko_wp_at'_def live'_def) done -crunch ifunsafe'[wp]: tcbSchedAppend if_unsafe_then_cap' - (simp: unless_def) -crunch ifunsafe'[wp]: tcbSchedDequeue if_unsafe_then_cap' - -crunch idle'[wp]: tcbSchedAppend valid_idle' - (simp: crunch_simps unless_def) - -crunch global_refs'[wp]: tcbSchedEnqueue valid_global_refs' - (wp: threadSet_global_refs simp: unless_def) -crunch global_refs'[wp]: tcbSchedAppend valid_global_refs' - (wp: threadSet_global_refs simp: unless_def) -crunch global_refs'[wp]: tcbSchedDequeue valid_global_refs' - (wp: threadSet_global_refs) - -crunch irq_node'[wp]: tcbSchedAppend "\s. P (irq_node' s)" - (simp: unless_def) -crunch irq_node'[wp]: tcbSchedDequeue "\s. P (irq_node' s)" - -crunch typ_at'[wp]: tcbSchedAppend "\s. P (typ_at' T p s)" - (simp: unless_def) - -crunch ctes_of[wp]: tcbSchedAppend "\s. P (ctes_of s)" - (simp: unless_def) - -crunch ksInterrupt[wp]: tcbSchedAppend "\s. P (ksInterruptState s)" - (simp: unless_def) -crunch ksInterrupt[wp]: tcbSchedDequeue "\s. P (ksInterruptState s)" - -crunch irq_states[wp]: tcbSchedAppend valid_irq_states' - (simp: unless_def) -crunch irq_states[wp]: tcbSchedDequeue valid_irq_states' - -crunch ct'[wp]: tcbSchedAppend "\s. P (ksCurThread s)" - (simp: unless_def) - -crunch pde_mappings'[wp]: tcbSchedAppend "valid_pde_mappings'" - (simp: unless_def) -crunch pde_mappings'[wp]: tcbSchedDequeue "valid_pde_mappings'" +crunches tcbSchedAppend, tcbSchedDequeue, tcbSchedEnqueue + for typ_at'[wp]: "\s. P (typ_at' T p s)" + and tcb_at'[wp]: "tcb_at' t" + and ctes_of[wp]: "\s. P (ctes_of s)" + and ksInterrupt[wp]: "\s. P (ksInterruptState s)" + and irq_states[wp]: valid_irq_states' + and irq_node'[wp]: "\s. P (irq_node' s)" + and ct'[wp]: "\s. P (ksCurThread s)" + and global_refs'[wp]: valid_global_refs' + and ifunsafe'[wp]: if_unsafe_then_cap' + and cap_to'[wp]: "ex_nonz_cap_to' p" + and state_refs_of'[wp]: "\s. P (state_refs_of' s)" + and state_hyp_refs_of'[wp]: "\s. P (state_hyp_refs_of' s)" + and idle'[wp]: valid_idle' + and valid_pde_mappings'[wp]: valid_pde_mappings' + (simp: unless_def crunch_simps obj_at'_def wp: getObject_tcb_wp) lemma tcbSchedEnqueue_vms'[wp]: "\valid_machine_state'\ tcbSchedEnqueue t \\_. valid_machine_state'\" @@ -520,19 +473,85 @@ lemma ct_idle_or_in_cur_domain'_lift2: apply simp+ done +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 tcbSchedNext_update_valid_mdb'[wp]: + "\valid_mdb' and tcb_at' tcbPtr\ threadSet (tcbSchedNext_update f) tcbPtr \\_. valid_mdb'\" + apply (wpsimp wp: threadSet_mdb') + apply (fastforce simp: obj_at'_def valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) + done + +lemma tcbSchedPrev_update_valid_mdb'[wp]: + "\valid_mdb' and tcb_at' tcbPtr\ threadSet (tcbSchedPrev_update f) tcbPtr \\_. valid_mdb'\" + apply (wpsimp wp: threadSet_mdb') + apply (fastforce simp: obj_at'_def valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) + done + +lemma tcbQueueRemove_valid_mdb': + "\\s. valid_mdb' s \ valid_objs' s\ tcbQueueRemove q tcbPtr \\_. valid_mdb'\" + unfolding tcbQueueRemove_def + apply (wpsimp wp: getTCB_wp) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (fastforce simp: valid_tcb'_def obj_at'_def) + done + +lemma tcbQueuePrepend_valid_mdb': + "\valid_mdb' and tcb_at' tcbPtr + and (\s. \ tcbQueueEmpty queue \ tcb_at' (the (tcbQueueHead queue)) s)\ + tcbQueuePrepend queue tcbPtr + \\_. valid_mdb'\" + unfolding tcbQueuePrepend_def + by (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') + +lemma tcbQueueAppend_valid_mdb': + "\\s. valid_mdb' s \ tcb_at' tcbPtr s + \ (\ tcbQueueEmpty queue \ tcb_at' (the (tcbQueueEnd queue)) s)\ + tcbQueueAppend queue tcbPtr + \\_. valid_mdb'\" + unfolding tcbQueueAppend_def + by (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') + +lemma tcbQueued_update_valid_mdb'[wp]: + "\valid_mdb' and tcb_at' tcbPtr\ threadSet (tcbQueued_update f) tcbPtr \\_. valid_mdb'\" + apply (wpsimp wp: threadSet_mdb') + apply (fastforce simp: obj_at'_def valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) + done + +lemma valid_mdb'_ksReadyQueuesL1Bitmap_update[simp]: + "valid_mdb' (ksReadyQueuesL1Bitmap_update f s) = valid_mdb' s" + by (simp add: valid_mdb'_def) + +lemma valid_mdb'_ksReadyQueuesL2Bitmap_update[simp]: + "valid_mdb' (ksReadyQueuesL2Bitmap_update f s) = valid_mdb' s" + by (simp add: valid_mdb'_def) + +lemma tcbSchedEnqueue_valid_mdb'[wp]: + "\valid_mdb' and valid_objs' and pspace_aligned' and pspace_distinct'\ + tcbSchedEnqueue tcbPtr + \\_. valid_mdb'\" + apply (clarsimp simp: tcbSchedEnqueue_def setQueue_def) + apply (wpsimp wp: tcbQueuePrepend_valid_mdb' threadGet_wp simp: bitmap_fun_defs) + apply normalise_obj_at' + apply (fastforce dest!: obj_at'_tcbQueueHead_ksReadyQueues + simp: ready_queue_relation_def ksReadyQueues_asrt_def obj_at'_def) + done + +crunches tcbSchedEnqueue + for cur_tcb'[wp]: cur_tcb' + (wp: threadSet_cur) + lemma tcbSchedEnqueue_invs'[wp]: - "\invs' - and st_tcb_at' runnable' t - and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ - tcbSchedEnqueue t + "\invs' and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ + tcbSchedEnqueue t \\_. invs'\" - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp tcbSchedEnqueue_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 tcbSchedEnqueue_ct_not_inQ + simp: cteCaps_of_def o_def) done crunch ksMachine[wp]: tcbSchedAppend "\s. P (ksMachineState s)" @@ -541,7 +560,7 @@ crunch ksMachine[wp]: tcbSchedAppend "\s. P (ksMachineState s)" lemma tcbSchedAppend_vms'[wp]: "\valid_machine_state'\ tcbSchedAppend t \\_. valid_machine_state'\" apply (simp add: valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift tcbSchedAppend_ksMachine) + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) done crunch pspace_domain_valid[wp]: tcbSchedAppend "pspace_domain_valid" @@ -556,21 +575,29 @@ crunch ksIdleThread[wp]: tcbSchedAppend "\s. P (ksIdleThread s)" crunch ksDomSchedule[wp]: tcbSchedAppend "\s. P (ksDomSchedule s)" (simp: unless_def) +lemma tcbQueueAppend_tcbPriority_obj_at'[wp]: + "tcbQueueAppend queue tptr \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + supply projectKOs[simp] + unfolding tcbQueueAppend_def + apply (wpsimp wp: threadSet_wp) + by (auto simp: obj_at'_def objBits_simps ps_clear_def split: if_splits) + +lemma tcbQueueAppend_tcbDomain_obj_at'[wp]: + "tcbQueueAppend queue tptr \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + supply projectKOs[simp] + unfolding tcbQueueAppend_def + apply (wpsimp wp: threadSet_wp) + by (auto simp: obj_at'_def objBits_simps ps_clear_def split: if_splits) + lemma tcbSchedAppend_tcbDomain[wp]: - "\ obj_at' (\tcb. P (tcbDomain tcb)) t' \ - tcbSchedAppend t - \ \_. obj_at' (\tcb. P (tcbDomain tcb)) t' \" + "tcbSchedAppend t \obj_at' (\tcb. P (tcbDomain tcb)) t'\" apply (clarsimp simp: tcbSchedAppend_def) - apply (wpsimp simp: unless_def)+ - done + by wpsimp lemma tcbSchedAppend_tcbPriority[wp]: - "\ obj_at' (\tcb. P (tcbPriority tcb)) t' \ - tcbSchedAppend t - \ \_. obj_at' (\tcb. P (tcbPriority tcb)) t' \" + "tcbSchedAppend t \obj_at' (\tcb. P (tcbPriority tcb)) t'\" apply (clarsimp simp: tcbSchedAppend_def) - apply (wpsimp simp: unless_def)+ - done + by wpsimp lemma tcbSchedAppend_tcb_in_cur_domain'[wp]: "\tcb_in_cur_domain' t'\ tcbSchedAppend t \\_. tcb_in_cur_domain' t' \" @@ -584,26 +611,60 @@ crunches tcbSchedAppend, tcbSchedDequeue (simp: unless_def) lemma tcbSchedAppend_sch_act_wf[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ tcbSchedAppend thread - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - apply (simp add:tcbSchedAppend_def bitmap_fun_defs) - apply (wp unless_wp setQueue_sch_act threadGet_wp|simp)+ - apply (fastforce simp:typ_at'_def obj_at'_def) + "tcbSchedAppend thread \\s. sch_act_wf (ksSchedulerAction s) s\" + by (wpsimp wp: sch_act_wf_lift) + +lemma tcbSchedAppend_valid_bitmapQ[wp]: + "\valid_bitmaps\ tcbSchedAppend tcbPtr \\_. valid_bitmapQ\" + supply if_split[split del] + unfolding tcbSchedAppend_def + apply (wpsimp simp: tcbQueueAppend_def + wp: setQueue_valid_bitmapQ' addToBitmap_valid_bitmapQ_except addToBitmap_bitmapQ + threadGet_wp hoare_vcg_if_lift2) + apply (clarsimp simp: ksReadyQueues_asrt_def split: if_splits) + apply normalise_obj_at' + apply (force dest: tcbQueueHead_iff_tcbQueueEnd + simp: valid_bitmaps_def valid_bitmapQ_def tcbQueueEmpty_def) + done + +lemma tcbSchedAppend_valid_mdb'[wp]: + "\valid_mdb' and valid_tcbs' and pspace_aligned' and pspace_distinct'\ + tcbSchedAppend tcbPtr + \\_. valid_mdb'\" + supply projectKOs[simp] + apply (clarsimp simp: tcbSchedAppend_def setQueue_def) + apply (wpsimp wp: tcbQueueAppend_valid_mdb' threadGet_wp simp: bitmap_fun_defs) + apply (fastforce dest: obj_at'_tcbQueueEnd_ksReadyQueues + simp: ready_queue_relation_def ksReadyQueues_asrt_def obj_at'_def) + done + +lemma tcbSchedAppend_valid_bitmaps[wp]: + "tcbSchedAppend tcbPtr \valid_bitmaps\" + unfolding valid_bitmaps_def + apply wpsimp + apply (clarsimp simp: valid_bitmaps_def) done lemma tcbSchedAppend_invs'[wp]: - "\invs' - and st_tcb_at' runnable' t - and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ - tcbSchedAppend t + "\invs' and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ + tcbSchedAppend t \\_. invs'\" - apply (simp add: invs'_def valid_state'_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: @@ -632,7 +693,7 @@ crunch ksMachine[wp]: tcbSchedDequeue "\s. P (ksMachineState s)" lemma tcbSchedDequeue_vms'[wp]: "\valid_machine_state'\ tcbSchedDequeue t \\_. valid_machine_state'\" apply (simp add: valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift tcbSchedDequeue_ksMachine) + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) done crunch pspace_domain_valid[wp]: tcbSchedDequeue "pspace_domain_valid" @@ -650,43 +711,88 @@ lemma tcbSchedDequeue_tcb_in_cur_domain'[wp]: "\tcb_in_cur_domain' t'\ tcbSchedDequeue t \\_. tcb_in_cur_domain' t' \" apply (rule tcb_in_cur_domain'_lift) apply wp - apply (clarsimp simp: tcbSchedDequeue_def) - apply (wp hoare_when_weak_wp | simp)+ + apply (clarsimp simp: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wpsimp wp: hoare_when_weak_wp getObject_tcb_wp threadGet_wp) done -lemma tcbSchedDequeue_tcbDomain[wp]: - "\ obj_at' (\tcb. P (tcbDomain tcb)) t' \ - tcbSchedDequeue t - \ \_. obj_at' (\tcb. P (tcbDomain tcb)) t' \" - apply (clarsimp simp: tcbSchedDequeue_def) - apply (wp hoare_when_weak_wp | simp)+ - done - -lemma tcbSchedDequeue_tcbPriority[wp]: - "\ obj_at' (\tcb. P (tcbPriority tcb)) t' \ - tcbSchedDequeue t - \ \_. obj_at' (\tcb. P (tcbPriority tcb)) t' \" - apply (clarsimp simp: tcbSchedDequeue_def) - apply (wp hoare_when_weak_wp | simp)+ +lemma tcbSchedDequeue_valid_mdb'[wp]: + "\valid_mdb' and valid_objs'\ tcbSchedDequeue tcbPtr \\_. valid_mdb'\" + unfolding tcbSchedDequeue_def + apply (wpsimp simp: bitmap_fun_defs setQueue_def wp: threadSet_mdb' tcbQueueRemove_valid_mdb') + apply (rule_tac Q="\_. tcb_at' tcbPtr" in hoare_post_imp) + apply (fastforce simp: tcb_cte_cases_def cteSizeBits_def) + apply (wpsimp wp: threadGet_wp)+ + apply (fastforce simp: obj_at'_def) done lemma tcbSchedDequeue_invs'[wp]: - "\invs' and tcb_at' t\ - tcbSchedDequeue t - \\_. invs'\" - unfolding invs'_def valid_state'_def - apply (rule hoare_pre) - 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 - tcbSchedDequeue_valid_queues - untyped_ranges_zero_lift - | simp add: cteCaps_of_def o_def)+ - apply (fastforce elim: valid_objs'_maxDomain valid_objs'_maxPriority simp: valid_pspace'_def)+ + "tcbSchedDequeue t \invs'\" + 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: + "\(s, s') \ state_relation; pspace_aligned s; pspace_distinct s; valid_queues s\ + \ ready_qs_runnable s'" + supply projectKOs[simp] + apply (clarsimp simp: ready_qs_runnable_def) + apply normalise_obj_at' + apply (frule state_relation_ready_queues_relation) + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def + list_queue_relation_def) + apply (drule_tac x="tcbDomain ko" in spec) + apply (drule_tac x="tcbPriority ko" in spec) + apply (clarsimp simp: valid_queues_def) + apply (drule_tac x="tcbDomain ko" in spec) + apply (drule_tac x="tcbPriority ko" in spec) + apply clarsimp + apply (drule_tac x=t in bspec) + apply (fastforce simp: inQ_def in_opt_pred obj_at'_def opt_map_red) + apply (fastforce dest: st_tcb_at_runnable_cross simp: obj_at'_def st_tcb_at'_def) + done + +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_queues)?, (frule invs_psp_aligned)?, (frule invs_distinct)?, + fastforce dest: ready_qs_runnable_cross + +defs idleThreadNotQueued_def: + "idleThreadNotQueued s \ obj_at' (Not \ tcbQueued) (ksIdleThread s) s" + +lemma idle_thread_not_queued: + "\valid_idle s; valid_queues s; valid_etcbs s\ + \ \ (\d p. idle_thread s \ set (ready_queues s d p))" + apply (clarsimp simp: valid_queues_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply clarsimp + apply (drule_tac x="idle_thread s" in bspec) + apply fastforce + apply (clarsimp simp: valid_idle_def pred_tcb_at_def obj_at_def valid_etcbs_def) done +lemma valid_idle_tcb_at: + "valid_idle s \ tcb_at (idle_thread s) s" + by (clarsimp simp: valid_idle_def pred_tcb_at_def obj_at_def is_tcb_def) + lemma setCurThread_corres: - "corres dc \ \ (modify (cur_thread_update (\_. t))) (setCurThread t)" - apply (unfold setCurThread_def) + "corres dc (valid_idle and valid_queues and valid_etcbs and pspace_aligned and pspace_distinct) \ + (modify (cur_thread_update (\_. t))) (setCurThread t)" + supply projectKOs[simp] + 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 opt_pred_def opt_map_def) apply (rule corres_modify) apply (simp add: state_relation_def swp_def) done @@ -709,48 +815,64 @@ proof - by (rule lift_neg_pred_tcb_at' [OF ArchThreadDecls_H_ARM_HYP_H_switchToThread_typ_at' pos]) qed -crunches Arch.switchToThread - for valid_queues[wp]: Invariants_H.valid_queues - (wp: crunch_wps simp: crunch_simps ignore: clearExMonitor) +crunches storeWordUser, setVMRoot, asUser, storeWordUser, Arch.switchToThread + for ksQ[wp]: "\s. P (ksReadyQueues s p)" + and ksIdleThread[wp]: "\s. P (ksIdleThread s)" + and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_objs'[wp]: valid_objs' + (wp: crunch_wps threadSet_sched_pointers getObject_tcb_wp getASID_wp + simp: crunch_simps obj_at'_def) + +crunches arch_switch_to_thread, arch_switch_to_idle_thread + for pspace_aligned[wp]: pspace_aligned + and pspace_distinct[wp]: pspace_distinct + and ready_qs_distinct[wp]: ready_qs_distinct + and valid_idle_new[wp]: valid_idle + (wp: ready_qs_distinct_lift simp: crunch_simps) + +lemma valid_queues_in_correct_ready_q[elim!]: + "valid_queues s \ in_correct_ready_q s" + by (clarsimp simp: valid_queues_def in_correct_ready_q_def) + +lemma valid_queues_ready_qs_distinct[elim!]: + "valid_queues s \ ready_qs_distinct s" + by (clarsimp simp: valid_queues_def ready_qs_distinct_def) 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_vs_lookup and valid_global_objs and unique_table_refs o caps_of_state - and st_tcb_at runnable t and valid_etcbs and (\s. sym_refs (state_hyp_refs_of s))) - (valid_arch_state' and valid_pspace' and Invariants_H.valid_queues - and st_tcb_at' runnable' t and cur_tcb' and (\s. sym_refs (state_hyp_refs_of' s))) + and st_tcb_at runnable t and valid_etcbs and (\s. sym_refs (state_hyp_refs_of s)) + and valid_queues and valid_idle) + (valid_arch_state' and no_0_obj' and sym_heap_sched_pointers and valid_objs' + and (\s. sym_refs (state_hyp_refs_of' s))) (switch_to_thread t) (switchToThread t)" - (is "corres _ ?PA ?PH _ _") - -proof - - have mainpart: "corres dc (?PA) (?PH) - (do y \ arch_switch_to_thread t; - y \ (tcb_sched_action tcb_sched_dequeue t); - modify (cur_thread_update (\_. t)) - od) - (do y \ Arch.switchToThread t; - y \ tcbSchedDequeue t; - setCurThread 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) + apply add_ready_qs_runnable + apply (simp add: switch_to_thread_def Thread_H.switchToThread_def) + apply (rule corres_symb_exec_l[OF _ _ get_sp]; (solves wpsimp)?) + apply (rule corres_symb_exec_l[OF _ _ assert_sp]; (solves wpsimp)?) + 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_stateAssert_ignore) + apply (fastforce dest!: state_relation_ready_queues_relation intro: ksReadyQueues_asrt_cross) + apply (rule corres_stateAssert_add_assertion[rotated]) + apply fastforce apply (rule corres_guard_imp) apply (rule corres_split[OF arch_switchToThread_corres]) apply (rule corres_split[OF tcbSchedDequeue_corres setCurThread_corres]) - apply (wpsimp simp: tcb_at_is_etcb_at st_tcb_at_tcb_at)+ - done - - show ?thesis - apply - - apply (simp add: switch_to_thread_def Thread_H.switchToThread_def) - apply (rule corres_symb_exec_l [where Q = "\ s rv. (?PA and (=) rv) s", - OF corres_symb_exec_l [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 tcb_at_idle_thread_lift: assumes T: "\T' t. \typ_at T' t\ f \\rv. typ_at T' t\" @@ -803,16 +925,24 @@ lemma arch_switchToIdleThread_corres: done lemma switchToIdleThread_corres: - "corres dc invs invs_no_cicd' switch_to_idle_thread switchToIdleThread" + "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 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_trivial, rule corres_modify) - apply (simp add: state_relation_def cdt_relation_def) - apply (wp+, simp+) - apply (simp add: all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def valid_pspace'_def) + 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_psp_aligned invs_distinct + invs_valid_idle) + apply (simp add: all_invs_but_ct_idle_or_in_cur_domain'_def valid_pspace'_def) done lemma gq_sp: "\P\ getQueue d p \\rv. P and (\s. ksReadyQueues s (d, p) = rv)\" @@ -843,11 +973,9 @@ proof - 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 Invariants_H.valid_queues_def - sch_act_wf ct_in_state'_def state_refs_of'_def - ps_clear_def valid_irq_node'_def valid_queues'_def ct_not_inQ_ct - ct_idle_or_in_cur_domain'_def - bitmapQ_defs valid_queues_no_bitmap_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 @@ -861,101 +989,20 @@ lemma setCurThread_invs: by (rule hoare_pre, rule setCurThread_invs_no_cicd') (simp add: invs'_to_invs_no_cicd'_def) -lemma valid_queues_not_runnable_not_queued: - fixes s - assumes vq: "Invariants_H.valid_queues 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 - - with vq have "st_tcb_at' runnable' t s" - unfolding Invariants_H.valid_queues_def valid_queues_no_bitmap_def - apply - - apply clarsimp - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp simp add: st_tcb_at'_def) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE) - apply (clarsimp) - done - - with st show False - apply - - apply (drule(1) pred_tcb_at_conj') - apply (clarsimp) - done -qed - -(* - * The idle thread is not part of any ready queues. - *) -lemma idle'_not_tcbQueued': - assumes vq: "Invariants_H.valid_queues 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 vq' show ?thesis - by (rule valid_queues_not_runnable_not_queued) - qed - lemma setCurThread_invs_no_cicd'_idle_thread: - "\invs_no_cicd' and (\s. t = ksIdleThread s) \ 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 - have idle'_activatable': "\ s t. st_tcb_at' idle' t s \ st_tcb_at' activatable' t s" - apply (clarsimp simp: st_tcb_at'_def o_def obj_at'_def) + "\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 ct_not_inQ_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 st_tcb_at'_def + idleThreadNotQueued_def) done - show ?thesis - apply (simp add: setCurThread_def) - apply wp - apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def) - apply (frule (2) idle'_not_tcbQueued'[simplified o_def]) - apply (clarsimp simp add: ct_not_inQ_ct idle'_activatable' - 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_queues_no_bitmap_def valid_queues'_def - pred_tcb_at'_def - cong: option.case_cong) - apply (clarsimp simp: obj_at'_def projectKOs idle_tcb'_def) - done -qed lemma setCurThread_invs_idle_thread: "\invs' and (\s. t = ksIdleThread s) \ setCurThread t \\rv. invs'\" @@ -996,13 +1043,13 @@ lemma Arch_switchToThread_tcb_in_cur_domain'[wp]: done lemma tcbSchedDequeue_not_tcbQueued: - "\ tcb_at' t \ tcbSchedDequeue t \ \_. obj_at' (\x. \ tcbQueued x) t \" + "\\\ tcbSchedDequeue t \\_. obj_at' (\x. \ tcbQueued x) t\" apply (simp add: tcbSchedDequeue_def) apply (wp|clarsimp)+ apply (rule_tac Q="\queued. obj_at' (\x. tcbQueued x = queued) t" in hoare_post_imp) - apply (clarsimp simp: obj_at'_def) - apply (wp threadGet_obj_at') - apply (simp) + apply (clarsimp simp: obj_at'_def) + apply (wpsimp wp: threadGet_wp)+ + apply (clarsimp simp: obj_at'_def) done lemma asUser_obj_at[wp]: "\obj_at' (P \ tcbState) t\ @@ -1043,10 +1090,6 @@ crunch valid_irq_states'[wp]: asUser "valid_irq_states'" crunch valid_machine_state'[wp]: asUser "valid_machine_state'" (wp: crunch_wps simp: crunch_simps) -crunch valid_queues'[wp]: asUser "valid_queues'" -(wp: crunch_wps simp: crunch_simps) - - lemma asUser_valid_irq_node'[wp]: "\\s. valid_irq_node' (irq_node' s) s\ asUser t (setRegister f r) \\_ s. valid_irq_node' (irq_node' s) s\" @@ -1123,22 +1166,17 @@ lemma Arch_switchToThread_invs_no_cicd': lemma tcbSchedDequeue_invs_no_cicd'[wp]: - "\invs_no_cicd' and tcb_at' t\ - tcbSchedDequeue t - \\_. invs_no_cicd'\" - unfolding all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def + "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 - tcbSchedDequeue_valid_queues_weak untyped_ranges_zero_lift | simp add: cteCaps_of_def o_def)+ apply clarsimp - apply (fastforce simp: valid_pspace'_def valid_queues_def - elim: valid_objs'_maxDomain valid_objs'_maxPriority intro: obj_at'_conjI) done lemma switchToThread_invs_no_cicd': - "\invs_no_cicd' and st_tcb_at' runnable' t and tcb_in_cur_domain' t \ ThreadDecls_H.switchToThread t \\rv. invs' \" + "\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') @@ -1146,7 +1184,7 @@ lemma switchToThread_invs_no_cicd': done lemma switchToThread_invs[wp]: - "\invs' and st_tcb_at' runnable' t and tcb_in_cur_domain' t \ switchToThread t \\rv. invs' \" + "\invs' and tcb_in_cur_domain' t \ switchToThread t \\rv. invs' \" apply (simp add: Thread_H.switchToThread_def ) apply (wp threadSet_timeslice_invs setCurThread_invs Arch_switchToThread_invs dmo_invs' @@ -1239,61 +1277,6 @@ lemma tcb_at_typ_at': done -lemma invs'_not_runnable_not_queued: - fixes s - assumes inv: "invs' s" - and st: "st_tcb_at' (Not \ runnable') t s" - shows "obj_at' (Not \ tcbQueued) t s" - apply (insert assms) - apply (rule valid_queues_not_runnable_not_queued) - apply (clarsimp simp add: invs'_def valid_state'_def)+ - done - -lemma valid_queues_not_tcbQueued_not_ksQ: - fixes s - assumes vq: "Invariants_H.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" - unfolding Invariants_H.valid_queues_def valid_queues_no_bitmap_def - apply clarify - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE) - apply (simp) - done - 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 valid_state'_def) - apply (drule(1) valid_queues_not_tcbQueued_not_ksQ) - apply (clarsimp) - done - -lemma ct_not_ksQ: - "\ invs' s; ksSchedulerAction s = ResumeCurrentThread \ - \ \p. ksCurThread s \ set (ksReadyQueues s p)" - apply (clarsimp simp: invs'_def valid_state'_def ct_not_inQ_def) - apply (frule(1) valid_queues_not_tcbQueued_not_ksQ) - apply (fastforce) - done - lemma setThreadState_rct: "\\s. (runnable' st \ ksCurThread s \ t) \ ksSchedulerAction s = ResumeCurrentThread\ @@ -1366,21 +1349,24 @@ lemma bitmapQ_from_bitmap_lookup: done lemma lookupBitmapPriority_obj_at': - "\ksReadyQueuesL1Bitmap s (ksCurDomain s) \ 0; valid_queues_no_bitmap s; valid_bitmapQ s; - bitmapQ_no_L1_orphans s\ - \ obj_at' (inQ (ksCurDomain s) (lookupBitmapPriority (ksCurDomain s) s) and runnable' \ tcbState) - (hd (ksReadyQueues s (ksCurDomain s, lookupBitmapPriority (ksCurDomain s) s))) s" + "\ksReadyQueuesL1Bitmap s d \ 0; valid_bitmapQ s; bitmapQ_no_L1_orphans s; + ksReadyQueues_asrt s; ready_qs_runnable s; pspace_aligned' s; pspace_distinct' s\ + \ obj_at' (inQ d (lookupBitmapPriority d s) and runnable' \ tcbState) + (the (tcbQueueHead (ksReadyQueues s (d, lookupBitmapPriority d s)))) s" apply (drule (2) bitmapQ_from_bitmap_lookup) apply (simp add: valid_bitmapQ_bitmapQ_simp) - apply (case_tac "ksReadyQueues s (ksCurDomain s, lookupBitmapPriority (ksCurDomain s) s)", simp) - apply (clarsimp, rename_tac t ts) - apply (drule cons_set_intro) - apply (drule (2) valid_queues_no_bitmap_objD) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def tcbQueueEmpty_def) + apply (drule_tac x=d in spec) + apply (drule_tac x="lookupBitmapPriority d s" in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (fastforce simp: obj_at'_and ready_qs_runnable_def obj_at'_def st_tcb_at'_def inQ_def + tcbQueueEmpty_def) done lemma bitmapL1_zero_ksReadyQueues: "\ valid_bitmapQ s ; bitmapQ_no_L1_orphans s \ - \ (ksReadyQueuesL1Bitmap s d = 0) = (\p. ksReadyQueues s (d,p) = [])" + \ (ksReadyQueuesL1Bitmap s d = 0) = (\p. tcbQueueEmpty (ksReadyQueues s (d, p)))" apply (cases "ksReadyQueuesL1Bitmap s d = 0") apply (force simp add: bitmapQ_def valid_bitmapQ_def) apply (fastforce dest: bitmapQ_from_bitmap_lookup simp: valid_bitmapQ_bitmapQ_simp) @@ -1451,7 +1437,7 @@ lemma bitmapL1_highest_lookup: done lemma bitmapQ_ksReadyQueuesI: - "\ bitmapQ d p s ; valid_bitmapQ s \ \ ksReadyQueues s (d, p) \ []" + "\ bitmapQ d p s ; valid_bitmapQ s \ \ \ tcbQueueEmpty (ksReadyQueues s (d, p))" unfolding valid_bitmapQ_def by simp lemma getReadyQueuesL2Bitmap_inv[wp]: @@ -1460,24 +1446,22 @@ lemma getReadyQueuesL2Bitmap_inv[wp]: lemma switchToThread_lookupBitmapPriority_wp: "\\s. invs_no_cicd' s \ bitmapQ (ksCurDomain s) (lookupBitmapPriority (ksCurDomain s) s) s \ - t = hd (ksReadyQueues s (ksCurDomain s, lookupBitmapPriority (ksCurDomain 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 ; 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 elim: obj_at'_weaken simp: inQ_def tcb_in_cur_domain'_def st_tcb_at'_def) - done - thus ?thesis - by (wp switchToThread_invs_no_cicd') (fastforce dest: invs_no_cicd'_queues) -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_no_cicd': "\invs_no_cicd'\ switchToIdleThread \\rv. invs'\" @@ -1578,9 +1562,9 @@ lemma guarded_switch_to_corres: and valid_vspace_objs and pspace_aligned and pspace_distinct and valid_vs_lookup and unique_table_refs o caps_of_state - and st_tcb_at runnable t and valid_etcbs and (\s. sym_refs (state_hyp_refs_of s))) - (valid_arch_state' and valid_pspace' and Invariants_H.valid_queues - and st_tcb_at' runnable' t and cur_tcb' and (\s. sym_refs (state_hyp_refs_of' s))) + and st_tcb_at runnable t and valid_etcbs and valid_queues and valid_idle and (\s. sym_refs (state_hyp_refs_of s))) + (valid_arch_state' and valid_pspace' and sym_heap_sched_pointers + and (\s. sym_refs (state_hyp_refs_of' s))) (guarded_switch_to t) (switchToThread t)" apply (simp add: guarded_switch_to_def) apply (rule corres_guard_imp) @@ -1625,7 +1609,7 @@ lemma curDomain_corres: "corres (=) \ \ (gets cur_domain) (curDomain)" lemma curDomain_corres': "corres (=) \ (\s. ksCurDomain s \ maxDomain) - (gets cur_domain) (if 1 < numDomains then curDomain else return 0)" + (gets cur_domain) (if Suc 0 < numDomains then curDomain else return 0)" apply (case_tac "1 < numDomains"; simp) apply (rule corres_guard_imp[OF curDomain_corres]; solves simp) (* if we have only one domain, then we are in it *) @@ -1635,27 +1619,32 @@ lemma curDomain_corres': lemma lookupBitmapPriority_Max_eqI: "\ valid_bitmapQ s ; bitmapQ_no_L1_orphans s ; ksReadyQueuesL1Bitmap s d \ 0 \ - \ lookupBitmapPriority d s = (Max {prio. ksReadyQueues s (d, prio) \ []})" + \ lookupBitmapPriority d s = (Max {prio. \ tcbQueueEmpty (ksReadyQueues s (d, prio))})" apply (rule Max_eqI[simplified eq_commute]; simp) apply (fastforce simp: bitmapL1_highest_lookup valid_bitmapQ_bitmapQ_simp) apply (metis valid_bitmapQ_bitmapQ_simp bitmapQ_from_bitmap_lookup) done lemma corres_gets_queues_getReadyQueuesL1Bitmap: - "corres (\qs l1. ((l1 = 0) = (\p. qs p = []))) \ valid_queues + "corres (\qs l1. (l1 = 0) = (\p. qs p = [])) \ valid_bitmaps (gets (\s. ready_queues s d)) (getReadyQueuesL1Bitmap d)" - unfolding state_relation_def valid_queues_def getReadyQueuesL1Bitmap_def - by (clarsimp simp: bitmapL1_zero_ksReadyQueues ready_queues_relation_def) + unfolding state_relation_def valid_bitmaps_def getReadyQueuesL1Bitmap_def + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def) + apply (drule_tac x=d in spec) + apply (fastforce simp: bitmapL1_zero_ksReadyQueues list_queue_relation_def tcbQueueEmpty_def) + done lemma guarded_switch_to_chooseThread_fragment_corres: "corres dc (P and st_tcb_at runnable t and invs and valid_sched) - (P' and st_tcb_at' runnable' t and invs_no_cicd') - (guarded_switch_to t) - (do runnable \ isRunnable t; - y \ assert runnable; - ThreadDecls_H.switchToThread t - od)" + (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) @@ -1670,35 +1659,50 @@ lemma guarded_switch_to_chooseThread_fragment_corres: 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' + \ Max {prio. ready_queues s d prio \ []} + = Max {prio. \ tcbQueueEmpty (ksReadyQueues s' (d, prio))}" + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def + list_queue_relation_def tcbQueueEmpty_def) + apply (rule Max_eq_if) + apply fastforce + apply fastforce + apply (fastforce dest: heap_path_head) + apply clarsimp + apply (drule_tac x=d in spec) + apply (drule_tac x=b in spec) + apply force + done + lemma bitmap_lookup_queue_is_max_non_empty: - "\ valid_queues s'; (s, s') \ state_relation; invs s; + "\ 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 all_invs_but_ct_idle_or_in_cur_domain'_def 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 \ - \ 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 (simp add: valid_queues_no_bitmap_def) - apply (erule_tac x="ksCurDomain s" in allE) - apply (erule_tac x="lookupBitmapPriority (ksCurDomain s) s" in allE) - apply (clarsimp simp: st_tcb_at'_def) - apply (erule obj_at'_weaken) - apply simp - 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 \" @@ -1710,52 +1714,72 @@ lemma invs_no_cicd_ksCurDomain_maxDomain': "invs_no_cicd' s \ ksCurDomain s \ maxDomain" unfolding invs_no_cicd'_def by simp +crunches curDomain + for valid_bitmaps[wp]: valid_bitmaps + lemma chooseThread_corres: - "corres dc (invs and valid_sched) (invs_no_cicd') - choose_thread chooseThread" (is "corres _ ?PREI ?PREH _ _") + "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 - unfolding choose_thread_def chooseThread_def - 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 \ 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 dest!: invs_no_cicd'_queues simp: bitmap_lookup_queue_is_max_non_empty) - 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 (clarsimp simp: if_apply_def2) - apply (wp hoare_vcg_conj_lift hoare_vcg_imp_lift ksReadyQueuesL1Bitmap_return_wp) - apply (wpsimp wp: curDomain_or_return_0 simp: curDomain_def)+ - apply (fastforce simp: invs_no_cicd'_def) - apply (clarsimp simp: valid_sched_def DetSchedInvs_AI.valid_queues_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 (simp add: invs_no_cicd_ksCurDomain_maxDomain') - apply (clarsimp dest!: invs_no_cicd'_queues) - apply (fastforce intro: ksReadyQueuesL1Bitmap_st_tcb_at') - done + 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 (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 = @@ -1844,7 +1868,7 @@ lemma isHighestPrio_corres: assumes "d' = d" assumes "p' = p" shows - "corres ((=)) \ valid_queues + "corres ((=)) \ valid_bitmaps (gets (is_highest_prio d p)) (isHighestPrio d' p')" using assms @@ -1854,18 +1878,16 @@ lemma isHighestPrio_corres: apply (rule corres_split[OF corres_gets_queues_getReadyQueuesL1Bitmap]) apply (rule corres_if_r'[where P'="\_. True",rotated]) apply (rule_tac corres_symb_exec_r) - apply (rule_tac - P="\s. q = ready_queues s d - " and - P'="\s. valid_queues s \ - l1 = ksReadyQueuesL1Bitmap s d \ - l1 \ 0 \ hprio = lookupBitmapPriority d s" and - F="hprio = Max {prio. q prio \ []}" in corres_req) - apply (elim conjE) - apply (clarsimp simp: valid_queues_def) - apply (subst lookupBitmapPriority_Max_eqI; blast?) - apply (fastforce simp: ready_queues_relation_def dest!: state_relationD) - apply fastforce + apply (rule_tac P="\s. q = ready_queues s d" + and P'="\s. valid_bitmaps s \ l1 = ksReadyQueuesL1Bitmap s d \ + l1 \ 0 \ hprio = lookupBitmapPriority d s" + and F="hprio = Max {prio. q prio \ []}" in corres_req) + apply (elim conjE) + apply (clarsimp simp: valid_bitmaps_def) + apply (subst lookupBitmapPriority_Max_eqI; blast?) + apply (fastforce dest: state_relation_ready_queues_relation Max_prio_helper[where d=d] + simp: tcbQueueEmpty_def) + apply fastforce apply (wpsimp simp: if_apply_def2 wp: hoare_drop_imps ksReadyQueuesL1Bitmap_return_wp)+ done @@ -1877,9 +1899,8 @@ crunch inv[wp]: schedule_switch_thread_fastfail P crunch inv[wp]: scheduleSwitchThreadFastfail P lemma setSchedulerAction_invs': (* not in wp set, clobbered by ssa_wp *) - "\\s. invs' s \ setSchedulerAction ChooseNewThread \\_. invs' \" + "setSchedulerAction ChooseNewThread \invs' \" by (wpsimp simp: invs'_def cur_tcb'_def valid_state'_def valid_irq_node'_def ct_not_inQ_def - valid_queues_def valid_queues_no_bitmap_def valid_queues'_def ct_idle_or_in_cur_domain'_def) lemma scheduleChooseNewThread_corres: @@ -1915,6 +1936,46 @@ lemma tcb_sched_action_sym_refs_state_hyp_refs_of[wp]: "tcb_sched_action a b \\s. sym_refs (state_hyp_refs_of s)\" by (wpsimp simp: tcb_sched_action_def) +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 + +crunches 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) + +crunches 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] @@ -1942,7 +2003,7 @@ lemma schedule_corres: apply (rule corres_split[OF thread_get_isRunnable_corres]) apply (rule corres_split[OF corres_when]) apply simp - apply (rule tcbSchedEnqueue_corres) + 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)+ @@ -1951,7 +2012,7 @@ lemma schedule_corres: rename_tac was_running wasRunning) apply (rule corres_split[OF corres_when]) apply simp - apply (rule tcbSchedEnqueue_corres) + 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[OF ethreadget_corres[where r="(=)"]]) @@ -1965,7 +2026,7 @@ lemma schedule_corres: 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]) + apply (rule corres_split[OF tcbSchedEnqueue_corres], simp) apply (simp, fold dc_def) apply (rule corres_split[OF setSchedulerAction_corres]) apply simp @@ -1981,7 +2042,7 @@ lemma schedule_corres: apply (rule corres_if, fastforce) - apply (rule corres_split[OF tcbSchedAppend_corres]) + apply (rule corres_split[OF tcbSchedAppend_corres], simp) apply (simp, fold dc_def) apply (rule corres_split[OF setSchedulerAction_corres]) apply simp @@ -2013,7 +2074,8 @@ lemma schedule_corres: 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)+ + del: gets_wp + | strengthen valid_objs'_valid_tcbs' invs_valid_pspace')+ apply (clarsimp simp: conj_ac if_apply_def2 cong: imp_cong conj_cong del: hoare_gets) apply (wp gets_wp)+ @@ -2036,14 +2098,13 @@ lemma schedule_corres: 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 invs_hyp_sym_refs) - apply (clarsimp simp add: pred_tcb_at_def obj_at_def is_tcb valid_idle_def) + apply (fastforce simp: 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)+ - apply (simp add: valid_sched_def valid_blocked_def valid_blocked_except_def) done (* haskell final subgoal *) @@ -2061,11 +2122,8 @@ proof - apply (simp add: setSchedulerAction_def) apply wp apply (clarsimp simp add: invs'_def valid_state'_def cur_tcb'_def - Invariants_H.valid_queues_def - state_refs_of'_def ps_clear_def - valid_irq_node'_def valid_queues'_def - tcb_in_cur_domain'_def ct_idle_or_in_cur_domain'_def - bitmapQ_defs valid_queues_no_bitmap_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 @@ -2100,12 +2158,13 @@ lemma getDomainTime_wp[wp]: "\\s. P (ksDomainTime s) s \ by wp lemma switchToThread_ct_not_queued_2: - "\invs_no_cicd' and tcb_at' t\ switchToThread t \\rv s. obj_at' (Not \ tcbQueued) (ksCurThread s) s\" - (is "\_\ _ \\_. ?POST\") + "\invs_no_cicd' and tcb_at' t\ + switchToThread t + \\_ s. obj_at' (Not \ tcbQueued) (ksCurThread s) s\" apply (simp add: Thread_H.switchToThread_def) apply (wp) apply (simp add: ARM_HYP_H.switchToThread_def setCurThread_def) - apply (wp tcbSchedDequeue_not_tcbQueued | simp )+ + apply (wp tcbSchedDequeue_not_tcbQueued hoare_drop_imp | simp)+ done lemma setCurThread_obj_at': @@ -2119,11 +2178,12 @@ proof - qed lemma switchToIdleThread_ct_not_queued_no_cicd': - "\ invs_no_cicd' \ switchToIdleThread \\rv s. obj_at' (Not \ tcbQueued) (ksCurThread s) s \" + "\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 (rule idle'_not_tcbQueued') - apply (simp add: invs_no_cicd'_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]: @@ -2140,7 +2200,7 @@ lemma switchToThread_tcb_in_cur_domain': ThreadDecls_H.switchToThread thread \\y s. tcb_in_cur_domain' (ksCurThread s) s\" apply (simp add: Thread_H.switchToThread_def setCurThread_def) - apply (wpsimp wp: tcbSchedDequeue_not_tcbQueued) + apply (wpsimp wp: tcbSchedDequeue_not_tcbQueued hoare_drop_imps) done lemma chooseThread_invs_no_cicd'_posts: (* generic version *) @@ -2162,11 +2222,14 @@ proof - by (simp add: all_invs_but_ct_idle_or_in_cur_domain'_def maxDomain_def) show ?thesis - unfolding chooseThread_def Let_def curDomain_def + apply (clarsimp simp: chooseThread_def Let_def curDomain_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp])+ apply (simp only: return_bind, simp) - apply (rule hoare_seq_ext[where B="\rv s. invs_no_cicd' s \ rv = ksCurDomain s"]) + apply (rule hoare_seq_ext[where B="\rv s. invs_no_cicd' s \ rv = ksCurDomain s + \ ksReadyQueues_asrt s \ ready_qs_runnable s"]) apply (rule_tac B="\rv s. invs_no_cicd' s \ curdom = ksCurDomain s \ - rv = ksReadyQueuesL1Bitmap s curdom" in hoare_seq_ext) + rv = ksReadyQueuesL1Bitmap s curdom \ + ksReadyQueues_asrt s \ ready_qs_runnable s" in hoare_seq_ext) apply (rename_tac l1) apply (case_tac "l1 = 0") (* switch to idle thread *) @@ -2180,12 +2243,10 @@ proof - 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 - apply (clarsimp dest!: invs_no_cicd'_queues - simp: valid_queues_def lookupBitmapPriority_def[symmetric]) - 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 (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 @@ -2224,11 +2285,14 @@ proof - (* FIXME this is almost identical to the chooseThread_invs_no_cicd'_posts proof, can generalise? *) show ?thesis - unfolding chooseThread_def Let_def curDomain_def + apply (clarsimp simp: chooseThread_def Let_def curDomain_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp])+ apply (simp only: return_bind, simp) - apply (rule hoare_seq_ext[where B="\rv s. invs_no_cicd' s \ rv = ksCurDomain s"]) + apply (rule hoare_seq_ext[where B="\rv s. invs_no_cicd' s \ rv = ksCurDomain s + \ ksReadyQueues_asrt s \ ready_qs_runnable s"]) apply (rule_tac B="\rv s. invs_no_cicd' s \ curdom = ksCurDomain s \ - rv = ksReadyQueuesL1Bitmap s curdom" in hoare_seq_ext) + rv = ksReadyQueuesL1Bitmap s curdom \ + ksReadyQueues_asrt s \ ready_qs_runnable s" in hoare_seq_ext) apply (rename_tac l1) apply (case_tac "l1 = 0") (* switch to idle thread *) @@ -2236,7 +2300,10 @@ proof - (* we have a thread to switch to *) apply (clarsimp simp: bitmap_fun_defs) apply (wp assert_inv) - apply (clarsimp dest!: invs_no_cicd'_queues simp: valid_queues_def) + 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 @@ -2385,12 +2452,20 @@ lemma sbn_sch_act_sane: done lemma possibleSwitchTo_corres: - "corres dc (valid_etcbs and weak_valid_sched_action and cur_tcb and st_tcb_at runnable t) - (Invariants_H.valid_queues and valid_queues' and - (\s. weak_sch_act_wf (ksSchedulerAction s) s) and cur_tcb' and tcb_at' t and st_tcb_at' runnable' t and valid_objs') - (possible_switch_to t) - (possibleSwitchTo t)" + "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 (rule corres_split[OF curDomain_corres], simp) @@ -2399,21 +2474,21 @@ lemma possibleSwitchTo_corres: apply (clarsimp simp: etcb_relation_def) apply (rule corres_split[OF getSchedulerAction_corres]) apply (rule corres_if, simp) - apply (rule tcbSchedEnqueue_corres) + 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) - apply (wp rescheduleRequired_valid_queues'_weak)+ + 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 (fastforce simp: valid_sched_def invs_def valid_state_def cur_tcb_def + 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 (simp add: tcb_at_is_etcb_at) + apply (fastforce simp: tcb_at_is_etcb_at) done end diff --git a/proof/refine/ARM_HYP/StateRelation.thy b/proof/refine/ARM_HYP/StateRelation.thy index 0587b987ed..458995c779 100644 --- a/proof/refine/ARM_HYP/StateRelation.thy +++ b/proof/refine/ARM_HYP/StateRelation.thy @@ -20,6 +20,10 @@ where lemmas cte_map_def' = cte_map_def[simplified cte_level_bits_def, simplified] +lemma cte_map_def2: + "cte_map \ \(oref, cref). oref + (of_bl cref << cte_level_bits)" + by (simp add: cte_map_def word_shift_by_n) + definition lookup_failure_map :: "ExceptionTypes_A.lookup_failure \ Fault_H.lookup_failure" where @@ -212,13 +216,20 @@ where \ tcb_bound_notification tcb = tcbBoundNotification tcb' \ tcb_mcpriority tcb = tcbMCP tcb'" +\ \ + A pair of objects @{term "(obj, obj')"} should satisfy the following relation when, under further + mild assumptions, a @{term corres_underlying} lemma for @{term "set_object obj"} + and @{term "setObject obj'"} can be stated: see setObject_other_corres in KHeap_R. + + TCBs do not satisfy this relation because the tcbSchedPrev and tcbSchedNext fields of a TCB are + used to model the ready queues, and so an update to such a field would correspond to an update + to a ready queue (see ready_queues_relation below).\ definition other_obj_relation :: "Structures_A.kernel_object \ Structures_H.kernel_object \ bool" where "other_obj_relation obj obj' \ (case (obj, obj') of - (TCB tcb, KOTCB tcb') \ tcb_relation tcb tcb' - | (Endpoint ep, KOEndpoint ep') \ ep_relation ep ep' + (Endpoint ep, KOEndpoint ep') \ ep_relation ep ep' | (Notification ntfn, KONotification ntfn') \ ntfn_relation ntfn ntfn' | (ArchObj (ARM_A.ASIDPool pool), KOArch (KOASIDPool pool')) \ asid_pool_relation pool pool' @@ -301,6 +312,12 @@ where | "aobj_relation_cuts (ARM_A.VCPU v) x = {(x, other_obj_relation)}" +definition tcb_relation_cut :: "Structures_A.kernel_object \ kernel_object \ bool" where + "tcb_relation_cut obj obj' \ + case (obj, obj') of + (TCB t, KOTCB t') \ tcb_relation t t' + | _ \ False" + primrec obj_relation_cuts :: "Structures_A.kernel_object \ word32 \ obj_relation_cuts" where @@ -308,7 +325,7 @@ where (if well_formed_cnode_n sz cs then {(cte_map (x, y), cte_relation y) | y. y \ dom cs} else {(x, \\)})" -| "obj_relation_cuts (TCB tcb) x = {(x, other_obj_relation)}" +| "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 (ArchObj ao) x = aobj_relation_cuts ao x" @@ -319,6 +336,7 @@ 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, \\)} + | TCB tcb \ {(x, tcb_relation_cut)} | ArchObj (PageTable pt) \ (\y. (x + (ucast y << pte_bits), pte_relation y)) ` (UNIV :: (9 word) set) | ArchObj (PageDirectory pd) \ (\y. (x + (ucast y << pde_bits), pde_relation y)) @@ -333,6 +351,7 @@ lemma obj_relation_cuts_def3: "obj_relation_cuts ko x = (case (a_type ko) of ACapTable n \ {(cte_map (x, y), cte_relation y) | y. length y = n} + | ATCB \ {(x, tcb_relation_cut)} | AArch APageTable \ (\y. (x + (ucast y << pte_bits), pte_relation y)) ` (UNIV :: (9 word) set) | AArch APageDirectory \ (\y. (x + (ucast y << pde_bits), pde_relation y)) @@ -351,6 +370,7 @@ definition "is_other_obj_relation_type tp \ case tp of ACapTable n \ False + | ATCB \ False | AArch APageTable \ False | AArch APageDirectory \ False | AArch (AUserData _) \ False @@ -362,6 +382,10 @@ 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_TCB: + "\ is_other_obj_relation_type ATCB" + by (simp add: is_other_obj_relation_type_def) + lemma is_other_obj_relation_type_UserData: "\ is_other_obj_relation_type (AArch (AUserData sz))" unfolding is_other_obj_relation_type_def by simp @@ -409,11 +433,55 @@ where "sched_act_relation choose_new_thread a' = (a' = ChooseNewThread)" | "sched_act_relation (switch_thread x) a' = (a' = SwitchToThread x)" -definition - ready_queues_relation :: "(Deterministic_A.domain \ Structures_A.priority \ Deterministic_A.ready_queue) - \ (domain \ priority \ KernelStateData_H.ready_queue) \ bool" -where - "ready_queues_relation qs qs' \ \d p. (qs d p = qs' (d, p))" +definition queue_end_valid :: "obj_ref list \ tcb_queue \ bool" where + "queue_end_valid ts q \ + (ts = [] \ tcbQueueEnd q = None) \ (ts \ [] \ tcbQueueEnd q = Some (last ts))" + +definition prev_queue_head :: "tcb_queue \ (obj_ref \ 'a) \ bool" where + "prev_queue_head q prevs \ \head. tcbQueueHead q = Some head \ prevs head = None" + +lemma prev_queue_head_heap_upd: + "\prev_queue_head q prevs; Some r \ tcbQueueHead q\ \ prev_queue_head q (prevs(r := x))" + by (clarsimp simp: prev_queue_head_def) + +definition list_queue_relation :: + "obj_ref list \ tcb_queue \ (obj_ref \ obj_ref) \ (obj_ref \ obj_ref) \ bool" + where + "list_queue_relation ts q nexts prevs \ + heap_ls nexts (tcbQueueHead q) ts \ queue_end_valid ts q \ prev_queue_head q prevs" + +lemma list_queue_relation_nil: + "list_queue_relation ts q nexts prevs \ ts = [] \ tcbQueueEmpty q" + by (fastforce dest: heap_path_head simp: tcbQueueEmpty_def list_queue_relation_def) + +definition ready_queue_relation :: + "Deterministic_A.domain \ Structures_A.priority + \ Deterministic_A.ready_queue \ ready_queue + \ (obj_ref \ obj_ref) \ (obj_ref \ obj_ref) + \ (obj_ref \ bool) \ bool" + where + "ready_queue_relation d p q q' nexts prevs flag \ + list_queue_relation q q' nexts prevs + \ (\t. flag t \ t \ set q) + \ (d > maxDomain \ p > maxPriority \ tcbQueueEmpty q')" + +definition ready_queues_relation_2 :: + "(Deterministic_A.domain \ Structures_A.priority \ Deterministic_A.ready_queue) + \ (domain \ priority \ ready_queue) + \ (obj_ref \ obj_ref) \ (obj_ref \ obj_ref) + \ (domain \ priority \ obj_ref \ bool) \ bool" + where + "ready_queues_relation_2 qs qs' nexts prevs inQs \ + \d p. let q = qs d p; q' = qs' (d, p); flag = inQs d p in + ready_queue_relation d p q q' nexts prevs flag" + +abbreviation ready_queues_relation :: "det_state \ kernel_state \ bool" where + "ready_queues_relation s s' \ + ready_queues_relation_2 + (ready_queues s) (ksReadyQueues s') (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + (\d p. inQ d p |< tcbs_of' s')" + +lemmas ready_queues_relation_def = ready_queues_relation_2_def definition ghost_relation :: "Structures_A.kheap \ (word32 \ vmpage_size) \ (word32 \ nat) \ bool" @@ -488,6 +556,8 @@ lemma obj_relation_cutsE: \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; + \tcb tcb'. \ y = x; ko = TCB tcb; ko' = KOTCB tcb'; tcb_relation tcb tcb' \ + \ R; \pt (z :: 9 word) pte'. \ ko = ArchObj (PageTable pt); y = x + (ucast z << pte_bits); ko' = KOArch (KOPTE pte'); pte_relation_aligned z (pt z) pte' \ \ R; @@ -498,13 +568,10 @@ lemma obj_relation_cutsE: y = x + n * 2 ^ pageBits; n < 2 ^ (pageBitsForSize sz - pageBits) \ \ R; \ y = x; other_obj_relation ko ko'; is_other_obj_relation_type (a_type ko) \ \ R \ \ R" - apply (simp add: obj_relation_cuts_def2 is_other_obj_relation_type_def - a_type_def - split: Structures_A.kernel_object.split_asm if_split_asm - ARM_A.arch_kernel_obj.split_asm) - apply ((clarsimp split: if_splits, - force simp: cte_relation_def pte_relation_def pde_relation_def)+)[5] - done + by (force simp: obj_relation_cuts_def2 is_other_obj_relation_type_def a_type_def + cte_relation_def pte_relation_def pde_relation_def tcb_relation_cut_def + split: Structures_A.kernel_object.splits kernel_object.splits if_splits + ARM_A.arch_kernel_obj.splits) lemma eq_trans_helper: "\ x = y; P y = Q \ \ P x = Q" @@ -580,7 +647,7 @@ where pspace_relation (kheap s) (ksPSpace s') \ ekheap_relation (ekheap s) (ksPSpace s') \ sched_act_relation (scheduler_action s) (ksSchedulerAction s') - \ ready_queues_relation (ready_queues s) (ksReadyQueues s') + \ ready_queues_relation s 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') @@ -602,6 +669,10 @@ lemma curthread_relation: "(a, b) \ state_relation \ ksCurThread b = cur_thread a" by (simp add: state_relation_def) +lemma curdomain_relation[elim!]: + "(s, s') \ state_relation \ cur_domain s = ksCurDomain s'" + by (clarsimp simp: state_relation_def) + lemma state_relation_pspace_relation[elim!]: "(s,s') \ state_relation \ pspace_relation (kheap s) (ksPSpace s')" by (simp add: state_relation_def) @@ -610,12 +681,24 @@ 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')" + by (clarsimp simp: state_relation_def) + +lemma state_relation_ready_queues_relation[elim!]: + "(s, s') \ state_relation \ ready_queues_relation s s'" + by (simp add: state_relation_def) + +lemma state_relation_idle_thread[elim!]: + "(s, s') \ state_relation \ idle_thread s = ksIdleThread s'" + by (clarsimp simp: state_relation_def) + lemma state_relationD: assumes sr: "(s, s') \ state_relation" shows "pspace_relation (kheap s) (ksPSpace s') \ ekheap_relation (ekheap s) (ksPSpace s') \ sched_act_relation (scheduler_action s) (ksSchedulerAction s') \ - ready_queues_relation (ready_queues s) (ksReadyQueues s') \ + ready_queues_relation s 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') \ @@ -637,7 +720,7 @@ lemma state_relationE [elim?]: and rl: "\pspace_relation (kheap s) (ksPSpace s'); ekheap_relation (ekheap s) (ksPSpace s'); sched_act_relation (scheduler_action s) (ksSchedulerAction s'); - ready_queues_relation (ready_queues s) (ksReadyQueues s'); + ready_queues_relation s 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'); diff --git a/proof/refine/ARM_HYP/Syscall_R.thy b/proof/refine/ARM_HYP/Syscall_R.thy index d9cdbe89ee..d915fe2193 100644 --- a/proof/refine/ARM_HYP/Syscall_R.thy +++ b/proof/refine/ARM_HYP/Syscall_R.thy @@ -351,16 +351,14 @@ lemma threadSet_tcbDomain_update_sch_act_wf[wp]: lemma setDomain_corres: "corres dc - (valid_etcbs and valid_sched and tcb_at tptr) - (invs' and sch_act_simple - and tcb_at' tptr and (\s. 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 corres_guard_imp) apply (rule corres_split[OF getCurThread_corres]) - apply (rule corres_split[OF tcbSchedDequeue_corres]) + apply (rule corres_split[OF tcbSchedDequeue_corres], simp) apply (rule corres_split) apply (rule ethread_set_corres; simp) apply (clarsimp simp: etcb_relation_def) @@ -369,26 +367,38 @@ lemma setDomain_corres: apply (rule corres_split) apply clarsimp apply (rule corres_when[OF refl]) - apply (rule tcbSchedEnqueue_corres) + apply (rule tcbSchedEnqueue_corres, simp) apply (rule corres_when[OF refl]) apply (rule rescheduleRequired_corres) - apply ((wp hoare_drop_imps hoare_vcg_conj_lift | clarsimp| assumption)+)[5] - apply clarsimp - apply (rule_tac Q="\_. valid_objs' and valid_queues' and valid_queues and - (\s. sch_act_wf (ksSchedulerAction s) s) and tcb_at' tptr" - in hoare_strengthen_post[rotated]) - apply (auto simp: invs'_def valid_state'_def sch_act_wf_weak st_tcb_at'_def o_def)[1] - apply (wp threadSet_valid_objs' threadSet_valid_queues'_no_state - threadSet_valid_queues_no_state - threadSet_pred_tcb_no_state | simp)+ - apply (rule_tac Q = "\r s. invs' s \ (\p. tptr \ set (ksReadyQueues s p)) \ 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) - apply (drule(1) bspec) - apply (clarsimp simp:tcb_cte_cases_def) + 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 Tcb_R.tcbSchedDequeue_not_in_queue)+ + apply (wp hoare_vcg_all_lift tcbSchedDequeue_not_queued)+ apply clarsimp apply (frule tcb_at_is_etcb_at) apply simp+ @@ -457,7 +467,7 @@ lemma performInvocation_corres: apply (rule corres_split[OF setDomain_corres]) apply (rule corres_trivial, simp) apply (wp)+ - apply (clarsimp+)[2] + apply ((clarsimp simp: invs_psp_aligned invs_distinct)+)[2] \ \CNodes\ apply clarsimp apply (rule corres_guard_imp) @@ -770,90 +780,71 @@ 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 - \\rv. invs'\" + doReplyTransfer t' t slot grant + \\_. invs'\" apply (simp add: doReplyTransfer_def liftM_def) apply (rule hoare_seq_ext [OF _ gts_sp']) apply (rule hoare_seq_ext [OF _ assert_sp]) apply (rule hoare_seq_ext [OF _ getCTE_sp]) apply (wp, wpc) - apply (wp) + apply wp apply (wp (once) sts_invs_minor'') - apply (simp) + apply simp apply (wp (once) sts_st_tcb') - apply (wp)[1] - apply (rule_tac Q="\rv s. invs' s - \ t \ ksIdleThread s - \ st_tcb_at' awaiting_reply' t s" + 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 (frule_tac t=t in invs'_not_runnable_not_queued) - apply (erule pred_tcb'_weakenE, case_tac st, clarsimp+) + apply clarsimp apply (rule conjI, erule pred_tcb'_weakenE, case_tac st, clarsimp+) - apply (rule conjI, rule impI, erule pred_tcb'_weakenE, case_tac st) - apply (clarsimp | drule(1) obj_at_conj')+ 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 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 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]) + 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 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="\rv s. invs' s \ sch_act_simple s - \ st_tcb_at' awaiting_reply' t s - \ t \ ksIdleThread s" - in hoare_post_imp) - apply (clarsimp) - apply (frule_tac t=t in invs'_not_runnable_not_queued) - apply (erule pred_tcb'_weakenE, case_tac st, clarsimp+) + 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 (rule conjI, rule impI, erule pred_tcb'_weakenE, case_tac st) - apply (clarsimp | drule(1) obj_at_conj')+ 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 clarsimp apply (erule_tac P="\st. awaiting_reply' st \ activatable' st" - in pred_tcb'_weakenE) + 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 clarsimp apply (rule conjI) - apply (clarsimp simp: invs'_def valid_state'_def valid_idle'_def) - apply (rule conjI) - apply clarsimp - apply (clarsimp simp: obj_at'_def idle_tcb'_def pred_tcb_at'_def) + 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 (rule conjI) apply (clarsimp simp : invs'_def valid_state'_def valid_idle'_def pred_tcb_at'_def obj_at'_def idle_tcb'_def) - apply (rule conjI) - apply clarsimp - apply (frule invs'_not_runnable_not_queued) - apply (erule pred_tcb'_weakenE, clarsimp) - apply (frule (1) not_tcbQueued_not_ksQ) - apply simp - apply clarsimp 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) @@ -863,35 +854,9 @@ lemma ct_active_runnable' [simp]: "ct_active' s \ ct_in_state' runnable' s" by (fastforce simp: ct_in_state'_def elim!: pred_tcb'_weakenE) -lemma valid_irq_node_tcbSchedEnqueue[wp]: - "\\s. valid_irq_node' (irq_node' s) s \ tcbSchedEnqueue ptr - \\rv s'. valid_irq_node' (irq_node' s') s'\" - apply (rule hoare_pre) - apply (simp add:valid_irq_node'_def ) - apply (wp unless_wp hoare_vcg_all_lift | wps)+ - apply (simp add:tcbSchedEnqueue_def) - apply (wp unless_wp| simp)+ - apply (simp add:valid_irq_node'_def) - done - -lemma rescheduleRequired_valid_queues_but_ct_domain: - "\\s. Invariants_H.valid_queues s \ valid_objs' s - \ (\x. ksSchedulerAction s = SwitchToThread x \ st_tcb_at' runnable' x s) \ - rescheduleRequired - \\_. Invariants_H.valid_queues\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp)+ - done - -lemma rescheduleRequired_valid_queues'_but_ct_domain: - "\\s. valid_queues' s - \ (\x. ksSchedulerAction s = SwitchToThread x \ st_tcb_at' runnable' x s) - \ - rescheduleRequired - \\_. valid_queues'\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp | fastforce simp: valid_queues'_def)+ - done +crunches tcbSchedEnqueue + for valid_irq_node[wp]: "\s. valid_irq_node' (irq_node' s) s" + (rule: valid_irq_node_lift) lemma tcbSchedEnqueue_valid_action: "\\s. \x. ksSchedulerAction s = SwitchToThread x \ st_tcb_at' runnable' x s\ @@ -902,10 +867,11 @@ lemma tcbSchedEnqueue_valid_action: done abbreviation (input) "all_invs_but_sch_extra \ - \s. valid_pspace' s \ Invariants_H.valid_queues s \ + \s. valid_pspace' s \ sym_refs (state_refs_of' s) \ sym_refs (state_hyp_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 \ @@ -917,7 +883,6 @@ abbreviation (input) "all_invs_but_sch_extra \ valid_machine_state' s \ cur_tcb' s \ untyped_ranges_zero' s \ - valid_queues' 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)" @@ -930,15 +895,13 @@ lemma rescheduleRequired_all_invs_but_extra: apply (rule hoare_pre) apply (wp add:rescheduleRequired_ct_not_inQ rescheduleRequired_sch_act' - rescheduleRequired_valid_queues_but_ct_domain - rescheduleRequired_valid_queues'_but_ct_domain valid_irq_node_lift valid_irq_handlers_lift'' irqs_masked_lift cur_tcb_lift) apply auto done lemma threadSet_all_invs_but_sch_extra: - shows "\ tcb_at' t and (\s. (\p. t \ set (ksReadyQueues s p))) and + shows "\ tcb_at' t and all_invs_but_sch_extra and sch_act_simple and K (ds \ maxDomain) \ threadSet (tcbDomain_update (\_. ds)) t @@ -959,13 +922,11 @@ lemma threadSet_all_invs_but_sch_extra: valid_irq_handlers_lift'' threadSet_ctes_ofT threadSet_not_inQ - threadSet_valid_queues'_no_state threadSet_tcbDomain_update_ct_idle_or_in_cur_domain' - threadSet_valid_queues threadSet_valid_dom_schedule' threadSet_iflive'T threadSet_ifunsafe'T - untyped_ranges_zero_lift + untyped_ranges_zero_lift threadSet_sched_pointers threadSet_valid_sched_pointers | simp add:tcb_cte_cases_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) @@ -993,9 +954,7 @@ lemma setDomain_invs': \ (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 (erule st_tcb_ex_cap'') apply simp - apply (case_tac st,simp_all)[1] apply (rule hoare_strengthen_post[OF hoare_vcg_conj_lift]) apply (rule threadSet_all_invs_but_sch_extra) prefer 2 @@ -1013,17 +972,14 @@ lemma setDomain_invs': done lemma performInv_invs'[wp]: - "\invs' and sch_act_simple - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p)) - and ct_active' and valid_invocation' i\ - RetypeDecls_H.performInvocation block call i \\rv. invs'\" + "\invs' and sch_act_simple and ct_active' and valid_invocation' i\ + RetypeDecls_H.performInvocation block call i + \\_. invs'\" unfolding performInvocation_def apply (cases i) - apply ((clarsimp simp: simple_sane_strg sch_act_simple_def - ct_not_ksQ sch_act_sane_def - | wp tcbinv_invs' arch_performInvocation_invs' - setDomain_invs' - | rule conjI | erule active_ex_cap')+) + 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]: @@ -1211,14 +1167,17 @@ crunch valid_duplicates'[wp]: addToBitmap "\s. vs_valid_duplicates' (ksP lemma tcbSchedEnqueue_valid_duplicates'[wp]: "\\s. vs_valid_duplicates' (ksPSpace s)\ tcbSchedEnqueue a \\rv s. vs_valid_duplicates' (ksPSpace s)\" - by (simp add: tcbSchedEnqueue_def unless_def setQueue_def | wp | wpc)+ + by (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_def setQueue_def | wp | wpc)+ crunch valid_duplicates'[wp]: rescheduleRequired "\s. vs_valid_duplicates' (ksPSpace s)" (wp: setObject_ksInterrupt updateObject_default_inv) crunch valid_duplicates'[wp]: setThreadState "\s. vs_valid_duplicates' (ksPSpace s)" -(*FIXME: move to Nondet_VCG.valid_validE_R *) +crunches reply_from_kernel + for pspace_aligned[wp]: pspace_aligned + and pspace_distinct[wp]: pspace_distinct + lemma handleInvocation_corres: "c \ b \ corres (dc \ dc) @@ -1265,13 +1224,9 @@ lemma handleInvocation_corres: apply simp apply (simp add: when_def) apply (rule conjI, rule impI) - apply (rule reply_from_kernel_tcb_at) + apply (wp reply_from_kernel_tcb_at) apply (rule impI, wp+) - apply simp+ - apply (wp hoare_drop_imps)+ - apply simp - apply wp - apply simp + 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" @@ -1287,7 +1242,6 @@ lemma handleInvocation_corres: and (\s. vs_valid_duplicates' (ksPSpace s))" in hoare_post_imp) apply (clarsimp simp: ct_in_state'_def) - apply (frule(1) ct_not_ksQ) apply (clarsimp) apply (wp setThreadState_nonqueued_state_update setThreadState_st_tcb setThreadState_rct)[1] @@ -1297,7 +1251,8 @@ lemma handleInvocation_corres: | rule hoare_vcg_E_elim)+ apply (clarsimp simp: tcb_at_invs invs_valid_objs valid_tcb_state_def ct_in_state_def - simple_from_active invs_mdb) + simple_from_active invs_mdb + invs_distinct invs_psp_aligned) apply (clarsimp simp: msg_max_length_def word_bits_def) apply (erule st_tcb_ex_cap, clarsimp+) apply fastforce @@ -1305,7 +1260,6 @@ lemma handleInvocation_corres: apply (frule tcb_at_invs') apply (clarsimp simp: invs'_def valid_state'_def ct_in_state'_def ct_not_inQ_def) - apply (frule(1) valid_queues_not_tcbQueued_not_ksQ) 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) @@ -1361,10 +1315,7 @@ lemma hinv_invs'[wp]: apply wp+ apply (wp sts_invs_minor' setThreadState_st_tcb setThreadState_rct ct_in_state_thread_state_lift' sts_st_tcb_at'_cases - | clarsimp - | strengthen ct_not_ksQ[rule_format] - )+ - apply (frule(1) ct_not_ksQ) + | clarsimp)+ apply (simp add: conj_comms) apply (fastforce simp add: tcb_at_invs' ct_in_state'_def simple_sane_strg @@ -1513,7 +1464,6 @@ lemma handleRecv_isBlocking_corres': and (\s. ex_nonz_cap_to (cur_thread s) s)) (invs' and ct_in_state' simple' and sch_act_sane - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p)) and (\s. ex_nonz_cap_to' (ksCurThread s) s)) (handle_recv isBlocking) (handleRecv isBlocking)" (is "corres dc (?pre1) (?pre2) (handle_recv _) (handleRecv _)") @@ -1576,8 +1526,7 @@ lemma handleRecv_isBlocking_corres': lemma handleRecv_isBlocking_corres: "corres dc (einvs and ct_active) - (invs' and ct_active' and sch_act_sane and - (\s. \p. ksCurThread s \ set (ksReadyQueues s p))) + (invs' and ct_active' and sch_act_sane) (handle_recv isBlocking) (handleRecv isBlocking)" apply (rule corres_guard_imp) apply (rule handleRecv_isBlocking_corres') @@ -1592,42 +1541,27 @@ lemma lookupCap_refs[wp]: "\invs'\ lookupCap t ref \\rv s. \r\zobj_refs' rv. ex_nonz_cap_to' r s\,-" by (simp add: lookupCap_def split_def | wp | simp add: o_def)+ -lemma deleteCallerCap_ksQ_ct': - "\invs' and ct_in_state' simple' and sch_act_sane and - (\s. ksCurThread s \ set (ksReadyQueues s p) \ thread = ksCurThread s)\ - deleteCallerCap thread - \\rv s. thread \ set (ksReadyQueues s p)\" - apply (rule_tac Q="\rv s. thread = ksCurThread s \ ksCurThread s \ set (ksReadyQueues s p)" - in hoare_strengthen_post) - apply (wp deleteCallerCap_ct_not_ksQ) - apply auto - done - lemma hw_invs'[wp]: "\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) - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p))\ + 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 - deleteCallerCap_ksQ_ct' hoare_lift_Pf2[OF deleteCallerCap_simple deleteCallerCap_ct'] | wpc | simp)+)[1] apply simp apply (wp deleteCallerCap_nonz_cap hoare_vcg_all_lift - deleteCallerCap_ksQ_ct' 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 - \ (\p. ksCurThread s \ set (ksReadyQueues s p)) \ thread = ksCurThread s \ ct_in_state' simple' s \ ex_nonz_cap_to' thread s @@ -1651,34 +1585,45 @@ lemma setSchedulerAction_obj_at'[wp]: by (wp, clarsimp elim!: obj_at'_pspaceI) lemma handleYield_corres: - "corres dc einvs (invs' and ct_active' and (\s. ksSchedulerAction s = ResumeCurrentThread)) handle_yield handleYield" + "corres dc + (einvs and ct_active) + (invs' and (\s. ksSchedulerAction s = ResumeCurrentThread)) + handle_yield handleYield" apply (clarsimp simp: handle_yield_def handleYield_def) apply (rule corres_guard_imp) apply (rule corres_split[OF getCurThread_corres]) apply simp - apply (rule corres_split[OF tcbSchedDequeue_corres]) - apply (rule corres_split[OF tcbSchedAppend_corres]) + apply (rule corres_split[OF tcbSchedDequeue_corres], simp) + apply (rule corres_split[OF tcbSchedAppend_corres], simp) apply (rule rescheduleRequired_corres) - apply (wp weak_sch_act_wf_lift_linear tcbSchedDequeue_valid_queues | simp add: )+ - apply (simp add: invs_def valid_sched_def valid_sched_action_def - cur_tcb_def tcb_at_is_etcb_at) - apply clarsimp - apply (frule ct_active_runnable') - apply (clarsimp simp: invs'_def valid_state'_def ct_in_state'_def sch_act_wf_weak cur_tcb'_def + 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) - apply (erule(1) valid_objs_valid_tcbE[OF valid_pspace_valid_objs']) - apply (simp add:valid_tcb'_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 hy_invs': "\invs' and ct_active'\ handleYield \\r. invs' and ct_active'\" apply (simp add: handleYield_def) - apply (wp ct_in_state_thread_state_lift' - rescheduleRequired_all_invs_but_ct_not_inQ - tcbSchedAppend_invs_but_ct_not_inQ' | simp)+ - apply (clarsimp simp add: 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 - ) + 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 @@ -1866,7 +1811,7 @@ 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 haskell_assert_wp doReplyTransfer_sane getCTE_wp'| wpc)+ + apply (wp doReplyTransfer_sane getCTE_wp'| wpc)+ apply (clarsimp simp: cte_wp_at_ctes_of) done @@ -1882,74 +1827,6 @@ lemma handleReply_nonz_cap_to_ct: crunch ksQ[wp]: handleFaultReply "\s. P (ksReadyQueues s p)" -lemma doReplyTransfer_ct_not_ksQ: - "\ invs' and sch_act_simple - and tcb_at' thread and tcb_at' word - and ct_in_state' simple' - and (\s. ksCurThread s \ word) - and (\s. \p. ksCurThread s \ set(ksReadyQueues s p))\ - doReplyTransfer thread word callerSlot g - \\rv s. \p. ksCurThread s \ set(ksReadyQueues s p)\" -proof - - have astct: "\t p. - \(\s. ksCurThread s \ set(ksReadyQueues s p) \ sch_act_sane s) - and (\s. ksCurThread s \ t)\ - possibleSwitchTo t \\rv s. ksCurThread s \ set(ksReadyQueues s p)\" - apply (rule hoare_weaken_pre) - apply (wps possibleSwitchTo_ct') - apply (wp possibleSwitchTo_ksQ') - apply (clarsimp simp: sch_act_sane_def) - done - have stsct: "\t st p. - \(\s. ksCurThread s \ set(ksReadyQueues s p)) and sch_act_simple\ - setThreadState st t - \\rv s. ksCurThread s \ set(ksReadyQueues s p)\" - apply (rule hoare_weaken_pre) - apply (wps setThreadState_ct') - apply (wp hoare_vcg_all_lift sts_ksQ) - apply (clarsimp) - done - show ?thesis - apply (simp add: doReplyTransfer_def) - apply (wp, wpc) - apply (wp astct stsct hoare_vcg_all_lift - cteDeleteOne_ct_not_ksQ hoare_drop_imp - hoare_lift_Pf2 [OF cteDeleteOne_sch_act_not cteDeleteOne_ct'] - hoare_lift_Pf2 [OF doIPCTransfer_pred_tcb_at' doIPCTransfer_ct'] - hoare_lift_Pf2 [OF doIPCTransfer_ksQ doIPCTransfer_ct'] - hoare_lift_Pf2 [OF threadSet_ksQ threadSet_ct] - hoare_lift_Pf2 [OF handleFaultReply_ksQ handleFaultReply_ct'] - | simp add: ct_in_state'_def)+ - apply (fastforce simp: sch_act_simple_def sch_act_sane_def ct_in_state'_def)+ - done -qed - -lemma handleReply_ct_not_ksQ: - "\invs' and sch_act_simple - and ct_in_state' simple' - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p))\ - handleReply - \\rv s. \p. ksCurThread s \ set (ksReadyQueues s p)\" - apply (simp add: handleReply_def del: split_paired_All) - apply (subst haskell_assert_def) - apply (wp | wpc)+ - apply (wp doReplyTransfer_ct_not_ksQ getThreadCallerSlot_inv)+ - apply (rule_tac Q="\cap. - (\s. \p. ksCurThread s \ set(ksReadyQueues s p)) - and invs' - and sch_act_simple - and (\s. thread = ksCurThread s) - and tcb_at' thread - and ct_in_state' simple' - and cte_wp_at' (\c. cteCap c = cap) callerSlot" - in hoare_post_imp) - apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def - cte_wp_at_ctes_of valid_cap'_def - dest!: ctes_of_valid') - apply (wp getSlotCap_cte_wp_at getThreadCallerSlot_inv)+ - apply (clarsimp) - done - crunch valid_etcbs[wp]: possible_switch_to "valid_etcbs" crunch valid_etcbs[wp]: handle_recv "valid_etcbs" (wp: crunch_wps simp: crunch_simps) @@ -1963,18 +1840,16 @@ lemma handleReply_handleRecv_corres: 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 handleReply_ct_not_ksQ handle_reply_valid_sched)+ + 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 (frule(1) ct_not_ksQ) 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) (invs' and sch_act_not thread - and (\s. \p. thread \ set(ksReadyQueues s p)) and st_tcb_at' simple' thread and ex_nonz_cap_to' thread) (handle_hypervisor_fault thread fault) (handleHypervisorFault thread fault)" @@ -2000,12 +1875,11 @@ lemma hvmf_invs_lift: doMachineOp_bind getRestartPC_def getRegister_def) lemma hvmf_invs_etc: - "\invs' and sch_act_not t and (\s. \p. t \ set (ksReadyQueues s p)) and st_tcb_at' simple' t and + "\invs' and sch_act_not t and st_tcb_at' simple' t and ex_nonz_cap_to' t\ handleVMFault t f \\_ _. True\, - \\_. invs' and sch_act_not t and (\s. \p. t \ set (ksReadyQueues s p)) and - st_tcb_at' simple' t and ex_nonz_cap_to' t\" + \\_. invs' and sch_act_not t and st_tcb_at' simple' t and ex_nonz_cap_to' t\" apply (rule hvmf_invs_lift) apply (clarsimp simp: invs'_def valid_state'_def valid_machine_state'_def) done @@ -2020,14 +1894,13 @@ lemma handleEvent_corres: (is "?handleEvent_corres") proof - have hw: - "\isBlocking. corres dc (einvs and ct_running and (\s. scheduler_action s = resume_cur_thread)) + "\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 - dest!: ct_not_ksQ)+ + elim!: st_tcb_weakenE pred_tcb'_weakenE)+ done show ?thesis apply (case_tac event) @@ -2053,7 +1926,6 @@ proof - simp: ct_in_state_def) apply wp apply (clarsimp) - apply (frule(1) ct_not_ksQ) apply (auto simp: ct_in_state'_def sch_act_simple_def sch_act_sane_def elim: pred_tcb'_weakenE st_tcb_ex_cap'')[1] @@ -2066,7 +1938,6 @@ proof - simp: ct_in_state_def valid_fault_def) apply wp apply clarsimp - apply (frule(1) ct_not_ksQ) apply (auto simp: ct_in_state'_def sch_act_simple_def sch_act_sane_def elim: pred_tcb'_weakenE st_tcb_ex_cap'')[1] @@ -2082,11 +1953,7 @@ proof - doMachineOp_getActiveIRQ_IRQ_active' | simp | simp add: imp_conjR | wp (once) hoare_drop_imps)+ - apply (clarsimp simp: invs'_def valid_state'_def ct_not_inQ_def valid_queues_def - valid_queues_no_bitmap_def) - apply (erule allE)+ - apply (erule conjE, drule (1) bspec) - apply (clarsimp simp: obj_at'_def inQ_def) + apply (clarsimp simp: invs'_def valid_state'_def ct_not_inQ_def valid_queues_def) apply (rule_tac corres_underlying_split) apply (rule corres_guard_imp, rule getCurThread_corres, simp+) apply (rule corres_split_catch) @@ -2099,7 +1966,6 @@ proof - apply (fastforce elim!: st_tcb_ex_cap st_tcb_weakenE simp: ct_in_state_def) apply wp apply (clarsimp) - apply (frule(1) ct_not_ksQ) 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) @@ -2110,7 +1976,6 @@ proof - simp: ct_in_state_def) apply wp apply (clarsimp) - apply (frule(1) ct_not_ksQ) apply (auto simp: ct_in_state'_def sch_act_simple_def sch_act_sane_def elim: pred_tcb'_weakenE st_tcb_ex_cap'')[1] @@ -2136,9 +2001,10 @@ lemma hv_stuff'[wp]: by (wpsimp wp: getDFSR_inv getHSR_inv getHDFAR_inv getRestartPC_inv det_getRestartPC asUser_inv) lemma hh_invs'[wp]: - "\invs' and sch_act_not p and (\s. \a b. p \ set (ksReadyQueues s (a, b))) and - st_tcb_at' simple' p and ex_nonz_cap_to' p and (\s. p \ ksIdleThread s)\ - handleHypervisorFault p t \\_. invs'\" + "\invs' and sch_act_not p and st_tcb_at' simple' p and ex_nonz_cap_to' p + and (\s. p \ ksIdleThread s)\ + handleHypervisorFault p t + \\_. invs'\" apply (simp add: ARM_HYP_H.handleHypervisorFault_def) apply (cases t; wpsimp) done @@ -2204,10 +2070,8 @@ proof - apply (rename_tac syscall) apply (case_tac syscall, (wp handleReply_sane handleReply_nonz_cap_to_ct handleReply_ksCurThread - handleReply_ct_not_ksQ | clarsimp simp: active_from_running' simple_from_running' simple_sane_strg simp del: split_paired_All | rule conjI active_ex_cap' - | drule ct_not_ksQ[rotated] | strengthen nidle)+) apply (rule hoare_strengthen_post, rule hoare_weaken_pre, @@ -2220,7 +2084,6 @@ proof - | 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' - | drule ct_not_ksQ[rotated] | wpc | wp (once) hoare_drop_imps hoare_vcg_all_lift)+ done qed diff --git a/proof/refine/ARM_HYP/TcbAcc_R.thy b/proof/refine/ARM_HYP/TcbAcc_R.thy index b0cc124095..35f8262257 100644 --- a/proof/refine/ARM_HYP/TcbAcc_R.thy +++ b/proof/refine/ARM_HYP/TcbAcc_R.thy @@ -58,10 +58,8 @@ lemma getHighestPrio_inv[wp]: unfolding bitmap_fun_defs by simp lemma valid_bitmapQ_bitmapQ_simp: - "\ valid_bitmapQ s \ \ - bitmapQ d p s = (ksReadyQueues s (d, p) \ [])" - unfolding valid_bitmapQ_def - by simp + "valid_bitmapQ s \ bitmapQ d p s = (\ tcbQueueEmpty (ksReadyQueues s (d, p)))" + by (simp add: valid_bitmapQ_def) lemma prioToL1Index_l1IndexToPrio_or_id: "\ unat (w'::priority) < 2 ^ wordRadix ; w < size w' \ @@ -84,20 +82,6 @@ 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 and runnable' \ tcbState) t s) - \ distinct (ksReadyQueues s (d, p)) - \ (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 - lemma st_tcb_at_coerce_abstract: assumes t: "st_tcb_at' P t c" assumes sr: "(a, c) \ state_relation" @@ -107,11 +91,10 @@ lemma st_tcb_at_coerce_abstract: projectKOs objBits_simps) 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 - ARM_A.arch_kernel_obj.split_asm)+ - apply fastforce + apply (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 + ARM_A.arch_kernel_obj.split_asm)+ done lemma st_tcb_at_runnable_coerce_concrete: @@ -128,24 +111,130 @@ lemma st_tcb_at_runnable_coerce_concrete: apply (case_tac "tcb_state tcb"; simp) 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" +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) done -lemma valid_objs'_maxDomain: - "\s t. \ valid_objs' s; tcb_at' t s \ \ obj_at' (\tcb. tcbDomain tcb \ maxDomain) t s" - apply (erule (1) valid_objs_valid_tcbE) - apply (clarsimp simp: valid_tcb'_def) +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 + 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 objBits_simps') + done + +definition valid_tcbs' :: "kernel_state \ bool" where + "valid_tcbs' s' \ \ptr tcb. ksPSpace s' ptr = Some (KOTCB tcb) \ valid_tcb' tcb s'" + +lemma valid_objs'_valid_tcbs'[elim!]: + "valid_objs' s \ valid_tcbs' s" + by (auto simp: valid_objs'_def valid_tcbs'_def valid_obj'_def split: kernel_object.splits) + +lemma invs'_valid_tcbs'[elim!]: + "invs' s \ valid_tcbs' s" + by (fastforce intro: valid_objs'_valid_tcbs') + +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 valid_tcb'_def projectKOs) done -lemma valid_objs'_maxPriority: - "\s t. \ valid_objs' s; tcb_at' t s \ \ obj_at' (\tcb. tcbPriority tcb \ maxPriority) t s" - apply (erule (1) valid_objs_valid_tcbE) - apply (clarsimp simp: valid_tcb'_def) +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 valid_tcb'_def projectKOs) done +lemmas valid_objs'_maxPriority = valid_tcbs'_maxPriority[OF valid_objs'_valid_tcbs'] + +lemma valid_tcbs'_obj_at': + assumes "valid_tcbs' 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" + using assms + 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 (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" + "\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 + opt_tcb_at'_def valid_arch_tcb'_def + split: option.splits thread_state.splits) + +lemma update_valid_tcbs'[simp]: + "\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': assumes masks: "\P. \\s. P (irq_masks s)\ f \\_ s. P (irq_masks s)\" shows "\valid_irq_states'\ doMachineOp f \\rv. valid_irq_states'\" @@ -243,56 +332,117 @@ lemma updateObject_tcb_inv: by simp (rule updateObject_default_inv) lemma setObject_update_TCB_corres': - assumes tcbs: "tcb_relation tcb tcb' \ tcb_relation tcbu tcbu'" - assumes tables: "\(getF, v) \ ran tcb_cap_cases. getF tcbu = getF tcb" - assumes tables': "\(getF, v) \ ran tcb_cte_cases. getF tcbu' = getF tcb'" + 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" + assumes tables': "\(getF, v) \ ran tcb_cte_cases. getF new_tcb' = getF tcb'" + assumes sched_pointers: "tcbSchedPrev new_tcb' = tcbSchedPrev tcb'" + "tcbSchedNext new_tcb' = tcbSchedNext tcb'" + assumes flag: "tcbQueued new_tcb' = tcbQueued tcb'" assumes r: "r () ()" - assumes exst: "exst_same tcb' tcbu'" - 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' \ exst_same tcb' tcbu'" 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 exst) - 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: projectKOs tcb_relation_cut_def exst) + 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 project_inject 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 () (); exst_same tcb' tcbu'\ - \ 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 fastforce - apply (clarsimp simp: getObject_def in_monad split_def obj_at'_def - loadObject_default_def projectKOs objBits_simps' - in_magnitude_check) + apply (erule (7) setObject_update_TCB_corres') + apply (clarsimp simp: getObject_def in_monad split_def obj_at'_def + loadObject_default_def objBits_simps' in_magnitude_check projectKOs)+ done lemma getObject_TCB_corres: - "corres tcb_relation (tcb_at t) (tcb_at' t) + "corres tcb_relation (tcb_at t and pspace_aligned and pspace_distinct) \ (gets_the (get_tcb t)) (getObject t)" + 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 (rule corres_gets_the) apply (rule corres_get_tcb) @@ -302,7 +452,8 @@ 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)" + 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 @@ -324,7 +475,8 @@ lemma ball_tcb_cte_casesI: 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. P (Thread a b c d e f g h i j k l m n p q) \ \ \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: @@ -333,18 +485,24 @@ 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" + 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) - (tcb_at' t) - (thread_set f t) (threadSet f' t)" + 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 (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+ @@ -374,9 +532,12 @@ lemma threadSet_corres_noopT: tcb_relation tcb (fn tcb')" assumes y: "\tcb. \(getF, setF) \ ran tcb_cte_cases. getF (fn tcb) = getF tcb" + 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) - (return v) (threadSet fn t)" + 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) @@ -392,16 +553,15 @@ proof - defer apply (subst bind_return [symmetric], rule corres_underlying_split [OF threadset_corresT]) - apply (simp add: x) - apply simp - apply (rule y) + 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 wpsimp+ - apply (erule pspace_relation_tcb_at[rotated]) - apply clarsimp - apply simp - apply simp done qed @@ -415,14 +575,20 @@ 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'\" + 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 P (tcb_at' t and P') + 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)+ @@ -659,7 +825,12 @@ lemma threadSet_valid_pspace'T_P: assumes v: "\tcb. (P \ Q' (tcbBoundNotification tcb)) \ (\s. valid_bound_ntfn' (tcbBoundNotification tcb) s \ valid_bound_ntfn' (tcbBoundNotification (F tcb)) s)" - + assumes p: "\tcb. (P \ Q'' (tcbSchedPrev tcb)) \ + (\s. opt_tcb_at' (tcbSchedPrev tcb) s + \ opt_tcb_at' (tcbSchedPrev (F tcb)) s)" + assumes n: "\tcb. (P \ Q''' (tcbSchedNext tcb)) \ + (\s. opt_tcb_at' (tcbSchedNext tcb) s + \ opt_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" @@ -667,9 +838,11 @@ lemma threadSet_valid_pspace'T_P: assumes w': "\tcb. tcbMCP tcb \ maxPriority \ tcbMCP (F tcb) \ maxPriority" assumes v': "\tcb s. valid_arch_tcb' (tcbArch tcb) s \ valid_arch_tcb' (tcbArch (F tcb)) s" shows - "\valid_pspace' and (\s. P \ st_tcb_at' Q t s \ bound_tcb_at' Q' t s)\ - threadSet F t - \\rv. valid_pspace'\" + "\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 + \\_. valid_pspace'\" apply (simp add: valid_pspace'_def threadSet_def) apply (rule hoare_pre, wp setObject_tcb_valid_objs getObject_tcb_wp) @@ -677,7 +850,7 @@ lemma threadSet_valid_pspace'T_P: 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 v w' v') + split_paired_Ball y u w v w' v' p n) done lemmas threadSet_valid_pspace'T = @@ -761,6 +934,10 @@ lemma threadSet_iflive'T: \ tcbState (F tcb) \ Inactive \ tcbState (F tcb) \ IdleThreadState \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) + \ ((\tcb. tcbSchedNext tcb = None \ tcbSchedNext (F tcb) \ None + \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) + \ ((\tcb. tcbSchedPrev tcb = None \ tcbSchedPrev (F tcb) \ None + \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) \ ((\tcb. \ tcbQueued tcb \ tcbQueued (F tcb) \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) \((\tcb. \ bound (atcbVCPUPtr (tcbArch tcb)) \ bound (atcbVCPUPtr (tcbArch (F tcb))) @@ -816,6 +993,12 @@ lemmas threadSet_ctes_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) + \ 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 objBits_simps') + lemma threadSet_idle'T: assumes x: "\tcb. \(getF, setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" shows @@ -854,30 +1037,6 @@ lemma set_tcb_bitmapQ_no_L2_orphans[wp]: apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp add: bitmapQ_def)+ done -lemma threadSet_valid_queues_no_bitmap: - "\ valid_queues_no_bitmap and - (\s. \d p. (\tcb. (inQ d p tcb \ runnable' (tcbState tcb)) \ - \(inQ d p (f tcb) \ runnable' (tcbState (f tcb)))) - \ obj_at' (\tcb. (inQ d p tcb \ runnable' (tcbState tcb)) \ - \(inQ d p (f tcb) \ runnable' (tcbState (f tcb)))) t s - \ t \ set (ksReadyQueues s (d, p)) - )\ - threadSet f t - \\rv. valid_queues_no_bitmap \" - apply (simp add: threadSet_def) - apply wp - apply (simp add: Invariants_H.valid_queues_no_bitmap_def' pred_tcb_at'_def) - - apply (wp setObject_queues_unchanged_tcb - hoare_Ball_helper - hoare_vcg_all_lift - setObject_tcb_strongest)[1] - apply (wp getObject_tcb_wp) - apply (clarsimp simp: valid_queues_no_bitmap_def' pred_tcb_at'_def) - apply (clarsimp simp: obj_at'_def projectKOs) - apply (fastforce) - done - lemma threadSet_valid_bitmapQ[wp]: "\ valid_bitmapQ \ threadSet f t \ \rv. valid_bitmapQ \" unfolding bitmapQ_defs threadSet_def @@ -896,73 +1055,6 @@ lemma threadSet_valid_bitmapQ_no_L2_orphans[wp]: by (clarsimp simp: setObject_def split_def) (wp | simp add: updateObject_default_def)+ -lemma threadSet_valid_queues: - "\Invariants_H.valid_queues and - (\s. \d p. (\tcb. (inQ d p tcb \ runnable' (tcbState tcb)) \ - \(inQ d p (f tcb) \ runnable' (tcbState (f tcb)))) - \ obj_at' (\tcb. (inQ d p tcb \ runnable' (tcbState tcb)) \ - \(inQ d p (f tcb) \ runnable' (tcbState (f tcb)))) t s - \ t \ set (ksReadyQueues s (d, p)) - )\ - threadSet f t - \\rv. Invariants_H.valid_queues\" - unfolding valid_queues_def - by (wp threadSet_valid_queues_no_bitmap;simp) - -definition - addToQs :: "(Structures_H.tcb \ Structures_H.tcb) - \ word32 \ (domain \ priority \ word32 list) - \ (domain \ priority \ word32 list)" -where - "addToQs F t \ \qs (qdom, prio). if (\ko. \ inQ qdom prio (F ko)) - then t # qs (qdom, prio) - else qs (qdom, prio)" - -lemma addToQs_set_def: - "(t' \ set (addToQs F t qs (qdom, prio))) = (t' \ set (qs (qdom, prio)) - \ (t' = t \ (\ko. \ inQ qdom prio (F ko))))" - by (auto simp add: addToQs_def) - -lemma threadSet_valid_queues_addToQs: - "\\s. (\ko qdom prio. ko_at' ko t s \ inQ qdom prio (F ko) \ \ inQ qdom prio ko - \ t \ set (ksReadyQueues s (qdom, prio))) - \ valid_queues' (ksReadyQueues_update (addToQs F t) s)\ - threadSet F t - \\rv. 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_set_def - split del: if_split cong: if_cong) - apply (fastforce simp: projectKOs split: if_split_asm) - done - -lemma threadSet_valid_queues_Qf: - "\\s. (\ko qdom prio. ko_at' ko t s \ inQ qdom prio (F ko) \ \ inQ qdom prio ko - \ t \ set (ksReadyQueues s (qdom, prio))) - \ valid_queues' (ksReadyQueues_update Qf s) - \ (\prio. set (Qf (ksReadyQueues s) prio) - \ set (addToQs F t (ksReadyQueues s) prio))\ - threadSet F t - \\rv. valid_queues'\" - apply (wp threadSet_valid_queues_addToQs) - apply (clarsimp simp: valid_queues'_def subset_iff) - done - -lemma addToQs_subset: - "set (qs p) \ set (addToQs F t qs p)" -by (clarsimp simp: addToQs_def split_def) - -lemmas threadSet_valid_queues' - = threadSet_valid_queues_Qf - [where Qf=id, simplified ksReadyQueues_update_id - id_apply addToQs_subset simp_thms] - lemma threadSet_cur: "\\s. cur_tcb' s\ threadSet f t \\rv s. cur_tcb' s\" apply (simp add: threadSet_def cur_tcb'_def) @@ -978,7 +1070,7 @@ lemma modifyReadyQueuesL1Bitmap_obj_at[wp]: crunches setThreadState, setBoundNotification for valid_arch' [wp]: valid_arch_state' - (simp: unless_def crunch_simps) + (simp: unless_def crunch_simps wp: crunch_wps) crunch ksInterrupt'[wp]: threadSet "\s. P (ksInterruptState s)" (wp: setObject_ksInterrupt updateObject_default_inv) @@ -1240,60 +1332,103 @@ lemma threadSet_valid_dom_schedule': unfolding threadSet_def by (wp setObject_ksDomSchedule_inv hoare_Ball_helper) -lemma threadSet_invs_trivialT: - assumes x: "\tcb. \(getF,setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" - assumes z: "\tcb. tcbState (F tcb) = tcbState tcb \ tcbDomain (F tcb) = tcbDomain tcb" - assumes w: "\tcb. is_aligned (tcbIPCBuffer tcb) msg_align_bits \ is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits" - assumes a: "\tcb. tcbBoundNotification (F tcb) = tcbBoundNotification tcb" - assumes w: "\tcb. is_aligned (tcbIPCBuffer tcb) msg_align_bits \ is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits" - 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 r: "\tcb. atcbVCPUPtr (tcbArch (F tcb)) = atcbVCPUPtr (tcbArch tcb)" - shows - "\\s. invs' s \ - 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. \ tcbQueued tcb \ tcbQueued (F tcb)) \ ex_nonz_cap_to' t s \ t \ ksCurThread s) \ - (\tcb. tcbQueued (F tcb) \ ksSchedulerAction s = ResumeCurrentThread \ tcbQueued tcb \ t \ ksCurThread s)\ - threadSet F t - \\rv. invs'\" -proof - - from z have domains: "\tcb. tcbDomain (F tcb) = tcbDomain tcb" by blast - note threadSet_sch_actT_P[where P=False, simplified] - have y: "\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 valid_state'_def split del: if_split) - apply (rule hoare_pre) - apply (wp x w v u b - threadSet_valid_pspace'T - threadSet_sch_actT_P[where P=False, simplified] - threadSet_valid_queues - threadSet_state_refs_of'T[where f'=id] - threadSet_state_hyp_refs_of' - 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_cur - untyped_ranges_zero_lift - |clarsimp simp: y z a r domains cteCaps_of_def valid_arch_tcb'_def|rule refl)+ - apply (clarsimp simp: obj_at'_def projectKOs pred_tcb_at'_def) - apply (clarsimp simp: cur_tcb'_def valid_irq_node'_def valid_queues'_def o_def) - apply (fastforce simp: domains ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def z a) +lemma threadSet_wp: + "\\s. \tcb. ko_at' tcb t s \ P (s\ksPSpace := (ksPSpace s)(t \ injectKO (f tcb))\)\ + threadSet f t + \\_. P\" + unfolding threadSet_def setObject_def + apply (wpsimp wp: getObject_tcb_wp simp: updateObject_default_def) + apply (auto simp: obj_at'_def split: if_splits) + apply (erule rsubst[where P=P]) + apply (clarsimp simp: fun_upd_def) + apply (prop_tac "\ptr. psMap (ksPSpace s) ptr = ksPSpace s ptr") + apply fastforce + apply metis + done + +lemma threadSet_sched_pointers: + "\\tcb. tcbSchedNext (F tcb) = tcbSchedNext tcb; \tcb. tcbSchedPrev (F tcb) = tcbSchedPrev tcb\ + \ threadSet F tcbPtr \\s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + apply (fastforce simp: opt_map_def obj_at'_def projectKOs elim: rsubst2[where P=P]) done -qed + +lemma threadSet_valid_sched_pointers: + "\\tcb. tcbSchedNext (F tcb) = tcbSchedNext tcb; \tcb. tcbSchedPrev (F tcb) = tcbSchedPrev tcb; + \tcb. tcbQueued (F tcb) = tcbQueued tcb\ + \ threadSet F tcbPtr \valid_sched_pointers\" + unfolding valid_sched_pointers_def + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + by (fastforce simp: opt_pred_def opt_map_def obj_at'_def projectKOs split: option.splits if_splits) + +lemma threadSet_tcbSchedNexts_of: + "(\tcb. tcbSchedNext (F tcb) = tcbSchedNext tcb) \ + threadSet F t \\s. P (tcbSchedNexts_of s)\" + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + apply (erule rsubst[where P=P]) + apply (fastforce simp: opt_map_def obj_at'_def projectKOs) + done + +lemma threadSet_tcbSchedPrevs_of: + "(\tcb. tcbSchedPrev (F tcb) = tcbSchedPrev tcb) \ + threadSet F t \\s. P (tcbSchedPrevs_of s)\" + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + apply (erule rsubst[where P=P]) + apply (fastforce simp: opt_map_def obj_at'_def projectKOs) + done + +lemma threadSet_tcbQueued: + "(\tcb. tcbQueued (F tcb) = tcbQueued tcb) \ + threadSet F t \\s. P (tcbQueued |< tcbs_of' s)\" + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + apply (erule rsubst[where P=P]) + apply (fastforce simp: opt_pred_def opt_map_def obj_at'_def projectKOs) + done + +crunches threadSet + for ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" + and ksReadyQueuesL1Bitmap[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" + and ksReadyQueuesL2Bitmap[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" + +lemma threadSet_invs_trivialT: + assumes + "\tcb. \(getF,setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" + "\tcb. tcbState (F tcb) = tcbState tcb" + "\tcb. is_aligned (tcbIPCBuffer tcb) msg_align_bits + \ is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits" + "\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. tcbMCP tcb \ maxPriority \ tcbMCP (F tcb) \ maxPriority" + "\tcb. atcbVCPUPtr (tcbArch (F tcb)) = atcbVCPUPtr (tcbArch tcb)" + shows "threadSet F t \invs'\" + apply (simp add: invs'_def valid_state'_def split del: if_split) + apply (wp threadSet_valid_pspace'T + threadSet_sch_actT_P[where P=False, simplified] + threadSet_state_refs_of'T[where f'=id] + threadSet_state_hyp_refs_of' + 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_cur + untyped_ranges_zero_lift + sym_heap_sched_pointers_lift threadSet_valid_sched_pointers + threadSet_tcbQueued + threadSet_tcbSchedPrevs_of threadSet_tcbSchedNexts_of valid_bitmaps_lift + | clarsimp simp: assms cteCaps_of_def valid_arch_tcb'_def | rule refl)+ + apply (clarsimp simp: o_def) + by (auto simp: assms obj_at'_def) lemmas threadSet_invs_trivial = threadSet_invs_trivialT [OF all_tcbI all_tcbI all_tcbI all_tcbI, OF ball_tcb_cte_casesI] @@ -1338,11 +1473,74 @@ lemma threadSet_valid_objs': apply (clarsimp elim!: obj_at'_weakenE) done +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'] + +lemma setObject_valid_tcbs': + assumes preserve_valid_tcb': "\s s' ko ko' x n tcb tcb'. + \ (ko', s') \ fst (updateObject val ko ptr x n s); P s; + lookupAround2 ptr (ksPSpace s) = (Some (x, ko), n); + projectKO_opt ko = Some tcb; projectKO_opt ko' = Some tcb'; + valid_tcb' tcb s \ \ valid_tcb' tcb' s" + shows "\valid_tcbs' and P\ setObject ptr val \\rv. valid_tcbs'\" + unfolding valid_tcbs'_def + apply (clarsimp simp: valid_def) + apply (rename_tac s s' ptr' tcb) + apply (prop_tac "\tcb'. valid_tcb' tcb s \ valid_tcb' tcb s'") + apply clarsimp + apply (erule (1) use_valid[OF _ setObject_valid_tcb']) + apply (drule spec, erule mp) + apply (clarsimp simp: setObject_def in_monad split_def lookupAround2_char1) + apply (rename_tac s ptr' new_tcb' ptr'' old_tcb_ko' s' f) + apply (case_tac "ptr'' = ptr'"; clarsimp) + apply (prop_tac "\old_tcb' :: tcb. projectKO_opt old_tcb_ko' = Some old_tcb'") + apply (frule updateObject_type) + apply (case_tac old_tcb_ko'; clarsimp simp: project_inject) + apply (erule exE) + apply (rule preserve_valid_tcb', assumption+) + apply (simp add: prod_eqI lookupAround2_char1) + apply force + apply (clarsimp simp: project_inject) + apply (clarsimp simp: project_inject) + done + +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 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 + \\_. valid_tcb' tcb\" + apply (simp add: threadSet_def) + apply (wpsimp wp: setObject_valid_tcb') + done + +lemma threadSet_valid_tcbs': + "\valid_tcbs' and (\s. \tcb. valid_tcb' tcb s \ valid_tcb' (f tcb) s)\ + threadSet f t + \\_. valid_tcbs'\" + apply (simp add: threadSet_def) + apply (rule hoare_seq_ext[OF _ getObject_tcb_sp]) + apply (wpsimp wp: setObject_tcb_valid_tcbs') + apply (clarsimp simp: obj_at'_def projectKOs valid_tcbs'_def) + 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 valid_arch_tcb'_def tcb_cte_cases_def objBits_simps' + atcbContextSet_def) + done + lemma asUser_corres': assumes y: "corres_underlying Id False True r \ \ f g" - shows "corres r (tcb_at t) - (tcb_at' t) - (as_user t f) (asUser t g)" + shows "corres r (tcb_at t and pspace_aligned and pspace_distinct) \ (as_user t f) (asUser t g)" proof - note arch_tcb_context_get_def[simp] note atcbContextGet_def[simp] @@ -1375,6 +1573,8 @@ lemma asUser_corres': using y by (fastforce simp: corres_underlying_def select_f_def split_def Id_def) show ?thesis + apply (rule_tac Q'="tcb_at' t" in corres_cross_add_guard) + apply (fastforce intro!: tcb_at_cross) apply (simp add: as_user_def asUser_def) apply (rule corres_guard_imp) apply (rule_tac r'="\tcb con. (arch_tcb_context_get o tcb_arch) tcb = con" @@ -1426,7 +1626,7 @@ proof - qed lemma asUser_getRegister_corres: - "corres (=) (tcb_at t) (tcb_at' t) + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ (as_user t (getRegister r)) (asUser t (getRegister r))" apply (rule asUser_corres') apply (clarsimp simp: getRegister_def) @@ -1475,14 +1675,6 @@ lemma asUser_valid_pspace'[wp]: | simp add: atcbContextSet_def valid_arch_tcb'_def)+ done -lemma asUser_valid_queues[wp]: - "\Invariants_H.valid_queues\ asUser t m \\rv. Invariants_H.valid_queues\" - apply (simp add: asUser_def split_def) - apply (wp hoare_drop_imps | simp)+ - - apply (wp threadSet_valid_queues hoare_drop_imps | simp)+ - done - lemma asUser_ifunsafe'[wp]: "\if_unsafe_then_cap'\ asUser t m \\rv. if_unsafe_then_cap'\" apply (simp add: asUser_def split_def) @@ -1584,17 +1776,15 @@ lemma no_fail_asUser [wp]: done lemma asUser_setRegister_corres: - "corres dc (tcb_at t) - (tcb_at' t) - (as_user t (setRegister r v)) - (asUser t (setRegister r v))" + "corres dc (tcb_at t and pspace_aligned and pspace_distinct) \ + (as_user t (setRegister r v)) (asUser t (setRegister r v))" apply (simp add: setRegister_def) apply (rule asUser_corres') apply (rule corres_modify'; simp) done lemma getThreadState_corres: - "corres thread_state_relation (tcb_at t) (tcb_at' t) + "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) @@ -1625,7 +1815,7 @@ lemma gts_inv'[wp]: "\P\ getThreadState t \\rv. by (simp add: getThreadState_def) wp lemma getBoundNotification_corres: - "corres (=) (tcb_at t) (tcb_at' t) + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ (get_bound_notification t) (getBoundNotification t)" apply (simp add: get_bound_notification_def getBoundNotification_def) apply (rule threadGet_corres) @@ -1698,25 +1888,6 @@ lemma setQueue_nosch[wp]: lemma gq_wp[wp]: "\\s. Q (ksReadyQueues s (d, p)) s\ getQueue d p \Q\" by (simp add: getQueue_def, wp) -lemma get_tcb_corres: - "corres tcb_relation (tcb_at t) (tcb_at' t) (gets_the (get_tcb t)) (getObject t)" - apply (rule corres_no_failI) - apply wp - apply (clarsimp simp add: gets_def - get_def return_def bind_def get_tcb_def - gets_the_def assert_opt_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 - split: option.split_asm) - apply (clarsimp simp add: return_def in_magnitude_check objBits_simps - state_relation_def - split: kernel_object.split_asm) - apply (frule(1) pspace_relation_absD) - apply (clarsimp simp add: other_obj_relation_def) - done - lemma no_fail_getQueue [wp]: "no_fail \ (getQueue d p)" by (simp add: getQueue_def) @@ -1798,19 +1969,22 @@ lemma ethreadget_corres: apply (simp add: x) done -lemma setQueue_corres: - "corres dc \ \ (set_tcb_queue d p q) (setQueue d p q)" - apply (rule corres_no_failI) - apply wp - apply (clarsimp simp: setQueue_def in_monad set_tcb_queue_def return_def simpler_modify_def) - apply (fastforce simp: state_relation_def ready_queues_relation_def) - done - - -lemma getQueue_corres: "corres (=) \ \ (get_tcb_queue qdom prio) (getQueue qdom prio)" - apply (clarsimp simp add: getQueue_def state_relation_def ready_queues_relation_def get_tcb_queue_def gets_def) - apply (fold gets_def) - apply simp +lemma getQueue_corres: + "corres (\ls q. (ls = [] \ tcbQueueEmpty q) \ (ls \ [] \ tcbQueueHead q = Some (hd ls)) + \ queue_end_valid ls q) + \ \ (get_tcb_queue qdom prio) (getQueue qdom prio)" + apply (clarsimp simp: get_tcb_queue_def getQueue_def tcbQueueEmpty_def) + apply (rule corres_bind_return2) + apply (rule corres_symb_exec_l[OF _ _ gets_sp]) + apply (rule corres_symb_exec_r[OF _ gets_sp]) + apply clarsimp + apply (drule state_relation_ready_queues_relation) + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def + list_queue_relation_def) + apply (drule_tac x=qdom in spec) + apply (drule_tac x=prio in spec) + apply (fastforce dest: heap_path_head) + apply wpsimp+ done lemma no_fail_return: @@ -1825,8 +1999,8 @@ lemma addToBitmap_noop_corres: (wp | simp add: state_relation_def | rule no_fail_pre)+ lemma addToBitmap_if_null_noop_corres: (* used this way in Haskell code *) - "corres dc \ \ (return ()) (if null queue then addToBitmap d p else return ())" - by (cases "null queue", simp_all add: addToBitmap_noop_corres) + "corres dc \ \ (return ()) (if tcbQueueEmpty queue then addToBitmap d p else return ())" + by (cases "tcbQueueHead queue", simp_all add: addToBitmap_noop_corres) lemma removeFromBitmap_corres_noop: "corres dc \ \ (return ()) (removeFromBitmap tdom prioa)" @@ -1843,54 +2017,701 @@ crunch typ_at'[wp]: removeFromBitmap "\s. P (typ_at' T p s)" 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 ekheap_relation_tcb_domain_priority: + "\ekheap_relation (ekheap s) (ksPSpace s'); ekheap s t = Some (tcb); + ksPSpace s' t = Some (KOTCB tcb')\ + \ 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 (clarsimp simp: other_obj_relation_def etcb_relation_def) + done + +lemma no_fail_thread_get[wp]: + "no_fail (tcb_at tcb_ptr) (thread_get f tcb_ptr)" + unfolding thread_get_def + apply wpsimp + apply (clarsimp simp: tcb_at_def) + done + +lemma pspace_relation_tcb_relation: + "\pspace_relation (kheap s) (ksPSpace s'); kheap s ptr = Some (TCB tcb); + ksPSpace s' ptr = Some (KOTCB tcb')\ + \ 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: obj_at_def obj_at'_def tcb_relation_cut_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 + +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) + +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 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 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 projectKOs) + done + +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) + +crunches 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) + +crunches 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 + +crunches 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) + +crunches 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 projectKOs[simp] + supply fun_upd_apply[simp del] + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def) + apply (wpsimp wp: threadSet_wp) + apply (clarsimp simp: list_queue_relation_def obj_at'_def) + apply (rename_tac tcb' d p) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: list_queue_relation_def) + apply (rule conjI) + apply (drule_tac x=tcbPtr in spec) + apply (fastforce intro: heap_path_heap_upd_not_in + simp: inQ_def opt_map_def opt_pred_def obj_at'_def) + apply (rule conjI) + apply (drule_tac x=tcbPtr in spec) + apply (clarsimp simp: prev_queue_head_def) + apply (prop_tac "ready_queues s d p \ []", fastforce) + apply (fastforce dest: heap_path_head simp: inQ_def opt_pred_def opt_map_def fun_upd_apply) + apply (auto simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + done + +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\ + isRunnable tcb_ptr + \\rv s. \tcb'. ko_at' tcb' tcb_ptr s + \ (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_def) + apply (fastforce simp: obj_at'_def split: Structures_H.thread_state.splits) + done + +crunch (no_fail) no_fail[wp]: isRunnable + +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) + +crunches 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 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 in_set_ready_queues_inQ_eq: + "ready_queues_relation s s' \ t \ set (ready_queues s d p) \ (inQ d p |< tcbs_of' s') t" + by (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def) + +lemma in_ready_q_tcbQueued_eq: + "ready_queues_relation s s' + \ (\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_queues_relation_def ready_queue_relation_def Let_def + inQ_def opt_pred_def + split: option.splits) + done + lemma tcbSchedEnqueue_corres: - "corres dc (is_etcb_at t) (tcb_at' t and Invariants_H.valid_queues and valid_queues') - (tcb_sched_action (tcb_sched_enqueue) t) (tcbSchedEnqueue t)" -proof - - have ready_queues_helper: - "\t tcb a b. \ ekheap a t = Some tcb; obj_at' tcbQueued t b ; valid_queues' b ; - ekheap_relation (ekheap a) (ksPSpace b) \ - \ t \ set (ksReadyQueues b (tcb_domain tcb, tcb_priority tcb))" - unfolding valid_queues'_def - by (fastforce dest: ekheap_relation_absD simp: obj_at'_def inQ_def etcb_relation_def projectKO_eq projectKO_tcb) - - show ?thesis unfolding tcbSchedEnqueue_def tcb_sched_action_def - apply (rule corres_symb_exec_r [OF _ _ threadGet_inv, - 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 (rule no_fail_pre, wp, blast) - apply (case_tac queued; simp_all) - apply (rule corres_no_failI; simp add: no_fail_return) - apply (clarsimp simp: in_monad ethread_get_def gets_the_def bind_assoc - assert_opt_def exec_gets is_etcb_at_def get_etcb_def get_tcb_queue_def - set_tcb_queue_def simpler_modify_def ready_queues_relation_def - state_relation_def tcb_sched_enqueue_def) - apply (rule ready_queues_helper; auto) - apply (clarsimp simp: when_def) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres) - apply (simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres) - apply (simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply simp - apply (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 - apply (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 exst_same_def) - apply (wp getObject_tcb_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 + "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] + projectKOs[simp] + 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) + 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)?) + + \ \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) + + 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) + + 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) + 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) + 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 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 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) + apply (frule valid_tcbs'_maxPriority[where t=tcbPtr], simp add: obj_at'_def) + 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) + 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 + 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 fun_upd_apply split: if_splits) + apply (clarsimp simp: fun_upd_apply 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 + split: if_splits option.splits) definition weak_sch_act_wf :: "scheduler_action \ kernel_state \ bool" @@ -1917,7 +2738,10 @@ lemma getSchedulerAction_corres: done lemma rescheduleRequired_corres: - "corres dc (weak_valid_sched_action and valid_etcbs) (Invariants_H.valid_queues and valid_queues' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)) + "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) @@ -1928,15 +2752,14 @@ lemma rescheduleRequired_corres: apply (case_tac action) apply simp apply simp - apply (rule tcbSchedEnqueue_corres) + 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 + 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 simp - apply (clarsimp simp: weak_sch_act_wf_def pred_tcb_at' split: scheduler_action.splits) + apply (clarsimp split: scheduler_action.splits) done lemma rescheduleRequired_corres_simple: @@ -2004,20 +2827,18 @@ lemmas addToBitmap_weak_sch_act_wf[wp] = weak_sch_act_wf_lift[OF addToBitmap_nosch] crunch st_tcb_at'[wp]: removeFromBitmap "st_tcb_at' P t" -crunch pred_tcb_at'[wp]: removeFromBitmap "pred_tcb_at' proj P t" +crunch pred_tcb_at'[wp]: removeFromBitmap "\s. Q (pred_tcb_at' proj P t s)" crunch not_st_tcb_at'[wp]: removeFromBitmap "\s. \ (st_tcb_at' P' t) s" -crunch not_pred_tcb_at'[wp]: removeFromBitmap "\s. \ (pred_tcb_at' proj P' t) s" crunch st_tcb_at'[wp]: addToBitmap "st_tcb_at' P' t" -crunch pred_tcb_at'[wp]: addToBitmap "pred_tcb_at' proj P' t" +crunch pred_tcb_at'[wp]: addToBitmap "\s. Q (pred_tcb_at' proj P t s)" crunch not_st_tcb_at'[wp]: addToBitmap "\s. \ (st_tcb_at' P' t) s" -crunch not_pred_tcb_at'[wp]: addToBitmap "\s. \ (pred_tcb_at' proj P' t) s" -crunch obj_at'[wp]: removeFromBitmap "obj_at' P t" +crunch obj_at'[wp]: removeFromBitmap "\s. Q (obj_at' P t s)" -crunch obj_at'[wp]: addToBitmap "obj_at' P t" +crunch obj_at'[wp]: addToBitmap "\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\" @@ -2034,9 +2855,11 @@ lemma addToBitmap_tcb_in_cur_domain'[wp]: done lemma tcbSchedDequeue_weak_sch_act_wf[wp]: - "\ \s. weak_sch_act_wf (ksSchedulerAction s) s \ tcbSchedDequeue a \ \_ s. weak_sch_act_wf (ksSchedulerAction s) s \" - apply (simp add: tcbSchedDequeue_def) - apply (wp threadSet_weak_sch_act_wf removeFromBitmap_weak_sch_act_wf | simp add: crunch_simps)+ + "tcbSchedDequeue tcbPtr \\s. weak_sch_act_wf (ksSchedulerAction s) s\" + apply (simp add: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wp threadSet_weak_sch_act_wf getObject_tcb_wp removeFromBitmap_weak_sch_act_wf + | simp add: crunch_simps threadGet_def)+ + apply (clarsimp simp: obj_at'_def) done lemma dequeue_nothing_eq[simp]: @@ -2052,44 +2875,344 @@ lemma gets_the_exec: "f s \ None \ (do x \ ge return_def assert_opt_def) done +lemma tcbQueueRemove_no_fail: + "no_fail (\s. tcb_at' tcbPtr s + \ (\ts. list_queue_relation ts queue (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ tcbPtr \ set ts) + \ sym_heap_sched_pointers s \ valid_objs' s) + (tcbQueueRemove queue tcbPtr)" + supply projectKOs[simp] + unfolding tcbQueueRemove_def + apply (wpsimp wp: getObject_tcb_wp) + apply normalise_obj_at' + apply (frule (1) ko_at_valid_objs') + apply fastforce + apply (clarsimp simp: list_queue_relation_def) + apply (prop_tac "tcbQueueHead queue \ Some tcbPtr \ tcbSchedPrevs_of s tcbPtr \ None") + apply (rule impI) + apply (frule not_head_prev_not_None[where p=tcbPtr]) + apply (fastforce simp: inQ_def opt_pred_def opt_map_def obj_at'_def) + apply (fastforce dest: heap_path_head) + apply fastforce + apply (fastforce simp: opt_map_def obj_at'_def valid_tcb'_def valid_bound_tcb'_def) + by (fastforce dest!: not_last_next_not_None[where p=tcbPtr] + simp: queue_end_valid_def opt_map_def obj_at'_def valid_obj'_def valid_tcb'_def) + +crunch (no_fail) no_fail[wp]: removeFromBitmap + +crunches removeFromBitmap + for ready_queues_relation[wp]: "ready_queues_relation s" + and list_queue_relation[wp]: + "\s'. list_queue_relation ts (P (ksReadyQueues s')) + (tcbSchedNexts_of s') (tcbSchedPrevs_of s')" + (simp: bitmap_fun_defs ready_queues_relation_def) + +\ \ + A direct analogue of tcbQueueRemove, used in tcb_sched_dequeue' below, so that within the proof of + tcbQueueRemove_corres, we may reason in terms of the list operations used within this function + rather than @{term filter}.\ +definition tcb_queue_remove :: "'a \ 'a list \ 'a list" where + "tcb_queue_remove a ls \ + if ls = [a] + then [] + else if a = hd ls + then tl ls + else if a = last ls + then butlast ls + else list_remove ls a" + +definition tcb_sched_dequeue' :: "obj_ref \ unit det_ext_monad" where + "tcb_sched_dequeue' tcb_ptr \ do + d \ ethread_get tcb_domain tcb_ptr; + prio \ ethread_get tcb_priority tcb_ptr; + queue \ get_tcb_queue d prio; + when (tcb_ptr \ set queue) $ set_tcb_queue d prio (tcb_queue_remove tcb_ptr queue) + od" + +lemma filter_tcb_queue_remove: + "\a \ set ls; distinct ls \ \ filter ((\) a) ls = tcb_queue_remove a ls" + apply (clarsimp simp: tcb_queue_remove_def) + apply (intro conjI impI) + apply (fastforce elim: filter_hd_equals_tl) + apply (fastforce elim: filter_last_equals_butlast) + apply (fastforce elim: filter_hd_equals_tl) + apply (frule split_list) + apply (clarsimp simp: list_remove_middle_distinct) + apply (subst filter_True | clarsimp simp: list_remove_none)+ + done + +lemma tcb_sched_dequeue_monadic_rewrite: + "monadic_rewrite False True (is_etcb_at t and (\s. \d p. distinct (ready_queues s d p))) + (tcb_sched_action tcb_sched_dequeue t) (tcb_sched_dequeue' t)" + supply if_split[split del] + apply (clarsimp simp: tcb_sched_dequeue'_def tcb_sched_dequeue_def tcb_sched_action_def + set_tcb_queue_def) + apply (rule monadic_rewrite_bind_tail)+ + apply (clarsimp simp: when_def) + apply (rule monadic_rewrite_if_r) + apply (rule_tac P="\_. distinct queue" in monadic_rewrite_guard_arg_cong) + apply (frule (1) filter_tcb_queue_remove) + apply (metis (mono_tags, lifting) filter_cong) + apply (rule monadic_rewrite_modify_noop) + apply (wpsimp wp: thread_get_wp)+ + apply (clarsimp simp: etcb_at_def split: option.splits) + apply (prop_tac "(\d' p. if d' = tcb_domain x2 \ p = tcb_priority x2 + then filter (\x. x \ t) (ready_queues s (tcb_domain x2) (tcb_priority x2)) + else ready_queues s d' p) + = ready_queues s") + apply (subst filter_True) + apply fastforce + apply (clarsimp intro!: ext split: if_splits) + apply fastforce + done + +crunches removeFromBitmap + for ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" + +lemma list_queue_relation_neighbour_in_set: + "\list_queue_relation ls q hp hp'; sym_heap hp hp'; p \ set ls\ + \ \nbr. (hp p = Some nbr \ nbr \ set ls) \ (hp' p = Some nbr \ nbr \ set ls)" + apply (rule heap_ls_neighbour_in_set) + apply (fastforce simp: list_queue_relation_def) + apply fastforce + apply (clarsimp simp: list_queue_relation_def prev_queue_head_def) + apply fastforce + done + +lemma in_queue_not_head_or_not_tail_length_gt_1: + "\tcbPtr \ set ls; tcbQueueHead q \ Some tcbPtr \ tcbQueueEnd q \ Some tcbPtr; + list_queue_relation ls q nexts prevs\ + \ Suc 0 < length ls" + apply (clarsimp simp: list_queue_relation_def) + apply (cases ls; fastforce simp: queue_end_valid_def) + done + lemma tcbSchedDequeue_corres: - "corres dc (is_etcb_at t) (tcb_at' t and Invariants_H.valid_queues) - (tcb_sched_action tcb_sched_dequeue t) (tcbSchedDequeue t)" - apply (simp only: tcbSchedDequeue_def tcb_sched_action_def) - apply (rule corres_symb_exec_r[OF _ _ threadGet_inv, where Q'="\rv. tcb_at' t and Invariants_H.valid_queues and obj_at' (\obj. tcbQueued obj = rv) t"]) - defer - apply (wp threadGet_obj_at', simp, simp) - apply (rule no_fail_pre, wp, simp) - apply (case_tac queued) - defer - apply (simp add: when_def) - apply (rule corres_no_failI) - apply (wp) - apply (clarsimp simp: in_monad ethread_get_def set_tcb_queue_def is_etcb_at_def state_relation_def) - apply (subgoal_tac "t \ set (ready_queues a (tcb_domain y) (tcb_priority y))") - prefer 2 - subgoal by (force simp: tcb_sched_dequeue_def Invariants_H.valid_queues_def valid_queues_no_bitmap_def - ready_queues_relation_def obj_at'_def inQ_def projectKO_eq project_inject) - apply (subst gets_the_exec) - apply (simp add: get_etcb_def) - apply (subst gets_the_exec) - apply (simp add: get_etcb_def) - apply (simp add: exec_gets simpler_modify_def get_etcb_def ready_queues_relation_def cong: if_cong get_tcb_queue_def) - apply (simp add: when_def) - apply (rule corres_guard_imp) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres, simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres, simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply (simp, rule getQueue_corres) - apply (rule corres_split_noop_rhs2) - apply (simp add: tcb_sched_dequeue_def) - apply (rule setQueue_corres) - apply (rule corres_split_noop_rhs) - apply (clarsimp, rule removeFromBitmap_corres_noop) - apply (rule threadSet_corres_noop; simp_all add: tcb_relation_def exst_same_def) - apply (wp | simp)+ + "tcb_ptr = tcbPtr \ + corres dc + (in_correct_ready_q and ready_qs_distinct and valid_etcbs and tcb_at tcb_ptr + and pspace_aligned and pspace_distinct) + (sym_heap_sched_pointers and valid_objs') + (tcb_sched_action tcb_sched_dequeue tcb_ptr) (tcbSchedDequeue tcbPtr)" + supply heap_path_append[simp del] fun_upd_apply[simp del] distinct_append[simp del] + list_remove_append[simp del] + projectKOs[simp] + apply (rule_tac Q'="tcb_at' tcbPtr" in corres_cross_add_guard) + apply (fastforce intro!: tcb_at_cross simp: obj_at_def is_tcb_def) + apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) + apply (fastforce dest: pspace_aligned_cross) + apply (rule_tac Q'=pspace_distinct' in corres_cross_add_guard) + apply (fastforce dest: pspace_distinct_cross) + apply (rule monadic_rewrite_corres_l[where P=P and Q=P for P, simplified]) + apply (rule monadic_rewrite_guard_imp[OF tcb_sched_dequeue_monadic_rewrite]) + apply (fastforce dest: tcb_at_is_etcb_at simp: in_correct_ready_q_def ready_qs_distinct_def) + apply (clarsimp simp: tcb_sched_dequeue'_def get_tcb_queue_def tcbSchedDequeue_def getQueue_def + unless_def when_def) + apply (rule corres_symb_exec_l[OF _ _ ethread_get_sp]; wpsimp?) + apply (rename_tac dom) + apply (rule corres_symb_exec_l[OF _ _ ethread_get_sp]; wpsimp?) + apply (rename_tac prio) + 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 _ threadGet_sp]; (solves wpsimp)?) + apply (rule corres_if_strong'; fastforce?) + apply (frule state_relation_ready_queues_relation) + apply (frule in_ready_q_tcbQueued_eq[where t=tcbPtr]) + apply (fastforce 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) + apply (rule corres_symb_exec_r[OF _ threadGet_sp]; wpsimp?) + apply (rule corres_symb_exec_r[OF _ threadGet_sp]; wpsimp?) + apply (rule corres_symb_exec_r[OF _ gets_sp]; wpsimp?) + apply (rule corres_from_valid_det) + apply (fastforce intro: det_wp_modify det_wp_pre simp: set_tcb_queue_def) + apply (wpsimp wp: tcbQueueRemove_no_fail) + apply (fastforce dest: state_relation_ready_queues_relation + simp: ex_abs_underlying_def ready_queues_relation_def ready_queue_relation_def + Let_def inQ_def opt_pred_def opt_map_def obj_at'_def) + apply (clarsimp simp: state_relation_def) + apply (intro hoare_vcg_conj_lift_pre_fix; + (solves \frule singleton_eqD, frule set_tcb_queue_projs_inv, wpsimp simp: swp_def\)?) + + \ \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 tcbQueueRemove_def + split_del: if_split) + apply (frule (1) tcb_at_is_etcb_at) + apply (clarsimp simp: obj_at_def is_etcb_at_def etcb_at_def) + apply normalise_obj_at' + 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) + + apply (case_tac "d \ tcb_domain etcb \ p \ tcb_priority etcb") + apply clarsimp + apply (cut_tac p=tcbPtr and ls="ready_queues s (tcb_domain etcb) (tcb_priority etcb)" + in list_queue_relation_neighbour_in_set) + apply (fastforce dest!: spec) + apply fastforce + apply fastforce + apply (cut_tac xs="ready_queues s d p" in heap_path_head') + apply (force dest!: spec simp: ready_queues_relation_def Let_def list_queue_relation_def) + 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 (cut_tac ts="ready_queues s d p" in list_queue_relation_nil) + apply fast + apply (clarsimp simp: tcbQueueEmpty_def) + apply (prop_tac "Some tcbPtr \ tcbQueueHead (ksReadyQueues s' (d, p))") + apply (metis hd_in_set not_emptyI option.sel option.simps(2)) + apply (prop_tac "tcbPtr \ set (ready_queues s d p)") + apply blast + apply (clarsimp simp: list_queue_relation_def) + apply (intro conjI; clarsimp) + + \ \the ready queue is the singleton consisting of tcbPtr\ + apply (intro conjI) + apply (force intro!: heap_path_heap_upd_not_in simp: fun_upd_apply) + apply (clarsimp simp: queue_end_valid_def fun_upd_apply) + apply (force simp: prev_queue_head_heap_upd fun_upd_apply) + apply (clarsimp simp: inQ_def in_opt_pred fun_upd_apply) + apply (clarsimp simp: fun_upd_apply) + apply (clarsimp simp: fun_upd_apply) + + apply (clarsimp simp: etcb_at_def obj_at'_def) + apply (intro conjI; clarsimp) + + \ \tcbPtr is the head of the ready queue\ + apply (intro conjI) + apply (intro heap_path_heap_upd_not_in) + apply (force simp: fun_upd_apply) + apply (force simp: not_emptyI opt_map_red) + apply assumption + apply (clarsimp simp: queue_end_valid_def fun_upd_apply) + apply (clarsimp simp: prev_queue_head_def fun_upd_apply) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + apply (clarsimp simp: fun_upd_apply) + apply (clarsimp simp: fun_upd_apply) + apply (intro conjI; clarsimp) + + \ \tcbPtr is the end of the ready queue\ + apply (intro conjI) + apply (intro heap_path_heap_upd_not_in) + apply (simp add: fun_upd_apply split: if_splits) + apply (force simp: not_emptyI opt_map_red) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + apply (clarsimp simp: queue_end_valid_def fun_upd_apply) + apply (force simp: prev_queue_head_def fun_upd_apply opt_map_red opt_map_upd_triv) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + apply (clarsimp simp: fun_upd_apply) + apply (clarsimp simp: fun_upd_apply) + + \ \tcbPtr is in the middle of the ready queue\ + apply (intro conjI) + apply (intro heap_path_heap_upd_not_in) + apply (simp add: fun_upd_apply) + apply (force simp: not_emptyI opt_map_red) + apply (force simp: not_emptyI opt_map_red) + apply fastforce + apply (clarsimp simp: opt_map_red opt_map_upd_triv) + apply (intro prev_queue_head_heap_upd) + apply (force dest!: spec) + apply (metis hd_in_set not_emptyI option.sel option.simps(2)) + apply fastforce + subgoal + by (clarsimp simp: inQ_def opt_map_def opt_pred_def fun_upd_apply + split: if_splits option.splits) + + \ \d = tcb_domain tcb \ p = tcb_priority tcb\ + apply clarsimp + apply (drule_tac x="tcb_domain etcb" in spec) + apply (drule_tac x="tcb_priority etcb" in spec) + apply (clarsimp simp: list_queue_relation_def) + apply (frule heap_path_head') + apply (frule heap_ls_distinct) + apply (intro conjI; clarsimp simp: tcbQueueEmpty_def) + + \ \the ready queue is the singleton consisting of tcbPtr\ + apply (intro conjI) + apply (simp add: fun_upd_apply tcb_queue_remove_def queue_end_valid_def heap_ls_unique + heap_path_last_end) + apply (simp add: fun_upd_apply tcb_queue_remove_def queue_end_valid_def heap_ls_unique + heap_path_last_end) + apply (simp add: fun_upd_apply prev_queue_head_def) + apply (case_tac "ready_queues s (tcb_domain etcb) (tcb_priority etcb)"; + clarsimp simp: tcb_queue_remove_def inQ_def opt_pred_def fun_upd_apply) + apply (intro conjI; clarsimp) + + \ \tcbPtr is the head of the ready queue\ + apply (frule set_list_mem_nonempty) + apply (frule in_queue_not_head_or_not_tail_length_gt_1) + apply fastforce + apply (fastforce simp: list_queue_relation_def) + apply (frule list_not_head) + apply (clarsimp simp: tcb_queue_remove_def) + apply (frule length_tail_nonempty) + apply (frule (2) heap_ls_next_of_hd) + apply (clarsimp simp: obj_at'_def) + apply (intro conjI impI allI) + apply (drule (1) heap_ls_remove_head_not_singleton) + apply (clarsimp simp: opt_map_red opt_map_upd_triv fun_upd_apply) + apply (clarsimp simp: queue_end_valid_def fun_upd_apply last_tl) + apply (clarsimp simp: prev_queue_head_def fun_upd_apply) + apply (case_tac "ready_queues s (tcb_domain etcb) (tcb_priority etcb)"; + clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + apply (intro conjI; clarsimp) + + \ \tcbPtr is the end of the ready queue\ + apply (frule set_list_mem_nonempty) + apply (frule in_queue_not_head_or_not_tail_length_gt_1) + apply fast + apply (force dest!: spec simp: list_queue_relation_def) + apply (clarsimp simp: queue_end_valid_def) + apply (frule list_not_last) + apply (clarsimp simp: tcb_queue_remove_def) + apply (frule length_gt_1_imp_butlast_nonempty) + apply (frule (3) heap_ls_prev_of_last) + apply (clarsimp simp: obj_at'_def) + apply (intro conjI impI; clarsimp?) + apply (drule (1) heap_ls_remove_last_not_singleton) + apply (force elim!: rsubst3[where P=heap_ls] simp: opt_map_def fun_upd_apply) + apply (clarsimp simp: opt_map_def fun_upd_apply) + apply (clarsimp simp: prev_queue_head_def fun_upd_apply opt_map_def) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + apply (meson distinct_in_butlast_not_last in_set_butlastD last_in_set not_last_in_set_butlast) + + \ \tcbPtr is in the middle of the ready queue\ + apply (clarsimp simp: obj_at'_def) + apply (frule set_list_mem_nonempty) + apply (frule split_list) + apply clarsimp + apply (rename_tac xs ys) + apply (prop_tac "xs \ [] \ ys \ []", fastforce simp: queue_end_valid_def) + apply clarsimp + apply (frule (2) ptr_in_middle_prev_next) + apply fastforce + apply (clarsimp simp: tcb_queue_remove_def) + apply (prop_tac "tcbPtr \ last xs") + apply (clarsimp simp: distinct_append) + apply (prop_tac "tcbPtr \ hd ys") + apply (fastforce dest: hd_in_set simp: distinct_append) + apply (prop_tac "last xs \ hd ys") + apply (metis distinct_decompose2 hd_Cons_tl last_in_set) + apply (prop_tac "list_remove (xs @ tcbPtr # ys) tcbPtr = xs @ ys") + apply (simp add: list_remove_middle_distinct del: list_remove_append) + apply (intro conjI impI allI; (solves \clarsimp simp: distinct_append\)?) + apply (fastforce elim!: rsubst3[where P=heap_ls] + dest!: heap_ls_remove_middle hd_in_set last_in_set + simp: distinct_append not_emptyI opt_map_def fun_upd_apply) + apply (clarsimp simp: queue_end_valid_def fun_upd_apply) + apply (case_tac xs; + fastforce simp: prev_queue_head_def opt_map_def fun_upd_apply distinct_append) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply distinct_append + split: option.splits) done lemma thread_get_test: "do cur_ts \ get_thread_state cur; g (test cur_ts) od = @@ -2097,7 +3220,9 @@ lemma thread_get_test: "do cur_ts \ get_thread_state cur; g (test cur apply (simp add: get_thread_state_def thread_get_def) done -lemma thread_get_isRunnable_corres: "corres (=) (tcb_at t) (tcb_at' t) (thread_get (\tcb. runnable (tcb_state tcb)) t) (isRunnable t)" +lemma thread_get_isRunnable_corres: + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ + (thread_get (\tcb. runnable (tcb_state tcb)) t) (isRunnable t)" apply (simp add: isRunnable_def getThreadState_def threadGet_def thread_get_def) apply (fold liftM_def) @@ -2111,8 +3236,8 @@ lemma thread_get_isRunnable_corres: "corres (=) (tcb_at t) (tcb_at' t) (thread_g lemma setThreadState_corres: "thread_state_relation ts ts' \ corres dc - (tcb_at t) - (tcb_at' t) + (tcb_at t and pspace_aligned and pspace_distinct) + \ (set_thread_state t ts) (setThreadState ts' t)" (is "?tsr \ corres dc ?Pre ?Pre' ?sts ?sts'") apply (simp add: set_thread_state_def setThreadState_def) @@ -2136,8 +3261,8 @@ lemma setThreadState_corres: lemma setBoundNotification_corres: "corres dc - (tcb_at t) - (tcb_at' t) + (tcb_at t and pspace_aligned and pspace_distinct) + \ (set_bound_notification t ntfn) (setBoundNotification ntfn t)" apply (simp add: set_bound_notification_def setBoundNotification_def) apply (subst thread_set_def[simplified, symmetric]) @@ -2147,29 +3272,84 @@ lemma setBoundNotification_corres: crunches rescheduleRequired, tcbSchedDequeue, setThreadState, setBoundNotification for tcb'[wp]: "tcb_at' addr" +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 + +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 + +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) + +crunches addToBitmap + for valid_objs'[wp]: valid_objs' + (simp: unless_def crunch_simps wp: crunch_wps) + +lemma tcbSchedEnqueue_valid_objs'[wp]: + "\valid_objs' and pspace_aligned' and pspace_distinct'\ + tcbSchedEnqueue tcbPtr + \\_. valid_objs'\" + 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 + crunches rescheduleRequired, removeFromBitmap for valid_objs'[wp]: valid_objs' (simp: crunch_simps) -lemma tcbSchedDequeue_valid_objs' [wp]: "\ valid_objs' \ tcbSchedDequeue t \\_. valid_objs' \" - unfolding tcbSchedDequeue_def - apply (wp threadSet_valid_objs') - apply (clarsimp simp add: valid_tcb'_def tcb_cte_cases_def) - apply wp - apply (simp add: if_apply_def2) - apply (wp hoare_drop_imps) - apply (wp | simp cong: if_cong add: valid_tcb'_def tcb_cte_cases_def if_apply_def2)+ +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] + +lemma tcbQueueRemove_valid_objs'[wp]: + "tcbQueueRemove queue tcbPtr \valid_objs'\" + unfolding tcbQueueRemove_def + apply (wpsimp wp: getObject_tcb_wp) + apply normalise_obj_at' + apply (fastforce dest!: tcb_ko_at_valid_objs_valid_tcb' + simp: valid_tcb'_def valid_bound_tcb'_def obj_at'_def) done +lemma tcbSchedDequeue_valid_objs'[wp]: + "tcbSchedDequeue t \valid_objs'\" + unfolding tcbSchedDequeue_def setQueue_def + by (wpsimp wp: threadSet_valid_objs') + lemma sts_valid_objs': - "\valid_objs' and valid_tcb_state' st\ - setThreadState st t - \\rv. valid_objs'\" - apply (simp add: setThreadState_def setQueue_def isRunnable_def isStopped_def) - apply (wp threadSet_valid_objs') - apply (simp add: valid_tcb'_def tcb_cte_cases_def) - apply (wp threadSet_valid_objs' | simp)+ - apply (clarsimp simp: valid_tcb'_def tcb_cte_cases_def) + "\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') + 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': @@ -2255,18 +3435,6 @@ lemma setQueue_valid_bitmapQ_except[wp]: unfolding setQueue_def bitmapQ_defs by (wp, clarsimp simp: bitmapQ_def) -lemma setQueue_valid_bitmapQ: (* enqueue only *) - "\ valid_bitmapQ and (\s. (ksReadyQueues s (d, p) = []) = (ts = [])) \ - setQueue d p ts - \\_. valid_bitmapQ \" - unfolding setQueue_def bitmapQ_defs - by (wp, clarsimp simp: bitmapQ_def) - -lemma setQueue_valid_queues': - "\valid_queues' and (\s. \t. obj_at' (inQ d p) t s \ t \ set ts)\ - setQueue d p ts \\_. valid_queues'\" - by (wp | simp add: valid_queues'_def setQueue_def)+ - lemma setQueue_cur: "\\s. cur_tcb' s\ setQueue d p ts \\rv s. cur_tcb' s\" unfolding setQueue_def cur_tcb'_def @@ -2404,9 +3572,17 @@ lemma threadSet_queued_sch_act_wf[wp]: apply (wp tcb_in_cur_domain'_lift | simp add: obj_at'_def)+ done +lemma tcbSchedNext_update_pred_tcb_at'[wp]: + "threadSet (tcbSchedNext_update f) t \\s. P (pred_tcb_at' proj P' t' s)\" + by (wp threadSet_pred_tcb_no_state crunch_wps | clarsimp simp: tcb_to_itcb'_def)+ + +lemma tcbSchedPrev_update_pred_tcb_at'[wp]: + "threadSet (tcbSchedPrev_update f) t \\s. P (pred_tcb_at' proj P' t' s)\" + by (wp threadSet_pred_tcb_no_state crunch_wps | clarsimp simp: tcb_to_itcb'_def)+ + lemma tcbSchedEnqueue_pred_tcb_at'[wp]: "\\s. pred_tcb_at' proj P' t' s \ tcbSchedEnqueue t \\_ s. pred_tcb_at' proj P' t' s\" - apply (simp add: tcbSchedEnqueue_def when_def unless_def) + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def when_def unless_def) apply (wp threadSet_pred_tcb_no_state crunch_wps | clarsimp simp: tcb_to_itcb'_def)+ done @@ -2414,8 +3590,9 @@ lemma tcbSchedDequeue_sch_act_wf[wp]: "\\s. sch_act_wf (ksSchedulerAction s) s\ tcbSchedDequeue t \\_ s. sch_act_wf (ksSchedulerAction s) s\" - unfolding tcbSchedDequeue_def - by (wp setQueue_sch_act | wp sch_act_wf_lift | simp add: if_apply_def2)+ + unfolding tcbSchedDequeue_def tcbQueueRemove_def + by (wp setQueue_sch_act threadSet_tcbDomain_triv hoare_drop_imps + | wp sch_act_wf_lift | simp add: if_apply_def2)+ crunch nosch: tcbSchedDequeue "\s. P (ksSchedulerAction s)" @@ -2511,21 +3688,22 @@ lemma tcbSchedEnqueue_sch_act[wp]: "\\s. sch_act_wf (ksSchedulerAction s) s\ tcbSchedEnqueue t \\_ s. sch_act_wf (ksSchedulerAction s) s\" - by (simp add: tcbSchedEnqueue_def unless_def) - (wp setQueue_sch_act | wp sch_act_wf_lift | clarsimp)+ + by (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_def) + (wp setQueue_sch_act threadSet_tcbDomain_triv | wp sch_act_wf_lift | clarsimp)+ lemma tcbSchedEnqueue_weak_sch_act[wp]: "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ tcbSchedEnqueue t \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: tcbSchedEnqueue_def unless_def) + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_def) apply (wp setQueue_sch_act threadSet_weak_sch_act_wf | clarsimp)+ done -lemma threadGet_wp: "\\s. tcb_at' t s \ (\tcb. ko_at' tcb t s \ P (f tcb) s)\ threadGet f t \P\" +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 + apply (clarsimp simp: obj_at'_def) done lemma threadGet_const: @@ -2535,6 +3713,11 @@ lemma threadGet_const: apply (clarsimp simp: obj_at'_def) done +lemma archThreadGet_wp: + "\\s. \tcb. ko_at' tcb t s \ Q (f (tcbArch tcb)) s\ archThreadGet f t \Q\" + unfolding archThreadGet_def + by (wpsimp wp: getObject_tcb_wp simp: obj_at'_def) + schematic_goal l2BitmapSize_def': (* arch specific consequence *) "l2BitmapSize = numeral ?X" by (simp add: l2BitmapSize_def wordBits_def word_size numPriorities_def) @@ -2572,14 +3755,6 @@ lemma addToBitmap_bitmapQ: by (wpsimp simp: bitmap_fun_defs bitmapQ_def prioToL1Index_bit_set prioL2Index_bit_set simp_del: bit_exp_iff) -lemma addToBitmap_valid_queues_no_bitmap_except: -" \ valid_queues_no_bitmap_except t \ - addToBitmap d p - \\_. valid_queues_no_bitmap_except t \" - unfolding addToBitmap_def modifyReadyQueuesL1Bitmap_def modifyReadyQueuesL2Bitmap_def - getReadyQueuesL1Bitmap_def getReadyQueuesL2Bitmap_def valid_queues_no_bitmap_except_def - by (wp, clarsimp) - crunch norq[wp]: addToBitmap "\s. P (ksReadyQueues s)" (wp: updateObject_cte_inv hoare_drop_imps) crunch norq[wp]: removeFromBitmap "\s. P (ksReadyQueues s)" @@ -2611,9 +3786,8 @@ lemma prioToL1Index_complement_nth_w2p: lemma valid_bitmapQ_exceptE: "\ valid_bitmapQ_except d' p' s ; d \ d' \ p \ p' \ - \ bitmapQ d p s = (ksReadyQueues s (d, p) \ [])" - unfolding valid_bitmapQ_except_def - by blast + \ bitmapQ d p s = (\ tcbQueueEmpty (ksReadyQueues s (d, p)))" + by (fastforce simp: valid_bitmapQ_except_def) lemma invertL1Index_eq_cancelD: "\ invertL1Index i = invertL1Index j ; i < l2BitmapSize ; j < l2BitmapSize \ @@ -2727,22 +3901,15 @@ lemma addToBitmap_valid_bitmapQ_except: done lemma addToBitmap_valid_bitmapQ: -" \ valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and - (\s. ksReadyQueues s (d,p) \ []) \ - addToBitmap d p - \\_. valid_bitmapQ \" -proof - - have "\ valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and - (\s. ksReadyQueues s (d,p) \ []) \ - addToBitmap d p - \\_. valid_bitmapQ_except d p and - bitmapQ_no_L2_orphans and (\s. bitmapQ d p s \ ksReadyQueues s (d,p) \ []) \" - by (wp addToBitmap_valid_queues_no_bitmap_except addToBitmap_valid_bitmapQ_except - addToBitmap_bitmapQ_no_L2_orphans addToBitmap_bitmapQ; simp) - - thus ?thesis - by - (erule hoare_strengthen_post; fastforce elim: valid_bitmap_valid_bitmapQ_exceptE) -qed + "\valid_bitmapQ_except d p and bitmapQ_no_L2_orphans + and (\s. \ tcbQueueEmpty (ksReadyQueues s (d,p)))\ + addToBitmap d p + \\_. valid_bitmapQ\" + (is "\?pre\ _ \_\") + apply (rule_tac Q="\_ s. ?pre s \ bitmapQ d p s" in hoare_strengthen_post) + apply (wpsimp wp: addToBitmap_valid_bitmapQ_except addToBitmap_bitmapQ) + apply (fastforce elim: valid_bitmap_valid_bitmapQ_exceptE) + done 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 \" @@ -2760,12 +3927,6 @@ lemma threadGet_const_tcb_at_imp_lift: apply (clarsimp simp: obj_at'_def) done -lemma valid_queues_no_bitmap_objD: - "\ valid_queues_no_bitmap s; t \ set (ksReadyQueues s (d, p))\ - \ obj_at' (inQ d p and runnable' \ tcbState) t s" - unfolding valid_queues_no_bitmap_def - by blast - lemma setQueue_bitmapQ_no_L1_orphans[wp]: "\ bitmapQ_no_L1_orphans \ setQueue d p ts @@ -2785,126 +3946,6 @@ lemma setQueue_sets_queue[wp]: unfolding setQueue_def by (wp, simp) -lemma tcbSchedEnqueueOrAppend_valid_queues: - (* f is either (t#ts) or (ts @ [t]), so we define its properties generally *) - assumes f_set[simp]: "\ts. t \ set (f ts)" - assumes f_set_insert[simp]: "\ts. set (f ts) = insert t (set ts)" - assumes f_not_empty[simp]: "\ts. f ts \ []" - assumes f_distinct: "\ts. \ distinct ts ; t \ set ts \ \ distinct (f ts)" - shows "\Invariants_H.valid_queues and st_tcb_at' runnable' t and valid_objs' \ - do queued \ threadGet tcbQueued t; - unless queued $ - do tdom \ threadGet tcbDomain t; - prio \ threadGet tcbPriority t; - queue \ getQueue tdom prio; - setQueue tdom prio $ f queue; - when (null queue) $ addToBitmap tdom prio; - threadSet (tcbQueued_update (\_. True)) t - od - od - \\_. Invariants_H.valid_queues\" -proof - - - define could_run where "could_run == - \d p t. obj_at' (\tcb. inQ d p (tcbQueued_update (\_. True) tcb) \ runnable' (tcbState tcb)) t" - - have addToBitmap_could_run: - "\d p. \\s. \d p. t \ set (ksReadyQueues s (d, p)) \ could_run d p t s\ - addToBitmap d p - \\_ s. \d p. t \ set (ksReadyQueues s (d, p)) \ could_run d p t s\" - unfolding bitmap_fun_defs - by (wp, clarsimp simp: could_run_def) - - have setQueue_valid_queues_no_bitmap_except: - "\d p ts. - \ valid_queues_no_bitmap_except t and - (\s. ksReadyQueues s (d, p) = ts \ p \ maxPriority \ d \ maxDomain \ t \ set ts) \ - setQueue d p (f ts) - \\rv. valid_queues_no_bitmap_except t\" - unfolding setQueue_def valid_queues_no_bitmap_except_def null_def - by (wp, auto intro: f_distinct) - - have threadSet_valid_queues_could_run: - "\f. \ valid_queues_no_bitmap_except t and - (\s. \d p. t \ set (ksReadyQueues s (d,p)) \ could_run d p t s) and - valid_bitmapQ and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans \ - threadSet (tcbQueued_update (\_. True)) t - \\rv. Invariants_H.valid_queues \" - unfolding threadSet_def could_run_def - apply (rule hoare_seq_ext[OF _ getObject_tcb_sp]) - apply (rule hoare_pre) - apply (simp add: valid_queues_def valid_queues_no_bitmap_def) - apply (wp setObject_queues_unchanged_tcb hoare_Ball_helper hoare_vcg_all_lift - setObject_tcb_strongest) - apply (clarsimp simp: valid_queues_no_bitmap_except_def obj_at'_def) - done - - have setQueue_could_run: "\d p ts. - \ valid_queues and (\_. t \ set ts) and - (\s. could_run d p t s) \ - setQueue d p ts - \\rv s. (\d p. t \ set (ksReadyQueues s (d, p)) \ could_run d p t s)\" - unfolding setQueue_def valid_queues_def could_run_def - by wp (fastforce dest: valid_queues_no_bitmap_objD simp: obj_at'_def inQ_def) - - note hoare_vcg_if_lift[wp] hoare_vcg_conj_lift[wp] hoare_vcg_const_imp_lift[wp] - - show ?thesis - unfolding tcbSchedEnqueue_def null_def - apply (rule hoare_pre) - apply (rule hoare_seq_ext) - apply (simp add: unless_def) - apply (wp threadSet_valid_queues_could_run) - apply (wp addToBitmap_could_run addToBitmap_valid_bitmapQ - addToBitmap_valid_queues_no_bitmap_except addToBitmap_bitmapQ_no_L2_orphans)+ - apply (wp setQueue_valid_queues_no_bitmap_except setQueue_could_run - setQueue_valid_bitmapQ_except setQueue_sets_queue setQueue_valid_bitmapQ)+ - apply (wp threadGet_const_tcb_at_imp_lift | simp add: if_apply_def2)+ - apply clarsimp - apply (frule pred_tcb_at') - apply (frule (1) valid_objs'_maxDomain) - apply (frule (1) valid_objs'_maxPriority) - apply (clarsimp simp: valid_queues_def st_tcb_at'_def obj_at'_def valid_queues_no_bitmap_exceptI) - apply (fastforce dest!: valid_queues_no_bitmap_objD simp: obj_at'_def inQ_def could_run_def) - done -qed - -lemma tcbSchedEnqueue_valid_queues[wp]: - "\Invariants_H.valid_queues - and st_tcb_at' runnable' t - and valid_objs' \ - tcbSchedEnqueue t - \\_. Invariants_H.valid_queues\" - unfolding tcbSchedEnqueue_def - by (fastforce intro: tcbSchedEnqueueOrAppend_valid_queues) - -lemma tcbSchedAppend_valid_queues[wp]: - "\Invariants_H.valid_queues - and st_tcb_at' runnable' t - and valid_objs' \ - tcbSchedAppend t - \\_. Invariants_H.valid_queues\" - unfolding tcbSchedAppend_def - by (fastforce intro: tcbSchedEnqueueOrAppend_valid_queues) - -lemma rescheduleRequired_valid_queues[wp]: - "\\s. Invariants_H.valid_queues s \ valid_objs' s \ - weak_sch_act_wf (ksSchedulerAction s) s\ - rescheduleRequired - \\_. Invariants_H.valid_queues\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp)+ - apply (fastforce simp: weak_sch_act_wf_def elim: valid_objs'_maxDomain valid_objs'_maxPriority) - done - -lemma rescheduleRequired_valid_queues_sch_act_simple: - "\Invariants_H.valid_queues and sch_act_simple\ - rescheduleRequired - \\_. Invariants_H.valid_queues\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp | fastforce simp: Invariants_H.valid_queues_def sch_act_simple_def)+ - done - lemma rescheduleRequired_valid_bitmapQ_sch_act_simple: "\ valid_bitmapQ and sch_act_simple\ rescheduleRequired @@ -2946,151 +3987,32 @@ lemma rescheduleRequired_bitmapQ_no_L2_orphans_sch_act_simple: lemma sts_valid_bitmapQ_sch_act_simple: "\valid_bitmapQ and sch_act_simple\ - setThreadState st t - \\_. valid_bitmapQ \" + setThreadState st t + \\_. valid_bitmapQ\" 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 Invariants_H.valid_queues_def inQ_def)+ + 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 \" + "\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 Invariants_H.valid_queues_def inQ_def)+ + 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 \" + "\bitmapQ_no_L1_orphans and sch_act_simple\ + setThreadState st t + \\_. bitmapQ_no_L1_orphans\" 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 Invariants_H.valid_queues_def inQ_def)+ - done - -lemma sts_valid_queues: - "\\s. Invariants_H.valid_queues s \ - ((\p. t \ set(ksReadyQueues s p)) \ runnable' st)\ - setThreadState st t \\rv. Invariants_H.valid_queues\" - apply (simp add: setThreadState_def) - apply (wp rescheduleRequired_valid_queues_sch_act_simple - threadSet_valid_queues [THEN hoare_strengthen_post]) - apply (clarsimp simp: sch_act_simple_def Invariants_H.valid_queues_def inQ_def)+ - done - -lemma sbn_valid_queues: - "\\s. Invariants_H.valid_queues s\ - setBoundNotification ntfn t \\rv. Invariants_H.valid_queues\" - apply (simp add: setBoundNotification_def) - apply (wp threadSet_valid_queues [THEN hoare_strengthen_post]) - apply (clarsimp simp: sch_act_simple_def Invariants_H.valid_queues_def inQ_def)+ - done - - - -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]: - "\valid_queues' and st_tcb_at' runnable' t \ - tcbSchedEnqueue t - \\_. valid_queues'\" - apply (simp add: tcbSchedEnqueue_def) - apply (rule hoare_pre) - apply (rule_tac B="\rv. valid_queues' and obj_at' (\obj. tcbQueued obj = rv) t" - in hoare_seq_ext) - 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_def)+ - apply (clarsimp simp: obj_at'_def inQ_def projectKOs valid_queues'_def) - apply (wp getObject_tcb_wp | simp add: threadGet_def)+ - apply (clarsimp simp: obj_at'_def) - done - -lemma rescheduleRequired_valid_queues'_weak[wp]: - "\\s. valid_queues' s \ weak_sch_act_wf (ksSchedulerAction s) s\ - rescheduleRequired - \\_. valid_queues'\" - apply (simp add: rescheduleRequired_def) - apply wpsimp - apply (clarsimp simp: weak_sch_act_wf_def) - done - -lemma rescheduleRequired_valid_queues'_sch_act_simple: - "\valid_queues' and sch_act_simple\ - rescheduleRequired - \\_. valid_queues'\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp | fastforce simp: valid_queues'_def sch_act_simple_def)+ - done - -lemma setThreadState_valid_queues'[wp]: - "\\s. valid_queues' s\ setThreadState st t \\rv. valid_queues'\" - apply (simp add: setThreadState_def) - apply (wp rescheduleRequired_valid_queues'_sch_act_simple) - apply (rule_tac Q="\_. valid_queues'" in hoare_post_imp) - apply (clarsimp simp: sch_act_simple_def) - apply (wp threadSet_valid_queues') - apply (fastforce simp: inQ_def obj_at'_def pred_tcb_at'_def) - 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 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) - done - -lemma setThreadState_valid_objs'[wp]: - "\ valid_tcb_state' st and valid_objs' \ setThreadState st t \ \_. valid_objs' \" - apply (simp add: setThreadState_def) - apply (wp threadSet_valid_objs' | clarsimp simp: valid_tcb'_tcbState_update)+ - done - -lemma rescheduleRequired_ksQ: - "\\s. sch_act_simple s \ P (ksReadyQueues s p)\ - rescheduleRequired - \\_ s. P (ksReadyQueues s p)\" - including no_pre - apply (simp add: rescheduleRequired_def sch_act_simple_def) - apply (rule_tac B="\rv s. (rv = ResumeCurrentThread \ rv = ChooseNewThread) - \ P (ksReadyQueues s p)" in hoare_seq_ext) - apply wpsimp - apply (case_tac x; simp) - apply wp + apply (clarsimp simp: sch_act_simple_def inQ_def)+ done lemma setSchedulerAction_ksQ[wp]: @@ -3105,17 +4027,6 @@ lemma sbn_ksQ: "\\s. P (ksReadyQueues s p)\ setBoundNotification ntfn t \\rv s. P (ksReadyQueues s p)\" by (simp add: setBoundNotification_def, wp) -lemma sts_ksQ: - "\\s. sch_act_simple s \ P (ksReadyQueues s p)\ - setThreadState st t - \\_ s. P (ksReadyQueues s p)\" - apply (simp add: setThreadState_def) - apply (wp rescheduleRequired_ksQ) - apply (rule_tac Q="\_ s. P (ksReadyQueues s p)" in hoare_post_imp) - apply (clarsimp simp: sch_act_simple_def)+ - apply (wp, simp) - done - lemma setQueue_ksQ[wp]: "\\s. P ((ksReadyQueues s)((d, p) := q))\ setQueue d p q @@ -3123,22 +4034,6 @@ lemma setQueue_ksQ[wp]: by (simp add: setQueue_def fun_upd_def[symmetric] | wp)+ -lemma tcbSchedEnqueue_ksQ: - "\\s. t' \ set (ksReadyQueues s p) \ t' \ t \ - tcbSchedEnqueue t \\_ s. t' \ set (ksReadyQueues s p)\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wpsimp wp: hoare_vcg_imp_lift threadGet_wp) - apply (drule obj_at_ko_at') - apply fastforce - done - -lemma rescheduleRequired_ksQ': - "\\s. t \ set (ksReadyQueues s p) \ sch_act_not t s \ - rescheduleRequired \\_ s. t \ set (ksReadyQueues s p)\" - apply (simp add: rescheduleRequired_def) - apply (wpsimp wp: tcbSchedEnqueue_ksQ) - done - lemma threadSet_tcbState_st_tcb_at': "\\s. P st \ threadSet (tcbState_update (\_. st)) t \\_. st_tcb_at' P t\" apply (simp add: threadSet_def pred_tcb_at'_def) @@ -3149,36 +4044,6 @@ lemma isRunnable_const: "\st_tcb_at' runnable' t\ isRunnable t \\runnable _. runnable \" by (rule isRunnable_wp) -lemma sts_ksQ': - "\\s. (runnable' st \ ksCurThread s \ t) \ P (ksReadyQueues s p)\ - setThreadState st t - \\_ s. P (ksReadyQueues s p)\" - apply (simp add: setThreadState_def) - apply (rule hoare_pre_disj') - apply (rule hoare_seq_ext [OF _ - hoare_vcg_conj_lift - [OF threadSet_tcbState_st_tcb_at' [where P=runnable'] - threadSet_ksQ]]) - apply (rule hoare_seq_ext [OF _ - hoare_vcg_conj_lift [OF isRunnable_const isRunnable_inv]]) - apply (clarsimp simp: when_def) - apply (case_tac x) - apply (clarsimp, wp)[1] - apply (clarsimp) - apply (rule hoare_seq_ext [OF _ - hoare_vcg_conj_lift - [OF threadSet_ct threadSet_ksQ]]) - apply (rule hoare_seq_ext [OF _ isRunnable_inv]) - apply (rule hoare_seq_ext [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 valid_ipc_buffer_ptr'D: assumes yv: "y < unat max_ipc_words" and buf: "valid_ipc_buffer_ptr' a s" @@ -3296,14 +4161,16 @@ lemmas msgRegisters_unfold unfolded toEnum_def enum_register, simplified] lemma getMRs_corres: - "corres (=) (tcb_at t) - (tcb_at' t and case_option \ valid_ipc_buffer_ptr' buf) + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) + (case_option \ valid_ipc_buffer_ptr' buf) (get_mrs t buf mi) (getMRs t buf (message_info_map mi))" proof - have S: "get = gets id" by (simp add: gets_def) - have T: "corres (\con regs. regs = map con msg_registers) (tcb_at t) (tcb_at' t) - (thread_get (arch_tcb_get_registers o tcb_arch) t) (asUser t (mapM getRegister ARM_HYP_H.msgRegisters))" + have T: "corres (\con regs. regs = map con msg_registers) + (tcb_at t and pspace_aligned and pspace_distinct) \ + (thread_get (arch_tcb_get_registers o tcb_arch) t) + (asUser t (mapM getRegister ARM_HYP_H.msgRegisters))" unfolding arch_tcb_get_registers_def apply (subst thread_get_as_user) apply (rule asUser_corres') @@ -3387,8 +4254,8 @@ lemma storeWordUser_valid_ipc_buffer_ptr' [wp]: lemma setMRs_corres: assumes m: "mrs' = mrs" shows - "corres (=) (tcb_at t and case_option \ in_user_frame buf) - (tcb_at' t and case_option \ valid_ipc_buffer_ptr' buf) + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct and case_option \ in_user_frame buf) + (case_option \ valid_ipc_buffer_ptr' buf) (set_mrs t buf mrs) (setMRs t buf mrs')" proof - have setRegister_def2: "setRegister = (\r v. modify (\s. s ( r := v )))" @@ -3448,14 +4315,12 @@ proof - qed lemma copyMRs_corres: - "corres (=) (tcb_at s and tcb_at r - and case_option \ in_user_frame sb - and case_option \ in_user_frame rb - and K (unat n \ msg_max_length)) - (tcb_at' s and tcb_at' r - and case_option \ valid_ipc_buffer_ptr' sb - and case_option \ valid_ipc_buffer_ptr' rb) - (copy_mrs s sb r rb n) (copyMRs s sb r rb n)" + "corres (=) + (tcb_at s and tcb_at r and pspace_aligned and pspace_distinct + and case_option \ in_user_frame sb and case_option \ in_user_frame rb + and K (unat n \ msg_max_length)) + (case_option \ valid_ipc_buffer_ptr' sb and case_option \ valid_ipc_buffer_ptr' rb) + (copy_mrs s sb r rb n) (copyMRs s sb r rb n)" proof - have U: "unat n \ msg_max_length \ map (toEnum :: nat \ word32) [7 ..< Suc (unat n)] = map of_nat [7 ..< Suc (unat n)]" @@ -3464,7 +4329,7 @@ proof - note R=R'[simplified] have as_user_bit: - "\v :: word32. corres dc (tcb_at s and tcb_at r) (tcb_at' s and tcb_at' r) + "\v :: word32. corres dc (tcb_at s and tcb_at r and pspace_aligned and pspace_distinct) \ (mapM (\ra. do v \ as_user s (getRegister ra); as_user r (setRegister ra v) @@ -3607,10 +4472,12 @@ qed lemmas valid_ipc_buffer_cap_simps = valid_ipc_buffer_cap_def [split_simps cap.split arch_cap.split] lemma lookupIPCBuffer_corres': - "corres (=) (tcb_at t and valid_objs and pspace_aligned) - (tcb_at' t and valid_objs' and pspace_aligned' - and pspace_distinct' and no_0_obj') - (lookup_ipc_buffer w t) (lookupIPCBuffer w t)" + "corres (=) + (tcb_at t and valid_objs and pspace_aligned and pspace_distinct) + (valid_objs' and no_0_obj') + (lookup_ipc_buffer w t) (lookupIPCBuffer w t)" + apply (rule corres_cross_add_guard[where Q'="pspace_aligned' and pspace_distinct'"]) + apply (fastforce simp: pspace_aligned_cross pspace_distinct_cross state_relation_def) apply (simp add: lookup_ipc_buffer_def ARM_HYP_H.lookupIPCBuffer_def) apply (rule corres_guard_imp) apply (rule corres_split_eqr[OF threadGet_corres]) @@ -3653,13 +4520,11 @@ lemma lookupIPCBuffer_corres': done lemma lookupIPCBuffer_corres: - "corres (=) (tcb_at t and invs) - (tcb_at' t and invs') - (lookup_ipc_buffer w t) (lookupIPCBuffer w t)" + "corres (=) (tcb_at t and invs) (valid_objs' and no_0_obj') + (lookup_ipc_buffer w t) (lookupIPCBuffer w t)" using lookupIPCBuffer_corres' by (rule corres_guard_imp, auto simp: invs'_def valid_state'_def) - crunch inv[wp]: lookupIPCBuffer P crunch pred_tcb_at'[wp]: rescheduleRequired "pred_tcb_at' proj P t" @@ -3719,7 +4584,7 @@ lemma ct_in_state'_set: crunches setQueue, rescheduleRequired, tcbSchedDequeue for idle'[wp]: "valid_idle'" - (simp: crunch_simps ) + (simp: crunch_simps wp: crunch_wps) lemma sts_valid_idle'[wp]: "\valid_idle' and valid_pspace' and @@ -3759,8 +4624,9 @@ lemma gbn_sp': lemma tcbSchedDequeue_tcbState_obj_at'[wp]: "\obj_at' (P \ tcbState) t'\ tcbSchedDequeue t \\rv. obj_at' (P \ tcbState) t'\" - apply (simp add: tcbSchedDequeue_def) - apply (wp | simp add: o_def split del: if_split cong: if_cong)+ + apply (simp add: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wpsimp wp: getObject_tcb_wp simp: o_def threadGet_def) + apply (clarsimp simp: obj_at'_def) done crunch typ_at'[wp]: setQueue "\s. P' (typ_at' P t s)" @@ -3779,10 +4645,14 @@ lemma setQueue_pred_tcb_at[wp]: lemma tcbSchedDequeue_pred_tcb_at'[wp]: "\\s. P' (pred_tcb_at' proj P t' s)\ tcbSchedDequeue t \\_ s. P' (pred_tcb_at' proj P t' s)\" apply (rule_tac P=P' in P_bool_lift) - apply (simp add: tcbSchedDequeue_def) - apply (wp threadSet_pred_tcb_no_state | clarsimp simp: tcb_to_itcb'_def)+ - apply (simp add: tcbSchedDequeue_def) - apply (wp threadSet_pred_tcb_no_state | clarsimp simp: tcb_to_itcb'_def)+ + apply (simp add: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wpsimp wp: threadSet_pred_tcb_no_state getObject_tcb_wp + simp: threadGet_def tcb_to_itcb'_def) + apply (clarsimp simp: obj_at'_def) + apply (simp add: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wpsimp wp: threadSet_pred_tcb_no_state getObject_tcb_wp + simp: threadGet_def tcb_to_itcb'_def) + apply (clarsimp simp: obj_at'_def) done lemma sts_st_tcb': @@ -3896,38 +4766,155 @@ crunch nonz_cap[wp]: addToBitmap "ex_nonz_cap_to' t" crunch iflive'[wp]: removeFromBitmap if_live_then_nonz_cap' crunch nonz_cap[wp]: removeFromBitmap "ex_nonz_cap_to' t" -lemma tcbSchedEnqueue_iflive'[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' tcb\ - tcbSchedEnqueue tcb \\_. if_live_then_nonz_cap'\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wp threadSet_iflive' hoare_drop_imps | simp add: crunch_simps)+ +crunches rescheduleRequired + for cap_to'[wp]: "ex_nonz_cap_to' p" + +lemma tcbQueued_update_tcb_cte_cases: + "(getF, setF) \ ran tcb_cte_cases \ getF (tcbQueued_update f tcb) = getF tcb" + unfolding tcb_cte_cases_def + by (case_tac tcb; fastforce simp: objBits_simps') + +lemma tcbSchedNext_update_tcb_cte_cases: + "(getF, setF) \ ran tcb_cte_cases \ getF (tcbSchedNext_update f tcb) = getF tcb" + unfolding tcb_cte_cases_def + by (case_tac tcb; fastforce simp: objBits_simps') + +lemma tcbSchedPrev_update_tcb_cte_cases: + "(getF, setF) \ ran tcb_cte_cases \ getF (tcbSchedPrev_update f tcb) = getF tcb" + unfolding tcb_cte_cases_def + by (case_tac tcb; fastforce simp: objBits_simps') + +lemma tcbSchedNext_update_ctes_of[wp]: + "threadSet (tcbSchedNext_update f) tptr \\s. P (ctes_of s)\" + by (wpsimp wp: threadSet_ctes_ofT simp: tcbSchedNext_update_tcb_cte_cases) + +lemma tcbSchedPrev_update_ctes_of[wp]: + "threadSet (tcbSchedPrev_update f) tptr \\s. P (ctes_of s)\" + by (wpsimp wp: threadSet_ctes_ofT simp: tcbSchedPrev_update_tcb_cte_cases) + +lemma tcbSchedNext_ex_nonz_cap_to'[wp]: + "threadSet (tcbSchedNext_update f) tptr \ex_nonz_cap_to' p\" + by (wpsimp wp: threadSet_cap_to simp: tcbSchedNext_update_tcb_cte_cases) + +lemma tcbSchedPrev_ex_nonz_cap_to'[wp]: + "threadSet (tcbSchedPrev_update f) tptr \ex_nonz_cap_to' p\" + by (wpsimp wp: threadSet_cap_to simp: tcbSchedPrev_update_tcb_cte_cases) + +lemma tcbSchedNext_update_iflive': + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' t s\ + threadSet (tcbSchedNext_update f) t + \\_. if_live_then_nonz_cap'\" + by (wpsimp wp: threadSet_iflive'T simp: tcbSchedNext_update_tcb_cte_cases) + +lemma tcbSchedPrev_update_iflive': + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' t s\ + threadSet (tcbSchedPrev_update f) t + \\_. if_live_then_nonz_cap'\" + by (wpsimp wp: threadSet_iflive'T simp: tcbSchedPrev_update_tcb_cte_cases) + +lemma tcbQueued_update_iflive'[wp]: + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' t s\ + threadSet (tcbQueued_update f) t + \\_. if_live_then_nonz_cap'\" + by (wpsimp wp: threadSet_iflive'T simp: tcbQueued_update_tcb_cte_cases) + +lemma getTCB_wp: + "\\s. \ko :: tcb. ko_at' ko p s \ Q ko s\ getObject p \Q\" + apply (wpsimp wp: getObject_tcb_wp) + apply (clarsimp simp: obj_at'_def) done -lemma rescheduleRequired_iflive'[wp]: - "\if_live_then_nonz_cap' - and (\s. \t. ksSchedulerAction s = SwitchToThread t - \ st_tcb_at' runnable' t s)\ - rescheduleRequired - \\rv. if_live_then_nonz_cap'\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp)+ - apply (clarsimp simp: pred_tcb_at'_def obj_at'_real_def) - apply (erule(1) if_live_then_nonz_capD') - apply (fastforce simp: projectKOs live'_def) +lemma tcbQueueRemove_if_live_then_nonz_cap': + "\if_live_then_nonz_cap' and valid_objs' and sym_heap_sched_pointers and ex_nonz_cap_to' tcbPtr\ + tcbQueueRemove q tcbPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbQueueRemove_def + apply (wpsimp wp: tcbSchedPrev_update_iflive' tcbSchedNext_update_iflive' + hoare_vcg_imp_lift' getTCB_wp) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + by (force dest: sym_heapD2[where p'=tcbPtr] sym_heapD1[where p=tcbPtr] + elim: if_live_then_nonz_capE' + simp: valid_tcb'_def opt_map_def obj_at'_def projectKOs + ko_wp_at'_def opt_tcb_at'_def live'_def) + +lemma tcbQueueRemove_ex_nonz_cap_to'[wp]: + "tcbQueueRemove q tcbPtr \ex_nonz_cap_to' tcbPtr'\" + unfolding tcbQueueRemove_def + by (wpsimp wp: threadSet_cap_to' hoare_drop_imps getTCB_wp) + +(* We could write this one as "\t. tcbQueueHead t \ ..." instead, but we can't do the same in + tcbQueueAppend_if_live_then_nonz_cap', and it's nicer if the two lemmas are symmetric *) +lemma tcbQueuePrepend_if_live_then_nonz_cap': + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' tcbPtr s + \ (\ tcbQueueEmpty q \ ex_nonz_cap_to' (the (tcbQueueHead q)) s)\ + tcbQueuePrepend q tcbPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbQueuePrepend_def + by (wpsimp wp: tcbSchedPrev_update_iflive' tcbSchedNext_update_iflive' + hoare_vcg_if_lift2 hoare_vcg_imp_lift') + +lemma tcbQueueAppend_if_live_then_nonz_cap': + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' tcbPtr s + \ (\ tcbQueueEmpty q \ ex_nonz_cap_to' (the (tcbQueueEnd q)) s)\ + tcbQueueAppend q tcbPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbQueueAppend_def + by (wpsimp wp: tcbSchedPrev_update_iflive' tcbSchedNext_update_iflive') + +lemma tcbQueueInsert_if_live_then_nonz_cap': + "\if_live_then_nonz_cap' and ex_nonz_cap_to' tcbPtr and valid_objs' and sym_heap_sched_pointers\ + tcbQueueInsert tcbPtr afterPtr + \\_. if_live_then_nonz_cap'\" + supply projectKOs[simp] + unfolding tcbQueueInsert_def + apply (wpsimp wp: tcbSchedPrev_update_iflive' tcbSchedNext_update_iflive' getTCB_wp) + apply (intro conjI) + apply (erule if_live_then_nonz_capE') + apply (clarsimp simp: ko_wp_at'_def obj_at'_def live'_def) + apply (erule if_live_then_nonz_capE') + apply (frule_tac p'=afterPtr in sym_heapD2) + apply (fastforce simp: opt_map_def obj_at'_def) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (clarsimp simp: valid_tcb'_def ko_wp_at'_def obj_at'_def opt_map_def live'_def) + done + +lemma tcbSchedEnqueue_iflive'[wp]: + "\if_live_then_nonz_cap' and pspace_aligned' and pspace_distinct'\ + tcbSchedEnqueue tcbPtr + \\_. if_live_then_nonz_cap'\" + supply projectKOs[simp] + unfolding tcbSchedEnqueue_def + apply (wpsimp wp: tcbQueuePrepend_if_live_then_nonz_cap' threadGet_wp) + apply normalise_obj_at' + apply (rename_tac tcb) + apply (frule_tac p=tcbPtr in if_live_then_nonz_capE') + apply (fastforce simp: ko_wp_at'_def obj_at'_def live'_def) + apply clarsimp + apply (erule if_live_then_nonz_capE') + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (fastforce dest!: obj_at'_tcbQueueHead_ksReadyQueues + simp: ko_wp_at'_def inQ_def opt_pred_def opt_map_def obj_at'_def live'_def + split: option.splits) done +crunches rescheduleRequired + for iflive'[wp]: if_live_then_nonz_cap' + lemma sts_iflive'[wp]: "\\s. if_live_then_nonz_cap' s - \ (st \ Inactive \ \ idle' st \ ex_nonz_cap_to' t s)\ + \ (st \ Inactive \ \ idle' st \ ex_nonz_cap_to' t s) + \ pspace_aligned' s \ pspace_distinct' s\ setThreadState st t \\rv. if_live_then_nonz_cap'\" apply (simp add: setThreadState_def setQueue_def) - apply (rule hoare_pre) - apply (wp | simp)+ - apply (rule_tac Q="\rv. if_live_then_nonz_cap'" in hoare_post_imp) - apply clarsimp - apply (wp threadSet_iflive' | simp)+ - apply auto + 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 done lemma sbn_iflive'[wp]: @@ -4046,6 +5033,19 @@ lemma setBoundNotification_vms'[wp]: apply (intro hoare_vcg_all_lift hoare_vcg_disj_lift; wp) done +lemma threadSet_ct_not_inQ: + "(\tcb. tcbQueued tcb = tcbQueued (F tcb)) + \ threadSet F tcbPtr \\s. P (ct_not_inQ s)\" + supply projectKOs[simp] + unfolding threadSet_def + apply (wpsimp wp: getTCB_wp simp: setObject_def updateObject_default_def) + apply (erule rsubst[where P=P]) + by (fastforce simp: ct_not_inQ_def obj_at'_def objBits_simps ps_clear_def split: if_splits) + +crunches tcbQueuePrepend, tcbQueueAppend, tcbQueueInsert, tcbQueueRemove, addToBitmap + for ct_not_inQ[wp]: ct_not_inQ + (wp: threadSet_ct_not_inQ crunch_wps) + lemma tcbSchedEnqueue_ct_not_inQ: "\ct_not_inQ and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ tcbSchedEnqueue t \\_. ct_not_inQ\" @@ -4069,12 +5069,7 @@ lemma tcbSchedEnqueue_ct_not_inQ: done show ?thesis apply (simp add: tcbSchedEnqueue_def unless_def null_def) - apply (wp ts sq hoare_convert_imp [OF addToBitmap_nosch addToBitmap_ct'])+ - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, clarsimp) - apply (wp sq hoare_convert_imp [OF setQueue_nosch setQueue_ct])+ - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, clarsimp) - apply wp - apply assumption + apply (wpsimp wp: ts sq hoare_vcg_imp_lift' getTCB_wp simp: threadGet_def)+ done qed @@ -4101,12 +5096,7 @@ lemma tcbSchedAppend_ct_not_inQ: done show ?thesis apply (simp add: tcbSchedAppend_def unless_def null_def) - apply (wp ts sq hoare_convert_imp [OF addToBitmap_nosch addToBitmap_ct'])+ - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, clarsimp) - apply (wp sq hoare_convert_imp [OF setQueue_nosch setQueue_ct])+ - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, clarsimp) - apply wp - apply assumption + apply (wpsimp wp: ts sq hoare_vcg_imp_lift' getTCB_wp simp: threadGet_def)+ done qed @@ -4135,12 +5125,10 @@ lemma rescheduleRequired_sa_cnt[wp]: lemma possibleSwitchTo_ct_not_inQ: "\ct_not_inQ and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ possibleSwitchTo t \\_. ct_not_inQ\" - (is "\?PRE\ _ \_\") apply (simp add: possibleSwitchTo_def curDomain_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) + | (rule hoare_post_imp[OF _ rescheduleRequired_sa_cnt], fastforce))+ done lemma threadSet_tcbState_update_ct_not_inQ[wp]: @@ -4220,29 +5208,6 @@ lemma tcbSchedDequeue_ct_not_inQ[wp]: done qed -lemma tcbSchedEnqueue_not_st: - "(\tcb st qd. P (tcb\tcbState := st, tcbQueued := qd\) \ P tcb) - \ \obj_at' P t'\ tcbSchedEnqueue t \\_. obj_at' P t'\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wp threadGet_wp | simp)+ - apply (clarsimp simp: obj_at'_def) - apply (case_tac obja) - apply fastforce - done - -lemma setThreadState_not_st: - "(\tcb st qd. P (tcb\tcbState := st, tcbQueued := qd\) \ P tcb) - \ \obj_at' P t'\ setThreadState st t \\_. obj_at' P t'\" - apply (simp add: setThreadState_def rescheduleRequired_def) - apply (wp hoare_vcg_conj_lift tcbSchedEnqueue_not_st - | wpc - | rule hoare_drop_imps - | simp)+ - apply (clarsimp simp: obj_at'_def) - apply (case_tac obj) - apply fastforce - done - crunch ct_idle_or_in_cur_domain'[wp]: setQueue ct_idle_or_in_cur_domain' (simp: ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) @@ -4271,17 +5236,8 @@ lemma removeFromBitmap_ct_idle_or_in_cur_domain'[wp]: | clarsimp simp: updateObject_default_def in_monad setNotification_def)+ done -lemma tcbSchedEnqueue_ksCurDomain[wp]: - "\ \s. P (ksCurDomain s)\ tcbSchedEnqueue tptr \\_ s. P (ksCurDomain s)\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply wpsimp - done - -lemma tcbSchedEnqueue_ksDomSchedule[wp]: - "\ \s. P (ksDomSchedule s)\ tcbSchedEnqueue tptr \\_ s. P (ksDomSchedule s)\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply wpsimp - done +crunches tcbQueuePrepend + for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' lemma tcbSchedEnqueue_ct_idle_or_in_cur_domain'[wp]: "\ct_idle_or_in_cur_domain'\ tcbSchedEnqueue tptr \\_. ct_idle_or_in_cur_domain'\" @@ -4359,12 +5315,385 @@ lemma sts_utr[wp]: apply (wp untyped_ranges_zero_lift) done +lemma removeFromBitmap_bitmapQ: + "\\\ removeFromBitmap d p \\_ s. \ bitmapQ d p s \" + unfolding bitmapQ_defs bitmap_fun_defs + by (wpsimp simp: bitmap_fun_defs) + +lemma removeFromBitmap_valid_bitmapQ[wp]: + "\valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans + and (\s. tcbQueueEmpty (ksReadyQueues s (d,p)))\ + removeFromBitmap d p + \\_. valid_bitmapQ\" + (is "\?pre\ _ \_\") + apply (rule_tac Q="\_ s. ?pre s \ \ bitmapQ d p s" in hoare_strengthen_post) + apply (wpsimp wp: removeFromBitmap_valid_bitmapQ_except removeFromBitmap_bitmapQ) + apply (fastforce elim: valid_bitmap_valid_bitmapQ_exceptE) + done + +crunches tcbSchedDequeue + for bitmapQ_no_L1_orphans[wp]: bitmapQ_no_L1_orphans + and bitmapQ_no_L2_orphans[wp]: bitmapQ_no_L2_orphans + (wp: crunch_wps simp: crunch_simps) + +lemma setQueue_nonempty_valid_bitmapQ': + "\\s. valid_bitmapQ s \ \ tcbQueueEmpty (ksReadyQueues s (d, p))\ + setQueue d p queue + \\_ s. \ tcbQueueEmpty queue \ valid_bitmapQ s\" + apply (wpsimp simp: setQueue_def) + apply (fastforce simp: valid_bitmapQ_def bitmapQ_def) + done + +lemma threadSet_valid_bitmapQ_except[wp]: + "threadSet f tcbPtr \valid_bitmapQ_except d p\" + unfolding threadSet_def + apply (wpsimp wp: getTCB_wp simp: setObject_def updateObject_default_def) + apply (clarsimp simp: valid_bitmapQ_except_def bitmapQ_def) + done + +lemma threadSet_bitmapQ: + "threadSet F t \bitmapQ domain priority\" + unfolding threadSet_def + apply (wpsimp wp: getTCB_wp simp: setObject_def updateObject_default_def) + by (clarsimp simp: bitmapQ_def) + +crunches tcbQueueRemove, tcbQueuePrepend, tcbQueueAppend + for valid_bitmapQ_except[wp]: "valid_bitmapQ_except d p" + and valid_bitmapQ[wp]: valid_bitmapQ + and bitmapQ[wp]: "bitmapQ tdom prio" + (wp: crunch_wps) + +lemma tcbQueued_imp_queue_nonempty: + "\list_queue_relation ts (ksReadyQueues s (tcbDomain tcb, tcbPriority tcb)) nexts prevs; + \t. t \ set ts \ (inQ (tcbDomain tcb) (tcbPriority tcb) |< tcbs_of' s) t; + ko_at' tcb tcbPtr s; tcbQueued tcb\ + \ \ tcbQueueEmpty (ksReadyQueues s (tcbDomain tcb, tcbPriority tcb))" + supply projectKOs[simp] + apply (clarsimp simp: list_queue_relation_def tcbQueueEmpty_def) + apply (drule_tac x=tcbPtr in spec) + apply (fastforce dest: heap_path_head simp: inQ_def opt_map_def opt_pred_def obj_at'_def) + done + +lemma tcbSchedDequeue_valid_bitmapQ[wp]: + "\valid_bitmaps\ tcbSchedDequeue tcbPtr \\_. valid_bitmapQ\" + unfolding tcbSchedDequeue_def tcbQueueRemove_def + apply (wpsimp wp: setQueue_nonempty_valid_bitmapQ' hoare_vcg_conj_lift + hoare_vcg_if_lift2 hoare_vcg_const_imp_lift threadGet_wp + | wp (once) hoare_drop_imps)+ + by (fastforce dest!: tcbQueued_imp_queue_nonempty + simp: ready_queue_relation_def ksReadyQueues_asrt_def obj_at'_def) + +lemma tcbSchedDequeue_valid_bitmaps[wp]: + "tcbSchedDequeue tcbPtr \valid_bitmaps\" + by (wpsimp simp: valid_bitmaps_def) + +lemma setQueue_valid_bitmapQ': (* enqueue only *) + "\valid_bitmapQ_except d p and bitmapQ d p and K (\ tcbQueueEmpty q)\ + setQueue d p q + \\_. valid_bitmapQ\" + unfolding setQueue_def bitmapQ_defs + by (wpsimp simp: bitmapQ_def) + +lemma tcbSchedEnqueue_valid_bitmapQ[wp]: + "\valid_bitmaps\ tcbSchedEnqueue tcbPtr \\_. valid_bitmapQ\" + supply if_split[split del] + unfolding tcbSchedEnqueue_def + apply (wpsimp simp: tcbQueuePrepend_def + wp: setQueue_valid_bitmapQ' addToBitmap_valid_bitmapQ_except addToBitmap_bitmapQ + threadGet_wp) + apply (fastforce simp: valid_bitmaps_def valid_bitmapQ_def tcbQueueEmpty_def split: if_splits) + done + +crunches tcbSchedEnqueue, tcbSchedAppend + for bitmapQ_no_L1_orphans[wp]: bitmapQ_no_L1_orphans + and bitmapQ_no_L2_orphans[wp]: bitmapQ_no_L2_orphans + +lemma tcbSchedEnqueue_valid_bitmaps[wp]: + "tcbSchedEnqueue tcbPtr \valid_bitmaps\" + unfolding valid_bitmaps_def + apply wpsimp + apply (clarsimp simp: valid_bitmaps_def) + done + +crunches rescheduleRequired, threadSet, setThreadState + for valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift) + +lemma tcbSchedEnqueue_valid_sched_pointers[wp]: + "tcbSchedEnqueue tcbPtr \valid_sched_pointers\" + supply projectKOs[simp] + apply (clarsimp simp: tcbSchedEnqueue_def getQueue_def unless_def) + \ \we step forwards until we can step over the addToBitmap in order to avoid state blow-up\ + apply (intro hoare_seq_ext[OF _ stateAssert_sp] hoare_seq_ext[OF _ isRunnable_inv] + hoare_seq_ext[OF _ assert_sp] hoare_seq_ext[OF _ threadGet_sp] + hoare_seq_ext[OF _ gets_sp] + | rule hoare_when_cases, fastforce)+ + apply (forward_inv_step wp: hoare_vcg_ex_lift) + supply if_split[split del] + apply (wpsimp wp: getTCB_wp + simp: threadSet_def setObject_def updateObject_default_def tcbQueuePrepend_def + setQueue_def) + apply (clarsimp simp: valid_sched_pointers_def) + apply (intro conjI impI) + apply (fastforce simp: opt_pred_def opt_map_def split: if_splits) + apply normalise_obj_at' + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (clarsimp simp: valid_sched_pointers_def list_queue_relation_def) + apply (case_tac "ts = []", fastforce simp: tcbQueueEmpty_def) + by (intro conjI impI; + force dest!: hd_in_set heap_path_head + simp: inQ_def opt_pred_def opt_map_def obj_at'_def split: if_splits) + +lemma tcbSchedAppend_valid_sched_pointers[wp]: + "tcbSchedAppend tcbPtr \valid_sched_pointers\" + supply projectKOs[simp] + apply (clarsimp simp: tcbSchedAppend_def getQueue_def unless_def) + \ \we step forwards until we can step over the addToBitmap in order to avoid state blow-up\ + apply (intro hoare_seq_ext[OF _ stateAssert_sp] hoare_seq_ext[OF _ isRunnable_inv] + hoare_seq_ext[OF _ assert_sp] hoare_seq_ext[OF _ threadGet_sp] + hoare_seq_ext[OF _ gets_sp] + | rule hoare_when_cases, fastforce)+ + apply (forward_inv_step wp: hoare_vcg_ex_lift) + supply if_split[split del] + apply (wpsimp wp: getTCB_wp + simp: threadSet_def setObject_def updateObject_default_def tcbQueueAppend_def + setQueue_def) + apply (clarsimp simp: valid_sched_pointers_def) + apply (intro conjI impI) + apply (fastforce simp: opt_pred_def opt_map_def split: if_splits) + apply normalise_obj_at' + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + by (intro conjI impI; + clarsimp dest: last_in_set + simp: valid_sched_pointers_def opt_map_def list_queue_relation_def tcbQueueEmpty_def + queue_end_valid_def inQ_def opt_pred_def obj_at'_def + split: if_splits option.splits; + fastforce) + +lemma tcbSchedDequeue_valid_sched_pointers[wp]: + "\valid_sched_pointers and sym_heap_sched_pointers\ + tcbSchedDequeue tcbPtr + \\_. valid_sched_pointers\" + supply if_split[split del] fun_upd_apply[simp del] projectKOs[simp] + apply (clarsimp simp: tcbSchedDequeue_def getQueue_def setQueue_def) + apply (wpsimp wp: threadSet_wp getTCB_wp threadGet_wp simp: tcbQueueRemove_def) + apply normalise_obj_at' + apply (rename_tac tcb) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (clarsimp split: if_splits) + apply (frule (1) list_queue_relation_neighbour_in_set[where p=tcbPtr]) + apply (fastforce simp: inQ_def opt_pred_def opt_map_def obj_at'_def) + apply (clarsimp simp: list_queue_relation_def) + apply (intro conjI impI) + \ \the ready queue is the singleton consisting of tcbPtr\ + apply (clarsimp simp: valid_sched_pointers_def) + apply (case_tac "ptr = tcbPtr") + apply (force dest!: heap_ls_last_None + simp: prev_queue_head_def queue_end_valid_def inQ_def opt_map_def obj_at'_def) + apply (simp add: fun_upd_def opt_pred_def) + \ \tcbPtr is the head of the ready queue\ + subgoal + by (auto dest!: heap_ls_last_None + simp: valid_sched_pointers_def fun_upd_apply prev_queue_head_def + inQ_def opt_pred_def opt_map_def obj_at'_def + split: if_splits option.splits) + \ \tcbPtr is the end of the ready queue\ + subgoal + by (auto dest!: heap_ls_last_None + simp: valid_sched_pointers_def queue_end_valid_def inQ_def opt_pred_def + opt_map_def fun_upd_apply obj_at'_def + split: if_splits option.splits) + \ \tcbPtr is in the middle of the ready queue\ + apply (intro conjI impI allI) + by (clarsimp simp: valid_sched_pointers_def inQ_def opt_pred_def opt_map_def fun_upd_apply obj_at'_def + split: if_splits option.splits; + auto) + +lemma tcbQueueRemove_sym_heap_sched_pointers: + "\\s. sym_heap_sched_pointers s + \ (\ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ tcbPtr \ set ts)\ + tcbQueueRemove q tcbPtr + \\_. sym_heap_sched_pointers\" + supply projectKOs[simp] + supply heap_path_append[simp del] + apply (clarsimp simp: tcbQueueRemove_def) + apply (wpsimp wp: threadSet_wp getTCB_wp) + apply (rename_tac tcb ts) + + \ \tcbPtr is the head of q, which is not a singleton\ + apply (rule conjI) + apply clarsimp + apply (clarsimp simp: list_queue_relation_def Let_def) + apply (prop_tac "tcbSchedNext tcb \ Some tcbPtr") + apply (fastforce dest: heap_ls_no_loops[where p=tcbPtr] simp: opt_map_def obj_at'_def) + apply (fastforce intro: sym_heap_remove_only' + simp: prev_queue_head_def opt_map_red opt_map_upd_triv obj_at'_def) + + \ \tcbPtr is the end of q, which is not a singleton\ + apply (intro impI) + apply (rule conjI) + apply clarsimp + apply (prop_tac "tcbSchedPrev tcb \ Some tcbPtr") + apply (fastforce dest!: heap_ls_prev_no_loops[where p=tcbPtr] + simp: list_queue_relation_def opt_map_def obj_at'_def) + apply (subst fun_upd_swap, fastforce) + apply (fastforce intro: sym_heap_remove_only simp: opt_map_red opt_map_upd_triv obj_at'_def) + + \ \tcbPtr is in the middle of q\ + apply (intro conjI impI allI) + apply (frule (2) list_queue_relation_neighbour_in_set[where p=tcbPtr]) + apply (frule split_list) + apply clarsimp + apply (rename_tac xs ys) + apply (prop_tac "xs \ [] \ ys \ []") + apply (fastforce simp: list_queue_relation_def queue_end_valid_def) + apply (clarsimp simp: list_queue_relation_def) + apply (frule (3) ptr_in_middle_prev_next) + apply (frule heap_ls_distinct) + apply (rename_tac afterPtr beforePtr xs ys) + apply (frule_tac before=beforePtr and middle=tcbPtr and after=afterPtr + in sym_heap_remove_middle_from_chain) + apply (fastforce dest: last_in_set simp: opt_map_def obj_at'_def) + apply (fastforce dest: hd_in_set simp: opt_map_def obj_at'_def) + apply (rule_tac hp="tcbSchedNexts_of s" in sym_heapD2) + apply fastforce + apply (fastforce simp: opt_map_def obj_at'_def) + apply (fastforce simp: opt_map_def obj_at'_def) + apply (fastforce simp: fun_upd_swap opt_map_red opt_map_upd_triv obj_at'_def split: if_splits) + done + +lemma tcbQueuePrepend_sym_heap_sched_pointers: + "\\s. sym_heap_sched_pointers s + \ (\ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ tcbPtr \ set ts) + \ tcbSchedNexts_of s tcbPtr = None \ tcbSchedPrevs_of s tcbPtr = None\ + tcbQueuePrepend q tcbPtr + \\_. sym_heap_sched_pointers\" + supply projectKOs[simp] + supply if_split[split del] + apply (clarsimp simp: tcbQueuePrepend_def) + apply (wpsimp wp: threadSet_wp) + apply (prop_tac "tcbPtr \ the (tcbQueueHead q)") + apply (case_tac "ts = []"; + fastforce dest: heap_path_head simp: list_queue_relation_def tcbQueueEmpty_def) + apply (drule_tac a=tcbPtr and b="the (tcbQueueHead q)" in sym_heap_connect) + apply assumption + apply (clarsimp simp: list_queue_relation_def prev_queue_head_def tcbQueueEmpty_def) + apply (fastforce simp: fun_upd_swap opt_map_red opt_map_upd_triv obj_at'_def tcbQueueEmpty_def) + done + +lemma tcbQueueInsert_sym_heap_sched_pointers: + "\\s. sym_heap_sched_pointers s + \ tcbSchedNexts_of s tcbPtr = None \ tcbSchedPrevs_of s tcbPtr = None\ + tcbQueueInsert tcbPtr afterPtr + \\_. sym_heap_sched_pointers\" + supply projectKOs[simp] + apply (clarsimp simp: tcbQueueInsert_def) + \ \forwards step in order to name beforePtr below\ + apply (rule hoare_seq_ext[OF _ getObject_tcb_sp]) + apply (rule hoare_seq_ext[OF _ assert_sp]) + apply (rule hoare_ex_pre_conj[simplified conj_commute], rename_tac beforePtr) + apply (rule hoare_seq_ext[OF _ assert_sp]) + apply (wpsimp wp: threadSet_wp) + apply normalise_obj_at' + apply (prop_tac "tcbPtr \ afterPtr") + apply (clarsimp simp: list_queue_relation_def opt_map_red obj_at'_def) + apply (prop_tac "tcbPtr \ beforePtr") + apply (fastforce dest: sym_heap_None simp: opt_map_def obj_at'_def split: option.splits) + apply (prop_tac "tcbSchedNexts_of s beforePtr = Some afterPtr") + apply (fastforce intro: sym_heapD2 simp: opt_map_def obj_at'_def) + apply (fastforce dest: sym_heap_insert_into_middle_of_chain + simp: fun_upd_swap opt_map_red opt_map_upd_triv obj_at'_def) + done + +lemma tcbQueueAppend_sym_heap_sched_pointers: + "\\s. sym_heap_sched_pointers s + \ (\ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ tcbPtr \ set ts) + \ tcbSchedNexts_of s tcbPtr = None \ tcbSchedPrevs_of s tcbPtr = None\ + tcbQueueAppend q tcbPtr + \\_. sym_heap_sched_pointers\" + supply projectKOs[simp] + supply if_split[split del] + apply (clarsimp simp: tcbQueueAppend_def) + apply (wpsimp wp: threadSet_wp) + apply (clarsimp simp: tcbQueueEmpty_def list_queue_relation_def queue_end_valid_def obj_at'_def + split: if_splits) + apply fastforce + apply (drule_tac a="last ts" and b=tcbPtr in sym_heap_connect) + apply (fastforce dest: heap_ls_last_None) + apply assumption + apply (simp add: opt_map_red tcbQueueEmpty_def) + apply (subst fun_upd_swap, simp) + apply (fastforce simp: opt_map_red opt_map_upd_triv) + done + +lemma tcbQueued_update_sym_heap_sched_pointers[wp]: + "threadSet (tcbQueued_update f) tcbPtr \sym_heap_sched_pointers\" + by (rule sym_heap_sched_pointers_lift; + wpsimp wp: threadSet_tcbSchedPrevs_of threadSet_tcbSchedNexts_of) + +lemma tcbSchedEnqueue_sym_heap_sched_pointers[wp]: + "\sym_heap_sched_pointers and valid_sched_pointers\ + tcbSchedEnqueue tcbPtr + \\_. sym_heap_sched_pointers\" + supply projectKOs[simp] + unfolding tcbSchedEnqueue_def + apply (wpsimp wp: tcbQueuePrepend_sym_heap_sched_pointers threadGet_wp + simp: addToBitmap_def bitmap_fun_defs) + apply (normalise_obj_at', rename_tac tcb) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (fastforce dest!: spec[where x=tcbPtr] inQ_implies_tcbQueueds_of + simp: valid_sched_pointers_def opt_pred_def opt_map_def obj_at'_def) + done + +lemma tcbSchedAppend_sym_heap_sched_pointers[wp]: + "\sym_heap_sched_pointers and valid_sched_pointers\ + tcbSchedAppend tcbPtr + \\_. sym_heap_sched_pointers\" + supply projectKOs[simp] + unfolding tcbSchedAppend_def + apply (wpsimp wp: tcbQueueAppend_sym_heap_sched_pointers threadGet_wp + simp: addToBitmap_def bitmap_fun_defs) + apply (normalise_obj_at', rename_tac tcb) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (fastforce dest!: spec[where x=tcbPtr] inQ_implies_tcbQueueds_of + simp: valid_sched_pointers_def opt_pred_def opt_map_def obj_at'_def) + done + +lemma tcbSchedDequeue_sym_heap_sched_pointers[wp]: + "\sym_heap_sched_pointers and valid_sched_pointers\ + tcbSchedDequeue tcbPtr + \\_. sym_heap_sched_pointers\" + supply projectKOs[simp] + unfolding tcbSchedDequeue_def + apply (wpsimp wp: tcbQueueRemove_sym_heap_sched_pointers hoare_vcg_if_lift2 threadGet_wp + simp: bitmap_fun_defs) + apply (fastforce simp: ready_queue_relation_def ksReadyQueues_asrt_def inQ_def opt_pred_def + opt_map_def obj_at'_def) + done + +crunches setThreadState + for valid_sched_pointers[wp]: valid_sched_pointers + and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + (simp: crunch_simps wp: crunch_wps threadSet_valid_sched_pointers threadSet_sched_pointers) + 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. (\p. t \ set(ksReadyQueues s p)) \ runnable' st) and (\s. runnable' st \ obj_at' tcbQueued t s \ st_tcb_at' runnable' t s) and sch_act_simple and invs'\ @@ -4373,21 +5702,21 @@ lemma sts_invs_minor': including no_pre apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) - apply (wp sts_valid_queues valid_irq_node_lift irqs_masked_lift - setThreadState_ct_not_inQ + apply (wp valid_irq_node_lift irqs_masked_lift + setThreadState_ct_not_inQ | simp add: cteCaps_of_def o_def)+ apply (clarsimp simp: sch_act_simple_def) apply (intro conjI) - apply clarsimp - defer - apply (clarsimp dest!: st_tcb_at_state_refs_ofD' - elim!: rsubst[where P=sym_refs] - intro!: ext) - apply (clarsimp elim!: st_tcb_ex_cap'') + apply clarsimp + defer + apply (clarsimp dest!: st_tcb_at_state_refs_ofD' + elim!: rsubst[where P=sym_refs] + intro!: ext) + apply (clarsimp elim!: st_tcb_ex_cap'') + apply fastforce + apply fastforce apply (frule tcb_in_valid_state', clarsimp+) - apply (cases st, simp_all add: valid_tcb_state'_def - split: Structures_H.thread_state.split_asm) - done + by (cases st; simp add: valid_tcb_state'_def split: Structures_H.thread_state.split_asm) lemma sts_cap_to'[wp]: "\ex_nonz_cap_to' p\ setThreadState st t \\rv. ex_nonz_cap_to' p\" @@ -4432,12 +5761,59 @@ lemma threadSet_ct_running': apply wp done +lemma tcbQueuePrepend_tcbPriority_obj_at'[wp]: + "tcbQueuePrepend queue tptr \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + supply projectKOs[simp] + unfolding tcbQueuePrepend_def + apply (wpsimp wp: threadSet_wp) + by (auto simp: obj_at'_def objBits_simps ps_clear_def split: if_splits) + +lemma tcbQueuePrepend_tcbDomain_obj_at'[wp]: + "tcbQueuePrepend queue tptr \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + supply projectKOs[simp] + unfolding tcbQueuePrepend_def + apply (wpsimp wp: threadSet_wp) + by (auto simp: obj_at'_def objBits_simps ps_clear_def split: if_splits) + +lemma tcbSchedDequeue_tcbPriority[wp]: + "tcbSchedDequeue t \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + unfolding tcbSchedDequeue_def tcbQueueRemove_def + by (wpsimp wp: hoare_when_weak_wp hoare_drop_imps) + +lemma tcbSchedDequeue_tcbDomain[wp]: + "tcbSchedDequeue t \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding tcbSchedDequeue_def tcbQueueRemove_def + by (wpsimp wp: hoare_when_weak_wp hoare_drop_imps) + +lemma tcbSchedEnqueue_tcbPriority_obj_at'[wp]: + "tcbSchedEnqueue tcbPtr \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + unfolding tcbSchedEnqueue_def setQueue_def + by wpsimp + +lemma tcbSchedEnqueue_tcbDomain_obj_at'[wp]: + "tcbSchedEnqueue tcbPtr \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding tcbSchedEnqueue_def setQueue_def + by wpsimp + +crunches rescheduleRequired + for tcbPriority_obj_at'[wp]: "obj_at' (\tcb. P (tcbPriority tcb)) t'" + and tcbDomain_obj_at'[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t'" + +lemma setThreadState_tcbPriority_obj_at'[wp]: + "setThreadState ts tptr \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + supply projectKOs[simp] + unfolding setThreadState_def + apply (wpsimp wp: threadSet_wp) + apply (fastforce simp: obj_at'_def objBits_simps ps_clear_def) + done + lemma setThreadState_tcb_in_cur_domain'[wp]: "\tcb_in_cur_domain' t'\ setThreadState st t \\_. tcb_in_cur_domain' t'\" apply (simp add: tcb_in_cur_domain'_def) apply (rule hoare_pre) apply wps - apply (wp setThreadState_not_st | simp)+ + apply (simp add: setThreadState_def) + apply (wpsimp wp: threadSet_ct_idle_or_in_cur_domain' hoare_drop_imps)+ done lemma asUser_global_refs': "\valid_global_refs'\ asUser t f \\rv. valid_global_refs'\" @@ -4583,10 +5959,13 @@ 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) - (set_eobject ptr etcb) (setObject ptr tcb')" + 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 @@ -4607,20 +5986,34 @@ lemma set_eobject_corres': 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 cte_relation_def tcb_relation_def projectKOs split: if_split_asm)+ + 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 (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 (clarsimp simp: projectKOs) - apply (insert e) - apply (clarsimp simp: other_obj_relation_def etcb_relation_def is_other_obj_relation_type split: Structures_A.kernel_object.splits Structures_H.kernel_object.splits ARM_A.arch_kernel_obj.splits) + 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 lemma set_eobject_corres: @@ -4628,9 +6021,13 @@ lemma set_eobject_corres: 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) - (set_eobject add etcbu) (setObject add tcbu')" + 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) @@ -4657,24 +6054,27 @@ lemma set_eobject_corres: 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) - (ethread_set f t) (threadSet f' t)" + 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+ + 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 simp + apply (clarsimp simp: obj_at'_def) done lemmas ethread_set_corres = diff --git a/proof/refine/ARM_HYP/Tcb_R.thy b/proof/refine/ARM_HYP/Tcb_R.thy index e8091f932d..80beb5be96 100644 --- a/proof/refine/ARM_HYP/Tcb_R.thy +++ b/proof/refine/ARM_HYP/Tcb_R.thy @@ -46,14 +46,14 @@ lemma activateThread_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) + 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 + apply (clarsimp simp: ct_in_state_def tcb_at_invs invs_distinct invs_psp_aligned elim!: st_tcb_weakenE) apply (clarsimp simp: tcb_at_invs' ct_in_state'_def elim!: pred_tcb'_weakenE) @@ -197,13 +197,13 @@ lemma setupReplyMaster_weak_sch_act_wf[wp]: apply assumption done -crunches setupReplyMaster - for valid_queues[wp]: "Invariants_H.valid_queues" - and valid_queues'[wp]: "valid_queues'" +crunches 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) (invs' and tcb_at' t) + "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) @@ -212,20 +212,22 @@ lemma restart_corres: 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]) - apply clarsimp + 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_valid_queues sts_st_tcb' - | clarsimp simp: valid_tcb_state'_def)+ - apply (rule_tac Q="\rv. valid_sched and cur_tcb" in hoare_strengthen_post) - apply wp - apply (simp add: valid_sched_def valid_sched_action_def) - apply (rule_tac Q="\rv. invs' and tcb_at' t" in hoare_strengthen_post) - apply wp - apply (clarsimp simp: invs'_def valid_state'_def sch_act_wf_weak valid_pspace'_def) - apply wp+ - apply (simp add: valid_sched_def invs_def tcb_at_is_etcb_at) - apply (clarsimp simp add: invs'_def valid_state'_def sch_act_wf_weak) + 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 lemma restart_invs': @@ -304,12 +306,6 @@ crunch sch_act_simple [wp]: asUser "sch_act_simple" crunch invs'[wp]: getSanitiseRegisterInfo invs' -lemma invs_valid_queues': - "invs' s \ valid_queues' s" - by (clarsimp simp:invs'_def valid_state'_def) - -declare invs_valid_queues'[rule_format, elim!] - lemma einvs_valid_etcbs: "einvs s \ valid_etcbs s" by (clarsimp simp: valid_sched_def) @@ -322,6 +318,11 @@ lemma asUser_postModifyRegisters_corres: apply (rule corres_stateAssert_assume) by simp+ +crunches restart + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + (simp: crunch_simps wp: crunch_wps threadSet_sched_pointers threadSet_valid_sched_pointers) + lemma invokeTCB_WriteRegisters_corres: "corres (dc \ (=)) (einvs and tcb_at dest and ex_nonz_cap_to dest) (invs' and sch_act_simple and tcb_at' dest and ex_nonz_cap_to' dest) @@ -347,17 +348,21 @@ lemma invokeTCB_WriteRegisters_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_valid_queues' invs_queues invs_weak_sch_act_wf - | 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 ((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 (wpsimp simp: getSanitiseRegisterInfo_def)+ + apply fastforce + apply fastforce done crunch it[wp]: suspend "\s. P (ksIdleThread s)" @@ -382,6 +387,10 @@ lemma suspend_ResumeCurrentThread_imp_notct[wp]: \\rv s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" by (wpsimp simp: suspend_def) +crunches restart, suspend + for cur_tcb'[wp]: cur_tcb' + (wp: crunch_wps threadSet_cur ignore: threadSet) + 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 @@ -409,7 +418,7 @@ proof - apply (rule corres_modify') apply simp apply simp - apply (simp | wp)+ + apply (simp add: invs_distinct invs_psp_aligned | wp)+ done have R: "\src src' des des' xs ys. \ src = src'; des = des'; xs = ys \ \ corres dc (tcb_at src and tcb_at des and invs) @@ -432,7 +441,7 @@ proof - apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) apply (rule asUser_setNextPC_corres) apply wp+ - apply simp+ + apply (simp add: invs_distinct invs_psp_aligned)+ done show ?thesis apply (simp add: invokeTCB_def performTransfer_def) @@ -458,11 +467,11 @@ proof - 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) + 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_state'_def invs_weak_sch_act_wf) - apply ((wp mapM_x_wp' hoare_weak_lift_imp | simp)+)[4] + 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 add: 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 @@ -509,41 +518,10 @@ lemma copyreg_invs': \\rv. invs'\" by (rule hoare_strengthen_post, rule copyreg_invs'', simp) -lemma threadSet_valid_queues_no_state: - "\Invariants_H.valid_queues and (\s. \p. t \ set (ksReadyQueues s p))\ - threadSet f t \\_. Invariants_H.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 setObject_queues_unchanged_tcb - 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 isRunnable_corres: - "corres (\ts runn. runnable ts = runn) (tcb_at t) (tcb_at' t) - (get_thread_state t) (isRunnable t)" + "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) @@ -564,16 +542,6 @@ lemma tcbSchedDequeue_not_queued: apply (wp tg_sp' [where P=\, simplified] | simp)+ done -lemma tcbSchedDequeue_not_in_queue: - "\p. \Invariants_H.valid_queues and tcb_at' t and valid_objs'\ tcbSchedDequeue t - \\rv s. t \ set (ksReadyQueues s p)\" - apply (rule_tac Q="\rv. Invariants_H.valid_queues and obj_at' (Not \ tcbQueued) t" - in hoare_post_imp) - apply (fastforce simp: valid_queues_def valid_queues_no_bitmap_def obj_at'_def projectKOs inQ_def) - apply (wp tcbSchedDequeue_not_queued tcbSchedDequeue_valid_queues | - simp add: valid_objs'_maxDomain valid_objs'_maxPriority)+ - done - lemma threadSet_ct_in_state': "(\tcb. tcbState (f tcb) = tcbState tcb) \ \ct_in_state' test\ threadSet f t \\rv. ct_in_state' test\" @@ -609,22 +577,27 @@ lemma threadSet_valid_objs_tcbPriority_update: apply (fastforce simp: obj_at'_def)+ done -lemma tcbSchedDequeue_ct_in_state': - "\ct_in_state' test\ tcbSchedDequeue t \\rv. ct_in_state' test\" +lemma tcbSchedDequeue_ct_in_state'[wp]: + "tcbSchedDequeue t \ct_in_state' test\" apply (simp add: ct_in_state'_def) apply (rule hoare_lift_Pf[where f=ksCurThread]; wpsimp) done crunch cur[wp]: tcbSchedDequeue cur_tcb' +crunches tcbSchedDequeue + for st_tcb_at'[wp]: "\s. P (st_tcb_at' st tcbPtr s)" + lemma sp_corres2: - "corres dc (valid_etcbs and weak_valid_sched_action and cur_tcb) - (Invariants_H.valid_queues and valid_queues' and cur_tcb' and tcb_at' t - and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_objs' and (\_. x \ maxPriority)) - (set_priority t x) (setPriority t x)" + "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]) + 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]) @@ -633,56 +606,45 @@ lemma sp_corres2: apply (wp corres_if; clarsimp) apply (rule rescheduleRequired_corres) apply (rule possibleSwitchTo_corres) - apply wp - apply wp - apply clarsimp - apply (wp hoare_weak_lift_imp hoare_vcg_if_lift hoare_wp_combs gts_wp) - apply clarsimp - apply (wp hoare_vcg_if_lift hoare_weak_lift_imp hoare_wp_combs isRunnable_wp) - apply (wp hoare_vcg_imp_lift' hoare_vcg_if_lift hoare_vcg_all_lift) - apply clarsimp - apply (wp hoare_drop_imps) - apply ((wp hoare_vcg_imp_lift' hoare_vcg_if_lift hoare_vcg_all_lift - isRunnable_wp threadSet_pred_tcb_no_state threadSet_valid_queues_no_state - threadSet_valid_queues'_no_state threadSet_valid_objs_tcbPriority_update - threadSet_weak_sch_act_wf threadSet_ct_in_state'[simplified ct_in_state'_def] - | simp add: etcb_relation_def)+)[1] - apply ((wp hoare_vcg_imp_lift' hoare_vcg_if_lift hoare_vcg_all_lift - isRunnable_wp threadSet_pred_tcb_no_state threadSet_valid_queues_no_state - threadSet_valid_queues'_no_state threadSet_cur threadSet_valid_objs_tcbPriority_update - threadSet_weak_sch_act_wf threadSet_ct_in_state'[simplified ct_in_state'_def] - | simp add: etcb_relation_def)+)[1] - apply ((wp hoare_vcg_imp_lift' hoare_vcg_if_lift hoare_vcg_all_lift - isRunnable_wp threadSet_pred_tcb_no_state threadSet_valid_queues_no_state - threadSet_cur threadSet_valid_queues'_no_state threadSet_valid_objs_tcbPriority_update - threadSet_weak_sch_act_wf threadSet_ct_in_state'[simplified ct_in_state'_def] - | simp add: etcb_relation_def)+)[1] - apply clarsimp - apply ((wp hoare_vcg_imp_lift' hoare_vcg_if_lift hoare_vcg_all_lift hoare_vcg_disj_lift - tcbSchedDequeue_not_in_queue - tcbSchedDequeue_valid_queues - tcbSchedDequeue_ct_in_state'[simplified ct_in_state'_def] | simp add: etcb_relation_def)+)[1] - apply clarsimp + 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 (force simp: state_relation_def elim: valid_objs'_maxDomain valid_objs'_maxPriority) + apply clarsimp done -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) +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 (clarsimp simp: valid_sched_def valid_sched_action_def) + 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 x) (setMCPriority t x)" +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 exst_same_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' \ @@ -694,100 +656,26 @@ 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) - (tcb_at' t) + 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 - apply (clarsimp simp add: threadset_corresT [OF _ x y e]) + 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] -crunch sch_act[wp]: tcbSchedEnqueue "\s. sch_act_wf (ksSchedulerAction s) s" - (simp: unless_def) - -crunch vq'[wp]: getCurThread valid_queues' - lemma tcbSchedDequeue_sch_act_simple[wp]: "tcbSchedDequeue t \sch_act_simple\" by (wpsimp simp: sch_act_simple_def) -lemma setP_vq[wp]: - "\\s. Invariants_H.valid_queues s \ tcb_at' t s \ sch_act_wf (ksSchedulerAction s) s \ valid_objs' s \ p \ maxPriority\ - setPriority t p - \\rv. Invariants_H.valid_queues\" - apply (simp add: setPriority_def) - apply (wpsimp ) - apply (wp hoare_vcg_imp_lift') - unfolding st_tcb_at'_def - apply (strengthen not_obj_at'_strengthen) - apply (wp hoare_wp_combs) - apply (wp hoare_vcg_imp_lift') - apply (wp threadSet_valid_queues threadSet_valid_objs_tcbPriority_update) - apply(wp threadSet_weak_sch_act_wf) - apply clarsimp - apply clarsimp - apply (wp hoare_vcg_imp_lift') - apply (wp threadSet_valid_queues threadSet_valid_objs_tcbPriority_update threadSet_sch_act, clarsimp) - apply (wp add:threadSet_valid_queues comb:hoare_drop_imps ) - apply (clarsimp simp: eq_commute[where a=t]) - apply (wp add: threadSet_valid_queues threadSet_valid_objs_tcbPriority_update threadSet_weak_sch_act_wf - hoare_vcg_imp_lift'[where P="\_ s. ksCurThread s \ _"] hoare_drop_imps hoare_vcg_all_lift - tcbSchedDequeue_not_in_queue tcbSchedEnqueue_valid_objs' tcbSchedDequeue_valid_queues - | clarsimp simp: valid_objs'_maxDomain valid_objs'_maxPriority)+ - done - -lemma valid_queues_subsetE': - "\ valid_queues' s; ksPSpace s = ksPSpace s'; - \x. set (ksReadyQueues s x) \ set (ksReadyQueues s' x) \ - \ valid_queues' s'" - by (simp add: valid_queues'_def obj_at'_def - ps_clear_def subset_iff projectKOs) - -crunch vq'[wp]: getCurThread valid_queues' - -lemma setP_vq'[wp]: - "\\s. valid_queues' s \ tcb_at' t s \ sch_act_wf (ksSchedulerAction s) s \ p \ maxPriority\ - setPriority t p - \\rv. valid_queues'\" - apply (simp add: setPriority_def) - apply (wpsimp wp: threadSet_valid_queues' hoare_drop_imps - threadSet_weak_sch_act_wf threadSet_sch_act) - apply (rule_tac Q="\_ s. valid_queues' s \ obj_at' (Not \ tcbQueued) t s \ sch_act_wf (ksSchedulerAction s) s - \ weak_sch_act_wf (ksSchedulerAction s) s" in hoare_strengthen_post, - wp tcbSchedDequeue_valid_queues' tcbSchedDequeue_not_queued) - apply (clarsimp simp: inQ_def) - apply normalise_obj_at' - apply clarsimp - done - -lemma setQueue_invs_bits[wp]: - "\valid_pspace'\ setQueue d p q \\rv. valid_pspace'\" - "\\s. sch_act_wf (ksSchedulerAction s) s\ setQueue d p q \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\\s. sym_refs (state_refs_of' s)\ setQueue d p q \\rv s. sym_refs (state_refs_of' s)\" - "\\s. sym_hyp_refs (state_refs_of' s)\ setQueue d p q \\rv s. sym_hyp_refs (state_refs_of' s)\" - "\if_live_then_nonz_cap'\ setQueue d p q \\rv. if_live_then_nonz_cap'\" - "\if_unsafe_then_cap'\ setQueue d p q \\rv. if_unsafe_then_cap'\" - "\cur_tcb'\ setQueue d p q \\rv. cur_tcb'\" - "\valid_global_refs'\ setQueue d p q \\rv. valid_global_refs'\" - "\valid_irq_handlers'\ setQueue d p q \\rv. valid_irq_handlers'\" - by (simp add: setQueue_def tcb_in_cur_domain'_def - | wp sch_act_wf_lift cur_tcb_lift - | fastforce)+ - -lemma setQueue_ex_idle_cap[wp]: - "\\s. ex_nonz_cap_to' (ksIdleThread s) s\ - setQueue d p q - \\rv s. ex_nonz_cap_to' (ksIdleThread s) s\" - by (simp add: setQueue_def, wp, - simp add: ex_nonz_cap_to'_def cte_wp_at_pspaceI) - lemma tcbPriority_caps_safe: "\tcb. \x\ran tcb_cte_cases. (\(getF, setF). getF (tcbPriority_update f tcb) = getF tcb) x" by (rule all_tcbI, rule ball_tcb_cte_casesI, simp+) @@ -796,22 +684,41 @@ lemma tcbPriority_Queued_caps_safe: "\tcb. \x\ran tcb_cte_cases. (\(getF, setF). getF (tcbPriority_update f (tcbQueued_update g tcb)) = getF tcb) x" by (rule all_tcbI, rule ball_tcb_cte_casesI, simp+) +lemma tcbSchedNext_update_tcb_cte_cases: + "(a, b) \ ran tcb_cte_cases \ a (tcbPriority_update f tcb) = a tcb" + unfolding tcb_cte_cases_def + by (case_tac tcb; fastforce simp: objBits_simps') + +lemma threadSet_priority_invs': + "\invs' and tcb_at' t and K (p \ maxPriority)\ + threadSet (tcbPriority_update (\_. p)) t + \\_. invs'\" + apply (rule hoare_gen_asm) + apply (simp add: invs'_def valid_state'_def split del: if_split) + apply (wp threadSet_valid_pspace' + threadSet_sch_actT_P[where P=False, simplified] + threadSet_state_refs_of'T[where f'=id] + threadSet_state_hyp_refs_of' + threadSet_iflive'T + threadSet_ifunsafe'T + threadSet_idle'T + valid_irq_node_lift + valid_irq_handlers_lift'' + threadSet_ctes_ofT + threadSet_not_inQ + threadSet_ct_idle_or_in_cur_domain' + threadSet_cur + untyped_ranges_zero_lift + sym_heap_sched_pointers_lift threadSet_valid_sched_pointers + threadSet_tcbSchedPrevs_of threadSet_tcbSchedNexts_of + | clarsimp simp: cteCaps_of_def tcbSchedNext_update_tcb_cte_cases | rule refl)+ + apply (clarsimp simp: o_def) + by (auto simp: obj_at'_def) + lemma setP_invs': "\invs' and tcb_at' t and K (p \ maxPriority)\ setPriority t p \\rv. invs'\" - apply (rule hoare_gen_asm) - apply (simp add: setPriority_def) - apply (wp rescheduleRequired_all_invs_but_ct_not_inQ valid_irq_node_lift - | simp add: if_apply_def2)+ - apply (rule hoare_strengthen_post, rule threadSet_invs_trivial, simp+) - apply (clarsimp simp: invs'_def valid_state'_def invs_valid_objs' elim!: st_tcb_ex_cap'') - apply auto[1] - apply (rule_tac Q="\_. invs' and obj_at' (Not \ tcbQueued) t - and (\s. \d p. t \ set (ksReadyQueues s (d,p)))" - in hoare_post_imp) - apply (clarsimp dest: obj_at_ko_at' simp: obj_at'_def inQ_def) - apply (wp tcbSchedDequeue_not_queued)+ - apply (clarsimp)+ - done + unfolding setPriority_def + by (wpsimp wp: rescheduleRequired_invs' threadSet_priority_invs') crunches setPriority, setMCPriority for typ_at'[wp]: "\s. P (typ_at' T p s)" @@ -1105,11 +1012,6 @@ lemma setMCPriority_valid_objs'[wp]: crunch sch_act_simple[wp]: setMCPriority sch_act_simple (wp: ssa_sch_act_simple crunch_wps rule: sch_act_simple_lift simp: crunch_simps) -(* For some reason, when this was embedded in a larger expression clarsimp wouldn't remove it. Adding it as a simp rule does *) -lemma inQ_tc_corres_helper: - "(\d p. (\tcb. tcbQueued tcb \ tcbPriority tcb = p \ tcbDomain tcb = d \ (tcbQueued tcb \ tcbDomain tcb \ d)) \ a \ set (ksReadyQueues s (d, p))) = True" - by clarsimp - abbreviation "valid_option_prio \ case_option True (\(p, auth). p \ maxPriority)" definition valid_tcb_invocation :: "tcbinvocation \ bool" where @@ -1117,107 +1019,95 @@ definition valid_tcb_invocation :: "tcbinvocation \ bool" where ThreadControl _ _ _ mcp p _ _ _ \ valid_option_prio p \ valid_option_prio mcp | _ \ True" -lemma threadcontrol_corres_helper1: +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 and valid_etcbs\" + thread_set (tcb_ipc_buffer_update f) a + \\x. weak_valid_sched_action\" apply (rule hoare_pre) apply (simp add: thread_set_def) - apply (wpsimp wp: set_object_wp) + 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) - apply (erule_tac x=a in allE)+ - apply (clarsimp simp: is_tcb_def) done -lemma threadcontrol_corres_helper2: - "is_aligned a msg_align_bits \ \invs' and tcb_at' t\ - threadSet (tcbIPCBuffer_update (\_. a)) t - \\x s. Invariants_H.valid_queues s \ valid_queues' s \ weak_sch_act_wf (ksSchedulerAction s) s\" - by (wp threadSet_invs_trivial - | strengthen invs_valid_queues' invs_queues invs_weak_sch_act_wf - | clarsimp simp: inQ_def )+ - 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))) - \\x. weak_valid_sched_action and valid_etcbs \" - apply (rule hoare_pre) - apply (wp check_cap_inv | simp add:)+ - by (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) + "\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 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))))) - \\x. Invariants_H.valid_queues and valid_queues' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\" - apply (wp - | strengthen invs_valid_queues' invs_queues invs_weak_sch_act_wf - | clarsimp simp: )+ + \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))))) + \\_ 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 isArchObjectCap_def isNotificationCap_def isEndpointCap_def - isReplyCap_def isIRQControlCap_def tcb_cnode_index_def cte_map_def cte_wp_at'_def + clarsimp simp: capBadge_def isCap_simps tcb_cnode_index_def cte_map_def cte_wp_at'_def cte_level_bits_def) +crunches cap_delete + for pspace_alinged[wp]: "pspace_aligned :: det_ext state \ _" + and pspace_distinct[wp]: "pspace_distinct :: det_ext state \ _" + (simp: crunch_simps preemption_point_def wp: crunch_wps OR_choiceE_weak_wp) + +lemmas check_cap_pspace_aligned[wp] = check_cap_inv[of pspace_aligned] +lemmas check_cap_pspace_distinct[wp] = check_cap_inv[of pspace_distinct] + 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 \ tcbDomain (F tcb) = tcbDomain tcb" - assumes a: "\tcb. tcbBoundNotification (F tcb) = tcbBoundNotification 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 r: "\tcb. atcbVCPUPtr (tcbArch (F tcb)) = atcbVCPUPtr (tcbArch tcb)" + assumes + "\tcb. \(getF,setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" + "\tcb. tcbState (F tcb) = tcbState tcb \ tcbDomain (F tcb) = tcbDomain 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 tcb \ maxDomain \ tcbDomain (F tcb) \ maxDomain" + "\tcb. tcbPriority tcb \ maxPriority \ tcbPriority (F tcb) \ maxPriority" + "\tcb. tcbMCP tcb \ maxPriority \ tcbMCP (F tcb) \ maxPriority" + "\tcb. atcbVCPUPtr (tcbArch (F tcb)) = atcbVCPUPtr (tcbArch tcb)" 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. \ tcbQueued tcb \ tcbQueued (F tcb)) \ ex_nonz_cap_to' t s \ t \ ksCurThread s) - \ (\tcb. tcbQueued (F tcb) \ ksSchedulerAction s = ResumeCurrentThread \ tcbQueued tcb \ t \ ksCurThread s)\ - threadSet F t - \\rv. invs'\" -proof - - from z have domains: "\tcb. tcbDomain (F tcb) = tcbDomain tcb" by blast - note threadSet_sch_actT_P[where P=False, simplified] - have y: "\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 valid_state'_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_state_refs_of'T[where f'=id] - threadSet_state_hyp_refs_of' - 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_cur - untyped_ranges_zero_lift - |clarsimp simp: y z a r domains cteCaps_of_def valid_arch_tcb'_def|rule refl)+ - apply (clarsimp simp: obj_at'_def projectKOs pred_tcb_at'_def) - apply (clarsimp simp: cur_tcb'_def valid_irq_node'_def valid_queues'_def o_def) - by (fastforce simp: domains ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def z a) -qed + "\\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_state_hyp_refs_of' + threadSet_idle'T + threadSet_not_inQ + threadSet_ct_idle_or_in_cur_domain' + threadSet_cur + | clarsimp simp: assms cteCaps_of_def valid_arch_tcb'_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\" @@ -1228,10 +1118,6 @@ 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) @@ -1245,6 +1131,16 @@ 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) +crunches option_update_thread + for aligned[wp]: pspace_aligned + and distinct[wp]: pspace_distinct + +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'" @@ -1287,8 +1183,8 @@ lemma transferCaps_corres: (invokeTCB (tcbinvocation.ThreadControl a sl' b' mcp_auth p_auth e' f' g'))" proof - have P: "\t v. corres dc - (tcb_at t) - (tcb_at' t) + (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 () @@ -1298,8 +1194,8 @@ proof - apply (safe, case_tac tcb', simp add: tcb_relation_def split: option.split) done have R: "\t v. corres dc - (tcb_at t) - (tcb_at' t) + (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)" @@ -1312,7 +1208,7 @@ proof - (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) (tcb_at' t) + 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) @@ -1436,10 +1332,20 @@ proof - apply (rule corres_split[OF getCurThread_corres], clarsimp) apply (rule corres_when[OF refl rescheduleRequired_corres]) apply (wpsimp wp: gct_wp)+ - apply (wp hoare_drop_imp) - apply (rule threadcontrol_corres_helper1[unfolded pred_conj_def]) - apply (wp hoare_drop_imp) - apply (wp threadcontrol_corres_helper2 | wpc | simp)+ + 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 @@ -1467,10 +1373,10 @@ proof - cap_delete_valid_cap cteDelete_deletes cteDelete_invs' | strengthen use_no_cap_to_obj_asid_strg - | clarsimp simp: inQ_def inQ_tc_corres_helper)+ + | clarsimp simp: inQ_def)+ apply (clarsimp simp: cte_wp_at_caps_of_state dest!: is_cnode_or_valid_arch_cap_asid) - apply (clarsimp simp: emptyable_def) + 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) @@ -1542,40 +1448,25 @@ proof - apply wp apply wp apply (wpsimp wp: hoare_vcg_const_imp_lift_R hoare_vcg_const_imp_lift - hoare_vcg_all_lift_R hoare_vcg_all_lift as_user_invs cap_delete_deletes - thread_set_ipc_tcb_cap_valid thread_set_tcb_ipc_buffer_cap_cleared_invs - thread_set_cte_wp_at_trivial thread_set_valid_cap cap_delete_valid_cap - reschedule_preserves_valid_sched thread_set_not_state_valid_sched + hoare_vcg_all_lift_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] - simp: ran_tcb_cap_cases) + 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_drop_imps) - apply ((wpsimp wp: hoare_vcg_const_imp_lift hoare_vcg_imp_lift' hoare_vcg_all_lift - threadSet_cte_wp_at' threadSet_invs_trivialT2 cteDelete_invs' - simp: tcb_cte_cases_def), (fastforce+)[6]) - apply wpsimp - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - threadSet_invs_trivialT2 threadSet_cte_wp_at' - simp: tcb_cte_cases_def, (fastforce+)[6]) - apply wpsimp - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - rescheduleRequired_invs' threadSet_cte_wp_at' - simp: tcb_cte_cases_def) - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - rescheduleRequired_invs' threadSet_invs_trivialT2 threadSet_cte_wp_at' - simp: tcb_cte_cases_def, (fastforce+)[6]) - apply wpsimp - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - rescheduleRequired_invs' threadSet_invs_trivialT2 threadSet_cte_wp_at' - simp: tcb_cte_cases_def, (fastforce+)[6]) - apply wpsimp - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - rescheduleRequired_invs' threadSet_cap_to' threadSet_invs_trivialT2 - threadSet_cte_wp_at' hoare_drop_imps - simp: tcb_cte_cases_def) - apply (clarsimp) + 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_lift_R hoare_vcg_all_lift hoare_vcg_const_imp_lift_R hoare_vcg_const_imp_lift threadSet_valid_objs' thread_set_not_state_valid_sched @@ -1588,9 +1479,9 @@ proof - | strengthen tcb_cap_always_valid_strg tcb_at_invs use_no_cap_to_obj_asid_strg - | (erule exE, clarsimp simp: word_bits_def))+) + | (erule exE, clarsimp simp: word_bits_def) | wp (once) hoare_drop_imps)+) apply (strengthen valid_tcb_ipc_buffer_update) - apply (strengthen invs_valid_objs')+ + 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 @@ -1630,6 +1521,7 @@ proof - 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 + invs_psp_aligned invs_distinct cong: conj_cong imp_cong split: option.split_asm) by (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def objBits_defs @@ -1718,7 +1610,7 @@ lemma setSchedulerAction_invs'[wp]: apply (simp add: setSchedulerAction_def) apply wp apply (clarsimp simp add: invs'_def valid_state'_def valid_irq_node'_def - valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs cur_tcb'_def + valid_queues_def bitmapQ_defs cur_tcb'_def ct_not_inQ_def) apply (simp add: ct_idle_or_in_cur_domain'_def) done @@ -1849,8 +1741,8 @@ lemma invokeTCB_corres: apply (rule TcbAcc_R.rescheduleRequired_corres) apply (rule corres_trivial, simp) apply (wpsimp wp: hoare_drop_imp)+ - apply (clarsimp simp: valid_sched_weak_strg einvs_valid_etcbs) - apply (clarsimp simp: Tcb_R.invs_valid_queues' Invariants_H.invs_queues) + apply (fastforce dest: valid_sched_valid_queues simp: valid_sched_weak_strg einvs_valid_etcbs) + apply fastforce done lemma tcbBoundNotification_caps_safe[simp]: @@ -1865,6 +1757,10 @@ lemma valid_bound_ntfn_lift: apply (wp typ_at_lifts[OF P])+ done +crunches 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 @@ -1877,7 +1773,7 @@ lemma bindNotification_invs': apply (simp add: bindNotification_def invs'_def valid_state'_def) apply (rule hoare_seq_ext[OF _ get_ntfn_sp']) apply (rule hoare_pre) - apply (wp set_ntfn_valid_pspace' sbn_sch_act' sbn_valid_queues valid_irq_node_lift + 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)+ @@ -2048,7 +1944,7 @@ lemma eq_ucast_word8[simp]: done lemma checkPrio_corres: - "corres (ser \ dc) (tcb_at auth) (tcb_at' auth) + "corres (ser \ dc) (tcb_at auth and pspace_aligned and pspace_distinct) \ (check_prio p auth) (checkPrio p auth)" apply (simp add: check_prio_def checkPrio_def) apply (rule corres_guard_imp) @@ -2071,7 +1967,7 @@ 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 valid_etcbs 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')" @@ -2083,14 +1979,13 @@ lemma decodeSetPriority_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 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; list_all2 (\(c, sl) (c', sl'). cap_relation c c' \ sl' = cte_map sl) extras extras' \ \ corres (ser \ tcbinv_relation) - (cur_tcb and valid_etcbs 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_mcpriority args cap slot extras) (decodeSetMCPriority args cap' extras')" @@ -2102,14 +1997,7 @@ lemma decodeSetMCPriority_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 simp: valid_cap_def valid_cap'_def)+ - done - -lemma valid_objs'_maxPriority': - "\s t. \ valid_objs' s; tcb_at' t s \ \ obj_at' (\tcb. tcbMCP tcb \ maxPriority) t s" - apply (erule (1) valid_objs_valid_tcbE) - apply (clarsimp simp: valid_tcb'_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\" @@ -2204,7 +2092,8 @@ lemma decodeSetSchedParams_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 valid_etcbs 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_sched_params args cap slot extras) (decodeSetSchedParams args cap' extras')" @@ -2632,8 +2521,7 @@ notes if_cong[cong] shows lemma decodeUnbindNotification_corres: "corres (ser \ tcbinv_relation) - (tcb_at t) - (tcb_at' t) + (tcb_at t and pspace_aligned and pspace_distinct) \ (decode_unbind_notification (cap.ThreadCap t)) (decodeUnbindNotification (capability.ThreadCap t))" apply (simp add: decode_unbind_notification_def decodeUnbindNotification_def) @@ -2683,7 +2571,7 @@ lemma decodeTCBInvocation_corres: corres_guard_imp[OF decodeBindNotification_corres] corres_guard_imp[OF decodeUnbindNotification_corres] corres_guard_imp[OF decodeSetTLSBase_corres], - simp_all add: valid_cap_simps valid_cap_simps' invs_def valid_sched_def) + simp_all add: valid_cap_simps valid_cap_simps' invs_def valid_state_def valid_sched_def) apply (auto simp: list_all2_map1 list_all2_map2 elim!: list_all2_mono) done diff --git a/proof/refine/ARM_HYP/Untyped_R.thy b/proof/refine/ARM_HYP/Untyped_R.thy index ce364fdf23..f5c0c6452b 100644 --- a/proof/refine/ARM_HYP/Untyped_R.thy +++ b/proof/refine/ARM_HYP/Untyped_R.thy @@ -1360,6 +1360,7 @@ crunches updateMDB, updateNewFreeIndex and ksWorkUnitsCompleted[wp]: "\s. P (ksWorkUnitsCompleted s)" and ksMachineState[wp]: "\s. P (ksMachineState s)" and ksArchState[wp]: "\s. P (ksArchState s)" + crunches insertNewCap for ksInterrupt[wp]: "\s. P (ksInterruptState s)" and norq[wp]: "\s. P (ksReadyQueues s)" @@ -1367,22 +1368,16 @@ crunches insertNewCap and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" and ksCurDomain[wp]: "\s. P (ksCurDomain s)" and ksCurThread[wp]: "\s. P (ksCurThread s)" + and sched_queues_projs[wp]: "\s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)" + and tcbQueueds_of[wp]: "\s. P (tcbQueued |< tcbs_of' s)" + and valid_sched_pointers[wp]: valid_sched_pointers (wp: crunch_wps) + crunch nosch[wp]: insertNewCaps "\s. P (ksSchedulerAction s)" (simp: crunch_simps zipWithM_x_mapM wp: crunch_wps) crunch exst[wp]: set_cdt "\s. P (exst s)" -(*FIXME: Move to StateRelation*) -lemma state_relation_schact[elim!]: - "(s,s') \ state_relation \ sched_act_relation (scheduler_action s) (ksSchedulerAction s')" - apply (simp add: state_relation_def) - done - -lemma state_relation_queues[elim!]: "(s,s') \ state_relation \ ready_queues_relation (ready_queues s) (ksReadyQueues s')" - apply (simp add: state_relation_def) - done - lemma set_original_symb_exec_l: "corres_underlying {(s, s'). f (kheap s) (exst s) s'} nf 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) @@ -1413,6 +1408,10 @@ lemma updateNewFreeIndex_noop_psp_corres: | simp add: updateTrackedFreeIndex_def getSlotCap_def)+ done +crunches updateMDB, updateNewFreeIndex, setCTE + for rdyq_projs[wp]: + "\s. P (ksReadyQueues s) (tcbSchedNexts_of s) (tcbSchedPrevs_of s) (\d p. inQ d p |< tcbs_of' s)" + lemma insertNewCap_corres: notes if_cong[cong del] if_weak_cong[cong] shows @@ -3656,7 +3655,7 @@ lemma updateFreeIndex_clear_invs': apply (wp valid_irq_node_lift setCTE_typ_at') apply (wp getCTE_wp) apply (simp add:updateCap_def) - apply (wp irqs_masked_lift valid_queues_lift' cur_tcb_lift ct_idle_or_in_cur_domain'_lift + apply (wp irqs_masked_lift cur_tcb_lift ct_idle_or_in_cur_domain'_lift valid_bitmaps_lift hoare_vcg_disj_lift untyped_ranges_zero_lift getCTE_wp setCTE_irq_handlers' | wp (once) hoare_use_eq[where f="gsUntypedZeroRanges"] | simp add: getSlotCap_def @@ -4222,14 +4221,12 @@ context begin interpretation Arch . (*FIXME: arch_split*) lemma resetUntypedCap_corres: "untypinv_relation ui ui' \ corres (dc \ dc) - (invs 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) @@ -5064,7 +5061,7 @@ lemma inv_untyped_corres': apply (clarsimp simp only: pred_conj_def invs ui) apply (strengthen vui) apply (cut_tac vui invs invs') - apply (clarsimp simp: cte_wp_at_caps_of_state valid_sched_etcbs) + 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 @@ -5227,9 +5224,6 @@ crunch irq_states' [wp]: insertNewCap valid_irq_states' crunch pde_mappings' [wp]: insertNewCap valid_pde_mappings' (wp: getCTE_wp') -crunch vq'[wp]: insertNewCap valid_queues' - (wp: crunch_wps) - crunch irqs_masked' [wp]: insertNewCap irqs_masked' (wp: crunch_wps rule: irqs_masked_lift) @@ -5320,8 +5314,8 @@ lemma insertNewCap_invs': apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) apply (wp insertNewCap_valid_pspace' sch_act_wf_lift - valid_queues_lift cur_tcb_lift tcb_in_cur_domain'_lift - insertNewCap_valid_global_refs' + cur_tcb_lift tcb_in_cur_domain'_lift valid_bitmaps_lift + insertNewCap_valid_global_refs' sym_heap_sched_pointers_lift valid_irq_node_lift insertNewCap_valid_irq_handlers) apply (clarsimp simp: cte_wp_at_ctes_of) apply (frule ctes_of_valid[rotated, where p=parent, OF valid_pspace_valid_objs']) diff --git a/proof/refine/ARM_HYP/VSpace_R.thy b/proof/refine/ARM_HYP/VSpace_R.thy index b067dc1d6f..f72b52e088 100644 --- a/proof/refine/ARM_HYP/VSpace_R.thy +++ b/proof/refine/ARM_HYP/VSpace_R.thy @@ -616,11 +616,6 @@ lemma setVCPU_ksQ[wp]: "\\s. P (ksReadyQueues s)\ setObject p (v::vcpu) \\rv s. P (ksReadyQueues s)\" by (wp setObject_qs updateObject_default_inv | simp)+ -lemma setVCPU_valid_queues'[wp]: - "setObject v (vcpu::vcpu) \valid_queues'\" - unfolding valid_queues'_def - by (rule hoare_lift_Pf[where f=ksReadyQueues]; wp hoare_vcg_all_lift updateObject_default_inv) - lemma setVCPU_ct_not_inQ[wp]: "setObject v (vcpu::vcpu) \ct_not_inQ\" apply (wp ct_not_inQ_lift) @@ -629,8 +624,8 @@ lemma setVCPU_ct_not_inQ[wp]: done lemma handleVMFault_corres: - "corres (fr \ dc) (tcb_at thread) (tcb_at' thread) - (handle_vm_fault thread fault) (handleVMFault thread fault)" + "corres (fr \ dc) (tcb_at thread and pspace_aligned and pspace_distinct) \ + (handle_vm_fault thread fault) (handleVMFault thread fault)" apply (simp add: ARM_HYP_H.handleVMFault_def) apply (cases fault) apply simp @@ -2705,8 +2700,8 @@ lemma message_info_from_data_eqv: lemma setMessageInfo_corres: "mi' = message_info_map mi \ - corres dc (tcb_at t) (tcb_at' t) - (set_message_info t mi) (setMessageInfo t mi')" + corres dc (tcb_at t and pspace_aligned and pspace_distinct) \ + (set_message_info t mi) (setMessageInfo t mi')" apply (simp add: setMessageInfo_def set_message_info_def) apply (subgoal_tac "wordFromMessageInfo (message_info_map mi) = message_info_to_data mi") @@ -3576,23 +3571,6 @@ lemma setVCPU_valid_arch': apply (wp hoare_vcg_all_lift hoare_drop_imp)+ done -lemma setVCPU_valid_queues [wp]: - "\valid_queues\ setObject p (v::vcpu) \\_. valid_queues\" - by (wp valid_queues_lift | simp add: pred_tcb_at'_def)+ - -crunches - vcpuDisable, vcpuRestore, vcpuEnable, vcpuUpdate, vcpuSaveRegRange, vgicUpdateLR - for valid_queues[wp]: valid_queues - (ignore: doMachineOp wp: mapM_x_wp) - -lemma vcpuSave_valid_queues[wp]: - "\Invariants_H.valid_queues\ vcpuSave param_a \\_. Invariants_H.valid_queues\" - by (wpsimp simp: vcpuSave_def armvVCPUSave_def wp: mapM_x_wp cong: option.case_cong_weak | simp)+ - -lemma vcpuSwitch_valid_queues[wp]: - "\Invariants_H.valid_queues\ vcpuSwitch param_a \\_. Invariants_H.valid_queues\" - by (wpsimp simp: vcpuSwitch_def modifyArchState_def | simp)+ - lemma isb_invs_no_cicd'[wp]: "\invs_no_cicd'\ doMachineOp isb \\rv. invs_no_cicd'\" apply (wpsimp wp: dmo_invs_no_cicd' no_irq no_irq_isb) @@ -3687,6 +3665,10 @@ lemma get_gic_vcpu_ctrl_vmcr_invs_no_cicd'[wp]: by (wpsimp wp: dmo_invs_no_cicd' no_irq_get_gic_vcpu_ctrl_vmcr no_irq simp: get_gic_vcpu_ctrl_vmcr_def gets_def in_monad) +lemma setVCPU_tcbs_of'[wp]: + "setObject v (vcpu :: vcpu) \\s. P' (tcbs_of' s)\" + by setObject_easy_cases + lemma setVCPU_regs_r_invs_cicd': "\invs_no_cicd' and ko_at' vcpu v\ setObject v (vcpuRegs_update (\_. (vcpuRegs vcpu)(r:=rval)) vcpu) \\_. invs_no_cicd'\" @@ -3701,7 +3683,7 @@ lemma setVCPU_regs_r_invs_cicd': cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift valid_pde_mappings_lift' setObject_typ_at' cur_tcb_lift - setVCPU_regs_valid_arch' setVCPU_regs_vcpu_live + setVCPU_regs_valid_arch' setVCPU_regs_vcpu_live valid_bitmaps_lift simp: objBits_simps archObjSize_def vcpu_bits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) apply (clarsimp simp: if_live_then_nonz_cap'_def obj_at'_real_def) @@ -3723,7 +3705,7 @@ lemma setVCPU_vgic_invs_cicd': cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift valid_pde_mappings_lift' setObject_typ_at' cur_tcb_lift - setVCPU_vgic_valid_arch' + setVCPU_vgic_valid_arch' valid_bitmaps_lift simp: objBits_simps archObjSize_def vcpu_bits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) apply (clarsimp simp: if_live_then_nonz_cap'_def obj_at'_real_def) @@ -3745,7 +3727,7 @@ lemma setVCPU_VPPIMasked_invs_cicd': cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift valid_pde_mappings_lift' setObject_typ_at' cur_tcb_lift - setVCPU_VPPIMasked_valid_arch' + setVCPU_VPPIMasked_valid_arch' valid_bitmaps_lift simp: objBits_simps archObjSize_def vcpu_bits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) apply (clarsimp simp: if_live_then_nonz_cap'_def obj_at'_real_def) @@ -3767,7 +3749,7 @@ lemma setVCPU_VTimer_invs_cicd': cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift valid_pde_mappings_lift' setObject_typ_at' cur_tcb_lift - setVCPU_VTimer_valid_arch' + setVCPU_VTimer_valid_arch' valid_bitmaps_lift simp: objBits_simps archObjSize_def vcpu_bits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) apply (clarsimp simp: if_live_then_nonz_cap'_def obj_at'_real_def) @@ -3901,13 +3883,12 @@ lemma vcpuSave_invs_no_cicd'[wp]: | assumption)+ lemma valid_arch_state'_armHSCurVCPU_update[simp]: - "ko_wp_at' (is_vcpu' and hyp_live') v s \ - valid_arch_state' s \ valid_arch_state' (s\ksArchState := armHSCurVCPU_update (\_. Some (v, b)) (ksArchState s)\)" - by (clarsimp simp: invs'_def valid_state'_def valid_queues_def valid_queues_no_bitmap_def - bitmapQ_defs valid_global_refs'_def valid_arch_state'_def global_refs'_def - valid_queues'_def valid_irq_node'_def valid_irq_handlers'_def - irq_issued'_def irqs_masked'_def valid_machine_state'_def - cur_tcb'_def) + "\ ko_wp_at' (is_vcpu' and hyp_live') v s; valid_arch_state' s \ \ + valid_arch_state' (s\ksArchState := armHSCurVCPU_update (\_. Some (v, b)) (ksArchState s)\)" + by (clarsimp simp: invs'_def valid_state'_def + bitmapQ_defs valid_global_refs'_def valid_arch_state'_def global_refs'_def + valid_irq_node'_def valid_irq_handlers'_def + irq_issued'_def irqs_masked'_def valid_machine_state'_def cur_tcb'_def) lemma dmo_vcpu_hyp: "\ko_wp_at' (is_vcpu' and hyp_live') v\ doMachineOp f \\_. ko_wp_at' (is_vcpu' and hyp_live') v\" @@ -3988,20 +3969,18 @@ lemma vcpuSwitch_valid_arch_state'[wp]: lemma invs_no_cicd'_armHSCurVCPU_update[simp]: "ko_wp_at' (is_vcpu' and hyp_live') v s \ invs_no_cicd' s \ invs_no_cicd' (s\ksArchState := armHSCurVCPU_update (\_. Some (v, b)) (ksArchState s)\)" - by (clarsimp simp: invs_no_cicd'_def valid_state'_def valid_queues_def valid_queues_no_bitmap_def - bitmapQ_defs valid_global_refs'_def valid_arch_state'_def global_refs'_def - valid_queues'_def valid_irq_node'_def valid_irq_handlers'_def - irq_issued'_def irqs_masked'_def valid_machine_state'_def - cur_tcb'_def) + by (clarsimp simp: invs_no_cicd'_def valid_state'_def + bitmapQ_defs valid_global_refs'_def valid_arch_state'_def global_refs'_def + valid_irq_node'_def valid_irq_handlers'_def + irq_issued'_def irqs_masked'_def valid_machine_state'_def cur_tcb'_def) lemma invs'_armHSCurVCPU_update[simp]: "ko_wp_at' (is_vcpu' and hyp_live') v s \ invs' s \ invs' (s\ksArchState := armHSCurVCPU_update (\_. Some (v, b)) (ksArchState s)\)" - apply (clarsimp simp: invs'_def valid_state'_def valid_queues_def valid_queues_no_bitmap_def - bitmapQ_defs valid_global_refs'_def valid_arch_state'_def global_refs'_def - valid_queues'_def valid_irq_node'_def valid_irq_handlers'_def - irq_issued'_def irqs_masked'_def valid_machine_state'_def - cur_tcb'_def) + apply (clarsimp simp: invs'_def valid_state'_def + bitmapQ_defs valid_global_refs'_def valid_arch_state'_def global_refs'_def + valid_irq_node'_def valid_irq_handlers'_def + irq_issued'_def irqs_masked'_def valid_machine_state'_def cur_tcb'_def) done lemma armHSCurVCPU_None_invs'[wp]: @@ -4025,7 +4004,7 @@ lemma setVCPU_vgic_invs': cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift valid_pde_mappings_lift' setObject_typ_at' cur_tcb_lift - setVCPU_vgic_valid_arch' + setVCPU_vgic_valid_arch' valid_bitmaps_lift simp: objBits_simps archObjSize_def vcpu_bits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) apply (clarsimp simp: if_live_then_nonz_cap'_def obj_at'_real_def) @@ -4045,7 +4024,7 @@ lemma setVCPU_regs_invs': cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift valid_pde_mappings_lift' setObject_typ_at' cur_tcb_lift - setVCPU_regs_valid_arch' + setVCPU_regs_valid_arch' valid_bitmaps_lift simp: objBits_simps archObjSize_def vcpu_bits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) apply (clarsimp simp: if_live_then_nonz_cap'_def obj_at'_real_def) @@ -4065,7 +4044,7 @@ lemma setVCPU_VPPIMasked_invs': cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift valid_pde_mappings_lift' setObject_typ_at' cur_tcb_lift - setVCPU_VPPIMasked_valid_arch' + setVCPU_VPPIMasked_valid_arch' valid_bitmaps_lift simp: objBits_simps archObjSize_def vcpu_bits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) apply (clarsimp simp: if_live_then_nonz_cap'_def obj_at'_real_def) @@ -4085,7 +4064,7 @@ lemma setVCPU_VTimer_invs': cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift valid_pde_mappings_lift' setObject_typ_at' cur_tcb_lift - setVCPU_VTimer_valid_arch' + setVCPU_VTimer_valid_arch' valid_bitmaps_lift simp: objBits_simps archObjSize_def vcpu_bits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) apply (clarsimp simp: if_live_then_nonz_cap'_def obj_at'_real_def) @@ -4481,14 +4460,6 @@ lemma storePDE_nordL2[wp]: "\\s. P (ksReadyQueuesL2Bitmap s)\ storePDE param_a param_b \\_ s. P (ksReadyQueuesL2Bitmap s)\" by (wpsimp wp: headM_inv hoare_drop_imp simp: storePDE_def updateObject_default_def) -lemma storePDE_valid_queues [wp]: - "\Invariants_H.valid_queues\ storePDE p pde \\_. Invariants_H.valid_queues\" - by (wp valid_queues_lift | simp add: pred_tcb_at'_def)+ - -lemma storePDE_valid_queues' [wp]: - "\valid_queues'\ storePDE p pde \\_. valid_queues'\" - by (wp valid_queues_lift') - lemma storePDE_iflive [wp]: "\if_live_then_nonz_cap'\ storePDE p pde \\rv. if_live_then_nonz_cap'\" apply (wpsimp simp: storePDE_def objBits_simps archObjSize_def vspace_bits_defs @@ -4644,6 +4615,22 @@ lemma storePTE_gsUntypedZeroRanges[wp]: "\\s. P (gsUntypedZeroRanges s)\ storePTE p pde \\rv s. P (gsUntypedZeroRanges s)\" by (wpsimp wp: headM_inv hoare_drop_imp simp: storePTE_def updateObject_default_def setObject_def) +lemma setObject_pte_tcb_of'[wp]: + "setObject slote (pte::pte) \\s. P' (tcbs_of' s)\" + by setObject_easy_cases + +crunches storePTE + for tcbs_of'[wp]: "\s. P (tcbs_of' s)" + (wp: crunch_wps) + +lemma setObject_pde_tcb_of'[wp]: + "setObject slote (pde::pde) \\s. P' (tcbs_of' s)\" + by setObject_easy_cases + +crunches storePDE + for tcbs_of'[wp]: "\s. P (tcbs_of' s)" + (wp: crunch_wps) + lemma storePDE_invs[wp]: "\invs' and valid_pde' pde and (\s. valid_pde_mapping' (p && mask pdBits) pde)\ @@ -4655,7 +4642,7 @@ lemma storePDE_invs[wp]: irqs_masked_lift valid_arch_state_lift' valid_irq_node_lift cur_tcb_lift valid_irq_handlers_lift'' - untyped_ranges_zero_lift + untyped_ranges_zero_lift sym_heap_sched_pointers_lift valid_bitmaps_lift | simp add: cteCaps_of_def o_def)+ apply clarsimp done @@ -4687,14 +4674,6 @@ lemma storePTE_nordL2[wp]: "\\s. P (ksReadyQueuesL2Bitmap s)\ storePTE param_a param_b \\_ s. P (ksReadyQueuesL2Bitmap s)\" by (wpsimp wp: headM_inv hoare_drop_imp simp: storePTE_def updateObject_default_def) -lemma storePTE_valid_queues [wp]: - "\Invariants_H.valid_queues\ storePTE p pde \\_. Invariants_H.valid_queues\" - by (wp valid_queues_lift | simp add: pred_tcb_at'_def)+ - -lemma storePTE_valid_queues' [wp]: - "\valid_queues'\ storePTE p pde \\_. valid_queues'\" - by (wp valid_queues_lift') - lemma storePTE_iflive [wp]: "\if_live_then_nonz_cap'\ storePTE p pte \\rv. if_live_then_nonz_cap'\" apply (wpsimp simp: storePTE_def objBits_simps archObjSize_def vspace_bits_defs @@ -4822,7 +4801,7 @@ lemma storePTE_invs [wp]: apply (wp sch_act_wf_lift valid_global_refs_lift' irqs_masked_lift valid_arch_state_lift' valid_irq_node_lift cur_tcb_lift valid_irq_handlers_lift'' - untyped_ranges_zero_lift + untyped_ranges_zero_lift valid_bitmaps_lift | simp add: cteCaps_of_def o_def)+ apply clarsimp done @@ -4868,14 +4847,6 @@ 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_valid_queues [wp]: - "\Invariants_H.valid_queues\ setObject p (ap::asidpool) \\_. Invariants_H.valid_queues\" - by (wp valid_queues_lift | simp add: pred_tcb_at'_def)+ - -lemma setASIDPool_valid_queues' [wp]: - "\valid_queues'\ setObject p (ap::asidpool) \\_. valid_queues'\" - by (wp valid_queues_lift') - 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 @@ -4998,17 +4969,22 @@ 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_state'_def valid_pspace'_def) - apply (wp sch_act_wf_lift valid_global_refs_lift' irqs_masked_lift - valid_irq_node_lift - cur_tcb_lift valid_irq_handlers_lift'' - untyped_ranges_zero_lift - updateObject_default_inv - | simp add: cteCaps_of_def - | rule setObject_ksPSpace_only)+ - apply (clarsimp simp: o_def) + apply (rule hoare_pre) + apply (wp sch_act_wf_lift valid_global_refs_lift' irqs_masked_lift + valid_irq_node_lift + cur_tcb_lift valid_irq_handlers_lift'' + untyped_ranges_zero_lift + updateObject_default_inv valid_bitmaps_lift + | simp add: cteCaps_of_def + | rule setObject_ksPSpace_only)+ + apply (clarsimp simp add: setObject_def o_def) done crunches vcpuSave, vcpuRestore, vcpuDisable, vcpuEnable diff --git a/proof/refine/RISCV64/ADT_H.thy b/proof/refine/RISCV64/ADT_H.thy index 12353508da..15bf6278fd 100644 --- a/proof/refine/RISCV64/ADT_H.thy +++ b/proof/refine/RISCV64/ADT_H.thy @@ -454,7 +454,7 @@ proof - apply (intro conjI impI allI) apply (erule pspace_dom_relatedE[OF _ pspace_relation]) apply clarsimp - apply (case_tac ko; simp add: other_obj_relation_def) + apply (case_tac ko; simp add: tcb_relation_cut_def other_obj_relation_def) apply (clarsimp simp: cte_relation_def split: if_split_asm) apply (clarsimp simp: ep_relation_def EndpointMap_def split: Structures_A.endpoint.splits) @@ -465,7 +465,7 @@ proof - apply (clarsimp split: if_split_asm)+ apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko; simp add: other_obj_relation_def) + apply (case_tac ko; simp add: tcb_relation_cut_def other_obj_relation_def) apply (clarsimp simp: cte_relation_def split: if_split_asm) apply (clarsimp simp: ntfn_relation_def AEndpointMap_def split: Structures_A.ntfn.splits) @@ -476,7 +476,7 @@ proof - apply (clarsimp split: if_split_asm)+ apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko; simp add: other_obj_relation_def) + apply (case_tac ko; simp add: tcb_relation_cut_def other_obj_relation_def) apply (clarsimp simp: cte_relation_def split: if_split_asm) apply (rename_tac arch_kernel_obj) apply (case_tac arch_kernel_obj; simp add: other_obj_relation_def) @@ -484,7 +484,7 @@ proof - apply (clarsimp split: if_split_asm)+ apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko, simp_all add: other_obj_relation_def) + 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) @@ -507,7 +507,7 @@ proof - apply (erule n_less_2p_pageBitsForSize) apply (clarsimp simp: shiftl_t2n mult_ac) apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko, simp_all add: other_obj_relation_def) + 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) @@ -530,7 +530,7 @@ proof - apply (erule n_less_2p_pageBitsForSize) apply (clarsimp simp: shiftl_t2n mult_ac) apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko, simp_all add: other_obj_relation_def) + 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) @@ -556,7 +556,7 @@ proof - 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: other_obj_relation_def + 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) @@ -623,7 +623,7 @@ proof - (* mapping architecture-specific objects *) apply clarsimp apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko, simp_all add: other_obj_relation_def) + 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 @@ -660,7 +660,7 @@ proof - apply (clarsimp dest!: koTypeOf_pte simp: objBits_simps bit_simps) apply (rename_tac pte') apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko; simp add: other_obj_relation_def) + apply (case_tac ko; simp add: tcb_relation_cut_def other_obj_relation_def) apply (clarsimp simp add: cte_relation_def split: if_split_asm) apply (rename_tac ako' y ko P ako) apply (case_tac ako; clarsimp simp: other_obj_relation_def bit_simps) @@ -749,7 +749,7 @@ lemma absEkheap_correct: apply (case_tac "ksPSpace s' x", clarsimp) apply (erule_tac x=x in allE, clarsimp) apply clarsimp - apply (case_tac a, simp_all add: other_obj_relation_def) + 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) apply (erule(1) pspace_dom_relatedE) @@ -777,7 +777,7 @@ lemma TCB_implies_KOTCB: apply (clarsimp simp add: pspace_relation_def pspace_dom_def dom_def UNION_eq Collect_eq) apply (erule_tac x=a in allE)+ - apply (clarsimp simp add: other_obj_relation_def + apply (clarsimp simp add: tcb_relation_cut_def split: Structures_H.kernel_object.splits) apply (drule iffD1) apply (fastforce simp add: dom_def image_def) @@ -1524,7 +1524,7 @@ definition domain_index_internal = ksDomScheduleIdx s, cur_domain_internal = ksCurDomain s, domain_time_internal = ksDomainTime s, - ready_queues_internal = curry (ksReadyQueues 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: @@ -1532,12 +1532,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 absEkheap_correct - absCDTList_correct[THEN fun_cong] state_relation_def invs_def valid_state_def - ready_queues_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) + 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 diff --git a/proof/refine/RISCV64/ArchAcc_R.thy b/proof/refine/RISCV64/ArchAcc_R.thy index 3beb2515cf..1465eda97a 100644 --- a/proof/refine/RISCV64/ArchAcc_R.thy +++ b/proof/refine/RISCV64/ArchAcc_R.thy @@ -52,27 +52,38 @@ lemma pspace_aligned_cross: 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) - apply (clarsimp simp: cte_map_def) - apply (simp add: cteSizeBits_def cte_level_bits_def) - apply (rule is_aligned_add) - apply (erule is_aligned_weaken) - apply simp - apply (rule is_aligned_shift) + + \\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_shiftl_self, simp) + + \\TCB\ + apply (clarsimp simp: tcbBlockSizeBits_def elim!: is_aligned_weaken) + + \\PageTable\ + apply (clarsimp simp: archObjSize_def pteBits_def table_size_def ptTranslationBits_def pte_bits_def) apply (rule is_aligned_add) apply (erule is_aligned_weaken) - apply (simp add: bit_simps) + apply simp apply (rule is_aligned_shift) + + \\DataPage\ apply (rule is_aligned_add) apply (erule is_aligned_weaken) apply (rule pbfs_atleast_pageBits) apply (rule is_aligned_shift) + + \\other_obj_relation\ apply (simp add: other_obj_relation_def) apply (clarsimp simp: bit_simps' tcbBlockSizeBits_def epSizeBits_def ntfnSizeBits_def - split: kernel_object.splits Structures_A.kernel_object.splits) - apply (clarsimp simp: archObjSize_def split: arch_kernel_object.splits arch_kernel_obj.splits) - apply (erule is_aligned_weaken) - apply (simp add: bit_simps) + split: kernel_object.splits Structures_A.kernel_object.splits) + apply (fastforce simp: archObjSize_def split: arch_kernel_object.splits arch_kernel_obj.splits) done lemma of_bl_shift_cte_level_bits: @@ -84,10 +95,12 @@ lemma obj_relation_cuts_range_limit: "\ (p', P) \ obj_relation_cuts ko p; P ko ko' \ \ \x n. p' = p + x \ is_aligned x n \ n \ obj_bits ko \ x \ mask (obj_bits ko)" apply (erule (1) obj_relation_cutsE; clarsimp) - apply (drule (1) wf_cs_nD) - apply (clarsimp simp: cte_map_def) - apply (rule_tac x=cte_level_bits in exI) - apply (simp add: is_aligned_shift of_bl_shift_cte_level_bits) + apply (drule (1) wf_cs_nD) + apply (clarsimp simp: cte_map_def) + apply (rule_tac x=cte_level_bits in exI) + apply (simp add: is_aligned_shift of_bl_shift_cte_level_bits) + apply (rule_tac x=tcbBlockSizeBits in exI) + apply (simp add: tcbBlockSizeBits_def) apply (rule_tac x=pte_bits in exI) apply (simp add: bit_simps is_aligned_shift mask_def) apply word_bitwise @@ -230,14 +243,6 @@ lemma getObject_ASIDPool_corres: apply (clarsimp simp: other_obj_relation_def asid_pool_relation_def) done -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 project_inject pspace_distinct'_def pspace_aligned'_def) - apply (drule bspec, erule domI)+ - apply simp - done - lemma storePTE_cte_wp_at'[wp]: "storePTE ptr val \\s. P (cte_wp_at' P' p s)\" apply (simp add: storePTE_def) @@ -442,10 +447,14 @@ lemma setObject_PT_corres: apply (drule_tac x=p in bspec, erule domI) apply (simp add: other_obj_relation_def split: Structures_A.kernel_object.splits) - apply (rule conjI) + apply (extract_conjunct \match conclusion in "ghost_relation _ _ _" \ -\) apply (clarsimp simp add: ghost_relation_def) apply (erule_tac x="p && ~~ mask pt_bits" in allE)+ apply fastforce + apply (extract_conjunct \match conclusion in "ready_queues_relation_2 _ _ _ _ _" \ -\) + apply (prop_tac "typ_at' (koTypeOf (injectKO pte')) p b") + apply (simp add: typ_at'_def ko_wp_at'_def) + subgoal by (fastforce dest: tcbs_of'_non_tcb_update) apply (simp add: map_to_ctes_upd_other) apply (simp add: fun_upd_def) apply (simp add: caps_of_state_after_update obj_at_def swp_cte_at_caps_of) diff --git a/proof/refine/RISCV64/Arch_R.thy b/proof/refine/RISCV64/Arch_R.thy index a209ca58c0..f9e759cd73 100644 --- a/proof/refine/RISCV64/Arch_R.thy +++ b/proof/refine/RISCV64/Arch_R.thy @@ -262,11 +262,10 @@ lemma performASIDControlInvocation_corres: deleteObjects_cte_wp_at' deleteObjects_null_filter[where p="makePoolParent i'"]) apply (clarsimp simp:invs_mdb max_free_index_def invs_untyped_children) - 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 (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) @@ -274,9 +273,9 @@ lemma performASIDControlInvocation_corres: apply (fold_subgoals (prefix))[2] subgoal premises prems using prems by (clarsimp simp:invs_def valid_state_def)+ apply (clarsimp simp: schact_is_rct_def) - apply (clarsimp simp:cte_wp_at_caps_of_state) + 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 (fastforce simp: cte_wp_at_caps_of_state) apply simp apply (frule_tac ptr = "(aa,ba)" in detype_invariants [rotated 3]) apply fastforce @@ -340,7 +339,7 @@ lemma performASIDControlInvocation_corres: apply (simp add:pageBits_def) apply clarsimp apply (drule(1) cte_cap_in_untyped_range) - apply (fastforce simp:cte_wp_at_ctes_of) + apply (fastforce simp: cte_wp_at_ctes_of) apply assumption+ apply fastforce apply simp diff --git a/proof/refine/RISCV64/Bits_R.thy b/proof/refine/RISCV64/Bits_R.thy index b6ba101ecd..bd6bafa35f 100644 --- a/proof/refine/RISCV64/Bits_R.thy +++ b/proof/refine/RISCV64/Bits_R.thy @@ -73,6 +73,10 @@ lemma projectKO_tcb: "(projectKO_opt ko = Some t) = (ko = KOTCB t)" by (cases ko) (auto simp: projectKO_opts_defs) +lemma tcb_of'_TCB[simp]: + "tcb_of' (KOTCB tcb) = Some tcb" + by (simp add: projectKO_tcb) + lemma projectKO_cte: "(projectKO_opt ko = Some t) = (ko = KOCTE t)" by (cases ko) (auto simp: projectKO_opts_defs) diff --git a/proof/refine/RISCV64/CNodeInv_R.thy b/proof/refine/RISCV64/CNodeInv_R.thy index d4feda068b..281a00261a 100644 --- a/proof/refine/RISCV64/CNodeInv_R.thy +++ b/proof/refine/RISCV64/CNodeInv_R.thy @@ -5042,8 +5042,6 @@ crunch valid_arch_state'[wp]: cteSwap "valid_arch_state'" crunch irq_states'[wp]: cteSwap "valid_irq_states'" -crunch vq'[wp]: cteSwap "valid_queues'" - crunch ksqsL1[wp]: cteSwap "\s. P (ksReadyQueuesL1Bitmap s)" crunch ksqsL2[wp]: cteSwap "\s. P (ksReadyQueuesL2Bitmap s)" @@ -5058,6 +5056,12 @@ crunch ct_not_inQ[wp]: cteSwap "ct_not_inQ" crunch ksDomScheduleIdx [wp]: cteSwap "\s. P (ksDomScheduleIdx s)" +crunches cteSwap + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + and valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift) + lemma cteSwap_invs'[wp]: "\invs' and valid_cap' c and valid_cap' c' and ex_cte_cap_to' c1 and ex_cte_cap_to' c2 and @@ -5513,6 +5517,10 @@ lemma updateCap_untyped_ranges_zero_simple: crunch tcb_in_cur_domain'[wp]: updateCap "tcb_in_cur_domain' t" (wp: crunch_wps simp: crunch_simps rule: tcb_in_cur_domain'_lift) +crunches updateCap + for valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift) + lemma make_zombie_invs': "\\s. invs' s \ s \' cap \ cte_wp_at' (\cte. isFinal (cteCap cte) sl (cteCaps_of s)) sl s \ @@ -5529,7 +5537,8 @@ lemma make_zombie_invs': st_tcb_at' ((=) Inactive) p s \ bound_tcb_at' ((=) None) p s \ obj_at' (Not \ tcbQueued) p s - \ (\pr. p \ set (ksReadyQueues s pr)))) sl 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_state'_def valid_pspace'_def valid_mdb'_def @@ -5566,7 +5575,9 @@ lemma make_zombie_invs': 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_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) apply (auto dest!: isCapDs)[1] apply (clarsimp simp: cte_wp_at_ctes_of disj_ac @@ -8528,6 +8539,15 @@ lemma cteMove_urz [wp]: apply auto done +crunches updateMDB + for valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift) + +(* FIXME: arch_split *) +lemma haskell_assert_inv: + "haskell_assert Q L \P\" + by wpsimp + lemma cteMove_invs' [wp]: "\\x. invs' x \ ex_cte_cap_to' word2 x \ cte_wp_at' (\c. weak_derived' (cteCap c) capability) word1 x \ @@ -8605,6 +8625,10 @@ crunch ksDomSchedule[wp]: updateCap "\s. P (ksDomSchedule s)" crunch ksDomScheduleIdx[wp]: updateCap "\s. P (ksDomScheduleIdx s)" crunch ksDomainTime[wp]: updateCap "\s. P (ksDomainTime s)" +crunches updateCap + for rdyq_projs[wp]: + "\s. P (ksReadyQueues s) (tcbSchedNexts_of s) (tcbSchedPrevs_of s) (\d p. inQ d p |< tcbs_of' s)" + lemma corres_null_cap_update: "cap_relation cap cap' \ corres dc (invs and cte_wp_at ((=) cap) slot) diff --git a/proof/refine/RISCV64/CSpace1_R.thy b/proof/refine/RISCV64/CSpace1_R.thy index 437285321d..3ee92fdf7c 100644 --- a/proof/refine/RISCV64/CSpace1_R.thy +++ b/proof/refine/RISCV64/CSpace1_R.thy @@ -233,7 +233,7 @@ lemma pspace_relation_cte_wp_at: apply (clarsimp elim!: cte_wp_at_weakenE') apply clarsimp apply (drule(1) pspace_relation_absD) - apply (clarsimp simp: other_obj_relation_def) + apply (clarsimp simp: tcb_relation_cut_def) apply (simp split: kernel_object.split_asm) apply (drule(2) aligned_distinct_obj_atI'[where 'a=tcb]) apply simp @@ -1631,10 +1631,10 @@ lemma cte_map_pulls_tcb_to_abstract: \ \tcb'. kheap s x = Some (TCB tcb') \ tcb_relation tcb' tcb \ (z = (x, tcb_cnode_index (unat ((y - x) >> cte_level_bits))))" apply (rule pspace_dom_relatedE, assumption+) - apply (erule(1) obj_relation_cutsE, simp_all split: if_split_asm) - apply (clarsimp simp: other_obj_relation_def + apply (erule(1) obj_relation_cutsE; + clarsimp simp: other_obj_relation_def split: Structures_A.kernel_object.split_asm - RISCV64_A.arch_kernel_obj.split_asm) + RISCV64_A.arch_kernel_obj.split_asm if_split_asm) apply (drule tcb_cases_related2) apply clarsimp apply (frule(1) cte_wp_at_tcbI [OF _ _ TrueI, where t="(a, b)" for a b, simplified]) @@ -1650,8 +1650,7 @@ lemma pspace_relation_update_tcbs: del: dom_fun_upd) apply (erule conjE) apply (rule ballI, drule(1) bspec) - apply (rule conjI, simp add: other_obj_relation_def) - apply (clarsimp split: Structures_A.kernel_object.split_asm) + apply (clarsimp simp: tcb_relation_cut_def split: Structures_A.kernel_object.split_asm) apply (drule bspec, fastforce) apply clarsimp apply (erule(1) obj_relation_cutsE, simp_all split: if_split_asm) @@ -1873,6 +1872,27 @@ lemma descendants_of_eq': apply simp done +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 + +lemma setObject_cte_tcbSchedNexts_of_use_valid_ksPSpace: + assumes step: "(x, s\ksPSpace := ps\) \ fst (setObject p (cte :: cte) s)" + 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_inQ_of_use_valid_ksPSpace: + assumes step: "(x, s\ksPSpace := ps\) \ fst (setObject p (cte :: cte) s)" + 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))) \ @@ -1886,7 +1906,12 @@ lemma updateCap_stuff: ksSchedulerAction s'' = ksSchedulerAction s' \ (ksArchState s'' = ksArchState s') \ (pspace_aligned' s' \ pspace_aligned' s'') \ - (pspace_distinct' s' \ pspace_distinct' s'')" using assms + (pspace_distinct' s' \ pspace_distinct' s'') \ + 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) @@ -1895,8 +1920,11 @@ lemma updateCap_stuff: apply (frule setCTE_pspace_only) apply (clarsimp simp: setCTE_def) apply (intro conjI impI) - apply (erule(1) use_valid [OF _ setObject_aligned]) - apply (erule(1) use_valid [OF _ setObject_distinct]) + 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 *) @@ -1913,16 +1941,16 @@ lemma pspace_relation_cte_wp_atI': apply (simp split: if_split_asm) apply (erule(1) pspace_dom_relatedE) apply (erule(1) obj_relation_cutsE, simp_all split: if_split_asm) + apply (subgoal_tac "n = x - y", clarsimp) + apply (drule tcb_cases_related2, clarsimp) + apply (intro exI, rule conjI) + apply (erule(1) cte_wp_at_tcbI[where t="(a, b)" for a b, simplified]) + apply fastforce + apply simp + apply clarsimp apply (simp add: other_obj_relation_def split: Structures_A.kernel_object.split_asm RISCV64_A.arch_kernel_obj.split_asm) - apply (subgoal_tac "n = x - y", clarsimp) - apply (drule tcb_cases_related2, clarsimp) - apply (intro exI, rule conjI) - apply (erule(1) cte_wp_at_tcbI[where t="(a, b)" for a b, simplified]) - apply fastforce - apply simp - apply clarsimp done lemma pspace_relation_cte_wp_atI: @@ -2444,7 +2472,7 @@ lemma updateCap_corres: apply (clarsimp simp: in_set_cap_cte_at_swp pspace_relations_def) apply (drule updateCap_stuff) apply simp - apply (rule conjI) + apply (extract_conjunct \match conclusion in "ghost_relation _ _ _" \ -\) apply (clarsimp simp: ghost_relation_typ_at set_cap_a_type_inv data_at_def) apply (rule conjI) prefer 2 @@ -2532,9 +2560,9 @@ lemma updateMDB_pspace_relation: apply (clarsimp simp: tcb_ctes_clear cte_level_bits_def objBits_defs) apply clarsimp apply (rule pspace_dom_relatedE, assumption+) - apply (rule obj_relation_cutsE, assumption+, simp_all split: if_split_asm)[1] - apply (clarsimp split: Structures_A.kernel_object.split_asm - RISCV64_A.arch_kernel_obj.split_asm + apply (rule obj_relation_cutsE, assumption+; + clarsimp split: Structures_A.kernel_object.split_asm + RISCV64_A.arch_kernel_obj.split_asm if_split_asm simp: other_obj_relation_def) apply (frule(1) tcb_cte_cases_aligned_helpers(1)) apply (frule(1) tcb_cte_cases_aligned_helpers(2)) @@ -2596,6 +2624,25 @@ lemma updateMDB_ctes_of: crunch aligned[wp]: updateMDB "pspace_aligned'" crunch pdistinct[wp]: updateMDB "pspace_distinct'" +crunch tcbSchedPrevs_of[wp]: updateMDB "\s. P (tcbSchedPrevs_of s)" +crunch tcbSchedNexts_of[wp]: updateMDB "\s. P (tcbSchedNexts_of s)" +crunch inQ_opt_pred[wp]: updateMDB "\s. P (inQ d p |< tcbs_of' s)" +crunch inQ_opt_pred'[wp]: updateMDB "\s. P (\d p. inQ d p |< tcbs_of' s)" +crunch ksReadyQueues[wp]: updateMDB "\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 + +crunches 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')" @@ -2618,7 +2665,11 @@ lemma updateMDB_the_lot: ksDomScheduleIdx s'' = ksDomScheduleIdx s' \ ksDomSchedule s'' = ksDomSchedule s' \ ksCurDomain s'' = ksCurDomain s' \ - ksDomainTime s'' = ksDomainTime s'" + ksDomainTime s'' = ksDomainTime s' \ + 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) @@ -2627,9 +2678,8 @@ using assms apply (erule use_valid) apply wp apply simp - 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 is_cap_revocable_eq: @@ -3792,6 +3842,9 @@ lemma updateUntypedCap_descendants_of: apply (clarsimp simp:mdb_next_rel_def mdb_next_def split:if_splits) done +crunches setCTE + for tcbQueued[wp]: "\s. P (tcbQueued |< tcbs_of' s)" + lemma setCTE_UntypedCap_corres: "\cap_relation cap (cteCap cte); is_untyped_cap cap; idx' = idx\ \ corres dc (cte_wp_at ((=) cap) src and valid_objs and @@ -3821,10 +3874,19 @@ lemma setCTE_UntypedCap_corres: apply assumption apply (clarsimp simp: pspace_relations_def) apply (subst conj_assoc[symmetric]) + apply clarsimp 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) @@ -5104,11 +5166,15 @@ lemma updateMDB_the_lot': ksDomScheduleIdx s'' = ksDomScheduleIdx s' \ ksDomSchedule s'' = ksDomSchedule s' \ ksCurDomain s'' = ksCurDomain s' \ - ksDomainTime s'' = ksDomainTime s'" + ksDomainTime s'' = ksDomainTime s' \ + 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 + done lemma cte_map_inj_eq': "\(cte_map p = cte_map p'); @@ -5210,7 +5276,6 @@ lemma cteInsert_corres: 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 "ksReadyQueues t = p" for p t)+ apply (thin_tac "ksSchedulerAction t = p" for p t)+ apply (clarsimp simp: pspace_relations_def) diff --git a/proof/refine/RISCV64/CSpace_R.thy b/proof/refine/RISCV64/CSpace_R.thy index 797bc486ce..b4c1d528ac 100644 --- a/proof/refine/RISCV64/CSpace_R.thy +++ b/proof/refine/RISCV64/CSpace_R.thy @@ -1091,43 +1091,6 @@ lemma bitmapQ_no_L2_orphans_lift: apply (rule hoare_vcg_prop, assumption) done -lemma valid_queues_lift_asm: - assumes tat1: "\d p tcb. \obj_at' (inQ d p) tcb and Q \ f \\_. obj_at' (inQ d p) tcb\" - and tat2: "\tcb. \st_tcb_at' runnable' tcb and Q \ f \\_. st_tcb_at' runnable' tcb\" - and prq: "\P. \\s. P (ksReadyQueues s) \ f \\_ s. P (ksReadyQueues s)\" - and prqL1: "\P. \\s. P (ksReadyQueuesL1Bitmap s)\ f \\_ s. P (ksReadyQueuesL1Bitmap s)\" - and prqL2: "\P. \\s. P (ksReadyQueuesL2Bitmap s)\ f \\_ s. P (ksReadyQueuesL2Bitmap s)\" - shows "\Invariants_H.valid_queues and Q\ f \\_. Invariants_H.valid_queues\" - proof - - have tat: "\d p tcb. \obj_at' (inQ d p) tcb and st_tcb_at' runnable' tcb and Q\ f - \\_. obj_at' (inQ d p) tcb and st_tcb_at' runnable' tcb\" - apply (rule hoare_chain [OF hoare_vcg_conj_lift [OF tat1 tat2]]) - apply (fastforce)+ - done - have tat_combined: "\d p tcb. \obj_at' (inQ d p and runnable' \ tcbState) tcb and Q\ f - \\_. obj_at' (inQ d p and runnable' \ tcbState) tcb\" - apply (rule hoare_chain [OF tat]) - apply (fastforce simp add: obj_at'_and pred_tcb_at'_def o_def)+ - done - show ?thesis unfolding valid_queues_def valid_queues_no_bitmap_def - by (wp tat_combined prq prqL1 prqL2 valid_bitmapQ_lift bitmapQ_no_L2_orphans_lift - bitmapQ_no_L1_orphans_lift hoare_vcg_all_lift hoare_vcg_conj_lift hoare_Ball_helper) - simp_all - qed - -lemmas valid_queues_lift = valid_queues_lift_asm[where Q="\_. True", simplified] - -lemma valid_queues_lift': - assumes tat: "\d p tcb. \\s. \ obj_at' (inQ d p) tcb s\ f \\_ s. \ obj_at' (inQ d p) tcb s\" - and prq: "\P. \\s. P (ksReadyQueues s)\ f \\_ s. P (ksReadyQueues s)\" - shows "\valid_queues'\ f \\_. valid_queues'\" - unfolding valid_queues'_def imp_conv_disj - by (wp hoare_vcg_all_lift hoare_vcg_disj_lift tat prq) - -lemma setCTE_norq [wp]: - "\\s. P (ksReadyQueues s)\ setCTE ptr cte \\r s. P (ksReadyQueues s) \" - by (clarsimp simp: valid_def dest!: setCTE_pspace_only) - lemma setCTE_norqL1 [wp]: "\\s. P (ksReadyQueuesL1Bitmap s)\ setCTE ptr cte \\r s. P (ksReadyQueuesL1Bitmap s) \" by (clarsimp simp: valid_def dest!: setCTE_pspace_only) @@ -2784,12 +2747,6 @@ lemma setCTE_inQ[wp]: apply (simp_all add: inQ_def) done -lemma setCTE_valid_queues'[wp]: - "\valid_queues'\ setCTE p cte \\rv. valid_queues'\" - apply (simp only: valid_queues'_def imp_conv_disj) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - done - crunch inQ[wp]: cteInsert "\s. P (obj_at' (inQ d p) t s)" (wp: crunch_wps) @@ -3289,6 +3246,13 @@ lemma cteInsert_untyped_ranges_zero[wp]: apply blast done +crunches cteInsert + 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 (\s. src \ dest) and (\s. cte_wp_at' (is_derived' (ctes_of s) src cap \ cteCap) src s) @@ -3297,9 +3261,9 @@ lemma cteInsert_invs: cteInsert cap src dest \\rv. invs'\" 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 CSpace_R.valid_queues_lift - valid_irq_node_lift valid_queues_lift' irqs_masked_lift cteInsert_norq - simp: st_tcb_at'_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 @@ -3603,10 +3567,13 @@ lemma corres_caps_decomposition: "\P. \\s. P (new_ups' s)\ g \\rv s. P (gsUserPages s)\" "\P. \\s. P (new_cns s)\ f \\rv s. P (cns_of_heap (kheap s))\" "\P. \\s. P (new_cns' s)\ g \\rv s. P (gsCNodes s)\" - "\P. \\s. P (new_queues s)\ f \\rv s. P (ready_queues s)\" + "\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_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)\" @@ -3622,7 +3589,9 @@ lemma corres_caps_decomposition: "\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 (new_queues s) (new_rqs' s')" + \ ready_queues_relation_2 (new_ready_queues s) (new_ksReadyQueues s') + (new_tcbSchedNexts_of s') (new_tcbSchedPrevs_of s') + (\d p. new_inQs d p s')" "\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 \ @@ -3690,8 +3659,9 @@ proof - 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 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 pspace_relations_def swp_cte_at))+ + 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 @@ -3796,7 +3766,7 @@ lemma create_reply_master_corres: apply clarsimp apply (rule corres_caps_decomposition) defer - apply (wp|simp)+ + 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) @@ -4172,6 +4142,9 @@ crunches setupReplyMaster 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]: @@ -4200,7 +4173,8 @@ lemma setupReplyMaster_invs'[wp]: 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 valid_queues_lift' hoare_vcg_disj_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 @@ -4464,8 +4438,8 @@ lemma arch_update_setCTE_invs: 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 + 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) @@ -5840,7 +5814,7 @@ lemma cteInsert_simple_invs: apply (rule hoare_pre) 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' irqs_masked_lift + 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 @@ -5975,6 +5949,21 @@ lemma arch_update_updateCap_invs: apply clarsimp 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 @@ -6006,6 +5995,8 @@ lemma updateCap_same_master: apply 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 @@ -6236,8 +6227,9 @@ lemma updateFreeIndex_forward_invs': apply (simp add:updateCap_def) apply (wp setCTE_irq_handlers' getCTE_wp) apply (simp add:updateCap_def) - apply (wp irqs_masked_lift valid_queues_lift' cur_tcb_lift ct_idle_or_in_cur_domain'_lift + apply (wp irqs_masked_lift cur_tcb_lift ct_idle_or_in_cur_domain'_lift hoare_vcg_disj_lift untyped_ranges_zero_lift getCTE_wp + sym_heap_sched_pointers_lift valid_bitmaps_lift | wp (once) hoare_use_eq[where f="gsUntypedZeroRanges"] | simp add: getSlotCap_def)+ apply (clarsimp simp: cte_wp_at_ctes_of fun_upd_def[symmetric]) diff --git a/proof/refine/RISCV64/Detype_R.thy b/proof/refine/RISCV64/Detype_R.thy index 6c6fb9cc16..42d0703b7d 100644 --- a/proof/refine/RISCV64/Detype_R.thy +++ b/proof/refine/RISCV64/Detype_R.thy @@ -558,7 +558,6 @@ lemma sym_refs_ko_wp_atD: 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 = @@ -578,8 +577,9 @@ lemma valid_objs: "valid_objs' s'" and pc: "pspace_canonical' s'" and pkm: "pspace_in_kernel_mappings' s'" and pd: "pspace_distinct' s'" - and vq: "valid_queues s'" - and vq': "valid_queues' s'" + and vbm: "valid_bitmaps s'" + and sym_sched: "sym_heap_sched_pointers s'" + and vsp: "valid_sched_pointers s'" and sym_refs: "sym_refs (state_refs_of' s')" and iflive: "if_live_then_nonz_cap' s'" and ifunsafe: "if_unsafe_then_cap' s'" @@ -770,7 +770,6 @@ lemma refs_notRange: apply (rule refs_of_live') apply clarsimp done - end context begin interpretation Arch . (*FIXME: arch_split*) @@ -836,6 +835,70 @@ crunches doMachineOp for deletionIsSafe_delete_locale[wp]: "deletionIsSafe_delete_locale base magnitude" (simp: deletionIsSafe_delete_locale_def) +lemma detype_tcbSchedNexts_of: + "\pspace_aligned' s'; pspace_distinct' s'; \p. p \ S \ \ ko_wp_at' live' p s'\ + \ ((\x. if x \ S then None else ksPSpace s' x) |> tcb_of' |> tcbSchedNext) + = tcbSchedNexts_of s'" + using pspace_alignedD' pspace_distinctD' + apply (clarsimp simp: opt_map_def) + apply (rule ext) + apply (rename_tac s) + apply (clarsimp simp: ko_wp_at'_def split: option.splits) + apply (drule_tac x=s in spec) + apply force + done + +lemma detype_tcbSchedPrevs_of: + "\pspace_aligned' s'; pspace_distinct' s'; \p. p \ S \ \ ko_wp_at' live' p s'\ + \ ((\x. if x \ S then None else ksPSpace s' x) |> tcb_of' |> tcbSchedPrev) + = tcbSchedPrevs_of s'" + using pspace_alignedD' pspace_distinctD' + using pspace_alignedD' pspace_distinctD' + apply (clarsimp simp: opt_map_def) + apply (rule ext) + apply (rename_tac s) + apply (clarsimp simp: ko_wp_at'_def split: option.splits) + apply (drule_tac x=s in spec) + apply force + done + +lemma detype_inQ: + "\pspace_aligned' s'; pspace_distinct' s'; \p. p \ S \ \ ko_wp_at' live' p s'\ + \ \d p. (inQ d p |< ((\x. if x \ S then None else ksPSpace s' x) |> tcb_of')) + = (inQ d p |< tcbs_of' s')" + using pspace_alignedD' pspace_distinctD' + using pspace_alignedD' pspace_distinctD' + apply (clarsimp simp: opt_map_def) + apply (rule ext) + apply (rename_tac s) + apply (clarsimp simp: inQ_def opt_pred_def ko_wp_at'_def split: option.splits) + apply (drule_tac x=s in spec) + apply force + done + +lemma detype_ready_queues_relation: + "\pspace_aligned' s'; pspace_distinct' s'; + \p. p \ {lower..upper} \ \ ko_wp_at' live' p s'; + ready_queues_relation s s'; upper = upper'\ + \ ready_queues_relation_2 + (ready_queues (detype {lower..upper'} s)) + (ksReadyQueues s') + ((\x. if lower \ x \ x \ upper then None + else ksPSpace s' x) |> + tcb_of' |> + tcbSchedNext) + ((\x. if lower \ x \ x \ upper then None + else ksPSpace s' x) |> + tcb_of' |> + tcbSchedPrev) + (\d p. inQ d p |< ((\x. if lower \ x \ x \ upper then None else ksPSpace s' x) |> tcb_of'))" + apply (clarsimp simp: detype_ext_def ready_queues_relation_def Let_def) + apply (frule (1) detype_tcbSchedNexts_of[where S="{lower..upper}"]; simp) + apply (frule (1) detype_tcbSchedPrevs_of[where S="{lower..upper}"]; simp) + apply (frule (1) detype_inQ[where S="{lower..upper}"]; simp) + apply (fastforce simp add: detype_def detype_ext_def) + done + lemma deleteObjects_corres: "is_aligned base magnitude \ magnitude \ 3 \ corres dc @@ -856,20 +919,19 @@ lemma deleteObjects_corres: apply (rule corres_stateAssert_implied[where P'=\, simplified]) prefer 2 apply clarsimp - 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 p_assoc_help invs_valid_pspace)[1] - apply (simp add:valid_cap_simps) + 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 (fastforce simp: sch_act_simple_def schact_is_rct_def state_relation_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: valid_cap_simps) apply (simp add: bind_assoc[symmetric] ksASIDMapSafe_def) apply (simp add: delete_objects_def) apply (rule_tac Q="\_ s. valid_objs s \ valid_list s \ @@ -921,6 +983,10 @@ lemma deleteObjects_corres: apply (clarsimp simp: valid_cap_def, assumption) apply (fastforce simp: detype_def detype_ext_def add_mask_fold intro!: ekheap_relation_detype) apply (simp add: add_mask_fold) + 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) @@ -932,13 +998,31 @@ lemma deleteObjects_corres: 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' live' p s' \ p = idle_thread_ptr \ p \ base_bits" + apply (case_tac "ko_wp_at' live' 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 invs_valid_idle'[OF invs]) + 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 mask_eq_exp_minus_1) + by fastforce + +lemma untyped_range_live_idle': + "p \ base_bits \ \ (ko_wp_at' live' p s' \ p = idle_thread_ptr)" + using live_idle_untyped_range' by blast + lemma valid_obj': - "\ valid_obj' obj s'; ko_wp_at' ((=) obj) p s' \ \ valid_obj' obj state'" + "\ 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 (rename_tac endpoint) apply (case_tac endpoint, simp_all add: valid_ep'_def)[1] @@ -965,10 +1049,21 @@ lemma valid_obj': apply (erule(2) cte_wp_at_tcbI') apply fastforce apply simp - 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 (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) + 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) 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]) @@ -976,14 +1071,46 @@ lemma valid_obj': apply simp done +lemma tcbSchedNexts_of_pspace': + "\pspace_aligned' s'; pspace_distinct' s'; pspace_distinct' state'\ + \ (pspace' |> tcb_of' |> tcbSchedNext) = tcbSchedNexts_of s'" + apply (rule ext) + apply (rename_tac p) + apply (case_tac "p \ base_bits") + apply (frule untyped_range_live_idle') + apply (clarsimp simp: opt_map_def) + apply (case_tac "ksPSpace s' p"; clarsimp) + apply (rename_tac obj) + apply (case_tac "tcb_of' obj"; clarsimp) + apply (clarsimp simp: ko_wp_at'_def obj_at'_def) + apply (fastforce simp: pspace_alignedD' pspace_distinctD') + apply (clarsimp simp: opt_map_def split: option.splits) + done + +lemma tcbSchedPrevs_of_pspace': + "\pspace_aligned' s'; pspace_distinct' s'; pspace_distinct' state'\ + \ (pspace' |> tcb_of' |> tcbSchedPrev) = tcbSchedPrevs_of s'" + apply (rule ext) + apply (rename_tac p) + apply (case_tac "p \ base_bits") + apply (frule untyped_range_live_idle') + apply (clarsimp simp: opt_map_def) + apply (case_tac "ksPSpace s' p"; clarsimp) + apply (rename_tac obj) + apply (case_tac "tcb_of' obj"; clarsimp) + apply (clarsimp simp: ko_wp_at'_def obj_at'_def) + apply (fastforce simp: pspace_alignedD' pspace_distinctD') + apply (clarsimp simp: opt_map_def split: option.splits) + done + lemma st_tcb: - "\P p. \ st_tcb_at' P p s'; \ P Inactive; \ P IdleThreadState \ \ st_tcb_at' P p state'" - by (fastforce simp: pred_tcb_at'_def obj_at'_real_def - dest: live_notRange) + "\P p. \ st_tcb_at' P p s'; \ P Inactive; \ P IdleThreadState \ \ st_tcb_at' P p state'" + by (fastforce simp: pred_tcb_at'_def obj_at'_real_def + dest: live_notRange) lemma irq_nodes_global: - "\irq :: irq. irq_node' s' + (ucast irq << cteSizeBits) \ global_refs' s'" - by (simp add: global_refs'_def) + "\irq :: irq. irq_node' s' + (ucast irq << cteSizeBits) \ global_refs' s'" + by (simp add: global_refs'_def) lemma global_refs: "global_refs' s' \ base_bits = {}" @@ -1189,17 +1316,18 @@ proof (simp add: invs'_def valid_state'_def valid_pspace'_def show "pspace_in_kernel_mappings' ?s" using pkm by (simp add: pspace_in_kernel_mappings'_def dom_def) - show "pspace_distinct' ?s" using pd + show pspace_distinct'_state': "pspace_distinct' ?s" using pd by (clarsimp simp add: pspace_distinct'_def ps_clear_def dom_if_None Diff_Int_distrib) - show "valid_objs' ?s" using valid_objs + show "valid_objs' ?s" using valid_objs sym_sched apply (clarsimp simp: valid_objs'_def ran_def) 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 + apply (frule pspace_alignedD'[OF _ pa]) + apply (frule pspace_distinctD'[OF _ pd]) + apply (clarsimp simp: ko_wp_at'_def) + apply fastforce done from sym_refs show "sym_refs (state_refs_of' ?s)" @@ -1211,19 +1339,6 @@ proof (simp add: invs'_def valid_state'_def valid_pspace'_def apply (simp add: refs_notRange[simplified] state_refs_ko_wp_at_eq) done - 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: inQ_def) - apply (clarsimp dest!: ex_nonz_cap_notRange) - done - - from vq' show "valid_queues' ?s" - by (simp add: valid_queues'_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) @@ -1471,6 +1586,20 @@ proof (simp add: invs'_def valid_state'_def valid_pspace'_def apply simp done + from vbm + show "valid_bitmaps state'" + by (simp add: valid_bitmaps_def bitmapQ_defs) + + from sym_sched + show "sym_heap (pspace' |> tcb_of' |> tcbSchedNext) (pspace' |> tcb_of' |> tcbSchedPrev)" + using pa pd pspace_distinct'_state' + by (fastforce simp: tcbSchedNexts_of_pspace' tcbSchedPrevs_of_pspace') + + from vsp show "valid_sched_pointers_2 (pspace' |> tcb_of' |> tcbSchedPrev) + (pspace' |> tcb_of' |> tcbSchedNext) + (tcbQueued |< (pspace' |> tcb_of'))" + by (clarsimp simp: valid_sched_pointers_def opt_pred_def opt_map_def) + qed (clarsimp) lemma (in delete_locale) delete_ko_wp_at': diff --git a/proof/refine/RISCV64/EmptyFail_H.thy b/proof/refine/RISCV64/EmptyFail_H.thy index 068729f1a3..bde07a1ef8 100644 --- a/proof/refine/RISCV64/EmptyFail_H.thy +++ b/proof/refine/RISCV64/EmptyFail_H.thy @@ -163,7 +163,7 @@ lemma ignoreFailure_empty_fail[intro!, wp, simp]: by (simp add: ignoreFailure_def empty_fail_catch) crunch (empty_fail) empty_fail[intro!, wp, simp]: cancelIPC, setThreadState, tcbSchedDequeue, setupReplyMaster, isStopped, possibleSwitchTo, tcbSchedAppend -(simp: Let_def setNotification_def setBoundNotification_def) +(simp: Let_def setNotification_def setBoundNotification_def wp: empty_fail_getObject) crunch (empty_fail) "_H_empty_fail"[intro!, wp, simp]: "ThreadDecls_H.suspend" (ignore_del: ThreadDecls_H.suspend) diff --git a/proof/refine/RISCV64/Finalise_R.thy b/proof/refine/RISCV64/Finalise_R.thy index f658b4d758..9039981d11 100644 --- a/proof/refine/RISCV64/Finalise_R.thy +++ b/proof/refine/RISCV64/Finalise_R.thy @@ -16,9 +16,7 @@ context begin interpretation Arch . (*FIXME: arch_split*) declare doUnbindNotification_def[simp] crunches copyGlobalMappings - for queues[wp]: "Invariants_H.valid_queues" - and queues'[wp]: "Invariants_H.valid_queues'" - and ifunsafe'[wp]: "if_unsafe_then_cap'" + for ifunsafe'[wp]: "if_unsafe_then_cap'" and pred_tcb_at'[wp]: "pred_tcb_at' proj P t" and vms'[wp]: "valid_machine_state'" and ct_not_inQ[wp]: "ct_not_inQ" @@ -95,20 +93,10 @@ crunch ksRQL1[wp]: emptySlot "\s. P (ksReadyQueuesL1Bitmap s)" crunch ksRQL2[wp]: emptySlot "\s. P (ksReadyQueuesL2Bitmap s)" crunch obj_at'[wp]: postCapDeletion "obj_at' P p" -lemmas postCapDeletion_valid_queues[wp] = - valid_queues_lift [OF postCapDeletion_obj_at' - postCapDeletion_pred_tcb_at' - postCapDeletion_ksRQ] - crunch inQ[wp]: clearUntypedFreeIndex "\s. P (obj_at' (inQ d p) t s)" crunch tcbDomain[wp]: clearUntypedFreeIndex "obj_at' (\tcb. P (tcbDomain tcb)) t" crunch tcbPriority[wp]: clearUntypedFreeIndex "obj_at' (\tcb. P (tcbPriority tcb)) t" -lemma emptySlot_queues [wp]: - "\Invariants_H.valid_queues\ emptySlot sl opt \\rv. Invariants_H.valid_queues\" - unfolding emptySlot_def - by (wp | wpcw | wp valid_queues_lift | simp)+ - crunch nosch[wp]: emptySlot "\s. P (ksSchedulerAction s)" crunch ksCurDomain[wp]: emptySlot "\s. P (ksCurDomain s)" @@ -1181,8 +1169,7 @@ definition "removeable' sl \ \s cap. (\p. p \ sl \ cte_wp_at' (\cte. capMasterCap (cteCap cte) = capMasterCap cap) p s) \ ((\p \ cte_refs' cap (irq_node' s). p \ sl \ cte_wp_at' (\cte. cteCap cte = NullCap) p s) - \ (\p \ zobj_refs' cap. ko_wp_at' (Not \ live') p s) - \ (\t \ threadCapRefs cap. \p. t \ set (ksReadyQueues s p)))" + \ (\p \ zobj_refs' cap. ko_wp_at' (Not \ live') p s))" lemma not_Final_removeable: "\ isFinal cap sl (cteCaps_of s) @@ -1400,11 +1387,6 @@ crunch irq_states' [wp]: emptySlot valid_irq_states' crunch no_0_obj' [wp]: emptySlot no_0_obj' (wp: crunch_wps) -crunch valid_queues'[wp]: setInterruptState "valid_queues'" - (simp: valid_queues'_def) - -crunch valid_queues'[wp]: emptySlot "valid_queues'" - end lemma deletedIRQHandler_irqs_masked'[wp]: @@ -1498,6 +1480,13 @@ lemma emptySlot_valid_arch'[wp]: by (wpsimp simp: emptySlot_def cte_wp_at_ctes_of wp: getCTE_wp hoare_drop_imps hoare_vcg_ex_lift) +crunches emptySlot + 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 \ (info \ NullCap \ post_cap_delete_pre' info sl (cteCaps_of s) )\ @@ -2292,6 +2281,14 @@ 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) +crunches 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]: "\invs'\ unbindNotification tcb \\rv. invs'\" apply (simp add: unbindNotification_def invs'_def valid_state'_def) @@ -2300,8 +2297,8 @@ lemma unbindNotification_invs[wp]: apply clarsimp apply (rule hoare_seq_ext[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 + 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 (clarsimp elim!: obj_atE' @@ -2341,7 +2338,7 @@ lemma unbindMaybeNotification_invs[wp]: apply (simp add: unbindMaybeNotification_def invs'_def valid_state'_def) apply (rule hoare_seq_ext[OF _ get_ntfn_sp']) apply (rule hoare_pre) - apply (wp sbn'_valid_pspace'_inv sbn_sch_act' sbn_valid_queues valid_irq_node_lift + 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)+ @@ -2495,7 +2492,6 @@ lemma cteDeleteOne_isFinal: lemmas setEndpoint_cteCaps_of[wp] = cteCaps_of_ctes_of_lift [OF set_ep_ctes_of] lemmas setNotification_cteCaps_of[wp] = cteCaps_of_ctes_of_lift [OF set_ntfn_ctes_of] -lemmas setQueue_cteCaps_of[wp] = cteCaps_of_ctes_of_lift [OF setQueue_ctes_of] lemmas threadSet_cteCaps_of = cteCaps_of_ctes_of_lift [OF threadSet_ctes_of] crunch isFinal: suspend, prepareThreadDelete "\s. isFinal cap slot (cteCaps_of s)" @@ -2584,16 +2580,6 @@ lemma unbindNotification_valid_objs'_helper': by (clarsimp simp: valid_bound_tcb'_def valid_ntfn'_def split: option.splits ntfn.splits) -lemma typ_at'_valid_tcb'_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_tcb' tcb s\ f \\rv s. valid_tcb' tcb s\" - including no_pre - apply (simp add: valid_tcb'_def) - apply (case_tac "tcbState tcb", simp_all add: valid_tcb_state'_def split_def valid_bound_ntfn'_def) - apply (wp hoare_vcg_const_Ball_lift typ_at_lifts[OF P] - | case_tac "tcbBoundNotification tcb", simp_all)+ - done - lemmas setNotification_valid_tcb' = typ_at'_valid_tcb'_lift [OF setNotification_typ_at'] lemma unbindNotification_valid_objs'[wp]: @@ -2726,10 +2712,6 @@ lemma unbindNotification_bound_tcb_at': apply (wp setBoundNotification_bound_tcb gbn_wp' | wpc | simp)+ done -crunches unbindNotification, unbindMaybeNotification - for valid_queues[wp]: "Invariants_H.valid_queues" - (wp: sbn_valid_queues) - crunches unbindNotification, unbindMaybeNotification for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" @@ -2754,6 +2736,36 @@ crunch obj_at'[wp]: prepareThreadDelete end +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 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 + split: option.splits) + +crunches updateRestartPC, cancelIPC + for valid_sched_pointers[wp]: valid_sched_pointers + (simp: crunch_simps wp: crunch_wps) + +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))) @@ -2773,21 +2785,22 @@ 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))))\" + \ 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 (wp prepares_delete_helper'' [OF cancelAllIPC_unlive] prepares_delete_helper'' [OF cancelAllSignals_unlive] - suspend_isFinal prepareThreadDelete_unqueued prepareThreadDelete_nonq + suspend_isFinal prepareThreadDelete_unqueued prepareThreadDelete_inactive prepareThreadDelete_isFinal - suspend_makes_inactive suspend_nonq + 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]], @@ -2854,7 +2867,9 @@ lemma cancelIPC_cte_wp_at': apply (clarsimp simp: cteCaps_of_def cte_wp_at_ctes_of x) done -crunch cte_wp_at'[wp]: tcbSchedDequeue "cte_wp_at' P p" +crunches tcbSchedDequeue + for cte_wp_at'[wp]: "cte_wp_at' P p" + (wp: crunch_wps) lemma suspend_cte_wp_at': assumes x: "\cap final. P cap \ finaliseCap cap final True = fail" @@ -2979,25 +2994,6 @@ crunch sch_act_not[wp]: cteDeleteOne "sch_act_not t" (simp: crunch_simps case_Null_If unless_def wp: crunch_wps getObject_inv loadObject_default_inv) -lemma cancelAllIPC_mapM_x_valid_queues: - "\Invariants_H.valid_queues and valid_objs' and (\s. \t\set q. tcb_at' t s)\ - mapM_x (\t. do - y \ setThreadState Structures_H.thread_state.Restart t; - tcbSchedEnqueue t - od) q - \\rv. Invariants_H.valid_queues\" - apply (rule_tac R="\_ s. (\t\set q. tcb_at' t s) \ valid_objs' s" - in hoare_post_add) - apply (rule hoare_pre) - apply (rule mapM_x_wp') - apply (rule hoare_name_pre_state) - apply (wp hoare_vcg_const_Ball_lift - tcbSchedEnqueue_valid_queues tcbSchedEnqueue_not_st - sts_valid_queues sts_st_tcb_at'_cases setThreadState_not_st - | simp - | ((elim conjE)?, drule (1) bspec, clarsimp elim!: obj_at'_weakenE simp: valid_tcb_state'_def))+ - done - lemma cancelAllIPC_mapM_x_weak_sch_act: "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ mapM_x (\t. do @@ -3011,13 +3007,15 @@ lemma cancelAllIPC_mapM_x_weak_sch_act: done lemma cancelAllIPC_mapM_x_valid_objs': - "\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 (wpsimp wp: mapM_x_wp' sts_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 @@ -3028,17 +3026,12 @@ lemma cancelAllIPC_mapM_x_tcbDomain_obj_at': tcbSchedEnqueue t od) q \\_. obj_at' (\tcb. P (tcbDomain tcb)) t'\" - by (wp mapM_x_wp' tcbSchedEnqueue_not_st setThreadState_oa_queued | simp)+ + by (wp mapM_x_wp' | simp)+ 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) - apply (wp tcbSchedEnqueue_not_st - | wpc - | simp)+ - done + "rescheduleRequired \obj_at' (\tcb. Q (tcbDomain tcb) (tcbPriority tcb)) t\" + unfolding rescheduleRequired_def tcbSchedEnqueue_def tcbQueuePrepend_def + by wpsimp lemma cancelAllIPC_tcbDomain_obj_at': "\obj_at' (\tcb. P (tcbDomain tcb)) t'\ @@ -3052,21 +3045,6 @@ lemma cancelAllIPC_tcbDomain_obj_at': | simp)+ done -lemma cancelAllIPC_valid_queues[wp]: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - cancelAllIPC ep_ptr - \\rv. Invariants_H.valid_queues\" - apply (simp add: cancelAllIPC_def ep'_Idle_case_helper) - apply (wp hoare_vcg_conj_lift hoare_vcg_const_Ball_lift - cancelAllIPC_mapM_x_valid_queues cancelAllIPC_mapM_x_valid_objs' cancelAllIPC_mapM_x_weak_sch_act - set_ep_valid_objs' getEndpoint_wp) - apply (clarsimp simp: valid_ep'_def) - apply (drule (1) ko_at_valid_objs') - apply (auto simp: valid_obj'_def valid_ep'_def valid_tcb'_def - split: endpoint.splits - elim: valid_objs_valid_tcbE) - done - lemma cancelAllSignals_tcbDomain_obj_at': "\obj_at' (\tcb. P (tcbDomain tcb)) t'\ cancelAllSignals epptr @@ -3083,41 +3061,8 @@ lemma unbindMaybeNotification_tcbDomain_obj_at': "\obj_at' (\tcb. P (tcbDomain tcb)) t'\ unbindMaybeNotification r \\_. obj_at' (\tcb. P (tcbDomain tcb)) t'\" - apply (simp add: unbindMaybeNotification_def) - apply (wp setBoundNotification_oa_queued getNotification_wp gbn_wp' | wpc | simp)+ - done - -lemma cancelAllSignals_valid_queues[wp]: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - cancelAllSignals ntfn - \\rv. Invariants_H.valid_queues\" - apply (simp add: cancelAllSignals_def) - apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) - apply (case_tac "ntfnObj ntfna", simp_all) - apply (wp, simp)+ - apply (wp hoare_vcg_conj_lift hoare_vcg_const_Ball_lift - cancelAllIPC_mapM_x_valid_queues cancelAllIPC_mapM_x_valid_objs' cancelAllIPC_mapM_x_weak_sch_act - set_ntfn_valid_objs' - | simp)+ - apply (clarsimp simp: valid_ep'_def) - apply (drule (1) ko_at_valid_objs') - apply (auto simp: valid_obj'_def valid_ntfn'_def valid_tcb'_def - split: endpoint.splits - elim: valid_objs_valid_tcbE) - done - -lemma finaliseCapTrue_standin_valid_queues[wp]: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - finaliseCapTrue_standin cap final - \\_. Invariants_H.valid_queues\" - apply (simp add: finaliseCapTrue_standin_def Let_def) - apply (safe) - apply (wp | clarsimp | wpc)+ - done - - -crunch valid_queues[wp]: isFinalCapability "Invariants_H.valid_queues" - (simp: crunch_simps) + unfolding unbindMaybeNotification_def + by (wpsimp wp: getNotification_wp gbn_wp' simp: setBoundNotification_def)+ crunch sch_act[wp]: isFinalCapability "\s. sch_act_wf (ksSchedulerAction s) s" (simp: crunch_simps) @@ -3126,93 +3071,6 @@ crunch weak_sch_act[wp]: isFinalCapability "\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. \obj_at' (inQ d p) tcb\ f \\_. obj_at' (inQ d p) tcb\" - and prq: "\P. \\s. P (ksReadyQueues s)\ f \\_ s. P (ksReadyQueues s)\" - shows "\valid_inQ_queues\ f \\_. valid_inQ_queues\" - proof - - show ?thesis - apply (clarsimp simp: valid_def valid_inQ_queues_def) - apply safe - apply (rule use_valid [OF _ tat], assumption) - apply (drule spec, drule spec, erule conjE, erule bspec) - apply (rule ccontr) - apply (erule notE[rotated], erule(1) use_valid [OF _ prq]) - apply (erule use_valid [OF _ prq]) - apply simp - done - qed - -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)+ - -lemma cancelAllIPC_mapM_x_valid_inQ_queues: - "\valid_inQ_queues\ - mapM_x (\t. do - y \ setThreadState Structures_H.thread_state.Restart t; - tcbSchedEnqueue t - od) q - \\rv. valid_inQ_queues\" - apply (rule mapM_x_wp_inv) - apply (wp sts_valid_queues [where st="Structures_H.thread_state.Restart", simplified] - setThreadState_st_tcb) - done - -lemma cancelAllIPC_valid_inQ_queues[wp]: - "\valid_inQ_queues\ - cancelAllIPC ep_ptr - \\rv. valid_inQ_queues\" - apply (simp add: cancelAllIPC_def ep'_Idle_case_helper) - apply (wp cancelAllIPC_mapM_x_valid_inQ_queues) - apply (wp hoare_conjI hoare_drop_imp | simp)+ - done - -lemma cancelAllSignals_valid_inQ_queues[wp]: - "\valid_inQ_queues\ - cancelAllSignals ntfn - \\rv. valid_inQ_queues\" - apply (simp add: cancelAllSignals_def) - apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) - apply (case_tac "ntfnObj ntfna", simp_all) - apply (wp, simp)+ - apply (wp cancelAllIPC_mapM_x_valid_inQ_queues)+ - apply (simp) - done - -crunches unbindNotification, unbindMaybeNotification - for valid_inQ_queues[wp]: "valid_inQ_queues" - -lemma finaliseCapTrue_standin_valid_inQ_queues[wp]: - "\valid_inQ_queues\ - finaliseCapTrue_standin cap final - \\_. valid_inQ_queues\" - apply (simp add: finaliseCapTrue_standin_def Let_def) - apply (safe) - apply (wp | clarsimp | wpc)+ - done - -crunch valid_inQ_queues[wp]: isFinalCapability valid_inQ_queues - (simp: crunch_simps) - -lemma cteDeleteOne_valid_inQ_queues[wp]: - "\valid_inQ_queues\ - cteDeleteOne sl - \\_. valid_inQ_queues\" - apply (simp add: cteDeleteOne_def unless_def) - apply (wpsimp wp: hoare_drop_imp hoare_vcg_all_lift) - done - crunch ksCurDomain[wp]: cteDeleteOne "\s. P (ksCurDomain s)" (wp: crunch_wps simp: crunch_simps unless_def) @@ -3703,178 +3561,6 @@ lemma isFinal_lift: lemmas final_matters'_simps = final_matters'_def [split_simps capability.split arch_capability.split] -definition set_thread_all :: "obj_ref \ Structures_A.tcb \ etcb - \ unit det_ext_monad" where - "set_thread_all ptr tcb etcb \ - do s \ get; - kh \ return $ (kheap s)(ptr \ (TCB tcb)); - ekh \ return $ (ekheap s)(ptr \ etcb); - put (s\kheap := kh, ekheap := ekh\) - od" - -definition thread_gets_the_all :: "obj_ref \ (Structures_A.tcb \ etcb) det_ext_monad" where - "thread_gets_the_all tptr \ - do tcb \ gets_the $ get_tcb tptr; - etcb \ gets_the $ get_etcb tptr; - return $ (tcb, etcb) od" - -definition thread_set_all :: "(Structures_A.tcb \ Structures_A.tcb) \ (etcb \ etcb) - \ obj_ref \ unit det_ext_monad" where - "thread_set_all f g tptr \ - do (tcb, etcb) \ thread_gets_the_all tptr; - set_thread_all tptr (f tcb) (g etcb) - od" - -lemma set_thread_all_corres: - fixes ob' :: "'a :: pspace_storable" - assumes x: "updateObject ob' = updateObject_default ob'" - assumes z: "\s. obj_at' P ptr s - \ map_to_ctes ((ksPSpace s) (ptr \ injectKO ob')) = map_to_ctes (ksPSpace s)" - assumes b: "\ko. P ko \ objBits ko = objBits ob'" - assumes P: "\(v::'a::pspace_storable). (1 :: machine_word) < 2 ^ (objBits v)" - assumes e: "etcb_relation etcb tcb'" - assumes is_t: "injectKO (ob' :: 'a :: pspace_storable) = KOTCB tcb'" - shows "other_obj_relation (TCB tcb) (injectKO (ob' :: 'a :: pspace_storable)) \ - corres dc (obj_at (same_caps (TCB tcb)) ptr and is_etcb_at ptr) - (obj_at' (P :: 'a \ bool) ptr) - (set_thread_all ptr tcb etcb) (setObject ptr ob')" - apply (rule corres_no_failI) - apply (rule no_fail_pre) - apply wp - apply (rule x) - apply (clarsimp simp: b elim!: obj_at'_weakenE) - apply (unfold set_thread_all_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 - updateObject_default_def in_magnitude_check [OF _ P]) - apply (clarsimp simp add: state_relation_def z) - apply (simp flip: trans_state_update) - apply (clarsimp simp add: swp_def fun_upd_def obj_at_def is_etcb_at_def) - apply (subst cte_wp_at_after_update,fastforce simp add: obj_at_def) - apply (subst caps_of_state_after_update,fastforce simp add: obj_at_def) - apply clarsimp - 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 - split: Structures_A.kernel_object.splits if_split_asm) - - apply (fold fun_upd_def) - apply (simp only: pspace_relation_def dom_fun_upd2 simp_thms) - apply (subst pspace_dom_update) - apply assumption - apply simp - 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: is_other_obj_relation_type) - apply (drule(1) bspec) - apply clarsimp - apply (frule_tac ko'="TCB tcb'" and x'=ptr in obj_relation_cut_same_type, - (fastforce simp add: is_other_obj_relation_type)+)[1] - 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 is_t) - by (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) - -lemma tcb_update_all_corres': - assumes tcbs: "tcb_relation tcb tcb' \ tcb_relation tcbu tcbu'" - assumes tables: "\(getF, v) \ ran tcb_cap_cases. getF tcbu = getF tcb" - assumes tables': "\(getF, v) \ ran tcb_cte_cases. getF tcbu' = getF tcb'" - assumes r: "r () ()" - assumes e: "etcb_relation etcb tcb' \ etcb_relation etcbu tcbu'" - shows "corres r (ko_at (TCB tcb) add and (\s. ekheap s add = Some etcb)) - (ko_at' tcb' add) - (set_thread_all add tcbu etcbu) (setObject add tcbu')" - apply (rule_tac F="tcb_relation tcb tcb' \ 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 (force simp: other_obj_relation_def ekheap_relation_def e) - apply (erule conjE) - apply (rule corres_guard_imp) - apply (rule corres_rel_imp) - apply (rule set_thread_all_corres[where P="(=) tcb'"]) - apply (rule ext)+ - apply simp - defer - apply (simp add: is_other_obj_relation_type_def - objBits_simps' other_obj_relation_def tcbs r)+ - apply (fastforce simp: is_etcb_at_def elim!: obj_at_weakenE dest: bspec[OF tables]) - apply (subst(asm) eq_commute, assumption) - apply (clarsimp simp: 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 thread_gets_the_all_corres: - shows "corres (\(tcb, etcb) tcb'. tcb_relation tcb tcb' \ etcb_relation etcb tcb') - (tcb_at t and is_etcb_at t) (tcb_at' t) - (thread_gets_the_all t) (getObject t)" - apply (rule corres_no_failI) - apply wp - apply (clarsimp simp: gets_def get_def return_def bind_def get_tcb_def thread_gets_the_all_def - threadGet_def ethread_get_def gets_the_def assert_opt_def get_etcb_def - is_etcb_at_def tcb_at_def liftM_def - split: option.splits Structures_A.kernel_object.splits) - 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 ko) - apply (simp_all add: fail_def return_def) - apply (clarsimp simp add: state_relation_def pspace_relation_def ekheap_relation_def) - apply (drule bspec) - apply clarsimp - apply blast - apply (drule bspec, erule domI) - apply (clarsimp simp add: other_obj_relation_def - lookupAround2_known1) - done - -lemma thread_set_all_corresT: - assumes x: "\tcb tcb'. tcb_relation tcb tcb' \ - tcb_relation (f tcb) (f' tcb')" - 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" - assumes e: "\etcb tcb'. etcb_relation etcb tcb' \ - etcb_relation (g etcb) (f' tcb')" - shows "corres dc (tcb_at t and valid_etcbs) - (tcb_at' t) - (thread_set_all f g t) (threadSet f' t)" - apply (simp add: thread_set_all_def threadSet_def bind_assoc) - apply (rule corres_guard_imp) - apply (rule corres_split[OF thread_gets_the_all_corres]) - apply (simp add: split_def) - apply (rule tcb_update_all_corres') - apply (erule x) - apply (rule y) - apply (clarsimp simp: bspec_split [OF spec [OF z]]) - apply fastforce - apply (erule e) - apply (simp add: thread_gets_the_all_def, wp+) - apply clarsimp - apply (frule(1) tcb_at_is_etcb_at) - apply (clarsimp simp add: tcb_at_def get_etcb_def obj_at_def) - apply (drule get_tcb_SomeD) - apply fastforce - apply simp - done - -lemmas thread_set_all_corres = - thread_set_all_corresT [OF _ _ all_tcbI, OF _ ball_tcb_cap_casesI ball_tcb_cte_casesI] - crunch idle_thread[wp]: deleteCallerCap "\s. P (ksIdleThread s)" (wp: crunch_wps) crunch sch_act_simple: deleteCallerCap sch_act_simple @@ -3890,89 +3576,6 @@ lemma setEndpoint_sch_act_not_ct[wp]: setEndpoint ptr val \\_ s. sch_act_not (ksCurThread s) s\" by (rule hoare_weaken_pre, wps setEndpoint_ct', wp, simp) -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 - -lemma cancelAllIPC_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - cancelAllIPC epptr - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - (is "\?PRE\ _ \\_. ?POST\") - apply (simp add: cancelAllIPC_def) - apply (wp, wpc, wp) - apply (wps rescheduleRequired_ct') - apply (wp rescheduleRequired_ksQ') - apply (clarsimp) - apply (wp cancelAll_ct_not_ksQ_helper mapM_x_wp_inv) - apply (wp hoare_lift_Pf2 [OF setEndpoint_ksQ setEndpoint_ct'])+ - apply (wps rescheduleRequired_ct') - apply (wp rescheduleRequired_ksQ') - apply (clarsimp) - apply (wp cancelAll_ct_not_ksQ_helper mapM_x_wp_inv) - apply (wp hoare_lift_Pf2 [OF setEndpoint_ksQ setEndpoint_ct'])+ - prefer 2 - apply assumption - apply (rule_tac Q="\ep. ?PRE and ko_at' ep epptr" in hoare_post_imp) - apply (clarsimp) - apply (rule conjI) - apply ((clarsimp simp: invs'_def valid_state'_def - sch_act_sane_def - | drule(1) ct_not_in_epQueue)+)[2] - apply (wp get_ep_sp') - done - -lemma cancelAllSignals_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - cancelAllSignals ntfnptr - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - (is "\?PRE\ _ \\_. ?POST\") - apply (simp add: cancelAllSignals_def) - apply (wp, wpc, wp+) - apply (wps rescheduleRequired_ct') - apply (wp rescheduleRequired_ksQ') - apply clarsimp - apply (wp cancelAll_ct_not_ksQ_helper mapM_x_wp_inv) - apply (wp hoare_lift_Pf2 [OF setNotification_ksQ setNotification_ksCurThread]) - apply (wps setNotification_ksCurThread, wp) - prefer 2 - apply assumption - apply (rule_tac Q="\ep. ?PRE and ko_at' ep ntfnptr" in hoare_post_imp) - apply ((clarsimp simp: invs'_def valid_state'_def sch_act_sane_def - | drule(1) ct_not_in_ntfnQueue)+)[1] - apply (wp get_ntfn_sp') - done - -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 hoare_seq_ext[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 setNotification_ksCurThread, wp) - apply clarsimp - done - lemma sbn_ct_in_state'[wp]: "\ct_in_state' P\ setBoundNotification ntfn t \\_. ct_in_state' P\" apply (simp add: ct_in_state'_def) @@ -4005,37 +3608,6 @@ lemma unbindMaybeNotification_sch_act_sane[wp]: apply (wp setNotification_sch_act_sane sbn_sch_act_sane | wpc | clarsimp)+ done -lemma finaliseCapTrue_standin_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - finaliseCapTrue_standin cap final - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - apply (simp add: finaliseCapTrue_standin_def Let_def) - apply (safe) - apply (wp cancelAllIPC_ct_not_ksQ cancelAllSignals_ct_not_ksQ - hoare_drop_imps unbindMaybeNotification_ct_not_ksQ - | wpc - | clarsimp simp: isNotificationCap_def isReplyCap_def split:capability.splits)+ - done - -lemma cteDeleteOne_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - cteDeleteOne slot - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - apply (simp add: cteDeleteOne_def unless_def split_def) - apply (rule hoare_seq_ext [OF _ getCTE_sp]) - apply (case_tac "\final. finaliseCap (cteCap cte) final True = fail") - apply (simp add: finaliseCapTrue_standin_simple_def) - apply wp - apply (clarsimp) - apply (wp emptySlot_cteCaps_of hoare_lift_Pf2 [OF emptySlot_ksRQ emptySlot_ct]) - apply (simp add: cteCaps_of_def) - apply (wp (once) hoare_drop_imps) - apply (wp finaliseCapTrue_standin_ct_not_ksQ isFinalCapability_inv)+ - apply (clarsimp) - done - end end diff --git a/proof/refine/RISCV64/Init_R.thy b/proof/refine/RISCV64/Init_R.thy index 9cac8880a1..7b0d851e7e 100644 --- a/proof/refine/RISCV64/Init_R.thy +++ b/proof/refine/RISCV64/Init_R.thy @@ -91,7 +91,7 @@ definition zeroed_intermediate_state :: ksDomSchedule = [], ksCurDomain = 0, ksDomainTime = 0, - ksReadyQueues = K [], + ksReadyQueues = K (TcbQueue None None), ksReadyQueuesL1Bitmap = K 0, ksReadyQueuesL2Bitmap = K 0, ksCurThread = 0, @@ -112,9 +112,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: ekheap_relation_def) - apply (clarsimp simp: ready_queues_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/RISCV64/InterruptAcc_R.thy b/proof/refine/RISCV64/InterruptAcc_R.thy index 02a1048ede..367b136b6c 100644 --- a/proof/refine/RISCV64/InterruptAcc_R.thy +++ b/proof/refine/RISCV64/InterruptAcc_R.thy @@ -50,14 +50,13 @@ lemma setIRQState_invs[wp]: apply (simp add: setIRQState_def setInterruptState_def getInterruptState_def) apply (wp dmo_maskInterrupt) apply (clarsimp simp: invs'_def valid_state'_def cur_tcb'_def - Invariants_H.valid_queues_def valid_queues'_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) + bitmapQ_defs valid_bitmaps_def) apply (rule conjI, clarsimp) apply (clarsimp simp: irqs_masked'_def ct_not_inQ_def) apply (rule conjI; clarsimp) @@ -148,8 +147,7 @@ lemma invs'_irq_state_independent [simp, intro!]: 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_queues_no_bitmap_def - valid_queues'_def + irqs_masked'_def bitmapQ_defs valid_bitmaps_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 diff --git a/proof/refine/RISCV64/Interrupt_R.thy b/proof/refine/RISCV64/Interrupt_R.thy index fffa216df0..dcc577606f 100644 --- a/proof/refine/RISCV64/Interrupt_R.thy +++ b/proof/refine/RISCV64/Interrupt_R.thy @@ -609,13 +609,6 @@ lemma decDomainTime_corres: apply (clarsimp simp:state_relation_def) done -lemma tcbSchedAppend_valid_objs': - "\valid_objs'\tcbSchedAppend t \\r. valid_objs'\" - apply (simp add:tcbSchedAppend_def) - apply (wpsimp wp: unless_wp threadSet_valid_objs' threadGet_wp) - apply (clarsimp simp add:obj_at'_def typ_at'_def) - done - lemma thread_state_case_if: "(case state of Structures_A.thread_state.Running \ f | _ \ g) = (if state = Structures_A.thread_state.Running then f else g)" @@ -626,26 +619,19 @@ lemma threadState_case_if: (if state = Structures_H.thread_state.Running then f else g)" by (case_tac state,auto) -lemma tcbSchedAppend_invs_but_ct_not_inQ': - "\invs' and st_tcb_at' runnable' t \ - tcbSchedAppend t \\_. all_invs_but_ct_not_inQ'\" - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp 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 - | fastforce elim!: st_tcb_ex_cap'' split: thread_state.split_asm)+ - done +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 timerTick_corres: - "corres dc (cur_tcb and valid_sched and pspace_aligned and pspace_distinct) - invs' - timer_tick timerTick" + "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="\ and (cur_tcb and valid_sched and pspace_aligned and pspace_distinct)" - and Q'="\ and invs'" in corres_guard_imp) + 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 @@ -665,63 +651,71 @@ lemma timerTick_corres: 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]) + apply (rule corres_split[OF tcbSchedAppend_corres], simp) apply (rule rescheduleRequired_corres) - apply (wp)[1] - apply (rule hoare_strengthen_post) - apply (rule tcbSchedAppend_invs_but_ct_not_inQ', clarsimp simp: sch_act_wf_weak) - apply (wp threadSet_timeslice_invs threadSet_valid_queues - threadSet_valid_queues' threadSet_pred_tcb_at_state)+ - apply simp - apply (rule corres_when,simp) + 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 (simp add:dec_domain_time_def) - apply wp+ - apply (simp add:decDomainTime_def) - apply wp - apply (wpsimp wp: hoare_weak_lift_imp threadSet_timeslice_invs threadSet_valid_queues - threadSet_valid_queues' tcbSchedAppend_valid_objs' + 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 tcbSchedAppend_valid_queues)+ - apply (strengthen sch_act_wf_weak) - apply (clarsimp simp:conj_comms) - apply (wp tcbSchedAppend_valid_queues tcbSchedAppend_sch_act_wf) - apply simp - apply (wpsimp wp: threadSet_valid_queues threadSet_pred_tcb_at_state threadSet_sch_act - threadSet_tcbDomain_triv threadSet_valid_queues' threadSet_valid_objs' - threadGet_wp gts_wp gts_wp')+ - apply (clarsimp simp: cur_tcb_def tcb_at_is_etcb_at valid_sched_def valid_sched_action_def) - apply (clarsimp simp: invs'_def valid_state'_def sch_act_wf_weak cur_tcb'_def inQ_def - ct_in_state'_def obj_at'_def) - apply (clarsimp simp:st_tcb_at'_def valid_idle'_def ct_idle_or_in_cur_domain'_def obj_at'_def) - apply simp - apply simp + 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) (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 (einvs) ?P' ?f ?g") - apply (simp add: handle_interrupt_def handleInterrupt_def ) + (is "corres dc ?P ?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. einvs" + where R="\rv. ?P" 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 )+ - apply (rule corres_guard_imp) - apply (rule corres_split) - apply (rule corres_machine_op, rule corres_eq_trivial ; (simp add: dc_def no_fail_maskInterrupt no_fail_bind no_fail_ackInterrupt)+)+ - apply ((wp | simp)+)[4] + apply (wp getIRQState_prop getIRQState_inv do_machine_op_bind doMachineOp_bind + | simp add: do_machine_op_bind doMachineOp_bind valid_sched_def)+ + apply (corres corres: corres_machine_op) apply (rule corres_gen_asm2) apply (case_tac st, simp_all add: irq_state_relation_def split: irqstate.split_asm) @@ -751,7 +745,7 @@ lemma handleInterrupt_corres: apply (rule corres_machine_op) apply (rule corres_eq_trivial, (simp add: no_fail_ackInterrupt)+) apply wp+ - apply (clarsimp simp: invs_distinct invs_psp_aligned) + apply (clarsimp simp: invs_distinct invs_psp_aligned schact_is_rct_def) apply clarsimp done @@ -774,14 +768,6 @@ lemma updateTimeSlice_valid_pspace[wp]: apply (auto simp:tcb_cte_cases_def cteSizeBits_def) done -lemma updateTimeSlice_valid_queues[wp]: - "\\s. Invariants_H.valid_queues s \ - threadSet (tcbTimeSlice_update (\_. ts')) thread - \\r s. Invariants_H.valid_queues s\" - apply (wp threadSet_valid_queues,simp) - apply (clarsimp simp:obj_at'_def inQ_def) - done - crunches tcbSchedAppend for irq_handlers'[wp]: valid_irq_handlers' and irqs_masked'[wp]: irqs_masked' @@ -789,29 +775,29 @@ crunches tcbSchedAppend (simp: unless_def tcb_cte_cases_def cteSizeBits_def wp: crunch_wps cur_tcb_lift) lemma timerTick_invs'[wp]: - "\invs'\ timerTick \\rv. invs'\" + "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 - tcbSchedAppend_invs_but_ct_not_inQ' - simp: tcb_cte_cases_def) - apply (rule_tac Q="\rv. invs'" in hoare_post_imp) - apply (clarsimp simp add:invs'_def valid_state'_def) + 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' - del: tcbSchedAppend_sch_act_wf)+ - apply (rule hoare_strengthen_post[OF tcbSchedAppend_invs_but_ct_not_inQ']) - apply (wpsimp simp: valid_pspace'_def sch_act_wf_weak)+ - apply (wpsimp wp: threadSet_pred_tcb_no_state threadSet_tcbDomain_triv - threadSet_valid_objs' threadSet_timeslice_invs)+ - apply (wp threadGet_wp) + 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 (clarsimp simp: invs'_def st_tcb_at'_def obj_at'_def valid_state'_def) + apply (auto simp: invs'_def st_tcb_at'_def obj_at'_def valid_state'_def cong: conj_cong) done lemma resetTimer_invs'[wp]: diff --git a/proof/refine/RISCV64/InvariantUpdates_H.thy b/proof/refine/RISCV64/InvariantUpdates_H.thy index 938a45b494..41354e5a19 100644 --- a/proof/refine/RISCV64/InvariantUpdates_H.thy +++ b/proof/refine/RISCV64/InvariantUpdates_H.thy @@ -38,8 +38,9 @@ lemma invs'_machine: proof - show ?thesis apply (cases "ksSchedulerAction s") - 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_queues_def valid_queues_no_bitmap_def bitmapQ_defs + 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 @@ -56,12 +57,13 @@ lemma invs_no_cicd'_machine: 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_queues_def valid_queues_no_bitmap_def bitmapQ_defs - vms ct_not_inQ_def - state_refs_of'_def ps_clear_def - valid_irq_node'_def mask - cong: option.case_cong) + 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) done qed @@ -98,14 +100,9 @@ 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_queues_ksSchedulerAction_update[simp]: - "valid_queues (ksSchedulerAction_update f s) = valid_queues s" - unfolding valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs - by simp - -lemma valid_queues'_ksSchedulerAction_update[simp]: - "valid_queues' (ksSchedulerAction_update f s) = valid_queues' s" - by (simp add: valid_queues'_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'" @@ -140,45 +137,25 @@ lemma tcb_in_cur_domain_ct[simp]: "tcb_in_cur_domain' t (ksCurThread_update f s) = tcb_in_cur_domain' t s" by (fastforce simp: tcb_in_cur_domain'_def) -lemma valid_queues'_ksCurDomain[simp]: - "valid_queues' (ksCurDomain_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) - -lemma valid_queues'_ksDomScheduleIdx[simp]: - "valid_queues' (ksDomScheduleIdx_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) +lemma valid_bitmaps_ksCurDomain[simp]: + "valid_bitmaps (ksCurDomain_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) -lemma valid_queues'_ksDomSchedule[simp]: - "valid_queues' (ksDomSchedule_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) +lemma valid_bitmaps_ksDomScheduleIdx[simp]: + "valid_bitmaps (ksDomScheduleIdx_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) -lemma valid_queues'_ksDomainTime[simp]: - "valid_queues' (ksDomainTime_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) +lemma valid_bitmaps_ksDomSchedule[simp]: + "valid_bitmaps (ksDomSchedule_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) -lemma valid_queues'_ksWorkUnitsCompleted[simp]: - "valid_queues' (ksWorkUnitsCompleted_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) +lemma valid_bitmaps_ksDomainTime[simp]: + "valid_bitmaps (ksDomainTime_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) -lemma valid_queues_ksCurDomain[simp]: - "valid_queues (ksCurDomain_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_ksDomScheduleIdx[simp]: - "valid_queues (ksDomScheduleIdx_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_ksDomSchedule[simp]: - "valid_queues (ksDomSchedule_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_ksDomainTime[simp]: - "valid_queues (ksDomainTime_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_ksWorkUnitsCompleted[simp]: - "valid_queues (ksWorkUnitsCompleted_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) +lemma valid_bitmaps_ksWorkUnitsCompleted[simp]: + "valid_bitmaps (ksWorkUnitsCompleted_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) lemma valid_irq_node'_ksCurDomain[simp]: "valid_irq_node' w (ksCurDomain_update f s) = valid_irq_node' w s" @@ -255,6 +232,10 @@ lemma valid_mdb_interrupts'[simp]: "valid_mdb' (ksInterruptState_update f s) = valid_mdb' s" by (simp add: valid_mdb'_def) +lemma valid_mdb'_ksReadyQueues_update[simp]: + "valid_mdb' (ksReadyQueues_update f s) = valid_mdb' s" + by (simp add: valid_mdb'_def) + lemma vms_ksReadyQueues_update[simp]: "valid_machine_state' (ksReadyQueues_update f s) = valid_machine_state' s" by (simp add: valid_machine_state'_def) @@ -279,10 +260,10 @@ lemma ct_in_state_ksSched[simp]: lemma invs'_wu [simp]: "invs' (ksWorkUnitsCompleted_update f s) = invs' s" - apply (simp add: invs'_def cur_tcb'_def valid_state'_def Invariants_H.valid_queues_def - valid_queues'_def valid_irq_node'_def valid_machine_state'_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 valid_queues_no_bitmap_def) + bitmapQ_defs) done lemma valid_arch_state'_interrupt[simp]: @@ -334,9 +315,8 @@ lemma sch_act_simple_ksReadyQueuesL2Bitmap[simp]: lemma ksDomainTime_invs[simp]: "invs' (ksDomainTime_update f s) = invs' s" - 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) + 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" @@ -364,9 +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 valid_state'_def valid_queues_def valid_queues'_def - valid_irq_node'_def cur_tcb'_def ct_idle_or_in_cur_domain'_def - tcb_in_cur_domain'_def valid_queues_no_bitmap_def - bitmapQ_no_L2_orphans_def bitmapQ_no_L1_orphans_def) + by (clarsimp simp: invs'_def valid_state'_def valid_queues_def valid_irq_node'_def cur_tcb'_def + ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def bitmapQ_defs) end \ No newline at end of file diff --git a/proof/refine/RISCV64/Invariants_H.thy b/proof/refine/RISCV64/Invariants_H.thy index 8a3518e556..5cc523ed1e 100644 --- a/proof/refine/RISCV64/Invariants_H.thy +++ b/proof/refine/RISCV64/Invariants_H.thy @@ -8,6 +8,7 @@ theory Invariants_H imports LevityCatch "AInvs.ArchDetSchedSchedule_AI" + "Lib.Heap_List" begin (* global data and code of the kernel, not covered by any cap *) @@ -137,6 +138,21 @@ definition cte_wp_at' :: "(cte \ bool) \ obj_ref \ kernel_state \ bool" where "cte_at' \ cte_wp_at' \" +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 tcbSchedPrevs_of :: "kernel_state \ obj_ref \ obj_ref option" where + "tcbSchedPrevs_of s \ tcbs_of' s |> tcbSchedPrev" + +abbreviation tcbSchedNexts_of :: "kernel_state \ obj_ref \ obj_ref option" where + "tcbSchedNexts_of s \ tcbs_of' s |> tcbSchedNext" + +abbreviation sym_heap_sched_pointers :: "global.kernel_state \ bool" where + "sym_heap_sched_pointers s \ sym_heap (tcbSchedNexts_of s) (tcbSchedPrevs_of s)" + definition tcb_cte_cases :: "machine_word \ ((tcb \ cte) \ ((cte \ cte) \ tcb \ tcb))" where "tcb_cte_cases \ [ 0 << cteSizeBits \ (tcbCTable, tcbCTable_update), 1 << cteSizeBits \ (tcbVTable, tcbVTable_update), @@ -188,8 +204,10 @@ definition state_refs_of' :: "kernel_state \ obj_ref \ ( fun live' :: "kernel_object \ bool" where "live' (KOTCB tcb) = - (bound (tcbBoundNotification 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' (KOEndpoint ep) = (ep \ IdleEP)" | "live' (KONotification ntfn) = (bound (ntfnBoundTCB ntfn) \ (\ts. ntfnObj ntfn = WaitingNtfn ts))" | "live' _ = False" @@ -387,6 +405,11 @@ definition valid_bound_ntfn' :: "machine_word option \ kernel_state definition is_device_frame_cap' :: "capability \ bool" where "is_device_frame_cap' cap \ case cap of ArchObjectCap (FrameCap _ _ _ 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 "valid_tcb' t s \ (\(getF, setF) \ ran tcb_cte_cases. s \' cteCap (getF t)) \ valid_tcb_state' (tcbState t) s @@ -394,7 +417,9 @@ definition valid_tcb' :: "tcb \ kernel_state \ bool" whe \ valid_bound_ntfn' (tcbBoundNotification t) s \ tcbDomain t \ maxDomain \ tcbPriority t \ maxPriority - \ tcbMCP 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 "valid_ep' ep s \ case ep of @@ -402,7 +427,6 @@ definition valid_ep' :: "Structures_H.endpoint \ kernel_state \ (ts \ [] \ (\t \ set ts. tcb_at' t s) \ distinct ts) | RecvEP ts \ (ts \ [] \ (\t \ set ts. tcb_at' t s) \ distinct ts)" - definition valid_bound_tcb' :: "machine_word option \ kernel_state \ bool" where "valid_bound_tcb' tcb_opt s \ case tcb_opt of None \ True | Some t \ tcb_at' t s" @@ -733,10 +757,15 @@ where | "runnable' (Structures_H.BlockedOnSend a b c d e) = False" | "runnable' (Structures_H.BlockedOnNotification x) = False" -definition - inQ :: "domain \ priority \ tcb \ bool" -where - "inQ d p tcb \ tcbQueued tcb \ tcbPriority tcb = p \ tcbDomain tcb = d" +definition inQ :: "domain \ priority \ tcb \ bool" where + "inQ d p tcb \ tcbQueued tcb \ tcbPriority tcb = p \ tcbDomain tcb = d" + +lemma inQ_implies_tcbQueueds_of: + "(inQ domain priority |< tcbs_of' s') tcbPtr \ (tcbQueued |< tcbs_of' s') tcbPtr" + by (clarsimp simp: opt_map_def opt_pred_def inQ_def split: option.splits) + +defs ready_qs_runnable_def: + "ready_qs_runnable s \ \t. obj_at' tcbQueued t s \ st_tcb_at' runnable' t s" definition (* for given domain and priority, the scheduler bitmap indicates a thread is in the queue *) @@ -746,15 +775,6 @@ where "bitmapQ d p s \ ksReadyQueuesL1Bitmap s d !! prioToL1Index p \ ksReadyQueuesL2Bitmap s (d, invertL1Index (prioToL1Index p)) !! unat (p && mask wordRadix)" - -definition - valid_queues_no_bitmap :: "kernel_state \ bool" -where - "valid_queues_no_bitmap \ \s. - (\d p. (\t \ set (ksReadyQueues s (d, p)). obj_at' (inQ d p and runnable' \ tcbState) t s) - \ distinct (ksReadyQueues s (d, p)) - \ (d > maxDomain \ p > maxPriority \ ksReadyQueues s (d,p) = []))" - 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 @@ -778,31 +798,62 @@ where \d i. ksReadyQueuesL1Bitmap s d !! i \ ksReadyQueuesL2Bitmap s (d, invertL1Index i) \ 0 \ i < l2BitmapSize" -definition - valid_bitmapQ :: "kernel_state \ bool" -where - "valid_bitmapQ \ \s. (\d p. bitmapQ d p s \ ksReadyQueues s (d,p) \ [])" +definition valid_bitmapQ :: "kernel_state \ bool" where + "valid_bitmapQ \ \s. \d p. bitmapQ d p s \ \ tcbQueueEmpty (ksReadyQueues s (d,p))" -definition - valid_queues :: "kernel_state \ bool" -where - "valid_queues \ \s. valid_queues_no_bitmap s \ valid_bitmapQ s \ - bitmapQ_no_L2_orphans s \ bitmapQ_no_L1_orphans s" +definition valid_bitmaps :: "kernel_state \ bool" where + "valid_bitmaps \ \s. valid_bitmapQ s \ bitmapQ_no_L2_orphans s \ bitmapQ_no_L1_orphans s" -definition - (* when a thread gets added to / removed from a queue, but before bitmap updated *) - valid_bitmapQ_except :: "domain \ priority \ kernel_state \ bool" -where +lemma valid_bitmaps_valid_bitmapQ[elim!]: + "valid_bitmaps s \ valid_bitmapQ s" + by (simp add: valid_bitmaps_def) + +lemma valid_bitmaps_bitmapQ_no_L2_orphans[elim!]: + "valid_bitmaps s \ bitmapQ_no_L2_orphans s" + by (simp add: valid_bitmaps_def) + +lemma valid_bitmaps_bitmapQ_no_L1_orphans[elim!]: + "valid_bitmaps s \ bitmapQ_no_L1_orphans s" + by (simp add: valid_bitmaps_def) + +lemma valid_bitmaps_lift: + assumes prq: "\P. f \\s. P (ksReadyQueues s)\" + assumes prqL1: "\P. f \\s. P (ksReadyQueuesL1Bitmap s)\" + assumes prqL2: "\P. f \\s. P (ksReadyQueuesL2Bitmap s)\" + shows "f \valid_bitmaps\" + unfolding valid_bitmaps_def valid_bitmapQ_def bitmapQ_def + bitmapQ_no_L1_orphans_def bitmapQ_no_L2_orphans_def + apply (rule hoare_pre) + apply (wps assms | wpsimp)+ + done + +(* when a thread gets added to / removed from a queue, but before bitmap updated *) +definition valid_bitmapQ_except :: "domain \ priority \ kernel_state \ bool" where "valid_bitmapQ_except d' p' \ \s. - (\d p. (d \ d' \ p \ p') \ (bitmapQ d p s \ ksReadyQueues s (d,p) \ []))" + \d p. (d \ d' \ p \ p') \ (bitmapQ d p s \ \ tcbQueueEmpty (ksReadyQueues s (d,p)))" lemmas bitmapQ_defs = valid_bitmapQ_def valid_bitmapQ_except_def bitmapQ_def bitmapQ_no_L2_orphans_def bitmapQ_no_L1_orphans_def -definition - valid_queues' :: "kernel_state \ bool" -where - "valid_queues' \ \s. \d p t. obj_at' (inQ d p) t s \ t \ set (ksReadyQueues s (d, p))" +\ \ + The tcbSchedPrev and tcbSchedNext fields of a TCB are used only to indicate membership in + one of the ready queues. \ +definition valid_sched_pointers_2 :: + "(obj_ref \ obj_ref) \ (obj_ref \ obj_ref) \ (obj_ref \ bool) \ bool " + where + "valid_sched_pointers_2 prevs nexts ready \ + \ptr. prevs ptr \ None \ nexts ptr \ None \ ready ptr" + +abbreviation valid_sched_pointers :: "kernel_state \ bool" where + "valid_sched_pointers s \ + valid_sched_pointers_2 (tcbSchedPrevs_of s) (tcbSchedNexts_of s) (tcbQueued |< tcbs_of' s)" + +lemmas valid_sched_pointers_def = valid_sched_pointers_2_def + +lemma valid_sched_pointersD: + "\valid_sched_pointers s; \ (tcbQueued |< tcbs_of' s) t\ + \ tcbSchedPrevs_of s t = None \ tcbSchedNexts_of s t = None" + by (fastforce simp: valid_sched_pointers_def in_opt_pred opt_map_red) definition tcb_in_cur_domain' :: "machine_word \ kernel_state \ bool" where "tcb_in_cur_domain' t \ \s. obj_at' (\tcb. ksCurDomain s = tcbDomain tcb) t s" @@ -949,7 +1000,7 @@ abbreviation definition valid_state' :: "kernel_state \ bool" where "valid_state' \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s - \ valid_queues s \ sym_refs (state_refs_of' 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 @@ -958,7 +1009,9 @@ definition valid_state' :: "kernel_state \ bool" where \ valid_irq_states' s \ valid_machine_state' s \ irqs_masked' s - \ valid_queues' s + \ sym_heap_sched_pointers s + \ valid_sched_pointers s + \ valid_bitmaps s \ ct_not_inQ s \ ct_idle_or_in_cur_domain' s \ pspace_domain_valid s @@ -1009,6 +1062,11 @@ definition abbreviation "active' st \ st = Structures_H.Running \ st = Structures_H.Restart" +lemma runnable_eq_active': "runnable' = active'" + apply (rule ext) + apply (case_tac st, simp_all) + done + abbreviation "simple' st \ st = Structures_H.Inactive \ st = Structures_H.Running \ @@ -1024,11 +1082,13 @@ abbreviation abbreviation(input) "all_invs_but_sym_refs_ct_not_inQ' \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s - \ valid_queues s \ if_live_then_nonz_cap' s \ if_unsafe_then_cap' 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 - \ cur_tcb' s \ valid_queues' s \ ct_idle_or_in_cur_domain' s + \ valid_irq_states' s \ irqs_masked' s + \ sym_heap_sched_pointers s \ valid_sched_pointers s \ valid_bitmaps s + \ valid_machine_state' s + \ cur_tcb' s \ ct_idle_or_in_cur_domain' s \ pspace_domain_valid s \ ksCurDomain s \ maxDomain \ valid_dom_schedule' s \ untyped_ranges_zero' s" @@ -1036,12 +1096,14 @@ abbreviation(input) abbreviation(input) "all_invs_but_ct_not_inQ' \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s - \ valid_queues s \ sym_refs (state_refs_of' 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 - \ cur_tcb' s \ valid_queues' s \ ct_idle_or_in_cur_domain' s + \ valid_irq_states' s \ irqs_masked' s + \ sym_heap_sched_pointers s \ valid_sched_pointers s \ valid_bitmaps s + \ valid_machine_state' s + \ cur_tcb' s \ ct_idle_or_in_cur_domain' s \ pspace_domain_valid s \ ksCurDomain s \ maxDomain \ valid_dom_schedule' s \ untyped_ranges_zero' s" @@ -1057,12 +1119,14 @@ lemma all_invs_but_not_ct_inQ_check': definition "all_invs_but_ct_idle_or_in_cur_domain' \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s - \ valid_queues s \ sym_refs (state_refs_of' 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 - \ cur_tcb' s \ valid_queues' s \ ct_not_inQ s + \ valid_irq_states' s \ irqs_masked' s + \ sym_heap_sched_pointers s \ valid_sched_pointers s \ valid_bitmaps s + \ valid_machine_state' s + \ cur_tcb' s \ ct_not_inQ s \ pspace_domain_valid s \ ksCurDomain s \ maxDomain \ valid_dom_schedule' s \ untyped_ranges_zero' s" @@ -2767,9 +2831,9 @@ lemma sch_act_wf_arch [simp]: "sch_act_wf sa (ksArchState_update f s) = sch_act_wf sa s" by (cases sa) (simp_all add: ct_in_state'_def tcb_in_cur_domain'_def) -lemma valid_queues_arch [simp]: - "valid_queues (ksArchState_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) +lemma valid_bitmaps_arch[simp]: + "valid_bitmaps (ksArchState_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) lemma if_unsafe_then_cap_arch' [simp]: "if_unsafe_then_cap' (ksArchState_update f s) = if_unsafe_then_cap' s" @@ -2787,22 +2851,14 @@ lemma sch_act_wf_machine_state [simp]: "sch_act_wf sa (ksMachineState_update f s) = sch_act_wf sa s" by (cases sa) (simp_all add: ct_in_state'_def tcb_in_cur_domain'_def) -lemma valid_queues_machine_state [simp]: - "valid_queues (ksMachineState_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_arch' [simp]: - "valid_queues' (ksArchState_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) - -lemma valid_queues_machine_state' [simp]: - "valid_queues' (ksMachineState_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) - lemma valid_irq_node'_machine_state [simp]: "valid_irq_node' x (ksMachineState_update f s) = valid_irq_node' x s" by (simp add: valid_irq_node'_def) +lemma valid_bitmaps_machine_state[simp]: + "valid_bitmaps (ksMachineState_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) + (* these should be reasonable safe for automation because of the 0 pattern *) lemma no_0_ko_wp' [elim!]: "\ ko_wp_at' Q 0 s; no_0_obj' s \ \ P" @@ -2884,19 +2940,6 @@ lemma typ_at_aligned': "\ typ_at' tp p s \ \ is_aligned p (objBitsT tp)" by (clarsimp simp add: typ_at'_def ko_wp_at'_def objBitsT_koTypeOf) -lemma valid_queues_obj_at'D: - "\ t \ set (ksReadyQueues s (d, p)); valid_queues s \ - \ obj_at' (inQ d p) t s" - apply (unfold valid_queues_def valid_queues_no_bitmap_def) - apply (elim conjE) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE) - apply (clarsimp) - done - lemma obj_at'_and: "obj_at' (P and P') t s = (obj_at' P t s \ obj_at' P' t s)" by (rule iffI, (clarsimp simp: obj_at'_def)+) @@ -2938,21 +2981,6 @@ lemma obj_at'_ko_at'_prop: "ko_at' ko t s \ obj_at' P t s = P ko" by (drule obj_at_ko_at', clarsimp simp: obj_at'_def) -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 \ st_tcb_at' runnable' t s) \ - distinct (ksReadyQueues s (d, p)) \ (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_queues_running: - assumes Q: "t \ set(ksReadyQueues s (d, p))" "valid_queues s" - shows "st_tcb_at' runnable' t s" - using assms by (clarsimp simp add: valid_queues_def valid_queues_no_bitmap_def') - 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) @@ -3033,8 +3061,16 @@ lemma invs_sch_act_wf' [elim!]: "invs' s \ sch_act_wf (ksSchedulerAction s) s" by (simp add: invs'_def valid_state'_def) -lemma invs_queues [elim!]: - "invs' s \ valid_queues s" +lemma invs_valid_bitmaps[elim!]: + "invs' s \ valid_bitmaps s" + by (simp add: invs'_def valid_state'_def) + +lemma invs_sym_heap_sched_pointers[elim!]: + "invs' s \ sym_heap_sched_pointers s" + by (simp add: invs'_def valid_state'_def) + +lemma invs_valid_sched_pointers[elim!]: + "invs' s \ valid_sched_pointers s" by (simp add: invs'_def valid_state'_def) lemma invs_valid_idle'[elim!]: @@ -3049,18 +3085,12 @@ 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_valid_queues'_strg: - "invs' s \ valid_queues' s" - by (clarsimp simp: invs'_def valid_state'_def) - -lemmas invs_valid_queues'[elim!] = invs_valid_queues'_strg[rule_format] - lemma einvs_valid_etcbs: "einvs s \ valid_etcbs s" by (clarsimp simp: valid_sched_def) lemma invs'_bitmapQ_no_L1_orphans: "invs' s \ bitmapQ_no_L1_orphans s" - by (drule invs_queues, simp add: valid_queues_def) + by (simp add: invs'_def valid_state'_def valid_bitmaps_def) lemma invs_ksCurDomain_maxDomain' [elim!]: "invs' s \ ksCurDomain s \ maxDomain" @@ -3085,32 +3115,22 @@ lemma invs_no_0_obj'[elim!]: lemma invs'_gsCNodes_update[simp]: "invs' (gsCNodes_update f s') = invs' s'" - apply (clarsimp simp: invs'_def valid_state'_def valid_queues_def valid_queues_no_bitmap_def - bitmapQ_defs - valid_queues'_def 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'") - apply (simp_all add: ct_in_state'_def tcb_in_cur_domain'_def ct_idle_or_in_cur_domain'_def ct_not_inQ_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_state'_def valid_queues_def valid_queues_no_bitmap_def - bitmapQ_defs - valid_queues'_def 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'") - apply (simp_all add: ct_in_state'_def ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def ct_not_inQ_def) - done - -lemma invs_queues_tcb_in_cur_domain': - "\ ksReadyQueues s (d, p) = x # xs; invs' s; d = ksCurDomain s\ - \ tcb_in_cur_domain' x s" - apply (subgoal_tac "x \ set (ksReadyQueues s (d, p))") - apply (drule (1) valid_queues_obj_at'D[OF _ invs_queues]) - apply (auto simp: inQ_def tcb_in_cur_domain'_def elim: obj_at'_weakenE) + 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: @@ -3126,7 +3146,7 @@ lemma invs'_ksDomScheduleIdx: unfolding invs'_def valid_state'_def by clarsimp lemma valid_bitmap_valid_bitmapQ_exceptE: - "\ valid_bitmapQ_except d p s ; (bitmapQ d p s \ ksReadyQueues s (d,p) \ []) ; + "\ valid_bitmapQ_except d p s; bitmapQ d p s \ \ tcbQueueEmpty (ksReadyQueues s (d,p)); bitmapQ_no_L2_orphans s \ \ valid_bitmapQ s" unfolding valid_bitmapQ_def valid_bitmapQ_except_def diff --git a/proof/refine/RISCV64/IpcCancel_R.thy b/proof/refine/RISCV64/IpcCancel_R.thy index 4bc46d5ded..2f0bf9932d 100644 --- a/proof/refine/RISCV64/IpcCancel_R.thy +++ b/proof/refine/RISCV64/IpcCancel_R.thy @@ -38,25 +38,6 @@ lemma cancelSignal_pred_tcb_at': crunch pred_tcb_at'[wp]: emptySlot "pred_tcb_at' proj P t" (wp: setCTE_pred_tcb_at') -(* valid_queues is too strong *) -definition valid_inQ_queues :: "KernelStateData_H.kernel_state \ bool" where - "valid_inQ_queues \ - \s. \d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) \ distinct (ksReadyQueues s (d, p))" - -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_inQ_queues_ksReadyQueuesL1Bitmap_upd[simp]: - "valid_inQ_queues (ksReadyQueuesL1Bitmap_update f s) = valid_inQ_queues s" - unfolding valid_inQ_queues_def - by simp - -lemma valid_inQ_queues_ksReadyQueuesL2Bitmap_upd[simp]: - "valid_inQ_queues (ksReadyQueuesL2Bitmap_update f s) = valid_inQ_queues s" - unfolding valid_inQ_queues_def - by simp - defs capHasProperty_def: "capHasProperty ptr P \ cte_wp_at' (\c. P (cteCap c)) ptr" @@ -75,11 +56,6 @@ locale delete_one_conc_pre = "\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_queues: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - cteDeleteOne sl \\rv. Invariants_H.valid_queues\" - assumes delete_one_inQ_queues: - "\valid_inQ_queues\ cteDeleteOne sl \\rv. valid_inQ_queues\" assumes delete_one_sch_act_simple: "\sch_act_simple\ cteDeleteOne sl \\rv. sch_act_simple\" assumes delete_one_sch_act_not: @@ -537,7 +513,7 @@ lemma (in delete_one) cancelIPC_ReplyCap_corres: and Q'="\_. invs' and st_tcb_at' awaiting_reply' t" in corres_underlying_split) apply (rule corres_guard_imp) - apply (rule threadset_corresT) + 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 cteSizeBits_def) @@ -661,16 +637,15 @@ lemma sch_act_simple_not_t[simp]: "sch_act_simple s \ sch_act_no context begin interpretation Arch . (*FIXME: arch_split*) +crunches setNotification + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_bitmaps[wp]: valid_bitmaps + (wp: valid_bitmaps_lift) + lemma cancelSignal_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. \ Invariants_H.valid_queues s; st_tcb_at' (Not \ runnable') t s \ - \ \x. t \ set (ksReadyQueues s x)" - 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\" @@ -681,9 +656,9 @@ lemma cancelSignal_invs': show ?thesis 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 setNotification_ksQ] sts_valid_queues + hoare_vcg_all_lift setThreadState_ct_not_inQ NTFNSN - hoare_vcg_all_lift setNotification_ksQ + hoare_vcg_all_lift | simp add: valid_tcb_state'_def list_case_If split del: if_split)+ prefer 2 apply assumption @@ -691,8 +666,6 @@ lemma cancelSignal_invs': apply (rule get_ntfn_sp') apply (rename_tac rv s) apply (clarsimp simp: pred_tcb_at') - apply (frule NIQ) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) apply (rule conjI) apply (clarsimp simp: valid_ntfn'_def) apply (case_tac "ntfnObj rv", simp_all add: isWaitingNtfn_def) @@ -732,9 +705,10 @@ lemma cancelSignal_invs': 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 r") + 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) @@ -792,23 +766,25 @@ lemma setEndpoint_ct_not_inQ[wp]: done lemma setEndpoint_ksDomScheduleIdx[wp]: - "\\s. P (ksDomScheduleIdx s)\ setEndpoint ptr ep \\_ s. P (ksDomScheduleIdx s)\" + "setEndpoint ptr ep \\s. P (ksDomScheduleIdx s)\" apply (simp add: setEndpoint_def setObject_def split_def) apply (wp updateObject_default_inv | simp)+ done + end +crunches 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 NIQ: "\s. \ Invariants_H.valid_queues s; st_tcb_at' (Not \ runnable') t s \ - \ \x. t \ set (ksReadyQueues s x)" - 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 EPSCHN: "\eeptr ep'. \\s. sch_act_not (ksCurThread s) s\ setEndpoint eeptr ep' \\_ s. sch_act_not (ksCurThread s) s\" @@ -833,8 +809,8 @@ proof - 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] - sts_valid_queues setThreadState_ct_not_inQ EPSCHN - hoare_vcg_all_lift setNotification_ksQ + setThreadState_ct_not_inQ EPSCHN + hoare_vcg_all_lift | simp add: valid_tcb_state'_def split del: if_split | wpc)+ prefer 2 @@ -842,14 +818,14 @@ proof - 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 (frule NIQ) - apply (erule pred_tcb'_weakenE, fastforce) apply (clarsimp, rule conjI) apply (auto simp: pred_tcb_at'_def obj_at'_def)[1] apply (rule conjI) @@ -1053,18 +1029,20 @@ lemma setBoundNotification_tcb_in_cur_domain'[wp]: apply (wp setBoundNotification_not_ntfn | simp)+ done -lemma cancelSignal_tcb_obj_at': - "(\tcb st qd. P (tcb\tcbState := st, tcbQueued := qd\) \ P tcb) - \ \obj_at' P t'\ cancelSignal t word \\_. obj_at' P t'\" - apply (simp add: cancelSignal_def setNotification_def) - apply (wp setThreadState_not_st getNotification_wp | wpc | simp)+ - done +lemma setThreadState_tcbDomain_obj_at'[wp]: + "setThreadState ts t \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding setThreadState_def + by wpsimp + +crunches 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 (simp add: cancelIPC_def Let_def) apply (wp hoare_vcg_conj_lift - setThreadState_not_st delete_one_tcbDomain_obj_at' cancelSignal_tcb_obj_at' + delete_one_tcbDomain_obj_at' | wpc | rule hoare_drop_imps | simp add: getThreadReplySlot_def o_def if_fun_split)+ @@ -1171,198 +1149,17 @@ lemma setNotification_weak_sch_act_wf[wp]: lemmas ipccancel_weak_sch_act_wfs = weak_sch_act_wf_lift[OF _ setCTE_pred_tcb_at'] -lemma tcbSchedDequeue_corres': - "corres dc (is_etcb_at t and tcb_at t and pspace_aligned and pspace_distinct) - (valid_inQ_queues) - (tcb_sched_action (tcb_sched_dequeue) t) (tcbSchedDequeue t)" - apply (rule corres_cross_over_guard[where P'=P' and Q="tcb_at' t and P'" for P']) - apply (fastforce simp: tcb_at_cross dest: state_relation_pspace_relation) - apply (simp only: tcbSchedDequeue_def tcb_sched_action_def) - apply (rule corres_symb_exec_r[OF _ _ threadGet_inv, where Q'="\rv. tcb_at' t and valid_inQ_queues and obj_at' (\obj. tcbQueued obj = rv) t"]) - defer - apply (wp threadGet_obj_at', simp, simp) - apply (wp, simp) - apply (case_tac queued) - defer - apply (simp add: unless_def when_def) - apply (rule corres_no_failI) - apply (wp) - apply (clarsimp simp: in_monad ethread_get_def get_etcb_def set_tcb_queue_def is_etcb_at_def state_relation_def gets_the_def gets_def get_def return_def bind_def assert_opt_def get_tcb_queue_def modify_def put_def) - apply (subgoal_tac "t \ set (ready_queues a (tcb_domain y) (tcb_priority y))") - prefer 2 - apply (force simp: tcb_sched_dequeue_def valid_inQ_queues_def - ready_queues_relation_def obj_at'_def inQ_def project_inject) - apply (simp add: ready_queues_relation_def) - apply (simp add: unless_def when_def) - apply (rule corres_guard_imp) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres, simp add: etcb_relation_def) - apply (simp split del: if_split) - apply (rule corres_split_eqr) - apply (rule ethreadget_corres, simp add: etcb_relation_def) - apply (rule corres_split_eqr[OF getQueue_corres]) - apply (simp split del: if_split) - apply (subst bind_return_unit, rule corres_split[where r'=dc]) - apply (simp add: tcb_sched_dequeue_def) - apply (rule setQueue_corres) - apply (rule corres_split_noop_rhs) - apply (clarsimp, rule removeFromBitmap_corres_noop) - apply (simp add: dc_def[symmetric]) - apply (rule threadSet_corres_noop, simp_all add: tcb_relation_def exst_same_def)[1] - apply (wp | simp)+ - done - -lemma setQueue_valid_inQ_queues: - "\valid_inQ_queues - and (\s. \t \ set ts. obj_at' (inQ d p) t s) - and K (distinct ts)\ - setQueue d p ts - \\_. valid_inQ_queues\" - apply (simp add: setQueue_def valid_inQ_queues_def) - apply wp - apply clarsimp - done - -lemma threadSet_valid_inQ_queues: - "\valid_inQ_queues and (\s. \d p. (\tcb. (inQ d p tcb) \ \(inQ d p (f tcb))) - \ obj_at' (\tcb. (inQ d p tcb) \ \(inQ d p (f tcb))) t s - \ t \ set (ksReadyQueues s (d, p)))\ - threadSet f t - \\rv. valid_inQ_queues\" - apply (simp add: threadSet_def) - apply wp - apply (simp add: valid_inQ_queues_def pred_tcb_at'_def) - apply (wp setObject_queues_unchanged_tcb - hoare_Ball_helper - hoare_vcg_all_lift - setObject_tcb_strongest)[1] - apply (wp getObject_tcb_wp) - apply (clarsimp simp: valid_inQ_queues_def pred_tcb_at'_def) - apply (clarsimp simp: obj_at'_def) - apply (fastforce) - done - -(* reorder the threadSet before the setQueue, useful for lemmas that don't refer to bitmap *) -lemma setQueue_after_addToBitmap: - "(setQueue d p q >>= (\rv. (when P (addToBitmap d p)) >>= (\rv. threadSet f t))) = - (when P (addToBitmap d p) >>= (\rv. (threadSet f t) >>= (\rv. setQueue d p q)))" - 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 (simp add: threadSet_def getObject_def setObject_def - loadObject_default_def bitmap_fun_defs - split_def projectKO_def2 alignCheck_assert - magnitudeCheck_assert updateObject_default_def) - apply (intro oblivious_bind, simp_all) - apply (clarsimp simp: bind_assoc) - done - -lemma tcbSchedEnqueue_valid_inQ_queues[wp]: - "\valid_inQ_queues\ tcbSchedEnqueue t \\_. valid_inQ_queues\" - apply (simp add: tcbSchedEnqueue_def setQueue_after_addToBitmap) - apply (rule hoare_pre) - apply (rule_tac B="\rv. valid_inQ_queues and obj_at' (\obj. tcbQueued obj = rv) t" - in hoare_seq_ext) - apply (rename_tac queued) - apply (case_tac queued, simp_all add: unless_def)[1] - apply (wp setQueue_valid_inQ_queues threadSet_valid_inQ_queues threadGet_wp - hoare_vcg_const_Ball_lift - | simp add: inQ_def bitmap_fun_defs - | fastforce simp: valid_inQ_queues_def inQ_def obj_at'_def)+ - done - - (* prevents wp from splitting on the when; stronger technique than hoare_when_weak_wp - FIXME: possible to replace with hoare_when_weak_wp? - *) -definition - "removeFromBitmap_conceal d p q t \ when (null [x\q . x \ t]) (removeFromBitmap d p)" - -lemma removeFromBitmap_conceal_valid_inQ_queues[wp]: - "\ valid_inQ_queues \ removeFromBitmap_conceal d p q t \ \_. valid_inQ_queues \" - unfolding valid_inQ_queues_def removeFromBitmap_conceal_def - by (wp|clarsimp simp: bitmap_fun_defs)+ - -lemma rescheduleRequired_valid_inQ_queues[wp]: - "\valid_inQ_queues\ rescheduleRequired \\_. valid_inQ_queues\" - apply (simp add: rescheduleRequired_def) - apply wpsimp - done - -lemma sts_valid_inQ_queues[wp]: - "\valid_inQ_queues\ setThreadState st t \\rv. valid_inQ_queues\" - apply (simp add: setThreadState_def) - apply (wp threadSet_valid_inQ_queues [THEN hoare_strengthen_post]) - apply (clarsimp simp: sch_act_simple_def Invariants_H.valid_queues_def inQ_def)+ - done - lemma updateObject_ep_inv: "\P\ updateObject (obj::endpoint) ko p q n \\rv. P\" by simp (rule updateObject_default_inv) -lemma sbn_valid_inQ_queues[wp]: - "\valid_inQ_queues\ setBoundNotification ntfn t \\rv. valid_inQ_queues\" - apply (simp add: setBoundNotification_def) - apply (wp threadSet_valid_inQ_queues [THEN hoare_strengthen_post]) - apply (clarsimp simp: sch_act_simple_def Invariants_H.valid_queues_def inQ_def)+ - done - -lemma setEndpoint_valid_inQ_queues[wp]: - "\valid_inQ_queues\ setEndpoint ptr ep \\rv. valid_inQ_queues\" - apply (unfold setEndpoint_def) - apply (rule setObject_ep_pre) - apply (simp add: valid_inQ_queues_def) - apply (wp hoare_Ball_helper hoare_vcg_all_lift setObject_queues_unchanged[OF updateObject_ep_inv]) - apply simp - done - -lemma set_ntfn_valid_inQ_queues[wp]: - "\valid_inQ_queues\ setNotification ptr ntfn \\rv. valid_inQ_queues\" - apply (unfold setNotification_def) - apply (rule setObject_ntfn_pre) - apply (simp add: valid_inQ_queues_def) - apply (wp hoare_Ball_helper hoare_vcg_all_lift) - apply (clarsimp simp: updateObject_default_def in_monad) - apply (wp updateObject_default_inv | simp)+ - done - -crunch valid_inQ_queues[wp]: cancelSignal valid_inQ_queues - (simp: updateObject_tcb_inv crunch_simps wp: crunch_wps) - -lemma (in delete_one_conc_pre) cancelIPC_valid_inQ_queues[wp]: - "\valid_inQ_queues\ cancelIPC t \\_. valid_inQ_queues\" - apply (simp add: cancelIPC_def Let_def getThreadReplySlot_def) - apply (wp hoare_drop_imps delete_one_inQ_queues threadSet_valid_inQ_queues | wpc | simp add:if_apply_def2 Fun.comp_def)+ - apply (clarsimp simp: valid_inQ_queues_def inQ_def)+ - done - -lemma valid_queues_inQ_queues: - "Invariants_H.valid_queues s \ valid_inQ_queues s" - by (force simp: Invariants_H.valid_queues_def valid_inQ_queues_def obj_at'_def - valid_queues_no_bitmap_def) - lemma asUser_tcbQueued_inv[wp]: "\obj_at' (\tcb. P (tcbQueued tcb)) t'\ asUser t m \\_. obj_at' (\tcb. P (tcbQueued tcb)) t'\" 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_valid_inQ_queues[wp]: - "\valid_inQ_queues\ asUser t f \\rv. valid_inQ_queues\" - unfolding valid_inQ_queues_def Ball_def - apply (wpsimp wp: hoare_vcg_all_lift) - defer - apply (wp asUser_ksQ) - apply assumption - apply (simp add: inQ_def[abs_def] obj_at'_conj) - apply (rule hoare_convert_imp) - apply (wp asUser_ksQ) - apply wp - done - -context begin -interpretation Arch . +context begin interpretation Arch . crunches cancel_ipc for pspace_aligned[wp]: "pspace_aligned :: det_state \ _" @@ -1371,6 +1168,30 @@ crunches cancel_ipc end +crunches asUser + for valid_sched_pointers[wp]: valid_sched_pointers + (wp: crunch_wps) + +crunches set_thread_state + for in_correct_ready_q[wp]: in_correct_ready_q + (wp: crunch_wps) + +crunches set_thread_state_ext + for ready_qs_distinct[wp]: ready_qs_distinct + (wp: crunch_wps) + +lemma set_thread_state_ready_qs_distinct[wp]: + "set_thread_state ref ts \ready_qs_distinct\" + unfolding set_thread_state_def + apply (wpsimp wp: set_object_wp) + by (clarsimp simp: ready_qs_distinct_def) + +lemma as_user_ready_qs_distinct[wp]: + "as_user tptr f \ready_qs_distinct\" + unfolding as_user_def + apply (wpsimp wp: set_object_wp) + by (clarsimp simp: ready_qs_distinct_def) + lemma (in delete_one) suspend_corres: "corres dc (einvs and tcb_at t) invs' (IpcCancel_A.suspend t) (ThreadDecls_H.suspend t)" @@ -1394,15 +1215,18 @@ lemma (in delete_one) suspend_corres: apply (rule corres_return_trivial) apply (rule corres_split_nor[OF setThreadState_corres]) apply wpsimp - apply (rule tcbSchedDequeue_corres') + apply (rule tcbSchedDequeue_corres, simp) apply wp - apply wpsimp - apply (wpsimp simp: update_restart_pc_def updateRestartPC_def)+ - apply (rule hoare_post_imp[where Q = "\rv s. tcb_at t s \ is_etcb_at t s \ pspace_aligned s \ pspace_distinct s"]) - apply simp - apply (wp | simp)+ - apply (fastforce simp: valid_sched_def tcb_at_is_etcb_at) - apply (clarsimp simp add: invs'_def valid_state'_def valid_queues_inQ_queues) + 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: @@ -1425,259 +1249,8 @@ lemma (in delete_one_conc_pre) cancelIPC_it[wp]: apply (wp hoare_drop_imps delete_one_it | wpc | simp add:if_apply_def2 Fun.comp_def)+ done -lemma tcbSchedDequeue_notksQ: - "\\s. t' \ set(ksReadyQueues s p)\ - tcbSchedDequeue t - \\_ s. t' \ set(ksReadyQueues s p)\" - 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+ - apply clarsimp - apply (rule_tac Q="\_ s. t' \ set(ksReadyQueues s p)" in hoare_post_imp) - apply (wp | clarsimp)+ - done - -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 B="\rv s. (rv = ResumeCurrentThread \ rv = ChooseNewThread) - \ ?OAQ t' p s" in hoare_seq_ext) - including classic_wp_pre - apply (wp | clarsimp)+ - apply (case_tac x) - apply (wp | clarsimp)+ - done - -lemma setThreadState_oa_queued: - "\\s. P' (obj_at' (\tcb. P (tcbQueued tcb) (tcbDomain tcb) (tcbPriority tcb)) t' s) \ - setThreadState st 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 \ setThreadState st t \\_. ?Q R \" - apply (simp add: setThreadState_def) - apply (wp rescheduleRequired_oa_queued) - apply (simp add: sch_act_simple_def) - apply (rule_tac Q="\_. ?Q R" in hoare_post_imp, clarsimp) - apply (wp threadSet_obj_at'_strongish) - apply (clarsimp) - done - show "\\s. \ ?Q P s\ setThreadState st t \\_ s. \ ?Q P s\" - by (simp add: not_obj_at' comp_def, wp hoare_convert_imp pos) - qed - -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 tcbSchedDequeue_ksQ_distinct[wp]: - "\\s. distinct (ksReadyQueues s p)\ - tcbSchedDequeue t - \\_ s. distinct (ksReadyQueues s p)\" - 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+ - apply (rule_tac Q="\_ s. distinct (ksReadyQueues s p)" in hoare_post_imp) - apply (clarsimp | wp)+ - done - -lemma sts_valid_queues_partial: - "\Invariants_H.valid_queues and sch_act_simple\ - setThreadState st t - \\_ s. \t' d p. - (t' \ set(ksReadyQueues s (d, p)) \ - (obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t' s - \ (t' \ t \ st_tcb_at' runnable' t' s))) - \ distinct (ksReadyQueues s (d, p))\" - (is "\_\ _ \\_ s. \t' d p. ?OA t' d p s \ ?DISTINCT d p s \") - apply (rule_tac Q="\_ s. (\t' d p. ?OA t' d p s) \ (\d p. ?DISTINCT d p s)" - in hoare_post_imp) - apply (clarsimp) - apply (rule hoare_conjI) - apply (rule_tac Q="\s. \t' d p. - ((t'\set(ksReadyQueues s (d, p)) - \ \ (sch_act_simple s)) - \ (obj_at'(\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t' s - \ st_tcb_at' runnable' t' s))" in hoare_pre_imp) - apply (fastforce simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def - pred_tcb_at'_def obj_at'_def inQ_def) - apply (rule hoare_vcg_all_lift)+ - apply (rule hoare_convert_imp) - including classic_wp_pre - apply (wp sts_ksQ setThreadState_oa_queued hoare_impI sts_pred_tcb_neq' - | clarsimp)+ - apply (rule_tac Q="\s. \d p. ?DISTINCT d p s \ sch_act_simple s" in hoare_pre_imp) - apply (clarsimp simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def) - apply (wp hoare_vcg_all_lift sts_ksQ) - apply (clarsimp) - done - -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 Q="(\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) - done - -lemma sts_invs_minor'_no_valid_queues: - "\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 \ obj_at' tcbQueued t s \ st_tcb_at' runnable' t s) - and sch_act_simple - and invs'\ - setThreadState st t - \\_ s. (\t' d p. - (t' \ set(ksReadyQueues s (d, p)) \ - (obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t' s - \ (t' \ t \ st_tcb_at' runnable' t' s))) - \ distinct (ksReadyQueues s (d, p)) \ (maxDomain < d \ maxPriority < p \ ksReadyQueues s (d, p) = [])) \ - valid_bitmapQ s \ - bitmapQ_no_L2_orphans s \ - bitmapQ_no_L1_orphans 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 \ - valid_queues' s \ - ct_not_inQ s \ - ct_idle_or_in_cur_domain' s \ - pspace_domain_valid s \ - ksCurDomain s \ maxDomain \ - valid_dom_schedule' s \ - untyped_ranges_zero' s \ - cur_tcb' s \ - tcb_at' t s\" - apply (simp add: invs'_def valid_state'_def valid_queues_def) - apply (wp sts_valid_queues_partial sts_ksQ - setThreadState_oa_queued sts_st_tcb_at'_cases - irqs_masked_lift - valid_irq_node_lift - setThreadState_ct_not_inQ - sts_valid_bitmapQ_sch_act_simple - sts_valid_bitmapQ_no_L2_orphans_sch_act_simple - sts_valid_bitmapQ_no_L1_orphans_sch_act_simple - hoare_vcg_conj_lift hoare_vcg_imp_lift hoare_vcg_all_lift)+ - apply (clarsimp simp: disj_imp) - apply (intro conjI) - apply (clarsimp simp: valid_queues_def) - apply (rule conjI, clarsimp) - apply (drule valid_queues_no_bitmap_objD, assumption) - apply (clarsimp simp: inQ_def comp_def) - apply (rule conjI) - apply (erule obj_at'_weaken) - apply (simp add: inQ_def) - apply (clarsimp simp: st_tcb_at'_def) - apply (erule obj_at'_weaken) - apply (simp add: inQ_def) - apply (simp add: valid_queues_no_bitmap_def) - apply clarsimp - apply (clarsimp simp: st_tcb_at'_def) - apply (drule obj_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def) - apply (clarsimp simp: valid_obj'_def valid_tcb'_def) - subgoal - by (fastforce simp: valid_tcb_state'_def - split: Structures_H.thread_state.splits) - apply (clarsimp dest!: st_tcb_at_state_refs_ofD' - elim!: rsubst[where P=sym_refs] - intro!: ext) - apply (fastforce simp: valid_queues_def inQ_def pred_tcb_at' pred_tcb_at'_def - elim!: st_tcb_ex_cap'' obj_at'_weakenE)+ - done - crunch ct_idle_or_in_cur_domain'[wp]: tcbSchedDequeue ct_idle_or_in_cur_domain' - -lemma tcbSchedDequeue_invs'_no_valid_queues: - "\\s. (\t' d p. - (t' \ set(ksReadyQueues s (d, p)) \ - (obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t' s - \ (t' \ t \ st_tcb_at' runnable' t' s))) - \ distinct (ksReadyQueues s (d, p)) \ (maxDomain < d \ maxPriority < p \ ksReadyQueues s (d, p) = [])) \ - valid_bitmapQ s \ - bitmapQ_no_L2_orphans s \ - bitmapQ_no_L1_orphans 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 \ - valid_queues' s \ - ct_not_inQ s \ - ct_idle_or_in_cur_domain' s \ - pspace_domain_valid s \ - ksCurDomain s \ maxDomain \ - valid_dom_schedule' s \ - untyped_ranges_zero' s \ - cur_tcb' s \ - tcb_at' t s\ - tcbSchedDequeue t - \\_. invs' \" - apply (simp add: invs'_def valid_state'_def) - apply (wp tcbSchedDequeue_valid_queues_weak valid_irq_handlers_lift - valid_irq_node_lift valid_irq_handlers_lift' - tcbSchedDequeue_irq_states irqs_masked_lift cur_tcb_lift - untyped_ranges_zero_lift - | clarsimp simp add: cteCaps_of_def valid_queues_def o_def)+ - apply (rule conjI) - apply (fastforce simp: obj_at'_def inQ_def st_tcb_at'_def valid_queues_no_bitmap_except_def) - apply (rule conjI, clarsimp simp: correct_queue_def) - apply (fastforce simp: valid_pspace'_def intro: obj_at'_conjI - elim: valid_objs'_maxDomain valid_objs'_maxPriority) - done - -lemmas sts_tcbSchedDequeue_invs' = - sts_invs_minor'_no_valid_queues - tcbSchedDequeue_invs'_no_valid_queues + (wp: crunch_wps) lemma asUser_sch_act_simple[wp]: "\sch_act_simple\ asUser s t \\_. sch_act_simple\" @@ -1689,11 +1262,14 @@ lemma (in delete_one_conc) suspend_invs'[wp]: "\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 (wp sts_tcbSchedDequeue_invs') - apply (simp add: updateRestartPC_def | strengthen no_refs_simple_strg')+ - prefer 2 - apply (wpsimp wp: hoare_drop_imps hoare_vcg_imp_lift' - | strengthen no_refs_simple_strg')+ + 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]: @@ -1737,109 +1313,6 @@ lemma (in delete_one_conc_pre) suspend_st_tcb_at': lemmas (in delete_one_conc_pre) suspend_makes_simple' = suspend_st_tcb_at' [where P=simple', simplified] -lemma valid_queues_not_runnable'_not_ksQ: - assumes "Invariants_H.valid_queues s" and "st_tcb_at' (Not \ runnable') t s" - shows "\d p. t \ set (ksReadyQueues s (d, p))" - using assms - apply - - apply (clarsimp simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def pred_tcb_at'_def) - apply (erule_tac x=d in allE) - apply (erule_tac x=p in allE) - apply (clarsimp) - apply (drule(1) bspec) - apply (clarsimp simp: obj_at'_def) - done - -declare valid_queues_not_runnable'_not_ksQ[OF ByAssum, simp] - -lemma cancelSignal_queues[wp]: - "\Invariants_H.valid_queues and st_tcb_at' (Not \ runnable') t\ - cancelSignal t ae \\_. Invariants_H.valid_queues \" - apply (simp add: cancelSignal_def) - apply (wp sts_valid_queues) - apply (rule_tac Q="\_ s. \p. t \ set (ksReadyQueues s p)" in hoare_post_imp, simp) - apply (wp hoare_vcg_all_lift) - apply (wpc) - apply (wp)+ - apply (rule_tac Q="\_ s. Invariants_H.valid_queues s \ (\p. t \ set (ksReadyQueues s p))" in hoare_post_imp) - apply (clarsimp) - apply (wp) - apply (clarsimp) - done - -lemma (in delete_one_conc_pre) cancelIPC_queues[wp]: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - cancelIPC t \\rv. Invariants_H.valid_queues\" - apply (simp add: cancelIPC_def Let_def getThreadReplySlot_def - cong: Structures_H.thread_state.case_cong list.case_cong) - apply (rule hoare_seq_ext [OF _ gts_sp']) - apply (rule hoare_pre) - apply (wpc - | wp hoare_vcg_conj_lift delete_one_queues threadSet_valid_queues - threadSet_valid_objs' sts_valid_queues setEndpoint_ksQ - hoare_vcg_all_lift threadSet_sch_act threadSet_weak_sch_act_wf - | simp add: o_def if_apply_def2 inQ_def - | rule hoare_drop_imps - | clarsimp simp: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def - elim!: pred_tcb'_weakenE)+ - apply (fastforce dest: valid_queues_not_runnable'_not_ksQ elim: pred_tcb'_weakenE) - done - -(* FIXME: move to Schedule_R *) -lemma tcbSchedDequeue_nonq[wp]: - "\Invariants_H.valid_queues and tcb_at' t and K (t = t')\ - tcbSchedDequeue t \\_ s. \d p. t' \ set (ksReadyQueues s (d, p))\" - apply (rule hoare_gen_asm) - apply (simp add: tcbSchedDequeue_def) - apply (wp threadGet_wp|simp)+ - apply (fastforce simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def obj_at'_def projectKOs inQ_def) - done - -lemma sts_ksQ_oaQ: - "\Invariants_H.valid_queues\ - setThreadState st t - \\_ s. t \ set (ksReadyQueues s (d, p)) \ - obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t s\" - (is "\_\ _ \\_. ?POST\") - proof - - have RR: "\sch_act_simple and ?POST\ rescheduleRequired \\_. ?POST\" - apply (simp add: rescheduleRequired_def) - apply (wp) - apply (clarsimp) - apply (rule_tac - Q="(\s. action = ResumeCurrentThread \ action = ChooseNewThread) and ?POST" - in hoare_pre_imp, assumption) - apply (case_tac action) - apply (clarsimp)+ - apply (wp) - apply (clarsimp simp: sch_act_simple_def) - done - show ?thesis - apply (simp add: setThreadState_def) - apply (wp RR) - apply (rule_tac Q="\_. ?POST" in hoare_post_imp) - apply (clarsimp simp add: sch_act_simple_def) - apply (wp hoare_convert_imp) - apply (clarsimp simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (fastforce dest: bspec elim!: obj_at'_weakenE simp: inQ_def) - done - qed - -lemma (in delete_one_conc_pre) suspend_nonq: - "\Invariants_H.valid_queues and valid_objs' and tcb_at' t - and (\s. weak_sch_act_wf (ksSchedulerAction s) s) - and (\s. t \ ksIdleThread s) and K (t = t')\ - suspend t - \\rv s. \d p. t' \ set (ksReadyQueues s (d, p))\" - apply (rule hoare_gen_asm) - apply (simp add: suspend_def) - unfolding updateRestartPC_def - apply (wp hoare_allI tcbSchedDequeue_t_notksQ sts_ksQ_oaQ) - apply wpsimp+ - done - lemma suspend_makes_inactive: "\K (t = t')\ suspend t \\rv. st_tcb_at' ((=) Inactive) t'\" apply (cases "t = t'", simp_all) @@ -1850,29 +1323,21 @@ lemma suspend_makes_inactive: declare threadSet_sch_act_sane [wp] declare sts_sch_act_sane [wp] -lemma tcbSchedEnqueue_ksQset_weak: - "\\s. t' \ set (ksReadyQueues s p)\ - tcbSchedEnqueue t - \\_ s. t' \ set (ksReadyQueues s p)\" (is "\?PRE\ _ \_\") - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wp hoare_vcg_conj_lift hoare_vcg_imp_lift hoare_vcg_if_lift) - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, ((wp | clarsimp)+))+ - done - 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 tcbSchedEnqueue_ct', wp, simp) + by (rule hoare_weaken_pre, wps, wp, simp) lemma sts_sch_act_not_ct[wp]: "\\s. sch_act_not (ksCurThread s) s\ setThreadState st t \\_ s. sch_act_not (ksCurThread s) s\" - by (rule hoare_weaken_pre, wps tcbSchedEnqueue_ct', wp, simp) + by (rule hoare_weaken_pre, wps, wp, simp) text \Cancelling all IPC in an endpoint or notification object\ lemma ep_cancel_corres_helper: - "corres dc ((\s. \t \ set list. tcb_at t s) and valid_etcbs and pspace_aligned and pspace_distinct) - (Invariants_H.valid_queues and valid_queues' and valid_objs') + "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 @@ -1881,28 +1346,34 @@ lemma ep_cancel_corres_helper: 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 (rule corres_guard_imp [OF setThreadState_corres]) - apply simp - apply (simp add: valid_tcb_state_def) - apply simp - apply (wp sts_valid_queues)+ - apply (force simp: tcb_at_is_etcb_at) - apply (fastforce elim: obj_at'_weakenE) - apply ((wp hoare_vcg_const_Ball_lift | simp)+)[1] - apply (rule hoare_pre) - apply (wp hoare_vcg_const_Ball_lift - weak_sch_act_wf_lift_linear sts_st_tcb' setThreadState_not_st - sts_valid_queues tcbSchedEnqueue_not_st - | simp)+ - apply (auto elim: obj_at'_weakenE simp: valid_tcb_state'_def) + 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 +crunches 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 ep_cancel_corres: "corres dc (invs and valid_sched and ep_at ep) (invs' and ep_at' ep) (cancel_all_ipc ep) (cancelAllIPC ep)" @@ -1910,10 +1381,10 @@ proof - have P: "\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_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 - \ Invariants_H.valid_queues s \ valid_queues' s \ valid_objs' 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; @@ -1935,22 +1406,23 @@ proof - 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 R="\_ s. \x\set list. tcb_at' x s \ valid_objs' s" + apply (rule_tac R="\_ 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 (rule hoare_name_pre_state) - apply ((wp hoare_vcg_const_Ball_lift mapM_x_wp' - sts_valid_queues setThreadState_not_st sts_st_tcb' tcbSchedEnqueue_not_st - | clarsimp - | fastforce elim: obj_at'_weakenE simp: valid_tcb_state'_def)+)[2] - apply (rule hoare_name_pre_state) + 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 elim!: valid_objs_valid_tcbE))+ + | (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 (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 @@ -1978,6 +1450,8 @@ lemma cancelAllSignals_corres: "corres dc (invs and valid_sched and ntfn_at ntfn) (invs' and ntfn_at' ntfn) (cancel_all_signals ntfn) (cancelAllSignals ntfn)" apply (simp add: cancel_all_signals_def cancelAllSignals_def) + 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+ @@ -1988,17 +1462,19 @@ lemma cancelAllSignals_corres: 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 setThreadState_not_st + weak_sch_act_wf_lift_linear set_thread_state_runnable_weak_valid_sched_action | simp)+ apply (rename_tac list) - apply (rule_tac R="\_ s. (\x\set list. tcb_at' x s) \ valid_objs' s" + apply (rule_tac R="\_ 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_queues setThreadState_not_st - simp: valid_tcb_state'_def) + 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)+ @@ -2045,6 +1521,11 @@ proof - done qed +lemma tcbSchedEnqueue_valid_pspace'[wp]: + "tcbSchedEnqueue tcbPtr \valid_pspace'\" + unfolding valid_pspace'_def + by wpsimp + lemma cancel_all_invs'_helper: "\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} @@ -2059,8 +1540,7 @@ lemma cancel_all_invs'_helper: apply clarsimp 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_valid_queues sts_st_tcb' setThreadState_not_st + 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 @@ -2069,7 +1549,7 @@ lemma cancel_all_invs'_helper: elim!: rsubst[where P=sym_refs] dest!: set_mono_suffix intro!: ext - | (drule (1) bspec, clarsimp simp: valid_pspace'_def valid_tcb'_def elim!: valid_objs_valid_tcbE))+ + | (drule (1) bspec, clarsimp simp: valid_pspace'_def valid_tcb'_def))+ done lemma ep_q_refs_max: @@ -2086,10 +1566,9 @@ lemma ep_q_refs_max: done lemma rescheduleRequired_invs'[wp]: - "\invs'\ rescheduleRequired \\rv. invs'\" + "rescheduleRequired \invs'\" apply (simp add: rescheduleRequired_def) apply (wpsimp wp: ssa_invs') - apply (clarsimp simp: invs'_def valid_state'_def) done lemma invs_rct_ct_activatable': @@ -2216,6 +1695,7 @@ lemma rescheduleRequired_all_invs_but_ct_not_inQ: lemma cancelAllIPC_invs'[wp]: "\invs'\ cancelAllIPC ep_ptr \\rv. invs'\" apply (simp add: cancelAllIPC_def ep'_Idle_case_helper cong del: if_cong) + apply (rule hoare_seq_ext[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' @@ -2244,6 +1724,7 @@ lemma cancelAllIPC_invs'[wp]: lemma cancelAllSignals_invs'[wp]: "\invs'\ cancelAllSignals ntfn \\rv. invs'\" apply (simp add: cancelAllSignals_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) apply (case_tac "ntfnObj ntfna", simp_all) apply (wp, simp) @@ -2275,12 +1756,14 @@ lemma cancelAllSignals_invs'[wp]: done lemma cancelAllIPC_valid_objs'[wp]: - "\valid_objs'\ cancelAllIPC ep \\rv. valid_objs'\" + "\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 hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ep_sp']) apply (rule hoare_pre) apply (wp set_ep_valid_objs' setSchedulerAction_valid_objs') - apply (rule_tac Q="\rv s. valid_objs' s \ (\x\set (epQueue ep). tcb_at' x s)" + 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) @@ -2297,8 +1780,9 @@ lemma cancelAllIPC_valid_objs'[wp]: done lemma cancelAllSignals_valid_objs'[wp]: - "\valid_objs'\ cancelAllSignals ntfn \\rv. valid_objs'\" + "\valid_objs' and pspace_aligned' and pspace_distinct'\ cancelAllSignals ntfn \\rv. valid_objs'\" apply (simp add: cancelAllSignals_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) apply (case_tac "ntfnObj ntfna", simp_all) apply (wp, simp) @@ -2351,19 +1835,17 @@ 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\" - apply (simp add: setThreadState_def setQueue_def - rescheduleRequired_def tcbSchedEnqueue_def - unless_def bitmap_fun_defs - cong: scheduler_action.case_cong cong del: if_cong - | wp | wpcw)+ - done + 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 unless_def) + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_def) apply (wp | simp add: setQueue_def bitmap_fun_defs)+ done @@ -2397,19 +1879,41 @@ lemma setObject_ko_wp_at': objBits_def[symmetric] ps_clear_upd in_magnitude_check v) -lemma rescheduleRequired_unlive: - "\\s. ko_wp_at' (Not \ live') p s \ ksSchedulerAction s \ SwitchToThread p\ - rescheduleRequired +lemma threadSet_unlive_other: + "\ko_wp_at' (Not \ live') p and K (p \ t)\ + threadSet f t \\rv. ko_wp_at' (Not \ live') p\" - apply (simp add: rescheduleRequired_def) - apply (wp | simp | wpc)+ - apply (simp add: tcbSchedEnqueue_def unless_def - threadSet_def setQueue_def threadGet_def) - apply (wp setObject_ko_wp_at getObject_tcb_wp - | simp add: objBits_simps' bitmap_fun_defs split del: if_split)+ - apply (clarsimp simp: o_def) - apply (drule obj_at_ko_at') - apply clarsimp + by (clarsimp simp: threadSet_def valid_def getObject_def + setObject_def in_monad loadObject_default_def + ko_wp_at'_def split_def in_magnitude_check + objBits_simps' updateObject_default_def + ps_clear_upd RISCV64_H.fromPPtr_def) + +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 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 + split: option.splits) + done + +lemma rescheduleRequired_unlive[wp]: + "\\s. ko_wp_at' (Not \ live') p s \ ksSchedulerAction s \ SwitchToThread p\ + rescheduleRequired + \\_. ko_wp_at' (Not \ live') p\" + supply comp_apply[simp del] + unfolding rescheduleRequired_def + apply (wpsimp wp: tcbSchedEnqueue_unlive_other) done lemmas setEndpoint_ko_wp_at' @@ -2419,6 +1923,7 @@ lemma cancelAllIPC_unlive: "\valid_objs' and (\s. sch_act_wf (ksSchedulerAction s) s)\ cancelAllIPC ep \\rv. ko_wp_at' (Not \ live') ep\" apply (simp add: cancelAllIPC_def ep'_Idle_case_helper) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ep_sp']) apply (rule hoare_pre) apply (wp cancelAll_unlive_helper setEndpoint_ko_wp_at' @@ -2437,6 +1942,7 @@ lemma cancelAllSignals_unlive: \ obj_at' (\ko. ntfnBoundTCB ko = None) ntfnptr s\ cancelAllSignals ntfnptr \\rv. ko_wp_at' (Not \ live') ntfnptr\" apply (simp add: cancelAllSignals_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) apply (case_tac "ntfnObj ntfn", simp_all add: setNotification_def) apply wp @@ -2501,25 +2007,20 @@ lemma cancelBadgedSends_filterM_helper': apply (rule hoare_pre) 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' sts_valid_queues setThreadState_not_st - tcbSchedEnqueue_not_st - untyped_ranges_zero_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 + apply (clarsimp simp: valid_pspace'_def cong: conj_cong) apply (intro conjI) - apply (clarsimp simp: valid_pspace'_def valid_tcb'_def elim!: valid_objs_valid_tcbE dest!: st_tcb_ex_cap'') - apply (fastforce dest!: 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) - apply (fastforce elim!: obj_atE' - simp: state_refs_of'_def tcb_bound_refs'_def - subsetD symreftype_inverse' - split: if_split_asm)+ - done + by (fastforce elim!: obj_atE' + simp: state_refs_of'_def tcb_bound_refs'_def subsetD symreftype_inverse' + split: if_split_asm)+ lemmas cancelBadgedSends_filterM_helper = spec [where x=Nil, OF cancelBadgedSends_filterM_helper', simplified] @@ -2529,7 +2030,8 @@ lemma cancelBadgedSends_invs[wp]: shows "\invs'\ cancelBadgedSends epptr badge \\rv. invs'\" apply (simp add: cancelBadgedSends_def) - apply (rule hoare_seq_ext [OF _ get_ep_sp']) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) + apply (rule hoare_seq_ext [OF _ get_ep_sp'], rename_tac ep) apply (case_tac ep, simp_all) apply ((wp | simp)+)[2] apply (subst bind_assoc [where g="\_. rescheduleRequired", @@ -2561,11 +2063,20 @@ lemma cancelBadgedSends_invs[wp]: crunch state_refs_of[wp]: tcb_sched_action "\s. P (state_refs_of s)" +lemma setEndpoint_valid_tcbs'[wp]: + "setEndpoint ePtr val \valid_tcbs'\" + unfolding setEndpoint_def + apply (wpsimp wp: setObject_valid_tcbs'[where P=\]) + apply (clarsimp simp: updateObject_default_def monad_simps) + apply fastforce + done lemma cancelBadgedSends_corres: "corres dc (invs and valid_sched and ep_at epptr) (invs' and ep_at' epptr) (cancel_badged_sends epptr bdg) (cancelBadgedSends epptr bdg)" 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 Q'=invs']) @@ -2575,11 +2086,16 @@ lemma cancelBadgedSends_corres: apply (rule corres_guard_imp) apply (rule corres_split_nor[OF setEndpoint_corres]) apply (simp add: ep_relation_def) - apply (rule corres_split_eqr[OF _ _ _ hoare_post_add[where R="\_. valid_objs'"]]) + apply (rule corres_split_eqr[OF _ _ _ hoare_post_add + [where R="\_. 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 \ pspace_aligned s \ pspace_distinct s" - and Q'="\xs s. Invariants_H.valid_queues s \ valid_queues' s \ valid_objs' s" + 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) @@ -2590,61 +2106,56 @@ lemma cancelBadgedSends_corres: 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]) + apply (rule corres_split[OF tcbSchedEnqueue_corres], simp) apply (rule corres_trivial) apply simp apply wp+ apply simp - apply (wp sts_valid_queues gts_st_tcb_at)+ + 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: is_tcb_def) - apply simp + 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_queues + 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 (wp gts_st_tcb_at hoare_vcg_imp_lift mapM_wp' - sts_st_tcb' sts_valid_queues - set_thread_state_runnable_weak_valid_sched_action - | clarsimp simp: valid_tcb_state'_def)+ - apply (wp hoare_vcg_const_Ball_lift weak_sch_act_wf_lift_linear set_ep_valid_objs' - | simp)+ + 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 (drule ko_at_valid_objs', clarsimp) - apply simp - apply (clarsimp simp: valid_obj'_def valid_ep'_def invs_weak_sch_act_wf - invs'_def valid_state'_def) + apply (fastforce simp: valid_ep'_def) done +crunches 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 (simp add: threadGet_def| wp getObject_tcb_wp)+ - apply (rule hoare_strengthen_post, rule hoare_post_taut) - apply (fastforce simp: obj_at'_def) - apply (rule hoare_post_taut) - apply wp+ - done + unfolding suspend_def + by (wpsimp simp: comp_def wp: tcbSchedDequeue_not_tcbQueued) crunch unqueued: prepareThreadDelete "obj_at' (\a. \ tcbQueued a) t" crunch inactive: prepareThreadDelete "st_tcb_at' ((=) Inactive) t'" -crunch nonq: prepareThreadDelete " \s. \d p. t' \ set (ksReadyQueues s (d, p))" end end diff --git a/proof/refine/RISCV64/Ipc_R.thy b/proof/refine/RISCV64/Ipc_R.thy index b9aaacf25f..cc33607a7f 100644 --- a/proof/refine/RISCV64/Ipc_R.thy +++ b/proof/refine/RISCV64/Ipc_R.thy @@ -764,14 +764,6 @@ lemma tcts_sch_act[wp]: \\rv s. sch_act_wf (ksSchedulerAction s) s\" by (wp sch_act_wf_lift tcb_in_cur_domain'_lift transferCapsToSlots_pres1) -lemma tcts_vq[wp]: - "\Invariants_H.valid_queues\ transferCapsToSlots ep buffer n caps slots mi \\rv. Invariants_H.valid_queues\" - by (wp valid_queues_lift transferCapsToSlots_pres1) - -lemma tcts_vq'[wp]: - "\valid_queues'\ transferCapsToSlots ep buffer n caps slots mi \\rv. valid_queues'\" - by (wp valid_queues_lift' transferCapsToSlots_pres1) - crunch state_refs_of' [wp]: setExtraBadge "\s. P (state_refs_of' s)" lemma tcts_state_refs_of'[wp]: @@ -979,6 +971,11 @@ crunch ksDomScheduleIdx[wp]: setExtraBadge "\s. P (ksDomScheduleIdx s)" crunch ksDomSchedule[wp]: transferCapsToSlots "\s. P (ksDomSchedule s)" crunch ksDomScheduleIdx[wp]: transferCapsToSlots "\s. P (ksDomScheduleIdx s)" +crunches transferCapsToSlots + 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) lemma transferCapsToSlots_invs[wp]: "\\s. invs' s \ distinct slots @@ -1226,18 +1223,12 @@ lemma set_mrs_valid_objs' [wp]: crunch valid_objs'[wp]: copyMRs valid_objs' (wp: crunch_wps simp: crunch_simps) -crunch valid_queues'[wp]: asUser "Invariants_H.valid_queues'" - (simp: crunch_simps wp: hoare_drop_imps) - - lemma setMRs_invs_bits[wp]: "\valid_pspace'\ setMRs t buf mrs \\rv. valid_pspace'\" "\\s. sch_act_wf (ksSchedulerAction s) s\ setMRs t buf mrs \\rv s. sch_act_wf (ksSchedulerAction s) s\" "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ setMRs t buf mrs \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" - "\Invariants_H.valid_queues\ setMRs t buf mrs \\rv. Invariants_H.valid_queues\" - "\valid_queues'\ setMRs t buf mrs \\rv. valid_queues'\" "\\s. P (state_refs_of' s)\ setMRs t buf mrs \\rv s. P (state_refs_of' s)\" @@ -1254,8 +1245,6 @@ lemma copyMRs_invs_bits[wp]: "\valid_pspace'\ copyMRs s sb r rb n \\rv. valid_pspace'\" "\\s. sch_act_wf (ksSchedulerAction s) s\ copyMRs s sb r rb n \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\Invariants_H.valid_queues\ copyMRs s sb r rb n \\rv. Invariants_H.valid_queues\" - "\valid_queues'\ copyMRs s sb r rb n \\rv. valid_queues'\" "\\s. P (state_refs_of' s)\ copyMRs s sb r rb n \\rv s. P (state_refs_of' s)\" @@ -1735,10 +1724,6 @@ crunch vp[wp]: doIPCTransfer "valid_pspace'" (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' wp: transferCapsToSlots_vp simp:ball_conj_distrib ) crunch sch_act_wf[wp]: doIPCTransfer "\s. sch_act_wf (ksSchedulerAction s) s" (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch vq[wp]: doIPCTransfer "Invariants_H.valid_queues" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch vq'[wp]: doIPCTransfer "valid_queues'" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) crunch state_refs_of[wp]: doIPCTransfer "\s. P (state_refs_of' s)" (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) crunch ct[wp]: doIPCTransfer "cur_tcb'" @@ -1890,16 +1875,6 @@ lemma getThreadCallerSlot_inv: "\P\ getThreadCallerSlot t \\_. P\" by (simp add: getThreadCallerSlot_def, wp) -lemma deleteCallerCap_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - deleteCallerCap t - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - apply (simp add: deleteCallerCap_def getSlotCap_def getThreadCallerSlot_def locateSlot_conv) - apply (wp getThreadCallerSlot_inv cteDeleteOne_ct_not_ksQ getCTE_wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - done - lemma finaliseCapTrue_standin_tcb_at' [wp]: "\tcb_at' x\ finaliseCapTrue_standin cap v2 \\_. tcb_at' x\" apply (simp add: finaliseCapTrue_standin_def Let_def) @@ -2055,39 +2030,11 @@ lemma cteDeleteOne_weak_sch_act[wp]: crunch weak_sch_act_wf[wp]: emptySlot "\s. weak_sch_act_wf (ksSchedulerAction s) s" crunch pred_tcb_at'[wp]: handleFaultReply "pred_tcb_at' proj P t" -crunch valid_queues[wp]: handleFaultReply "Invariants_H.valid_queues" -crunch valid_queues'[wp]: handleFaultReply "valid_queues'" crunch tcb_in_cur_domain'[wp]: handleFaultReply "tcb_in_cur_domain' t" crunch sch_act_wf[wp]: unbindNotification "\s. sch_act_wf (ksSchedulerAction s) s" (wp: sbn_sch_act') -crunch valid_queues'[wp]: cteDeleteOne valid_queues' - (simp: crunch_simps unless_def inQ_def - wp: crunch_wps sts_st_tcb' getObject_inv loadObject_default_inv - threadSet_valid_queues' rescheduleRequired_valid_queues'_weak) - -lemma cancelSignal_valid_queues'[wp]: - "\valid_queues'\ cancelSignal t ntfn \\rv. valid_queues'\" - apply (simp add: cancelSignal_def) - apply (rule hoare_pre) - apply (wp getNotification_wp| wpc | simp)+ - done - -lemma cancelIPC_valid_queues'[wp]: - "\valid_queues' and (\s. sch_act_wf (ksSchedulerAction s) s) \ cancelIPC t \\rv. valid_queues'\" - apply (simp add: cancelIPC_def Let_def getThreadReplySlot_def locateSlot_conv liftM_def) - apply (rule hoare_seq_ext[OF _ gts_sp']) - apply (case_tac state, simp_all) defer 2 - apply (rule hoare_pre) - apply ((wp getEndpoint_wp getCTE_wp | wpc | simp)+)[8] - apply (wp cteDeleteOne_valid_queues') - apply (rule_tac Q="\_. valid_queues' and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) - apply (clarsimp simp: capHasProperty_def cte_wp_at_ctes_of) - apply (wp threadSet_valid_queues' threadSet_sch_act| simp)+ - apply (clarsimp simp: inQ_def) - done - crunch valid_objs'[wp]: handleFaultReply valid_objs' lemma cte_wp_at_is_reply_cap_toI: @@ -2099,6 +2046,13 @@ crunches handle_fault_reply for pspace_alignedp[wp]: pspace_aligned and pspace_distinct[wp]: pspace_distinct +crunches cteDeleteOne, doIPCTransfer, handleFaultReply + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + and pspace_aligned'[wp]: pspace_aligned' + and pspace_distinct'[wp]: pspace_distinct' + (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) + lemma doReplyTransfer_corres: "corres dc (einvs and tcb_at receiver and tcb_at sender @@ -2144,8 +2098,12 @@ lemma doReplyTransfer_corres: apply (rule corres_split[OF setThreadState_corres]) apply simp apply (rule possibleSwitchTo_corres) - apply (wp set_thread_state_runnable_valid_sched set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' sts_st_tcb' sts_valid_queues sts_valid_objs' delete_one_tcbDomain_obj_at' - | simp add: valid_tcb_state'_def)+ + 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]) @@ -2154,7 +2112,11 @@ lemma doReplyTransfer_corres: apply (fastforce) apply (clarsimp simp:is_cap_simps) apply (wp weak_valid_sched_action_lift)+ - apply (rule_tac Q="\_. valid_queues' and valid_objs' and cur_tcb' and tcb_at' receiver and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp, simp add: sch_act_wf_weak) + 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) @@ -2186,7 +2148,9 @@ lemma doReplyTransfer_corres: 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 Invariants_H.valid_queues and valid_queues' and valid_objs'" + 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) @@ -2195,18 +2159,16 @@ lemma doReplyTransfer_corres: 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_queues + sts_st_tcb' sts_valid_objs' | force simp: valid_sched_def valid_sched_action_def valid_tcb_state'_def)+ apply (rule corres_guard_imp) apply (rule setThreadState_corres) apply (clarsimp simp: tcb_relation_def) apply (wp threadSet_cur weak_sch_act_wf_lift_linear threadSet_pred_tcb_no_state - thread_set_not_state_valid_sched threadSet_valid_queues threadSet_valid_queues' + 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 (wp threadSet_cur weak_sch_act_wf_lift_linear threadSet_pred_tcb_no_state - thread_set_not_state_valid_sched threadSet_valid_queues threadSet_valid_queues' - | simp add: runnable_def inQ_def valid_tcb'_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) @@ -2476,10 +2438,12 @@ proof - 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 setThreadState_valid_queues' sts_valid_queues sts_weak_sch_act_wf + 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) + 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) @@ -2544,11 +2508,13 @@ proof - 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 setThreadState_valid_queues' sts_valid_queues sts_weak_sch_act_wf + 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)+)[1] + | 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) @@ -2622,14 +2588,15 @@ lemma sendSignal_corres: apply (rule possibleSwitchTo_corres) apply wp apply (wp set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' - sts_valid_queues sts_st_tcb' hoare_disjI2 + 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 (clarsimp simp: invs'_def valid_state'_def sch_act_wf_weak - valid_tcb_state'_def) + 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)+ @@ -2655,23 +2622,23 @@ lemma sendSignal_corres: apply (rule corres_split[OF asUser_setRegister_corres]) apply (rule possibleSwitchTo_corres) apply ((wp | simp)+)[1] - apply (rule_tac Q="\_. Invariants_H.valid_queues and valid_queues' and - (\s. sch_act_wf (ksSchedulerAction s) s) and + apply (rule_tac Q="\_. (\s. sch_act_wf (ksSchedulerAction s) s) and cur_tcb' and - st_tcb_at' runnable' (hd list) and valid_objs'" + 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_queues setThreadState_valid_queues' - setThreadState_st_tcb + 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 (clarsimp 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 (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) @@ -2689,16 +2656,14 @@ lemma sendSignal_corres: apply (wp cur_tcb_lift | 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_queues setThreadState_valid_queues' - setThreadState_st_tcb - | 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 (clarsimp 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 (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] @@ -2729,38 +2694,6 @@ lemma possibleSwitchTo_sch_act[wp]: apply (auto simp: obj_at'_def projectKOs tcb_in_cur_domain'_def) done -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\" - apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs) - apply (wp hoare_drop_imps | wpc | simp)+ - apply (auto simp: valid_tcb'_def weak_sch_act_wf_def - dest: pred_tcb_at' - elim!: valid_objs_valid_tcbE) - done - -lemma possibleSwitchTo_ksQ': - "\(\s. t' \ set (ksReadyQueues s p) \ sch_act_not t' s) and K(t' \ t)\ - possibleSwitchTo t - \\_ s. t' \ set (ksReadyQueues s p)\" - apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs) - apply (wp hoare_weak_lift_imp rescheduleRequired_ksQ' tcbSchedEnqueue_ksQ threadGet_wp - | wpc - | simp split del: if_split)+ - apply (auto simp: obj_at'_def) - done - -lemma possibleSwitchTo_valid_queues'[wp]: - "\valid_queues' and (\s. sch_act_wf (ksSchedulerAction s) s) - and st_tcb_at' runnable' t\ - possibleSwitchTo t - \\rv. valid_queues'\" - apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs) - apply (wp hoare_weak_lift_imp threadGet_wp | wpc | simp)+ - apply (auto simp: obj_at'_def) - done - crunch st_refs_of'[wp]: possibleSwitchTo "\s. P (state_refs_of' s)" (wp: crunch_wps) @@ -2772,15 +2705,15 @@ crunch ct[wp]: possibleSwitchTo 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'\" + "\if_live_then_nonz_cap' and ex_nonz_cap_to' t and (\s. sch_act_wf (ksSchedulerAction s) s) + and pspace_aligned' and pspace_distinct'\ + possibleSwitchTo t + \\_. if_live_then_nonz_cap'\" apply (simp add: possibleSwitchTo_def curDomain_def) apply (wp | wpc | simp)+ apply (simp only: imp_conv_disj, wp hoare_vcg_all_lift hoare_vcg_disj_lift) apply (wp threadGet_wp)+ - apply (auto simp: obj_at'_def projectKOs) + apply (auto simp: obj_at'_def) done crunch ifunsafe[wp]: possibleSwitchTo if_unsafe_then_cap' @@ -2812,10 +2745,6 @@ crunch irqs_masked'[wp]: sendSignal "irqs_masked'" simp: crunch_simps unless_def o_def rule: irqs_masked_lift) -lemma sts_running_valid_queues: - "runnable' st \ \ Invariants_H.valid_queues \ setThreadState st t \\_. Invariants_H.valid_queues \" - by (wp sts_valid_queues, clarsimp) - 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) @@ -2828,24 +2757,21 @@ lemma setThreadState_nonqueued_state_update: \ st \ {Inactive, Running, Restart, IdleThreadState} \ (st \ Inactive \ ex_nonz_cap_to' t s) \ (t = ksIdleThread s \ idle' st) - - \ (\ runnable' st \ sch_act_simple s) - \ (\ runnable' st \ (\p. t \ set (ksReadyQueues s p)))\ - setThreadState st t \\rv. invs'\" + \ (\ 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 - sts_valid_queues - setThreadState_ct_not_inQ) + 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 (drule simple_st_tcb_at_state_refs_ofD') apply (drule bound_tcb_at_state_refs_ofD') - apply (rule conjI, fastforce) - 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 (rule conjI) + apply clarsimp + apply (erule delta_sym_refs) + apply (fastforce split: if_split_asm) + apply (fastforce simp: symreftype_inverse' tcb_bound_refs'_def split: if_split_asm) + apply fastforce done lemma cteDeleteOne_reply_cap_to'[wp]: @@ -2913,16 +2839,14 @@ lemma cancelAllIPC_not_rct[wp]: \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" apply (simp add: cancelAllIPC_def) apply (wp | wpc)+ + apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) + apply simp + apply (rule mapM_x_wp_inv) + apply (wp)+ apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) apply simp apply (rule mapM_x_wp_inv) - apply (wp)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wp)+ - apply (wp hoare_vcg_all_lift hoare_drop_imp) - apply (simp_all) + apply (wpsimp wp: hoare_vcg_all_lift hoare_drop_imp)+ done lemma cancelAllSignals_not_rct[wp]: @@ -2931,12 +2855,10 @@ lemma cancelAllSignals_not_rct[wp]: \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" apply (simp add: cancelAllSignals_def) apply (wp | wpc)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wp)+ - apply (wp hoare_vcg_all_lift hoare_drop_imp) - apply (simp_all) + 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 not_rct[wp]: finaliseCapTrue_standin "\s. ksSchedulerAction s \ ResumeCurrentThread" @@ -3020,7 +2942,6 @@ lemma sai_invs'[wp]: 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 - sts_valid_queues [where st="Structures_H.thread_state.Running", simplified] set_ntfn_valid_objs' cur_tcb_lift sts_st_tcb' hoare_convert_imp [OF setNotification_nosch] | simp split del: if_split)+ @@ -3233,11 +3154,11 @@ lemma receiveIPC_corres: 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 Invariants_H.valid_queues - and valid_queues' and valid_pspace' and valid_objs' - and (\s. weak_sch_act_wf (ksSchedulerAction s) s)" + 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]) @@ -3246,17 +3167,18 @@ lemma receiveIPC_corres: apply (rule corres_split[OF setThreadState_corres]) apply simp apply (rule possibleSwitchTo_corres) - apply (wp sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action - | simp)+ - apply (wp sts_st_tcb_at'_cases sts_valid_queues setThreadState_valid_queues' - setThreadState_st_tcb + 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 (clarsimp simp: st_tcb_at_tcb_at st_tcb_def2 valid_sched_def - valid_sched_action_def) + 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" - in hoare_post_imp, erule sch_act_wf_weak) + 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 @@ -3475,30 +3397,6 @@ lemma setupCallerCap_state_refs_of[wp]: apply (simp add: fun_upd_def cong: if_cong) done -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 vq[wp]: cteInsert "Invariants_H.valid_queues" - (wp: crunch_wps) - -crunch vq[wp]: getThreadCallerSlot "Invariants_H.valid_queues" - (wp: crunch_wps) - -crunch vq[wp]: getThreadReplySlot "Invariants_H.valid_queues" - (wp: crunch_wps) - -lemma setupCallerCap_vq[wp]: - "\Invariants_H.valid_queues and (\s. \p. send \ set (ksReadyQueues s p))\ - setupCallerCap send recv grant \\_. Invariants_H.valid_queues\" - apply (simp add: setupCallerCap_def) - apply (wp crunch_wps sts_valid_queues) - apply (fastforce simp: valid_queues_def obj_at'_def inQ_def) - done - -crunch vq'[wp]: setupCallerCap "valid_queues'" - (wp: crunch_wps) - 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)" @@ -3540,7 +3438,7 @@ lemma setupCallerCap_vp[wp]: done lemma setupCallerCap_iflive[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' sender\ + "\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 @@ -3552,7 +3450,7 @@ lemma setupCallerCap_iflive[wp]: lemma setupCallerCap_ifunsafe[wp]: "\if_unsafe_then_cap' and valid_objs' and - ex_nonz_cap_to' rcvr and tcb_at' rcvr\ + 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 @@ -3574,13 +3472,11 @@ lemma setupCallerCap_global_refs'[wp]: \\rv. valid_global_refs'\" unfolding setupCallerCap_def getThreadCallerSlot_def getThreadReplySlot_def locateSlot_conv - apply (wp getSlotCap_cte_wp_at - | simp add: o_def unique_master_reply_cap' - | strengthen eq_imp_strg - | wp (once) getCTE_wp | clarsimp simp: cte_wp_at_ctes_of)+ - (* at setThreadState *) - apply (rule_tac Q="\_. valid_global_refs'" in hoare_post_imp, wpsimp+) - done + 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 valid_arch'[wp]: setupCallerCap "valid_arch_state'" (wp: hoare_drop_imps) @@ -3756,12 +3652,21 @@ crunches possibleSwitchTo for ksArch[wp]: "\s. P (ksArchState s)" (wp: possibleSwitchTo_ctes_of crunch_wps ignore: constOnFailure) +crunches asUser + for valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift wp: crunch_wps) + +crunches setupCallerCap, possibleSwitchTo, doIPCTransfer + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + and valid_bitmaps[wp]: valid_bitmaps + (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) + (* t = ksCurThread s *) lemma ri_invs' [wp]: "\invs' and sch_act_not t and ct_in_state' simple' and st_tcb_at' simple' t - and (\s. \p. t \ set (ksReadyQueues s p)) and ex_nonz_cap_to' t and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s)\ receiveIPC t cap isBlocking @@ -3779,7 +3684,7 @@ lemma ri_invs' [wp]: 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 - sts_valid_queues setThreadState_ct_not_inQ + 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) @@ -3806,7 +3711,7 @@ lemma ri_invs' [wp]: 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 - sts_valid_queues setThreadState_ct_not_inQ + 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) @@ -3830,9 +3735,8 @@ lemma ri_invs' [wp]: 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' sts_valid_queues - setThreadState_ct_not_inQ possibleSwitchTo_valid_queues - possibleSwitchTo_valid_queues' + 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 @@ -3850,8 +3754,6 @@ lemma ri_invs' [wp]: st_tcb_at_refs_of_rev' conj_ac split del: if_split cong: if_cong) - apply (frule_tac t=sender in valid_queues_not_runnable'_not_ksQ) - apply (erule pred_tcb'_weakenE, clarsimp) apply (subgoal_tac "sch_act_not sender s") prefer 2 apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) @@ -3885,7 +3787,6 @@ lemma ri_invs' [wp]: lemma rai_invs'[wp]: "\invs' and sch_act_not t and st_tcb_at' simple' t - and (\s. \p. t \ set (ksReadyQueues s p)) and ex_nonz_cap_to' t and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s) and (\s. \ntfnptr. isNotificationCap cap @@ -3902,7 +3803,7 @@ lemma rai_invs'[wp]: apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) apply (wp valid_irq_node_lift sts_sch_act' typ_at_lifts - sts_valid_queues setThreadState_ct_not_inQ + setThreadState_ct_not_inQ asUser_urz | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def | wpc)+ apply (clarsimp simp: pred_tcb_at' valid_tcb_state'_def) @@ -3920,7 +3821,7 @@ lemma rai_invs'[wp]: apply (clarsimp split: if_split_asm) apply (fastforce simp: tcb_bound_refs'_def symreftype_inverse' split: if_split_asm) - apply (clarsimp dest!: global'_no_ex_cap) + 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) @@ -3940,7 +3841,7 @@ lemma rai_invs'[wp]: apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) apply (wp hoare_vcg_const_Ball_lift valid_irq_node_lift sts_sch_act' - sts_valid_queues setThreadState_ct_not_inQ typ_at_lifts + setThreadState_ct_not_inQ typ_at_lifts asUser_urz | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def | wpc)+ apply (clarsimp simp: valid_tcb_state'_def) @@ -3968,7 +3869,7 @@ lemma rai_invs'[wp]: 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 (clarsimp dest!: global'_no_ex_cap) + apply (fastforce dest!: global'_no_ex_cap) done lemma getCTE_cap_to_refs[wp]: @@ -4000,7 +3901,6 @@ lemma cteInsert_invs_bits[wp]: "\\s. sch_act_wf (ksSchedulerAction s) s\ cteInsert a b c \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\Invariants_H.valid_queues\ cteInsert a b c \\rv. Invariants_H.valid_queues\" "\cur_tcb'\ cteInsert a b c \\rv. cur_tcb'\" "\\s. P (state_refs_of' s)\ cteInsert a b c @@ -4018,9 +3918,12 @@ lemma possibleSwitchTo_sch_act_not: crunch urz[wp]: possibleSwitchTo "untyped_ranges_zero'" (simp: crunch_simps unless_def wp: crunch_wps) +crunches possibleSwitchTo + for pspace_aligned'[wp]: pspace_aligned' + and pspace_distinct'[wp]: pspace_distinct' + lemma si_invs'[wp]: "\invs' and st_tcb_at' simple' t - and (\s. \p. t \ set (ksReadyQueues s p)) and sch_act_not t and ex_nonz_cap_to' ep and ex_nonz_cap_to' t\ sendIPC bl call ba cg cgr t ep @@ -4039,8 +3942,8 @@ lemma si_invs'[wp]: 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 sts_valid_queues setThreadState_ct_not_inQ - possibleSwitchTo_ksQ' possibleSwitchTo_ct_not_inQ hoare_vcg_all_lift sts_ksQ' + 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"] @@ -4092,8 +3995,7 @@ lemma si_invs'[wp]: 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' sts_valid_queues - setThreadState_ct_not_inQ) + 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") @@ -4112,8 +4014,7 @@ lemma si_invs'[wp]: 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' - sts_valid_queues setThreadState_ct_not_inQ) + 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) @@ -4139,19 +4040,15 @@ lemma si_invs'[wp]: lemma sfi_invs_plus': "\invs' and st_tcb_at' simple' t and sch_act_not t - and (\s. \p. t \ set (ksReadyQueues s p)) and ex_nonz_cap_to' t\ - sendFaultIPC t f - \\rv. invs'\, \\rv. invs' and st_tcb_at' simple' t - and (\s. \p. t \ set (ksReadyQueues s p)) - and sch_act_not t and (\s. ksIdleThread s \ t)\" + sendFaultIPC t f + \\_. invs'\, \\_. invs' and st_tcb_at' simple' t and sch_act_not t and (\s. ksIdleThread s \ t)\" apply (simp add: sendFaultIPC_def) apply (wp threadSet_invs_trivial threadSet_pred_tcb_no_state threadSet_cap_to' | wpc | simp)+ apply (rule_tac Q'="\rv s. invs' s \ sch_act_not t s \ st_tcb_at' simple' t s - \ (\p. t \ set (ksReadyQueues s p)) \ ex_nonz_cap_to' t s \ t \ ksIdleThread s \ (\r\zobj_refs' rv. ex_nonz_cap_to' r s)" @@ -4173,7 +4070,6 @@ lemma handleFault_corres: corres dc (einvs and st_tcb_at active thread and ex_nonz_cap_to thread and (\_. valid_fault f)) (invs' and sch_act_not thread - and (\s. \p. thread \ set(ksReadyQueues s p)) 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) @@ -4197,17 +4093,13 @@ lemma sts_invs_minor'': \ (st \ Inactive \ \ idle' st \ st' \ Inactive \ \ idle' st')) t and (\s. t = ksIdleThread s \ idle' st) - and (\s. (\p. t \ set (ksReadyQueues s p)) \ runnable' st) - and (\s. runnable' st \ obj_at' tcbQueued t s - \ st_tcb_at' runnable' t s) 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' sts_valid_queues - setThreadState_ct_not_inQ) + apply (wp valid_irq_node_lift sts_sch_act' setThreadState_ct_not_inQ) apply clarsimp apply (rule conjI) apply fastforce @@ -4222,12 +4114,11 @@ lemma sts_invs_minor'': apply (clarsimp dest!: st_tcb_at_state_refs_ofD' elim!: rsubst[where P=sym_refs] intro!: ext) - apply (clarsimp elim!: st_tcb_ex_cap'') + apply (fastforce elim!: st_tcb_ex_cap'') done lemma hf_invs' [wp]: "\invs' and sch_act_not t - and (\s. \p. t \ set(ksReadyQueues s p)) and st_tcb_at' simple' t and ex_nonz_cap_to' t and (\s. t \ ksIdleThread s)\ handleFault t f \\r. invs'\" diff --git a/proof/refine/RISCV64/KHeap_R.thy b/proof/refine/RISCV64/KHeap_R.thy index 194f9a1b90..9073187811 100644 --- a/proof/refine/RISCV64/KHeap_R.thy +++ b/proof/refine/RISCV64/KHeap_R.thy @@ -13,8 +13,45 @@ lemma lookupAround2_known1: "m x = Some y \ fst (lookupAround2 x m) = Some (x, y)" by (fastforce simp: lookupAround2_char1) +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 + context begin interpretation Arch . (*FIXME: arch_split*) +lemma setObject_modify_variable_size: + fixes v :: "'a :: pspace_storable" shows + "\obj_at' (P :: 'a \ bool) p s; updateObject v = updateObject_default v; + (1 :: machine_word) < 2 ^ objBits v; obj_at' (\obj. objBits v = objBits obj) p s\ + \ setObject p v s = modify (ksPSpace_update (\ps. ps (p \ injectKO v))) s" + apply (clarsimp simp: setObject_def split_def exec_gets obj_at'_def lookupAround2_known1 + assert_opt_def updateObject_default_def bind_assoc) + apply (simp add: projectKO_def alignCheck_assert) + apply (simp add: project_inject objBits_def) + apply (clarsimp simp only: koTypeOf_injectKO) + apply (frule in_magnitude_check[where s'=s]) + apply blast + apply fastforce + apply (simp add: magnitudeCheck_assert in_monad bind_def gets_def oassert_opt_def + get_def return_def) + apply (simp add: simpler_modify_def) + done + +lemma setObject_modify: + fixes v :: "'a :: pspace_storable" shows + "\obj_at' (P :: 'a \ bool) p s; updateObject v = updateObject_default v; + (1 :: machine_word) < 2 ^ objBits v; \ko. P ko \ objBits ko = objBits v \ + \ setObject p v s = modify (ksPSpace_update (\ps. ps (p \ injectKO v))) s" + apply (rule setObject_modify_variable_size) + apply fastforce + apply fastforce + apply fastforce + unfolding obj_at'_def + by fastforce + lemma obj_at_getObject: assumes R: "\a b n ko s obj::'a::pspace_storable. @@ -114,8 +151,7 @@ lemma corres_get_tcb: apply (drule bspec) apply clarsimp apply blast - apply (clarsimp simp add: other_obj_relation_def - lookupAround2_known1) + apply (clarsimp simp: tcb_relation_cut_def lookupAround2_known1) done lemma lookupAround2_same1[simp]: @@ -381,6 +417,40 @@ lemma setObject_tcb_strongest: updateObject_default_def ps_clear_upd) done +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 opt_pred_def projectKO_opts_defs projectKO_eq + split: if_split_asm + Structures_H.kernel_object.split_asm + +lemma setObject_endpoint_tcbs_of'[wp]: + "setObject c (endpoint :: endpoint) \\s. P' (tcbs_of' s)\" + by setObject_easy_cases + +lemma setObject_notification_tcbs_of'[wp]: + "setObject c (notification :: notification) \\s. P' (tcbs_of' s)\" + by setObject_easy_cases + +lemma setObject_cte_tcbSchedNexts_of[wp]: + "setObject c (cte :: cte) \\s. P' (tcbSchedNexts_of s)\" + by setObject_easy_cases + +lemma setObject_cte_tcbSchedPrevs_of[wp]: + "setObject c (cte :: cte) \\s. P' (tcbSchedPrevs_of s)\" + by setObject_easy_cases + +lemma setObject_cte_tcbQueued[wp]: + "setObject c (cte :: cte) \\s. P' (tcbQueued |< tcbs_of' s)\" + supply inQ_def[simp] + by setObject_easy_cases + +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 getObject_obj_at': assumes x: "\q n ko. loadObject p q n ko = (loadObject_default p q n ko :: ('a :: pspace_storable) kernel)" @@ -896,7 +966,7 @@ lemma obj_relation_cut_same_type: \ (\sz sz'. a_type ko = AArch (ADeviceData sz) \ a_type ko' = AArch (ADeviceData sz'))" apply (rule ccontr) apply (simp add: obj_relation_cuts_def2 a_type_def) - apply (auto simp: other_obj_relation_def cte_relation_def pte_relation_def + apply (auto simp: other_obj_relation_def tcb_relation_cut_def cte_relation_def pte_relation_def split: Structures_A.kernel_object.split_asm if_split_asm Structures_H.kernel_object.split_asm arch_kernel_obj.split_asm) @@ -913,6 +983,16 @@ 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\ + \ tcbs_of' (s'\ksPSpace := (ksPSpace s')(ptr \ ko)\) = tcbs_of' s'" + by (fastforce simp: typ_at'_def ko_wp_at'_def opt_map_def projectKO_opts_defs + split: kernel_object.splits) + +lemma typ_at'_koTypeOf: + "ko_at' ob' ptr b \ typ_at' (koTypeOf (injectKO ob')) ptr b" + by (auto simp: typ_at'_def ko_wp_at'_def obj_at'_def project_inject) + lemma setObject_other_corres: fixes ob' :: "'a :: pspace_storable" assumes x: "updateObject ob' = updateObject_default ob'" @@ -942,7 +1022,7 @@ lemma setObject_other_corres: 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 (extract_conjunct \match conclusion in "ghost_relation _ _ _" \ -\) apply (clarsimp simp add: ghost_relation_def) apply (erule_tac x=ptr in allE)+ apply (clarsimp simp: obj_at_def a_type_def @@ -952,6 +1032,14 @@ lemma setObject_other_corres: apply (simp only: pspace_relation_def pspace_dom_update dom_fun_upd2 simp_thms) apply (elim conjE) apply (frule bspec, erule domI) + apply (prop_tac "typ_at' (koTypeOf (injectKO ob')) ptr b") + subgoal + by (clarsimp simp: typ_at'_def ko_wp_at'_def obj_at'_def projectKO_opts_defs + 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 clarsimp apply (rule conjI) apply (rule ballI, drule(1) bspec) apply (drule domD) @@ -960,31 +1048,30 @@ lemma setObject_other_corres: apply clarsimp apply (frule_tac ko'=ko and x'=ptr in obj_relation_cut_same_type, (fastforce simp add: is_other_obj_relation_type t)+) - apply (erule disjE) - apply (simp add: is_other_obj_relation_type t) - apply (erule disjE) - apply (insert t, - clarsimp simp: is_other_obj_relation_type_CapTable a_type_def) - apply (erule disjE) - apply (insert t, - clarsimp simp: is_other_obj_relation_type_UserData a_type_def) - apply (insert t, - clarsimp simp: is_other_obj_relation_type_DeviceData a_type_def) - 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)+ - done + apply (insert t) + apply ((erule disjE + | 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 map_to_ctes_upd_other is_other_obj_relation_type_def @@ -1074,13 +1161,14 @@ lemma typ_at'_valid_obj'_lift: 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, + 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 valid_bound_ntfn'_def - split: option.splits, - wpsimp) + 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) done @@ -1357,32 +1445,6 @@ lemma set_ep_bitmapQ_no_L2_orphans[wp]: apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp add: bitmapQ_def)+ done -lemma set_ep_valid_queues[wp]: - "\Invariants_H.valid_queues\ setEndpoint epptr ep \\rv. Invariants_H.valid_queues\" - apply (simp add: Invariants_H.valid_queues_def) - apply (wp hoare_vcg_conj_lift) - apply (simp add: setEndpoint_def valid_queues_no_bitmap_def) - apply (wp hoare_Ball_helper hoare_vcg_all_lift) - apply (rule obj_at_setObject2) - apply (clarsimp simp: updateObject_default_def in_monad) - apply (wp updateObject_default_inv set_ep_valid_bitmapQ[unfolded setEndpoint_def] - | simp add: valid_queues_no_bitmap_def)+ - done - -lemma set_ep_valid_queues'[wp]: - "\valid_queues'\ setEndpoint epptr ep \\rv. valid_queues'\" - apply (unfold setEndpoint_def) - apply (simp only: valid_queues'_def imp_conv_disj - obj_at'_real_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - apply (rule setObject_ko_wp_at) - apply simp - apply (simp add: objBits_simps') - apply simp - apply (wp updateObject_default_inv | simp)+ - apply (clarsimp simp: ko_wp_at'_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\" @@ -1579,34 +1641,6 @@ lemma set_ntfn_bitmapQ_no_L2_orphans[wp]: apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp)+ done -lemma set_ntfn_valid_queues[wp]: - "\Invariants_H.valid_queues\ setNotification p ntfn \\rv. Invariants_H.valid_queues\" - apply (simp add: Invariants_H.valid_queues_def) - apply (rule hoare_pre) - apply (wp hoare_vcg_conj_lift) - apply (simp add: setNotification_def valid_queues_no_bitmap_def) - apply (wp hoare_Ball_helper hoare_vcg_all_lift) - apply (rule obj_at_setObject2) - apply (clarsimp simp: updateObject_default_def in_monad) - apply (wp updateObject_default_inv set_ep_valid_bitmapQ[unfolded setEndpoint_def] - | simp add: valid_queues_no_bitmap_def)+ - done - -lemma set_ntfn_valid_queues'[wp]: - "\valid_queues'\ setNotification p ntfn \\rv. valid_queues'\" - apply (unfold setNotification_def) - apply (rule setObject_ntfn_pre) - apply (simp only: valid_queues'_def imp_conv_disj - obj_at'_real_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - apply (rule setObject_ko_wp_at) - apply simp - apply (simp add: objBits_simps') - apply simp - apply (wp updateObject_default_inv | simp)+ - apply (clarsimp simp: ko_wp_at'_def) - 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)))\ @@ -1993,6 +2027,21 @@ lemma setNotification_ct_idle_or_in_cur_domain'[wp]: crunch gsUntypedZeroRanges[wp]: setNotification "\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)\" + assumes nexts: "\P. f \\s. P (tcbSchedNexts_of s)\" + shows "f \sym_heap_sched_pointers\" + by (rule_tac f=tcbSchedPrevs_of in hoare_lift_Pf2; wpsimp wp: assms) + +crunches setNotification + for tcbSchedNexts_of[wp]: "\s. P (tcbSchedNexts_of s)" + and tcbSchedPrevs_of[wp]: "\s. P (tcbSchedPrevs_of s)" + and valid_sched_pointers[wp]: valid_sched_pointers + and ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" + and ksReadyQueuesL1Bitmap[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" + and ksReadyQueuesL2Bitmap[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" + (simp: updateObject_default_def) + lemma set_ntfn_minor_invs': "\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)) @@ -2002,9 +2051,10 @@ lemma set_ntfn_minor_invs': and (\s. ptr \ ksIdleThread s) \ setNotification ptr val \\rv. invs'\" - apply (clarsimp simp add: invs'_def valid_state'_def cteCaps_of_def) - apply (wp irqs_masked_lift valid_irq_node_lift untyped_ranges_zero_lift, - simp_all add: o_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')+ @@ -2089,21 +2139,17 @@ crunch typ_at'[wp]: doMachineOp "\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'\" + "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 - valid_pspace'_def valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs - | wp cur_tcb_lift sch_act_wf_lift tcb_in_cur_domain'_lift - | fastforce elim: state_refs_of'_pspaceI)+ + | wp + | fastforce elim: state_refs_of'_pspaceI)+ crunch obj_at'[wp]: doMachineOp "\s. P (obj_at' P' p s)" @@ -2132,5 +2178,28 @@ lemma obj_at'_is_canonical: apply (clarsimp simp: obj_at'_def pspace_canonical'_def) by (drule_tac x=t in bspec) clarsimp+ +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 project_inject pspace_distinct'_def pspace_aligned'_def) + apply (drule bspec, erule domI)+ + apply (clarsimp simp: bit_simps objBits_simps' word_bits_def + split: kernel_object.splits arch_kernel_object.splits) + done + +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 + +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) + end end diff --git a/proof/refine/RISCV64/Refine.thy b/proof/refine/RISCV64/Refine.thy index 55317f076d..b1411c393d 100644 --- a/proof/refine/RISCV64/Refine.thy +++ b/proof/refine/RISCV64/Refine.thy @@ -77,7 +77,7 @@ lemma typ_at_UserDataI: apply clarsimp apply (subst mask_lower_twice [where n = pageBits, OF pbfs_atleast_pageBits, symmetric]) apply (clarsimp simp: obj_relation_cuts_def2 pte_relation_def - cte_relation_def other_obj_relation_def + cte_relation_def other_obj_relation_def tcb_relation_cut_def split: Structures_A.kernel_object.split_asm Structures_H.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) @@ -106,7 +106,7 @@ lemma typ_at_DeviceDataI: apply clarsimp apply (subst mask_lower_twice [where n = pageBits, OF pbfs_atleast_pageBits, symmetric]) apply (clarsimp simp: obj_relation_cuts_def2 pte_relation_def - cte_relation_def other_obj_relation_def + cte_relation_def other_obj_relation_def tcb_relation_cut_def split: Structures_A.kernel_object.split_asm Structures_H.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) @@ -496,6 +496,10 @@ qed definition "ex_abs G \ \s'. \s. ((s :: (det_ext) state),s') \ state_relation \ G s" +lemma ex_abs_ksReadyQueues_asrt: + "ex_abs P s \ ksReadyQueues_asrt s" + by (fastforce simp: ex_abs_def intro: ksReadyQueues_asrt_cross) + lemma device_update_invs': "\invs'\doMachineOp (device_memory_update ds) \\_. invs'\" @@ -559,7 +563,7 @@ lemma kernel_corres': apply simp apply (rule handleInterrupt_corres[simplified dc_def]) apply simp - apply (wp hoare_drop_imps hoare_vcg_all_lift)[1] + 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' \ @@ -635,7 +639,7 @@ lemma entry_corres: apply (rule corres_split[OF getCurThread_corres]) apply (rule corres_split) apply simp - apply (rule threadset_corresT) + 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 cteSizeBits_def) diff --git a/proof/refine/RISCV64/Retype_R.thy b/proof/refine/RISCV64/Retype_R.thy index 8ac1ba2fc3..f6006974a5 100644 --- a/proof/refine/RISCV64/Retype_R.thy +++ b/proof/refine/RISCV64/Retype_R.thy @@ -293,7 +293,7 @@ lemma state_relation_null_filterE: null_filter (caps_of_state t) = null_filter (caps_of_state s); null_filter' (ctes_of t') = null_filter' (ctes_of s'); pspace_relation (kheap t) (ksPSpace t'); - ekheap_relation (ekheap t) (ksPSpace 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'; @@ -979,7 +979,7 @@ lemma retype_ekheap_relation: apply (intro impI conjI) apply clarsimp apply (drule_tac x=a in bspec,force) - apply (clarsimp simp add: other_obj_relation_def split: if_split_asm) + 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 RISCV64_H.object_type.splits @@ -1157,6 +1157,11 @@ lemma ksMachineState_update_gs[simp]: by (simp add: update_gs_def split: aobject_type.splits Structures_A.apiobject_type.splits) +lemma ksReadyQueues_update_gs[simp]: + "ksReadyQueues (update_gs tp us addrs s) = ksReadyQueues s" + by (simp add: update_gs_def + split: aobject_type.splits Structures_A.apiobject_type.splits) + lemma update_gs_ksMachineState_update_swap: "update_gs tp us addrs (ksMachineState_update f s) = ksMachineState_update f (update_gs tp us addrs s)" @@ -1179,6 +1184,144 @@ lemma update_gs_simps[simp]: gsUserPages_update (\ups x. if x \ ptrs then Some RISCVHugePage else ups x)" by (simp_all add: update_gs_def) +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 - + 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_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 "\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 (fastforce simp: ptr_add_def p_assoc_help) + done +qed + +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 + "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 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 + 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_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 + "tcbSchedNexts_of + (s'\ksPSpace := foldr (\addr. data_map_insert addr ko) (new_cap_addrs m ptr ko) (ksPSpace s')\) + = tcbSchedNexts_of s'" +proof - + 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 + 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 + 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 + by (cases ty; + fastforce simp add: makeObjectKO_def makeObject_tcb + 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" @@ -1207,7 +1350,7 @@ lemma retype_state_relation: \ state_relation" (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) + 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 ko] num_r]) @@ -1396,6 +1539,16 @@ lemma retype_state_relation: else cns x" in exI, simp) apply (rule_tac x=id in exI, simp)+ done + + have rdyqrel: "ready_queues_relation s s'" + using sr by (simp add: state_relation_def) + + thus "ready_queues_relation_2 (ready_queues s) (ksReadyQueues s') + (?ps' |> tcb_of' |> tcbSchedNext) (?ps' |> tcb_of' |> tcbSchedPrev) + (\d p. inQ d p |< (?ps' |> tcb_of'))" + using retype_ready_queues_relation[OF _ vs' pn' ko cover num_r] + by (clarsimp simp: ready_queues_relation_def Let_def) + qed lemma new_cap_addrs_fold': @@ -2369,7 +2522,6 @@ qed lemma other_objs_default_relation: "\ case ty of Structures_A.EndpointObject \ ko = injectKO (makeObject :: endpoint) | Structures_A.NotificationObject \ ko = injectKO (makeObject :: Structures_H.notification) - | Structures_A.TCBObject \ ko = injectKO (makeObject :: tcb) | _ \ False \ \ obj_relation_retype (default_object ty dev n) ko" apply (rule obj_relation_retype_other_obj) @@ -2390,6 +2542,13 @@ lemma other_objs_default_relation: split: Structures_A.apiobject_type.split_asm) done +lemma tcb_relation_retype: + "obj_relation_retype (default_object Structures_A.TCBObject dev n) (KOTCB makeObject)" + by (clarsimp simp: default_object_def obj_relation_retype_def tcb_relation_def default_tcb_def + makeObject_tcb makeObject_cte new_context_def newContext_def + fault_rel_optionation_def initContext_def default_arch_tcb_def newArchTCB_def + arch_tcb_relation_def objBits_simps' tcb_relation_cut_def) + lemma captable_relation_retype: "n < word_bits \ obj_relation_retype (default_object Structures_A.CapTableObject dev n) (KOCTE makeObject)" @@ -3106,10 +3265,10 @@ proof (intro conjI impI) apply (rule_tac ptr="x + xa" in cte_wp_at_tcbI', assumption+) apply fastforce apply simp - apply (rename_tac thread_state mcp priority bool option nat cptr vptr bound user_context) - apply (case_tac thread_state, simp_all add: valid_tcb_state'_def - valid_bound_ntfn'_def obj_at_disj' - split: option.splits)[2] + 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)]) @@ -3817,16 +3976,6 @@ lemma sch_act_wf_lift_asm: apply auto done -lemma valid_queues_lift_asm': - assumes tat: "\d p t. \\s. \ obj_at' (inQ d p) t s \ Q d p s\ f \\_ s. \ obj_at' (inQ d p) t s\" - and prq: "\P. \\s. P (ksReadyQueues s)\ f \\_ s. P (ksReadyQueues s)\" - shows "\\s. valid_queues' s \ (\d p. Q d p s)\ f \\_. valid_queues'\" - apply (simp only: valid_queues'_def imp_conv_disj) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift - tat prq) - apply simp - done - lemma createObjects'_ct[wp]: "\\s. P (ksCurThread s)\ createObjects' p n v us \\rv s. P (ksCurThread s)\" by (rule createObjects_pspace_only, simp) @@ -4168,34 +4317,150 @@ crunch irq_states' [wp]: createNewCaps valid_irq_states' crunch ksMachine[wp]: createObjects "\s. P (ksMachineState s)" (simp: crunch_simps unless_def) -lemma createNewCaps_valid_queues': - "\valid_queues' and pspace_no_overlap' ptr sz - 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_queues'\" - apply (wp valid_queues_lift_asm' [OF createNewCaps_obj_at2]) - apply (clarsimp) - apply (simp add: makeObjectKO_def - split: object_type.split_asm - apiobject_type.split_asm) - apply (clarsimp simp: inQ_def) - apply (auto simp: makeObject_tcb - split: object_type.splits apiobject_type.splits) - done - -lemma createNewCaps_valid_queues: - "\valid_queues and pspace_no_overlap' ptr sz - 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_queues\" - apply (rule hoare_gen_asm) - apply (wpsimp wp: valid_queues_lift_asm createNewCaps_obj_at2[where sz=sz]) - apply (simp add: inQ_def) - apply (wp createNewCaps_pred_tcb_at'[where sz=sz] | simp)+ +lemma createObjects_valid_bitmaps: + "createObjects' ptr n val gbits \valid_bitmaps\" + apply (clarsimp simp: createObjects'_def alignError_def split_def) + apply (wp case_option_wp[where P="\_. P" and P'=P for P, simplified] assert_inv + | clarsimp simp del: fun_upd_apply)+ + apply (clarsimp simp: valid_bitmaps_def valid_bitmapQ_def bitmapQ_def bitmapQ_no_L2_orphans_def + bitmapQ_no_L1_orphans_def) + done + +lemma valid_bitmaps_gsCNodes_update[simp]: + "valid_bitmaps (gsCNodes_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) + +lemma valid_bitmaps_gsUserPages_update[simp]: + "valid_bitmaps (gsUserPages_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) + +crunches curDomain + for valid_bitmaps[wp]: valid_bitmaps + and sched_pointers[wp]: "\s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)" + and valid_sched_pointers[wp]: valid_sched_pointers + +lemma createNewCaps_valid_bitmaps: + "\\s. valid_pspace' s \ pspace_no_overlap' ptr sz s \ valid_bitmaps s\ + createNewCaps ty ptr n us dev + \\_. valid_bitmaps\" + unfolding createNewCaps_def + apply (clarsimp simp: RISCV64_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 (wpsimp wp: createObjects_valid_bitmaps) + by (wpsimp wp: createObjects_valid_bitmaps[simplified o_def] mapM_x_wp + | simp add: makeObject_tcb objBits_def createObjects_def + | intro conjI impI)+ + +lemma createObjects_sched_queues: + "\\s. n \ 0 + \ range_cover ptr sz (objBitsKO val + gbits) n + \ P (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ (case val of KOTCB tcb \ tcbSchedNext tcb = None \ tcbSchedPrev tcb = None + | _ \ True) + \ pspace_aligned' s \ pspace_distinct' s + \ pspace_no_overlap' ptr sz s\ + createObjects' ptr n val gbits + \\_ s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" + (is "\ \s. _ \ _ \ ?Pre s \ _ \\_. _\") +proof (rule hoare_grab_asm)+ + 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 \\_ s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" + proof - + have shiftr_not_zero:" 1 \ ((of_nat n)::machine_word) << gbits" + using range_cover_not_zero_shift[OF not_0 cover,where gbits = gbits] + by (simp add:word_le_sub1) + show ?thesis + apply (clarsimp simp: createObjects'_def unless_def alignError_def split_def) + apply (wp | clarsimp simp del: fun_upd_apply)+ + 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 (clarsimp simp: foldr_upd_app_if) + apply (rule_tac a="tcbSchedNexts_of s" and b="tcbSchedPrevs_of s" + in rsubst2[rotated, OF sym sym, where P=P]) + apply (rule ext) + apply (clarsimp simp: opt_map_def) + apply (frule (3) retype_ksPSpace_None[simplified mult.commute]) + apply (fastforce intro: cover) + apply fastforce + apply (clarsimp split: kernel_object.splits option.splits) + apply (rule ext) + apply (clarsimp simp: opt_map_def) + apply (frule (3) retype_ksPSpace_None[simplified mult.commute]) + apply (fastforce intro: cover) + apply fastforce + apply (clarsimp split: kernel_object.splits option.splits) + apply simp + done + qed +qed + +lemma createNewCaps_sched_queues: + assumes cover: "range_cover ptr sz (APIType_capBits ty us) n" + assumes not_0: "n \ 0" + shows + "\\s. valid_pspace' s \ pspace_no_overlap' ptr sz s + \ P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\ + createNewCaps ty ptr n us dev + \\_ s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" + unfolding createNewCaps_def + apply (clarsimp simp: RISCV64_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) + apply (wpsimp wp: mapM_x_wp' createObjects_sched_queues + simp: curDomain_def) + by (wpsimp wp: mapM_x_wp' createObjects_sched_queues[simplified o_def] + threadSet_sched_pointers + | simp add: objBitsKO_def APIType_capBits_def valid_pspace'_def makeObject_tcb + objBits_def pageBits_def archObjSize_def createObjects_def + pt_bits_def pte_bits_def word_size_bits_def table_size_def + ptTranslationBits_def + | intro conjI impI)+ + +lemma createObjects_valid_sched_pointers: + "\\s. valid_sched_pointers s + \ (case val of KOTCB tcb \ tcbSchedNext tcb = None \ tcbSchedPrev tcb = None + | _ \ True)\ + createObjects' ptr n val gbits + \\_. valid_sched_pointers\" + apply (clarsimp simp: createObjects'_def unless_def alignError_def split_def) + apply (wp case_option_wp[where P="\_. P" and P'=P for P, simplified] assert_inv + | clarsimp simp del: fun_upd_apply)+ + apply (clarsimp simp: valid_sched_pointers_def foldr_upd_app_if opt_pred_def opt_map_def comp_def) + apply (cases "tcb_of' val"; clarsimp) done +lemma createNewCaps_valid_sched_pointers: + "\\s. valid_pspace' s \ pspace_no_overlap' ptr sz s \ valid_sched_pointers s\ + createNewCaps ty ptr n us dev + \\_. valid_sched_pointers\" + unfolding createNewCaps_def + apply (clarsimp simp: RISCV64_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 (wpsimp wp: createObjects_valid_sched_pointers) + by (wpsimp wp: createObjects_valid_sched_pointers[simplified o_def] mapM_x_wp + threadSet_valid_sched_pointers + | simp add: makeObject_tcb objBits_def createObjects_def + | intro conjI impI)+ + lemma mapM_x_threadSet_valid_pspace: "\valid_pspace' and K (curdom \ maxDomain)\ mapM_x (threadSet (tcbDomain_update (\_. curdom))) addrs \\y. valid_pspace'\" @@ -4577,12 +4842,13 @@ proof (rule hoare_gen_asm, elim conjE) createNewCaps_valid_arch_state valid_irq_node_lift_asm [unfolded pred_conj_def, OF _ createNewCaps_obj_at'] createNewCaps_irq_handlers' createNewCaps_vms - createNewCaps_valid_queues - createNewCaps_valid_queues' createNewCaps_pred_tcb_at' cnc_ct_not_inQ createNewCaps_ct_idle_or_in_cur_domain' createNewCaps_sch_act_wf createNewCaps_urz[where sz=sz] + createNewCaps_sched_queues[OF cover not_0] + createNewCaps_valid_sched_pointers + createNewCaps_valid_bitmaps | simp)+ using not_0 apply (clarsimp simp: valid_pspace'_def) @@ -4655,35 +4921,6 @@ lemma createObjects_sch: apply (wp sch_act_wf_lift_asm createObjects_pred_tcb_at' createObjects_orig_obj_at3 | force)+ done -lemma createObjects_queues: - "\\s. valid_queues 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. valid_queues\" - apply (wpsimp wp: valid_queues_lift_asm [unfolded pred_conj_def, OF createObjects_orig_obj_at3] - createObjects_pred_tcb_at' [unfolded pred_conj_def]) - apply fastforce - apply wp+ - apply fastforce - done - -lemma createObjects_queues': - assumes no_tcb: "\t. projectKO_opt val \ Some (t::tcb)" - shows - "\\s. valid_queues' 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. valid_queues'\" - apply (simp add: createObjects_def) - apply (wp valid_queues_lift_asm') - apply (wp createObjects_orig_obj_at2') - apply clarsimp - apply assumption - apply wp - using no_tcb - apply fastforce - done - lemma createObjects_no_cte_ifunsafe': assumes no_cte: "\c. projectKO_opt val \ Some (c::cte)" assumes no_tcb: "\t. projectKO_opt val \ Some (t::tcb)" @@ -4929,36 +5166,46 @@ proof - 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 (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' - createObjects_queues' [OF no_tcb] - assms | simp add: objBits_def )+ + apply (wp createObjects_no_cte_ifunsafe' assms) apply (rule hoare_vcg_conj_lift) apply (simp add: createObjects_def) apply (wp createObjects_idle') + apply (wp irqs_masked_lift createObjects_no_cte_valid_global + createObjects_valid_arch createObjects_irq_state + createObjects_no_cte_irq_handlers assms + | 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' - createObjects_queues' [OF no_tcb] assms + assms createObjects_pspace_domain_valid co_ct_not_inQ createObjects_ct_idle_or_in_cur_domain' createObjects_untyped_ranges_zero'[OF moKO] + createObjects_sched_queues | simp)+ apply clarsimp using no_cte no_tcb apply ((intro conjI; assumption?); simp add: valid_pspace'_def objBits_def) apply (fastforce simp add: split_def split: option.splits) - apply (clarsimp simp: invs'_def no_tcb valid_state'_def no_cte split: option.splits) + apply (auto simp: invs'_def no_tcb valid_state'_def no_cte + split: option.splits kernel_object.splits) done qed @@ -4995,7 +5242,7 @@ lemma gcd_corres: "corres (=) \ \ (gets cur_domain) curDomain" 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. 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 @@ -5006,7 +5253,7 @@ lemma retype_region2_extra_ext_mapM_x_corres: 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. tcb_at' t s" + and P'="\s. \t \ set addrs. obj_at' (Not \ tcbQueued) t s" in corres_mapM_x) apply simp apply (rule corres_guard_imp) @@ -5014,8 +5261,10 @@ lemma retype_region2_extra_ext_mapM_x_corres: apply (case_tac tcb') apply simp apply fastforce - 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 @@ -5048,10 +5297,11 @@ lemma retype_region2_obj_at: apply (auto simp: obj_at_def default_object_def is_tcb_def) done -lemma createObjects_tcb_at': +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\ - createObjects ptr n (KOTCB makeObject) 0 \\ptrs s. \addr\set ptrs. tcb_at' addr 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 project_inject objBitsKO_def objBits_def makeObject_tcb) done @@ -5116,8 +5366,9 @@ lemma corres_retype_region_createNewCaps: apply (rule corres_retype[where 'a = tcb], simp_all add: obj_bits_api_def objBits_simps' pageBits_def APIType_map2_def makeObjectKO_def - other_objs_default_relation)[1] + tcb_relation_retype)[1] apply (fastforce simp: range_cover_def) + apply (simp add: tcb_relation_retype) apply (rule corres_split_nor) apply (simp add: APIType_map2_def) apply (rule retype_region2_extra_ext_mapM_x_corres) @@ -5127,7 +5378,7 @@ lemma corres_retype_region_createNewCaps: apply wp apply wp apply ((wp retype_region2_obj_at | simp add: APIType_map2_def)+)[1] - apply ((wp createObjects_tcb_at'[where sz=sz] + apply ((wp createObjects_Not_tcbQueued[where sz=sz] | simp add: APIType_map2_def objBits_simps' obj_bits_api_def)+)[1] apply simp apply simp diff --git a/proof/refine/RISCV64/Schedule_R.thy b/proof/refine/RISCV64/Schedule_R.thy index 4b28bcfbaf..8726445b59 100644 --- a/proof/refine/RISCV64/Schedule_R.thy +++ b/proof/refine/RISCV64/Schedule_R.thy @@ -15,11 +15,6 @@ declare hoare_weak_lift_imp[wp_split del] (* Levity: added (20090713 10:04:12) *) declare sts_rel_idle [simp] -lemma invs_no_cicd'_queues: - "invs_no_cicd' s \ valid_queues s" - unfolding invs_no_cicd'_def - by simp - 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)" @@ -89,275 +84,259 @@ lemma schedule_choose_new_thread_sched_act_rct[wp]: unfolding schedule_choose_new_thread_def by wp +\ \This proof shares many similarities with the proof of @{thm tcbSchedEnqueue_corres}\ lemma tcbSchedAppend_corres: - notes trans_state_update'[symmetric, simp del] - shows - "corres dc (is_etcb_at t and tcb_at t and pspace_aligned and pspace_distinct) - (Invariants_H.valid_queues and valid_queues') - (tcb_sched_action (tcb_sched_append) t) (tcbSchedAppend t)" - apply (rule corres_cross_over_guard[where P'=Q and Q="tcb_at' t and Q" for Q]) - apply (fastforce simp: tcb_at_cross state_relation_def) - apply (simp only: tcbSchedAppend_def tcb_sched_action_def) - apply (rule corres_symb_exec_r [OF _ _ threadGet_inv, 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, simp) - apply (rule no_fail_pre, wp, simp) - apply (case_tac queued) - apply (simp add: unless_def when_def) - apply (rule corres_no_failI) - apply wp+ - apply (clarsimp simp: in_monad ethread_get_def gets_the_def bind_assoc - assert_opt_def exec_gets is_etcb_at_def get_etcb_def get_tcb_queue_def - set_tcb_queue_def simpler_modify_def) - - apply (subgoal_tac "tcb_sched_append t (ready_queues a (tcb_domain y) (tcb_priority y)) - = (ready_queues a (tcb_domain y) (tcb_priority y))") - apply (simp add: state_relation_def ready_queues_relation_def) - apply (clarsimp simp: tcb_sched_append_def state_relation_def - valid_queues'_def ready_queues_relation_def - ekheap_relation_def etcb_relation_def - obj_at'_def inQ_def project_inject) - apply (drule_tac x=t in bspec,clarsimp) + "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_append tcb_ptr) (tcbSchedAppend 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_append_def get_tcb_queue_def + tcbSchedAppend_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]; 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) + 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 (clarsimp simp: unless_def when_def cong: if_cong) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres) - apply (simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres) - apply (simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply simp - apply (rule getQueue_corres) - apply (rule corres_split_noop_rhs2) - apply (simp add: tcb_sched_append_def) - apply (intro conjI impI) - apply (rule corres_guard_imp) - apply (rule setQueue_corres) - prefer 3 - apply (rule_tac P=\ and Q="K (t \ set queuea)" in corres_assume_pre) - apply simp - apply simp - apply simp - apply (rule corres_split_noop_rhs2) - apply (rule addToBitmap_if_null_noop_corres) - apply (rule threadSet_corres_noop, simp_all add: tcb_relation_def exst_same_def)[1] - apply wp+ - apply (wp getObject_tcb_wp | simp add: threadGet_def)+ - apply (fastforce simp: valid_queues_def valid_queues_no_bitmap_def obj_at'_def inQ_def - project_inject) - done + apply (rule corres_symb_exec_r[OF _ threadGet_sp]; (solves wpsimp)?) + apply (rule corres_symb_exec_r[OF _ threadGet_sp]; (solves wpsimp)?) + apply (rule corres_symb_exec_r[OF _ gets_sp]; (solves wpsimp)?) + \ \break off the addToBitmap\ + apply (rule corres_add_noop_lhs) + apply (rule corres_underlying_split[rotated 2, + where Q="\_. P" and P=P and Q'="\_. P'" and P'=P' for P P']) -crunches tcbSchedEnqueue, tcbSchedAppend, tcbSchedDequeue - for valid_pspace'[wp]: valid_pspace' - and valid_arch_state'[wp]: valid_arch_state' - (simp: unless_def) + apply wpsimp + apply (wpsimp wp: hoare_vcg_if_lift hoare_vcg_ex_lift) + apply (corres corres: addToBitmap_if_null_noop_corres) + + apply (rule corres_from_valid_det) + apply (fastforce intro: det_wp_modify det_wp_pre simp: set_tcb_queue_def) + apply (wpsimp simp: tcbQueueAppend_def wp: hoare_vcg_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'_tcbQueueEnd_ksReadyQueues simp: obj_at'_def) + + apply (rename_tac s rv t) + apply (clarsimp simp: state_relation_def) + apply (intro hoare_vcg_conj_lift_pre_fix; + (solves \frule singleton_eqD, frule set_tcb_queue_projs_inv, wpsimp simp: swp_def\)?) + + \ \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 simp: setQueue_def tcbQueueAppend_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) + 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 obj_at'_tcbQueueEnd_ksReadyQueues) + apply fast + apply fast + apply fastforce + apply fastforce + apply (cut_tac xs="ready_queues s d p" in heap_path_head') + apply (force dest!: spec simp: list_queue_relation_def) + 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) + apply (metis inQ_def option.simps(5) tcb_of'_TCB) + apply (intro conjI impI; clarsimp) + + \ \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 (tcbQueueEnd (ksReadyQueues s' (tcb_domain etcb, tcb_priority etcb))) + \ set (ready_queues s d p)") + apply (erule orthD2) + apply (drule_tac x="tcb_domain etcb" in spec) + apply (drule_tac x="tcb_priority etcb" in spec) + apply clarsimp + apply (drule_tac x="the (tcbQueueEnd (ksReadyQueues s' (tcb_domain etcb, tcb_priority etcb)))" + in spec) + subgoal by (auto simp: in_opt_pred opt_map_red) + 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"; + clarsimp 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 split: if_splits) + apply (case_tac "t = the (tcbQueueEnd (ksReadyQueues s' (tcb_domain etcb, tcb_priority etcb)))") + apply (clarsimp simp: inQ_def opt_pred_def fun_upd_apply) + 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 tcb \ p = tcb_priority tcb\ + 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) + apply (frule valid_tcbs'_maxPriority[where t=tcbPtr], simp add: obj_at'_def) + 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) + apply (intro conjI; clarsimp) + + \ \the ready queue was originally empty\ + apply (force simp: inQ_def in_opt_pred fun_upd_apply opt_map_def obj_at'_def + queue_end_valid_def prev_queue_head_def + split: if_splits option.splits) + + \ \the ready queue was not originally empty\ + apply (drule (2) heap_ls_append[where new=tcbPtr]) + apply (rule conjI) + apply (clarsimp simp: fun_upd_apply queue_end_valid_def opt_map_def split: if_splits) + apply (rule conjI) + apply (clarsimp simp: fun_upd_apply queue_end_valid_def) + apply (rule conjI) + apply (subst opt_map_upd_triv) + apply (clarsimp simp: opt_map_def fun_upd_apply queue_end_valid_def split: if_splits) + apply (clarsimp simp: prev_queue_head_def fun_upd_apply split: if_splits) + by (clarsimp simp: inQ_def in_opt_pred fun_upd_apply queue_end_valid_def split: if_splits) + +lemma tcbQueueAppend_valid_objs'[wp]: + "\\s. valid_objs' s \ tcb_at' tcbPtr s \ (\end. tcbQueueEnd queue = Some end \ tcb_at' end s)\ + tcbQueueAppend queue tcbPtr + \\_. valid_objs'\" + unfolding tcbQueueAppend_def + apply (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') + apply (clarsimp simp: tcbQueueEmpty_def valid_bound_tcb'_def split: option.splits) + done + +lemma tcbSchedAppend_valid_objs'[wp]: + "\valid_objs' and pspace_aligned' and pspace_distinct'\ + tcbSchedAppend tcbPtr + \\_. valid_objs'\" + apply (clarsimp simp: tcbSchedAppend_def setQueue_def) + apply (wpsimp wp: threadSet_valid_objs' threadGet_wp hoare_vcg_all_lift) + apply (normalise_obj_at', rename_tac tcb "end") + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (frule tcbQueueHead_iff_tcbQueueEnd) + apply (force dest!: obj_at'_tcbQueueEnd_ksReadyQueues simp: tcbQueueEmpty_def obj_at'_def) + done crunches tcbSchedAppend, tcbSchedDequeue for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" (wp: threadSet_pred_tcb_no_state simp: unless_def tcb_to_itcb'_def) -lemma removeFromBitmap_valid_queues_no_bitmap_except[wp]: - "\ valid_queues_no_bitmap_except t \ - removeFromBitmap d p - \\_. valid_queues_no_bitmap_except t \" - unfolding bitmapQ_defs valid_queues_no_bitmap_except_def - by (wp| clarsimp simp: bitmap_fun_defs)+ - -lemma removeFromBitmap_bitmapQ: - "\ \s. True \ removeFromBitmap d p \\_ s. \ bitmapQ d p s \" - unfolding bitmapQ_defs bitmap_fun_defs - by (wp| clarsimp simp: bitmap_fun_defs)+ - -lemma removeFromBitmap_valid_bitmapQ[wp]: -" \ valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - (\s. ksReadyQueues s (d,p) = []) \ - removeFromBitmap d p - \\_. valid_bitmapQ \" -proof - - have "\ valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - (\s. ksReadyQueues s (d,p) = []) \ - removeFromBitmap d p - \\_. valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - (\s. \ bitmapQ d p s \ ksReadyQueues s (d,p) = []) \" - by (rule hoare_pre) - (wp removeFromBitmap_valid_queues_no_bitmap_except removeFromBitmap_valid_bitmapQ_except - removeFromBitmap_bitmapQ, simp) - thus ?thesis - by - (erule hoare_strengthen_post; fastforce elim: valid_bitmap_valid_bitmapQ_exceptE) -qed - -(* this should be the actual weakest precondition to establish valid_queues - under tagging a thread as not queued *) -lemma threadSet_valid_queues_dequeue_wp: - "\ valid_queues_no_bitmap_except t and - valid_bitmapQ and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - (\s. \d p. t \ set (ksReadyQueues s (d,p))) \ - threadSet (tcbQueued_update (\_. False)) t - \\rv. valid_queues \" - unfolding threadSet_def - apply (rule hoare_seq_ext[OF _ getObject_tcb_sp]) - apply (rule hoare_pre) - apply (simp add: valid_queues_def valid_queues_no_bitmap_except_def valid_queues_no_bitmap_def) - apply (wp setObject_queues_unchanged_tcb hoare_Ball_helper hoare_vcg_all_lift - setObject_tcb_strongest) - apply (clarsimp simp: valid_queues_no_bitmap_except_def obj_at'_def valid_queues_no_bitmap_def) - done - (* FIXME move *) lemmas obj_at'_conjI = obj_at_conj' -lemma setQueue_valid_queues_no_bitmap_except_dequeue_wp: - "\d p ts t. - \ \s. valid_queues_no_bitmap_except t s \ - (\t' \ set ts. obj_at' (inQ d p and runnable' \ tcbState) t' s) \ - t \ set ts \ distinct ts \ p \ maxPriority \ d \ maxDomain \ - setQueue d p ts - \\rv. valid_queues_no_bitmap_except t \" - unfolding setQueue_def valid_queues_no_bitmap_except_def null_def - by wp force - -definition (* if t is in a queue, it should be tagged with right priority and domain *) - "correct_queue t s \ \d p. t \ set(ksReadyQueues s (d, p)) \ - (obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t s)" - -lemma valid_queues_no_bitmap_correct_queueI[intro]: - "valid_queues_no_bitmap s \ correct_queue t s" - unfolding correct_queue_def valid_queues_no_bitmap_def - by (fastforce simp: obj_at'_def inQ_def) - - -lemma tcbSchedDequeue_valid_queues_weak: - "\ valid_queues_no_bitmap_except t and valid_bitmapQ and - bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - correct_queue t and - obj_at' (\tcb. tcbDomain tcb \ maxDomain \ tcbPriority tcb \ maxPriority) t \ - tcbSchedDequeue t - \\_. Invariants_H.valid_queues\" -proof - - show ?thesis - unfolding tcbSchedDequeue_def null_def valid_queues_def - apply wp (* stops on threadSet *) - apply (rule hoare_post_eq[OF _ threadSet_valid_queues_dequeue_wp], - simp add: valid_queues_def) - apply (wp hoare_vcg_if_lift hoare_vcg_conj_lift hoare_vcg_imp_lift)+ - apply (wp hoare_vcg_imp_lift setQueue_valid_queues_no_bitmap_except_dequeue_wp - setQueue_valid_bitmapQ threadGet_const_tcb_at hoare_vcg_if_lift)+ - (* wp done *) - apply (normalise_obj_at') - apply (clarsimp simp: correct_queue_def) - apply (normalise_obj_at') - apply (fastforce simp add: valid_queues_no_bitmap_except_def valid_queues_no_bitmap_def elim: obj_at'_weaken)+ - done -qed - -lemma tcbSchedDequeue_valid_queues: - "\Invariants_H.valid_queues - and obj_at' (\tcb. tcbDomain tcb \ maxDomain) t - and obj_at' (\tcb. tcbPriority tcb \ maxPriority) t\ - tcbSchedDequeue t - \\_. Invariants_H.valid_queues\" - apply (rule hoare_pre, rule tcbSchedDequeue_valid_queues_weak) - apply (fastforce simp: valid_queues_def valid_queues_no_bitmap_def obj_at'_def inQ_def) - done - -lemma tcbSchedAppend_valid_queues'[wp]: - (* most of this is identical to tcbSchedEnqueue_valid_queues' in TcbAcc_R *) - "\valid_queues' and tcb_at' t\ tcbSchedAppend t \\_. valid_queues'\" - apply (simp add: tcbSchedAppend_def) - apply (rule hoare_pre) - apply (rule_tac B="\rv. valid_queues' and obj_at' (\obj. tcbQueued obj = rv) t" - in hoare_seq_ext) - 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 inQ_def) - apply (wp setQueue_valid_queues' | simp | simp add: setQueue_def)+ - apply (wp getObject_tcb_wp | simp add: threadGet_def)+ - apply (clarsimp simp: obj_at'_def inQ_def valid_queues'_def) - apply (wp getObject_tcb_wp | simp add: threadGet_def)+ - apply (clarsimp simp: obj_at'_def) - done - -lemma threadSet_valid_queues'_dequeue: (* threadSet_valid_queues' is too weak for dequeue *) - "\\s. (\d p t'. obj_at' (inQ d p) t' s \ t' \ t \ t' \ set (ksReadyQueues s (d, p))) \ - obj_at' (inQ d p) t s \ - threadSet (tcbQueued_update (\_. False)) t - \\rv. valid_queues' \" - unfolding valid_queues'_def - apply (rule hoare_pre) - apply (wp hoare_vcg_all_lift) - apply (simp only: imp_conv_disj not_obj_at') - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - apply (simp add: not_obj_at') - apply (clarsimp simp: typ_at_tcb') - apply normalise_obj_at' - apply (fastforce elim: obj_at'_weaken simp: inQ_def) - done - -lemma setQueue_ksReadyQueues_lift: - "\ \s. P (s\ksReadyQueues := (ksReadyQueues s)((d, p) := ts)\) ts \ - setQueue d p ts - \ \_ s. P s (ksReadyQueues s (d,p))\" - unfolding setQueue_def - by (wp, clarsimp simp: fun_upd_def cong: if_cong) - -lemma tcbSchedDequeue_valid_queues'[wp]: - "\valid_queues' and tcb_at' t\ - tcbSchedDequeue t \\_. valid_queues'\" - unfolding tcbSchedDequeue_def - apply (rule_tac B="\rv. valid_queues' and obj_at' (\obj. tcbQueued obj = rv) t" - in hoare_seq_ext) - prefer 2 - apply (wp threadGet_const_tcb_at) - apply (fastforce simp: obj_at'_def) - apply clarsimp - apply (rename_tac queued) - apply (case_tac queued, simp_all) - apply wp - apply (rule_tac d=tdom and p=prio in threadSet_valid_queues'_dequeue) - apply (rule hoare_pre_post, assumption) - apply (wp | clarsimp simp: bitmap_fun_defs)+ - apply (wp hoare_vcg_all_lift setQueue_ksReadyQueues_lift) - apply clarsimp - apply (wp threadGet_obj_at' threadGet_const_tcb_at)+ - apply clarsimp - apply (rule context_conjI, clarsimp simp: obj_at'_def) - apply (clarsimp simp: valid_queues'_def obj_at'_def inQ_def|wp)+ - done +crunches tcbSchedAppend, tcbSchedDequeue, tcbSchedEnqueue + for tcb_at'[wp]: "tcb_at' t" + and cap_to'[wp]: "ex_nonz_cap_to' p" + and ifunsafe'[wp]: if_unsafe_then_cap' + (wp: crunch_wps simp: crunch_simps) lemma tcbSchedAppend_iflive'[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' tcb\ - tcbSchedAppend tcb \\_. if_live_then_nonz_cap'\" - apply (simp add: tcbSchedAppend_def unless_def) - apply (wp threadSet_iflive' hoare_drop_imps | simp add: crunch_simps)+ + "\if_live_then_nonz_cap' and pspace_aligned' and pspace_distinct'\ + tcbSchedAppend tcbPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbSchedAppend_def + apply (wpsimp wp: tcbQueueAppend_if_live_then_nonz_cap' threadGet_wp simp: bitmap_fun_defs) + apply (frule_tac p=tcbPtr in if_live_then_nonz_capE') + apply (fastforce simp: ko_wp_at'_def st_tcb_at'_def obj_at'_def runnable_eq_active') + apply (clarsimp simp: tcbQueueEmpty_def) + apply (erule if_live_then_nonz_capE') + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (fastforce dest!: obj_at'_tcbQueueEnd_ksReadyQueues + simp: ko_wp_at'_def inQ_def obj_at'_def tcbQueueEmpty_def) done lemma tcbSchedDequeue_iflive'[wp]: - "\if_live_then_nonz_cap'\ tcbSchedDequeue tcb \\_. if_live_then_nonz_cap'\" + "\if_live_then_nonz_cap' and valid_objs' and sym_heap_sched_pointers\ + tcbSchedDequeue tcbPtr + \\_. if_live_then_nonz_cap'\" apply (simp add: tcbSchedDequeue_def) - apply (wp threadSet_iflive' hoare_when_weak_wp | simp add: crunch_simps)+ - apply ((wp | clarsimp simp: bitmap_fun_defs)+)[1] (* deal with removeFromBitmap *) - apply (wp threadSet_iflive' hoare_when_weak_wp | simp add: crunch_simps)+ - apply (rule_tac Q="\rv. \" in hoare_post_imp, fastforce) - apply (wp | simp add: crunch_simps)+ + apply (wpsimp wp: tcbQueueRemove_if_live_then_nonz_cap' threadGet_wp) + apply (fastforce elim: if_live_then_nonz_capE' simp: obj_at'_def ko_wp_at'_def) done crunches tcbSchedAppend, tcbSchedDequeue, tcbSchedEnqueue @@ -403,19 +382,87 @@ lemma ct_idle_or_in_cur_domain'_lift2: apply simp+ done +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'\" + apply (wpsimp wp: setObject_tcb_mdb' getTCB_wp simp: threadSet_def obj_at'_def) + apply fastforce + done + +lemma tcbSchedNext_update_valid_mdb'[wp]: + "\valid_mdb' and tcb_at' tcbPtr\ threadSet (tcbSchedNext_update f) tcbPtr \\_. valid_mdb'\" + apply (wpsimp wp: threadSet_mdb') + apply (fastforce simp: obj_at'_def valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) + done + +lemma tcbSchedPrev_update_valid_mdb'[wp]: + "\valid_mdb' and tcb_at' tcbPtr\ threadSet (tcbSchedPrev_update f) tcbPtr \\_. valid_mdb'\" + apply (wpsimp wp: threadSet_mdb') + apply (fastforce simp: obj_at'_def valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) + done + +lemma tcbQueueRemove_valid_mdb': + "\\s. valid_mdb' s \ valid_objs' s\ tcbQueueRemove q tcbPtr \\_. valid_mdb'\" + unfolding tcbQueueRemove_def + apply (wpsimp wp: getTCB_wp) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (fastforce simp: valid_tcb'_def obj_at'_def) + done + +lemma tcbQueuePrepend_valid_mdb': + "\valid_mdb' and tcb_at' tcbPtr + and (\s. \ tcbQueueEmpty queue \ tcb_at' (the (tcbQueueHead queue)) s)\ + tcbQueuePrepend queue tcbPtr + \\_. valid_mdb'\" + unfolding tcbQueuePrepend_def + by (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') + +lemma tcbQueueAppend_valid_mdb': + "\\s. valid_mdb' s \ tcb_at' tcbPtr s + \ (\ tcbQueueEmpty queue \ tcb_at' (the (tcbQueueEnd queue)) s)\ + tcbQueueAppend queue tcbPtr + \\_. valid_mdb'\" + unfolding tcbQueueAppend_def + by (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') + +lemma tcbQueued_update_valid_mdb'[wp]: + "\valid_mdb' and tcb_at' tcbPtr\ threadSet (tcbQueued_update f) tcbPtr \\_. valid_mdb'\" + apply (wpsimp wp: threadSet_mdb') + apply (fastforce simp: obj_at'_def valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) + done + +lemma valid_mdb'_ksReadyQueuesL1Bitmap_update[simp]: + "valid_mdb' (ksReadyQueuesL1Bitmap_update f s) = valid_mdb' s" + by (simp add: valid_mdb'_def) + +lemma valid_mdb'_ksReadyQueuesL2Bitmap_update[simp]: + "valid_mdb' (ksReadyQueuesL2Bitmap_update f s) = valid_mdb' s" + by (simp add: valid_mdb'_def) + +lemma tcbSchedEnqueue_valid_mdb'[wp]: + "\valid_mdb' and valid_objs' and pspace_aligned' and pspace_distinct'\ + tcbSchedEnqueue tcbPtr + \\_. valid_mdb'\" + apply (clarsimp simp: tcbSchedEnqueue_def setQueue_def) + apply (wpsimp wp: tcbQueuePrepend_valid_mdb' threadGet_wp simp: bitmap_fun_defs) + apply normalise_obj_at' + apply (fastforce dest!: obj_at'_tcbQueueHead_ksReadyQueues + simp: ready_queue_relation_def ksReadyQueues_asrt_def obj_at'_def) + done + +crunches tcbSchedEnqueue + for cur_tcb'[wp]: cur_tcb' + (wp: threadSet_cur) + lemma tcbSchedEnqueue_invs'[wp]: - "\invs' - and st_tcb_at' runnable' t - and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ - tcbSchedEnqueue t + "\invs' and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ + tcbSchedEnqueue t \\_. invs'\" - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp tcbSchedEnqueue_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 tcbSchedEnqueue_ct_not_inQ + simp: cteCaps_of_def o_def) done crunch ksMachine[wp]: tcbSchedAppend "\s. P (ksMachineState s)" @@ -424,7 +471,7 @@ crunch ksMachine[wp]: tcbSchedAppend "\s. P (ksMachineState s)" lemma tcbSchedAppend_vms'[wp]: "\valid_machine_state'\ tcbSchedAppend t \\_. valid_machine_state'\" apply (simp add: valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift tcbSchedAppend_ksMachine) + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) done crunch pspace_domain_valid[wp]: tcbSchedAppend "pspace_domain_valid" @@ -439,21 +486,27 @@ crunch ksIdleThread[wp]: tcbSchedAppend "\s. P (ksIdleThread s)" crunch ksDomSchedule[wp]: tcbSchedAppend "\s. P (ksDomSchedule s)" (simp: unless_def) +lemma tcbQueueAppend_tcbPriority_obj_at'[wp]: + "tcbQueueAppend queue tptr \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + unfolding tcbQueueAppend_def + apply (wpsimp wp: threadSet_wp) + by (auto simp: obj_at'_def objBits_simps ps_clear_def split: if_splits) + +lemma tcbQueueAppend_tcbDomain_obj_at'[wp]: + "tcbQueueAppend queue tptr \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding tcbQueueAppend_def + apply (wpsimp wp: threadSet_wp) + by (auto simp: obj_at'_def objBits_simps ps_clear_def split: if_splits) + lemma tcbSchedAppend_tcbDomain[wp]: - "\ obj_at' (\tcb. P (tcbDomain tcb)) t' \ - tcbSchedAppend t - \ \_. obj_at' (\tcb. P (tcbDomain tcb)) t' \" + "tcbSchedAppend t \obj_at' (\tcb. P (tcbDomain tcb)) t'\" apply (clarsimp simp: tcbSchedAppend_def) - apply (wpsimp simp: unless_def)+ - done + by wpsimp lemma tcbSchedAppend_tcbPriority[wp]: - "\ obj_at' (\tcb. P (tcbPriority tcb)) t' \ - tcbSchedAppend t - \ \_. obj_at' (\tcb. P (tcbPriority tcb)) t' \" + "tcbSchedAppend t \obj_at' (\tcb. P (tcbPriority tcb)) t'\" apply (clarsimp simp: tcbSchedAppend_def) - apply (wpsimp simp: unless_def)+ - done + by wpsimp lemma tcbSchedAppend_tcb_in_cur_domain'[wp]: "\tcb_in_cur_domain' t'\ tcbSchedAppend t \\_. tcb_in_cur_domain' t' \" @@ -472,28 +525,59 @@ crunches tcbSchedDequeue, tcbSchedAppend for arch'[wp]: "\s. P (ksArchState s)" lemma tcbSchedAppend_sch_act_wf[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ tcbSchedAppend thread - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - apply (simp add:tcbSchedAppend_def bitmap_fun_defs) - apply (wp unless_wp setQueue_sch_act threadGet_wp|simp)+ - apply (fastforce simp:typ_at'_def obj_at'_def) + "tcbSchedAppend thread \\s. sch_act_wf (ksSchedulerAction s) s\" + by (wpsimp wp: sch_act_wf_lift) + +lemma tcbSchedAppend_valid_bitmapQ[wp]: + "\valid_bitmaps\ tcbSchedAppend tcbPtr \\_. valid_bitmapQ\" + supply if_split[split del] + unfolding tcbSchedAppend_def + apply (wpsimp simp: tcbQueueAppend_def + wp: setQueue_valid_bitmapQ' addToBitmap_valid_bitmapQ_except addToBitmap_bitmapQ + threadGet_wp hoare_vcg_if_lift2) + apply (clarsimp simp: ksReadyQueues_asrt_def split: if_splits) + apply normalise_obj_at' + apply (force dest: tcbQueueHead_iff_tcbQueueEnd + simp: valid_bitmaps_def valid_bitmapQ_def tcbQueueEmpty_def) + done + +lemma tcbSchedAppend_valid_mdb'[wp]: + "\valid_mdb' and valid_tcbs' and pspace_aligned' and pspace_distinct'\ + tcbSchedAppend tcbPtr + \\_. valid_mdb'\" + apply (clarsimp simp: tcbSchedAppend_def setQueue_def) + apply (wpsimp wp: tcbQueueAppend_valid_mdb' threadGet_wp simp: bitmap_fun_defs) + apply (fastforce dest: obj_at'_tcbQueueEnd_ksReadyQueues + simp: ready_queue_relation_def ksReadyQueues_asrt_def obj_at'_def) + done + +lemma tcbSchedAppend_valid_bitmaps[wp]: + "tcbSchedAppend tcbPtr \valid_bitmaps\" + unfolding valid_bitmaps_def + apply wpsimp + apply (clarsimp simp: valid_bitmaps_def) done lemma tcbSchedAppend_invs'[wp]: - "\invs' - and st_tcb_at' runnable' t - and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ - tcbSchedAppend t + "\invs' and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ + tcbSchedAppend t \\_. invs'\" - apply (simp add: invs'_def valid_state'_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: @@ -522,7 +606,7 @@ crunch ksMachine[wp]: tcbSchedDequeue "\s. P (ksMachineState s)" lemma tcbSchedDequeue_vms'[wp]: "\valid_machine_state'\ tcbSchedDequeue t \\_. valid_machine_state'\" apply (simp add: valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift tcbSchedDequeue_ksMachine) + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) done crunch pspace_domain_valid[wp]: tcbSchedDequeue "pspace_domain_valid" @@ -540,46 +624,89 @@ lemma tcbSchedDequeue_tcb_in_cur_domain'[wp]: "\tcb_in_cur_domain' t'\ tcbSchedDequeue t \\_. tcb_in_cur_domain' t' \" apply (rule tcb_in_cur_domain'_lift) apply wp - apply (clarsimp simp: tcbSchedDequeue_def) - apply (wp hoare_when_weak_wp | simp)+ - done - -lemma tcbSchedDequeue_tcbDomain[wp]: - "\ obj_at' (\tcb. P (tcbDomain tcb)) t' \ - tcbSchedDequeue t - \ \_. obj_at' (\tcb. P (tcbDomain tcb)) t' \" - apply (clarsimp simp: tcbSchedDequeue_def) - apply (wp hoare_when_weak_wp | simp)+ - done - -lemma tcbSchedDequeue_tcbPriority[wp]: - "\ obj_at' (\tcb. P (tcbPriority tcb)) t' \ - tcbSchedDequeue t - \ \_. obj_at' (\tcb. P (tcbPriority tcb)) t' \" - apply (clarsimp simp: tcbSchedDequeue_def) - apply (wp hoare_when_weak_wp | simp)+ + apply (clarsimp simp: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wpsimp wp: hoare_when_weak_wp getObject_tcb_wp threadGet_wp) done crunch ksDomScheduleIdx[wp]: tcbSchedDequeue "\s. P (ksDomScheduleIdx s)" (simp: unless_def) +lemma tcbSchedDequeue_valid_mdb'[wp]: + "\valid_mdb' and valid_objs'\ tcbSchedDequeue tcbPtr \\_. valid_mdb'\" + unfolding tcbSchedDequeue_def + apply (wpsimp simp: bitmap_fun_defs setQueue_def wp: threadSet_mdb' tcbQueueRemove_valid_mdb') + apply (rule_tac Q="\_. tcb_at' tcbPtr" in hoare_post_imp) + apply (fastforce simp: tcb_cte_cases_def cteSizeBits_def) + apply (wpsimp wp: threadGet_wp)+ + apply (fastforce simp: obj_at'_def) + done + lemma tcbSchedDequeue_invs'[wp]: - "\invs' and tcb_at' t\ - tcbSchedDequeue t - \\_. invs'\" - unfolding invs'_def valid_state'_def - apply (rule hoare_pre) - 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 - tcbSchedDequeue_valid_queues - untyped_ranges_zero_lift - | simp add: cteCaps_of_def o_def)+ - apply (fastforce elim: valid_objs'_maxDomain valid_objs'_maxPriority simp: valid_pspace'_def)+ + "tcbSchedDequeue t \invs'\" + 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: + "\(s, s') \ state_relation; pspace_aligned s; pspace_distinct s; valid_queues s\ + \ ready_qs_runnable s'" + apply (clarsimp simp: ready_qs_runnable_def) + apply normalise_obj_at' + apply (frule state_relation_ready_queues_relation) + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def + list_queue_relation_def) + apply (drule_tac x="tcbDomain ko" in spec) + apply (drule_tac x="tcbPriority ko" in spec) + apply (clarsimp simp: valid_queues_def) + apply (drule_tac x="tcbDomain ko" in spec) + apply (drule_tac x="tcbPriority ko" in spec) + apply clarsimp + apply (drule_tac x=t in bspec) + apply (fastforce simp: inQ_def in_opt_pred obj_at'_def opt_map_red) + apply (fastforce dest: st_tcb_at_runnable_cross simp: obj_at'_def st_tcb_at'_def) + done + +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_queues)?, (frule invs_psp_aligned)?, (frule invs_distinct)?, + fastforce dest: ready_qs_runnable_cross + +defs idleThreadNotQueued_def: + "idleThreadNotQueued s \ obj_at' (Not \ tcbQueued) (ksIdleThread s) s" + +lemma idle_thread_not_queued: + "\valid_idle s; valid_queues s; valid_etcbs s\ + \ \ (\d p. idle_thread s \ set (ready_queues s d p))" + apply (clarsimp simp: valid_queues_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply clarsimp + apply (drule_tac x="idle_thread s" in bspec) + apply fastforce + apply (clarsimp simp: valid_idle_def pred_tcb_at_def obj_at_def valid_etcbs_def) done +lemma valid_idle_tcb_at: + "valid_idle s \ tcb_at (idle_thread s) s" + by (clarsimp simp: valid_idle_def pred_tcb_at_def obj_at_def is_tcb_def) + lemma setCurThread_corres: - "corres dc \ \ (modify (cur_thread_update (\_. t))) (setCurThread t)" - apply (unfold setCurThread_def) + "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 opt_pred_def opt_map_def) apply (rule corres_modify) apply (simp add: state_relation_def swp_def) done @@ -606,49 +733,58 @@ qed crunches storeWordUser, setVMRoot, asUser, storeWordUser, Arch.switchToThread for ksQ[wp]: "\s. P (ksReadyQueues s p)" and ksIdleThread[wp]: "\s. P (ksIdleThread s)" - and valid_queues[wp]: "Invariants_H.valid_queues" - (wp: crunch_wps simp: crunch_simps) + and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_objs'[wp]: valid_objs' + (wp: crunch_wps threadSet_sched_pointers simp: crunch_simps) -crunches arch_switch_to_thread +crunches arch_switch_to_thread, arch_switch_to_idle_thread for pspace_aligned[wp]: pspace_aligned and pspace_distinct[wp]: pspace_distinct + and ready_qs_distinct[wp]: ready_qs_distinct + and valid_idle[wp]: valid_idle + (wp: ready_qs_distinct_lift) + +lemma valid_queues_in_correct_ready_q[elim!]: + "valid_queues s \ in_correct_ready_q s" + by (clarsimp simp: valid_queues_def in_correct_ready_q_def) + +lemma valid_queues_ready_qs_distinct[elim!]: + "valid_queues s \ ready_qs_distinct s" + by (clarsimp simp: valid_queues_def ready_qs_distinct_def) lemma switchToThread_corres: "corres dc (valid_arch_state and valid_objs and valid_vspace_objs and pspace_aligned and pspace_distinct and valid_vs_lookup and valid_global_objs and unique_table_refs - and st_tcb_at runnable t and valid_etcbs) - (no_0_obj' and Invariants_H.valid_queues) + 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') (switch_to_thread t) (switchToThread t)" - (is "corres _ ?PA ?PH _ _") -proof - - have mainpart: "corres dc (?PA) (?PH) - (do y \ arch_switch_to_thread t; - y \ (tcb_sched_action tcb_sched_dequeue t); - modify (cur_thread_update (\_. t)) - od) - (do y \ Arch.switchToThread t; - y \ tcbSchedDequeue t; - setCurThread 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) + apply add_ready_qs_runnable + apply (simp add: switch_to_thread_def Thread_H.switchToThread_def) + apply (rule corres_symb_exec_l[OF _ _ get_sp]; (solves wpsimp)?) + apply (rule corres_symb_exec_l[OF _ _ assert_sp]; (solves wpsimp)?) + 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_stateAssert_ignore) + apply (fastforce dest!: state_relation_ready_queues_relation intro: ksReadyQueues_asrt_cross) + apply (rule corres_stateAssert_add_assertion[rotated]) + apply fastforce apply (rule corres_guard_imp) apply (rule corres_split[OF arch_switchToThread_corres]) apply (rule corres_split[OF tcbSchedDequeue_corres setCurThread_corres]) - apply (wp|clarsimp simp: tcb_at_is_etcb_at st_tcb_at_tcb_at)+ - done - - show ?thesis - apply - - apply (simp add: switch_to_thread_def Thread_H.switchToThread_def) - apply (rule corres_symb_exec_l [where Q = "\ s rv. (?PA and (=) rv) s", - OF corres_symb_exec_l [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 @@ -664,15 +800,21 @@ lemma arch_switchToIdleThread_corres: done lemma switchToIdleThread_corres: - "corres dc invs invs_no_cicd' switch_to_idle_thread switchToIdleThread" + "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 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_trivial, rule corres_modify) - apply (simp add: state_relation_def cdt_relation_def) - apply (wp+, simp+) + 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) @@ -707,11 +849,9 @@ proof - 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 Invariants_H.valid_queues_def - sch_act_wf ct_in_state'_def state_refs_of'_def - ps_clear_def valid_irq_node'_def valid_queues'_def ct_not_inQ_ct - ct_idle_or_in_cur_domain'_def - bitmapQ_defs valid_queues_no_bitmap_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 @@ -725,100 +865,20 @@ lemma setCurThread_invs: by (rule hoare_pre, rule setCurThread_invs_no_cicd') (simp add: invs'_to_invs_no_cicd'_def) -lemma valid_queues_not_runnable_not_queued: - fixes s - assumes vq: "Invariants_H.valid_queues 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 - - with vq have "st_tcb_at' runnable' t s" - unfolding Invariants_H.valid_queues_def valid_queues_no_bitmap_def - apply - - apply clarsimp - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp simp add: st_tcb_at'_def) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE) - apply (clarsimp) - done - - with st show False - apply - - apply (drule(1) pred_tcb_at_conj') - apply (clarsimp) - done -qed - -(* - * The idle thread is not part of any ready queues. - *) -lemma idle'_not_tcbQueued': - assumes vq: "Invariants_H.valid_queues 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 add: valid_idle'_def pred_tcb_at'_def obj_at'_def idle_tcb'_def) - with vq vq' show ?thesis - by (rule valid_queues_not_runnable_not_queued) -qed - lemma setCurThread_invs_no_cicd'_idle_thread: - "\invs_no_cicd' and (\s. t = ksIdleThread s) \ 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 - have idle'_activatable': "\ s t. st_tcb_at' idle' t s \ st_tcb_at' activatable' t s" - apply (clarsimp simp: st_tcb_at'_def o_def obj_at'_def) + "\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 st_tcb_at'_def + idleThreadNotQueued_def) done - show ?thesis - apply (simp add: setCurThread_def) - apply wp - apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def) - apply (frule (2) idle'_not_tcbQueued'[simplified o_def]) - apply (clarsimp simp add: ct_not_inQ_ct idle'_activatable' - 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_queues_no_bitmap_def valid_queues'_def - pred_tcb_at'_def - cong: option.case_cong) - apply (clarsimp simp: obj_at'_def idle_tcb'_def ) - done -qed lemma setCurThread_invs_idle_thread: "\invs' and (\s. t = ksIdleThread s) \ setCurThread t \\rv. invs'\" @@ -853,13 +913,13 @@ lemma Arch_switchToThread_tcb_in_cur_domain'[wp]: done lemma tcbSchedDequeue_not_tcbQueued: - "\ tcb_at' t \ tcbSchedDequeue t \ \_. obj_at' (\x. \ tcbQueued x) t \" + "\\\ tcbSchedDequeue t \\_. obj_at' (\x. \ tcbQueued x) t\" apply (simp add: tcbSchedDequeue_def) apply (wp|clarsimp)+ apply (rule_tac Q="\queued. obj_at' (\x. tcbQueued x = queued) t" in hoare_post_imp) - apply (clarsimp simp: obj_at'_def) - apply (wp threadGet_obj_at') - apply (simp) + apply (clarsimp simp: obj_at'_def) + apply (wpsimp wp: threadGet_wp)+ + apply (clarsimp simp: obj_at'_def) done lemma asUser_tcbState_inv[wp]: @@ -883,10 +943,6 @@ crunch valid_irq_states'[wp]: asUser "valid_irq_states'" crunch valid_machine_state'[wp]: asUser "valid_machine_state'" (wp: crunch_wps simp: crunch_simps) -crunch valid_queues'[wp]: asUser "valid_queues'" -(wp: crunch_wps simp: crunch_simps) - - lemma asUser_valid_irq_node'[wp]: "\\s. valid_irq_node' (irq_node' s) s\ asUser t (setRegister f r) \\_ s. valid_irq_node' (irq_node' s) s\" @@ -946,55 +1002,38 @@ lemma asUser_utr[wp]: done lemma threadSet_invs_no_cicd'_trivialT: - assumes x: "\tcb. \(getF,setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" - assumes z: "\tcb. tcbState (F tcb) = tcbState tcb \ tcbDomain (F tcb) = tcbDomain tcb" - assumes w: "\tcb. is_aligned (tcbIPCBuffer tcb) msg_align_bits \ is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits" - assumes a: "\tcb. tcbBoundNotification (F tcb) = tcbBoundNotification tcb" - assumes w: "\tcb. is_aligned (tcbIPCBuffer tcb) msg_align_bits \ is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits" - 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 \ tcbDomain (F tcb) = tcbDomain tcb" + "\tcb. is_aligned (tcbIPCBuffer tcb) msg_align_bits \ is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits" + "\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 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_no_cicd' 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. \ tcbQueued tcb \ tcbQueued (F tcb)) \ ex_nonz_cap_to' t s \ t \ ksCurThread s) \ - (\tcb. tcbQueued (F tcb) \ ksSchedulerAction s = ResumeCurrentThread \ tcbQueued tcb \ t \ ksCurThread s)\ - threadSet F t - \\rv. invs_no_cicd'\" -proof - - from z have domains: "\tcb. tcbDomain (F tcb) = tcbDomain tcb" by blast - note threadSet_sch_actT_P[where P=False, simplified] - have y: "\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_no_cicd'_def valid_state'_def split del: if_split) - apply (rule hoare_pre) - apply (wp x w v u b - threadSet_valid_pspace'T - threadSet_sch_actT_P[where P=False, simplified] - threadSet_valid_queues - 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_cur - untyped_ranges_zero_lift - |clarsimp simp: y z a domains cteCaps_of_def |rule refl)+ - apply (clarsimp simp: obj_at'_def pred_tcb_at'_def) - apply (clarsimp simp: cur_tcb'_def valid_irq_node'_def valid_queues'_def o_def) - by (fastforce simp: domains ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def z a) -qed + "threadSet F t \invs_no_cicd'\" + apply (simp add: invs_no_cicd'_def valid_state'_def) + apply (wp threadSet_valid_pspace'T + threadSet_sch_actT_P[where P=False, simplified] + 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_sched_pointers threadSet_valid_sched_pointers + threadSet_cur + untyped_ranges_zero_lift + | clarsimp simp: assms cteCaps_of_def | rule refl)+ + by (auto simp: o_def) lemmas threadSet_invs_no_cicd'_trivial = threadSet_invs_no_cicd'_trivialT [OF all_tcbI all_tcbI all_tcbI all_tcbI, OF ball_tcb_cte_casesI] @@ -1013,22 +1052,17 @@ lemma Arch_switchToThread_invs_no_cicd': done lemma tcbSchedDequeue_invs_no_cicd'[wp]: - "\invs_no_cicd' and tcb_at' t\ - tcbSchedDequeue t - \\_. invs_no_cicd'\" - unfolding all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def + "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 - tcbSchedDequeue_valid_queues_weak untyped_ranges_zero_lift | simp add: cteCaps_of_def o_def)+ apply clarsimp - apply (fastforce simp: valid_pspace'_def valid_queues_def - elim: valid_objs'_maxDomain valid_objs'_maxPriority intro: obj_at'_conjI) done lemma switchToThread_invs_no_cicd': - "\invs_no_cicd' and st_tcb_at' runnable' t and tcb_in_cur_domain' t \ ThreadDecls_H.switchToThread t \\rv. invs' \" + "\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') @@ -1036,7 +1070,7 @@ lemma switchToThread_invs_no_cicd': done lemma switchToThread_invs[wp]: - "\invs' and st_tcb_at' runnable' t and tcb_in_cur_domain' t \ switchToThread t \\rv. invs' \" + "\invs' and tcb_in_cur_domain' t \ switchToThread t \\rv. invs' \" apply (simp add: Thread_H.switchToThread_def ) apply (wp threadSet_timeslice_invs setCurThread_invs Arch_switchToThread_invs dmo_invs' @@ -1111,61 +1145,6 @@ lemma obj_tcb_at': "obj_at' (\tcb::tcb. P tcb) t s \ tcb_at' t s" by (clarsimp simp: obj_at'_def) -lemma invs'_not_runnable_not_queued: - fixes s - assumes inv: "invs' s" - and st: "st_tcb_at' (Not \ runnable') t s" - shows "obj_at' (Not \ tcbQueued) t s" - apply (insert assms) - apply (rule valid_queues_not_runnable_not_queued) - apply (clarsimp simp add: invs'_def valid_state'_def)+ - done - -lemma valid_queues_not_tcbQueued_not_ksQ: - fixes s - assumes vq: "Invariants_H.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" - unfolding Invariants_H.valid_queues_def valid_queues_no_bitmap_def - apply clarify - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE) - apply (simp) - done - 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 valid_state'_def) - apply (drule(1) valid_queues_not_tcbQueued_not_ksQ) - apply (clarsimp) - done - -lemma ct_not_ksQ: - "\ invs' s; ksSchedulerAction s = ResumeCurrentThread \ - \ \p. ksCurThread s \ set (ksReadyQueues s p)" - apply (clarsimp simp: invs'_def valid_state'_def ct_not_inQ_def) - apply (frule(1) valid_queues_not_tcbQueued_not_ksQ) - apply (fastforce) - done - lemma setThreadState_rct: "\\s. (runnable' st \ ksCurThread s \ t) \ ksSchedulerAction s = ResumeCurrentThread\ @@ -1237,21 +1216,24 @@ lemma bitmapQ_from_bitmap_lookup: done lemma lookupBitmapPriority_obj_at': - "\ksReadyQueuesL1Bitmap s (ksCurDomain s) \ 0; valid_queues_no_bitmap s; valid_bitmapQ s; - bitmapQ_no_L1_orphans s\ - \ obj_at' (inQ (ksCurDomain s) (lookupBitmapPriority (ksCurDomain s) s) and runnable' \ tcbState) - (hd (ksReadyQueues s (ksCurDomain s, lookupBitmapPriority (ksCurDomain s) s))) s" + "\ksReadyQueuesL1Bitmap s d \ 0; valid_bitmapQ s; bitmapQ_no_L1_orphans s; + ksReadyQueues_asrt s; ready_qs_runnable s; pspace_aligned' s; pspace_distinct' s\ + \ obj_at' (inQ d (lookupBitmapPriority d s) and runnable' \ tcbState) + (the (tcbQueueHead (ksReadyQueues s (d, lookupBitmapPriority d s)))) s" apply (drule (2) bitmapQ_from_bitmap_lookup) apply (simp add: valid_bitmapQ_bitmapQ_simp) - apply (case_tac "ksReadyQueues s (ksCurDomain s, lookupBitmapPriority (ksCurDomain s) s)", simp) - apply (clarsimp, rename_tac t ts) - apply (drule cons_set_intro) - apply (drule (2) valid_queues_no_bitmap_objD) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def tcbQueueEmpty_def) + apply (drule_tac x=d in spec) + apply (drule_tac x="lookupBitmapPriority d s" in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (fastforce simp: obj_at'_and ready_qs_runnable_def obj_at'_def st_tcb_at'_def inQ_def + tcbQueueEmpty_def) done lemma bitmapL1_zero_ksReadyQueues: "\ valid_bitmapQ s ; bitmapQ_no_L1_orphans s \ - \ (ksReadyQueuesL1Bitmap s d = 0) = (\p. ksReadyQueues s (d,p) = [])" + \ (ksReadyQueuesL1Bitmap s d = 0) = (\p. tcbQueueEmpty (ksReadyQueues s (d, p)))" apply (cases "ksReadyQueuesL1Bitmap s d = 0") apply (force simp add: bitmapQ_def valid_bitmapQ_def) apply (fastforce dest: bitmapQ_from_bitmap_lookup simp: valid_bitmapQ_bitmapQ_simp) @@ -1322,7 +1304,7 @@ lemma bitmapL1_highest_lookup: done lemma bitmapQ_ksReadyQueuesI: - "\ bitmapQ d p s ; valid_bitmapQ s \ \ ksReadyQueues s (d, p) \ []" + "\ bitmapQ d p s ; valid_bitmapQ s \ \ \ tcbQueueEmpty (ksReadyQueues s (d, p))" unfolding valid_bitmapQ_def by simp lemma getReadyQueuesL2Bitmap_inv[wp]: @@ -1331,24 +1313,22 @@ lemma getReadyQueuesL2Bitmap_inv[wp]: lemma switchToThread_lookupBitmapPriority_wp: "\\s. invs_no_cicd' s \ bitmapQ (ksCurDomain s) (lookupBitmapPriority (ksCurDomain s) s) s \ - t = hd (ksReadyQueues s (ksCurDomain s, lookupBitmapPriority (ksCurDomain 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 ; 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 elim: obj_at'_weaken simp: inQ_def tcb_in_cur_domain'_def st_tcb_at'_def) - done - thus ?thesis - by (wp switchToThread_invs_no_cicd') (fastforce dest: invs_no_cicd'_queues) -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_no_cicd': "\invs_no_cicd'\ switchToIdleThread \\rv. invs'\" @@ -1447,8 +1427,8 @@ 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 - and st_tcb_at runnable t and valid_etcbs) - (no_0_obj' and Invariants_H.valid_queues) + 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') (guarded_switch_to t) (switchToThread t)" apply (simp add: guarded_switch_to_def) apply (rule corres_guard_imp) @@ -1493,7 +1473,7 @@ lemma curDomain_corres: "corres (=) \ \ (gets cur_domain) (curDomain)" lemma curDomain_corres': "corres (=) \ (\s. ksCurDomain s \ maxDomain) - (gets cur_domain) (if 1 < numDomains then curDomain else return 0)" + (gets cur_domain) (if Suc 0 < numDomains then curDomain else return 0)" apply (case_tac "1 < numDomains"; simp) apply (rule corres_guard_imp[OF curDomain_corres]; solves simp) (* if we have only one domain, then we are in it *) @@ -1503,27 +1483,32 @@ lemma curDomain_corres': lemma lookupBitmapPriority_Max_eqI: "\ valid_bitmapQ s ; bitmapQ_no_L1_orphans s ; ksReadyQueuesL1Bitmap s d \ 0 \ - \ lookupBitmapPriority d s = (Max {prio. ksReadyQueues s (d, prio) \ []})" + \ lookupBitmapPriority d s = (Max {prio. \ tcbQueueEmpty (ksReadyQueues s (d, prio))})" apply (rule Max_eqI[simplified eq_commute]; simp) apply (fastforce simp: bitmapL1_highest_lookup valid_bitmapQ_bitmapQ_simp) apply (metis valid_bitmapQ_bitmapQ_simp bitmapQ_from_bitmap_lookup) done lemma corres_gets_queues_getReadyQueuesL1Bitmap: - "corres (\qs l1. ((l1 = 0) = (\p. qs p = []))) \ valid_queues + "corres (\qs l1. (l1 = 0) = (\p. qs p = [])) \ valid_bitmaps (gets (\s. ready_queues s d)) (getReadyQueuesL1Bitmap d)" - unfolding state_relation_def valid_queues_def getReadyQueuesL1Bitmap_def - by (clarsimp simp: bitmapL1_zero_ksReadyQueues ready_queues_relation_def) + unfolding state_relation_def valid_bitmaps_def getReadyQueuesL1Bitmap_def + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def) + apply (drule_tac x=d in spec) + apply (fastforce simp: bitmapL1_zero_ksReadyQueues list_queue_relation_def tcbQueueEmpty_def) + done lemma guarded_switch_to_chooseThread_fragment_corres: "corres dc (P and st_tcb_at runnable t and invs and valid_sched) - (P' and st_tcb_at' runnable' t and invs_no_cicd') - (guarded_switch_to t) - (do runnable \ isRunnable t; - y \ assert runnable; - ThreadDecls_H.switchToThread t - od)" + (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) @@ -1538,35 +1523,50 @@ lemma guarded_switch_to_chooseThread_fragment_corres: 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' + \ Max {prio. ready_queues s d prio \ []} + = Max {prio. \ tcbQueueEmpty (ksReadyQueues s' (d, prio))}" + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def + list_queue_relation_def tcbQueueEmpty_def) + apply (rule Max_eq_if) + apply fastforce + apply fastforce + apply (fastforce dest: heap_path_head) + apply clarsimp + apply (drule_tac x=d in spec) + apply (drule_tac x=b in spec) + apply force + done + lemma bitmap_lookup_queue_is_max_non_empty: - "\ valid_queues s'; (s, s') \ state_relation; invs s; + "\ 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 all_invs_but_ct_idle_or_in_cur_domain'_def 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 \ - \ 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 (simp add: valid_queues_no_bitmap_def) - apply (erule_tac x="ksCurDomain s" in allE) - apply (erule_tac x="lookupBitmapPriority (ksCurDomain s) s" in allE) - apply (clarsimp simp: st_tcb_at'_def) - apply (erule obj_at'_weaken) - apply simp - 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 \" @@ -1578,52 +1578,72 @@ lemma invs_no_cicd_ksCurDomain_maxDomain': "invs_no_cicd' s \ ksCurDomain s \ maxDomain" unfolding invs_no_cicd'_def by simp +crunches curDomain + for valid_bitmaps[wp]: valid_bitmaps + lemma chooseThread_corres: - "corres dc (invs and valid_sched) (invs_no_cicd') - choose_thread chooseThread" (is "corres _ ?PREI ?PREH _ _") + "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 - unfolding choose_thread_def chooseThread_def - 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 \ 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 dest!: invs_no_cicd'_queues simp: bitmap_lookup_queue_is_max_non_empty) - 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 (clarsimp simp: if_apply_def2) - apply (wp hoare_vcg_conj_lift hoare_vcg_imp_lift ksReadyQueuesL1Bitmap_return_wp) - apply (wpsimp wp: curDomain_or_return_0 simp: curDomain_def)+ - apply (fastforce simp: invs_no_cicd'_def) - apply (clarsimp simp: valid_sched_def DetSchedInvs_AI.valid_queues_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 (simp add: invs_no_cicd_ksCurDomain_maxDomain') - apply (clarsimp dest!: invs_no_cicd'_queues) - apply (fastforce intro: ksReadyQueuesL1Bitmap_st_tcb_at') - done + 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 (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 = @@ -1712,7 +1732,7 @@ lemma isHighestPrio_corres: assumes "d' = d" assumes "p' = p" shows - "corres ((=)) \ valid_queues + "corres ((=)) \ valid_bitmaps (gets (is_highest_prio d p)) (isHighestPrio d' p')" using assms @@ -1722,18 +1742,16 @@ lemma isHighestPrio_corres: apply (rule corres_split[OF corres_gets_queues_getReadyQueuesL1Bitmap]) apply (rule corres_if_r'[where P'="\_. True",rotated]) apply (rule_tac corres_symb_exec_r) - apply (rule_tac - P="\s. q = ready_queues s d - " and - P'="\s. valid_queues s \ - l1 = ksReadyQueuesL1Bitmap s d \ - l1 \ 0 \ hprio = lookupBitmapPriority d s" and - F="hprio = Max {prio. q prio \ []}" in corres_req) - apply (elim conjE) - apply (clarsimp simp: valid_queues_def) - apply (subst lookupBitmapPriority_Max_eqI; blast?) - apply (fastforce simp: ready_queues_relation_def dest!: state_relationD) - apply fastforce + apply (rule_tac P="\s. q = ready_queues s d" + and P'="\s. valid_bitmaps s \ l1 = ksReadyQueuesL1Bitmap s d \ + l1 \ 0 \ hprio = lookupBitmapPriority d s" + and F="hprio = Max {prio. q prio \ []}" in corres_req) + apply (elim conjE) + apply (clarsimp simp: valid_bitmaps_def) + apply (subst lookupBitmapPriority_Max_eqI; blast?) + apply (fastforce dest: state_relation_ready_queues_relation Max_prio_helper[where d=d] + simp: tcbQueueEmpty_def) + apply fastforce apply (wpsimp simp: if_apply_def2 wp: hoare_drop_imps ksReadyQueuesL1Bitmap_return_wp)+ done @@ -1744,9 +1762,8 @@ crunch inv[wp]: curDomain P crunch inv[wp]: scheduleSwitchThreadFastfail P lemma setSchedulerAction_invs': (* not in wp set, clobbered by ssa_wp *) - "\\s. invs' s \ setSchedulerAction ChooseNewThread \\_. invs' \" + "setSchedulerAction ChooseNewThread \invs' \" by (wpsimp simp: invs'_def cur_tcb'_def valid_state'_def valid_irq_node'_def ct_not_inQ_def - valid_queues_def valid_queues_no_bitmap_def valid_queues'_def ct_idle_or_in_cur_domain'_def) lemma scheduleChooseNewThread_corres: @@ -1776,6 +1793,46 @@ lemma ethread_get_when_corres: 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 + +crunches 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) + +crunches 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) + 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] @@ -1804,7 +1861,7 @@ lemma schedule_corres: apply (rule corres_split[OF thread_get_isRunnable_corres]) apply (rule corres_split) apply (rule corres_when, simp) - apply (rule tcbSchedEnqueue_corres) + 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)+ @@ -1813,7 +1870,7 @@ lemma schedule_corres: rename_tac was_running wasRunning) apply (rule corres_split) apply (rule corres_when, simp) - apply (rule tcbSchedEnqueue_corres) + 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) @@ -1829,7 +1886,7 @@ lemma schedule_corres: 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]) + apply (rule corres_split[OF tcbSchedEnqueue_corres], simp) apply (simp, fold dc_def) apply (rule corres_split) apply (rule setSchedulerAction_corres; simp) @@ -1843,7 +1900,7 @@ lemma schedule_corres: 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]) + apply (rule corres_split[OF tcbSchedAppend_corres], simp) apply (simp, fold dc_def) apply (rule corres_split) apply (rule setSchedulerAction_corres; simp) @@ -1875,7 +1932,8 @@ lemma schedule_corres: 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)+ + del: gets_wp + | strengthen valid_objs'_valid_tcbs')+ apply (clarsimp simp: conj_ac if_apply_def2 cong: imp_cong conj_cong del: hoare_gets) apply (wp gets_wp)+ @@ -1898,18 +1956,17 @@ lemma schedule_corres: 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 (clarsimp simp add: pred_tcb_at_def obj_at_def is_tcb valid_idle_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)+ - apply (simp add: valid_sched_def valid_blocked_def valid_blocked_except_def) done (* haskell final subgoal *) - apply (clarsimp simp: if_apply_def2 invs'_def valid_state'_def + 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 @@ -1923,11 +1980,8 @@ proof - apply (simp add: setSchedulerAction_def) apply wp apply (clarsimp simp add: invs'_def valid_state'_def cur_tcb'_def - Invariants_H.valid_queues_def - state_refs_of'_def ps_clear_def - valid_irq_node'_def valid_queues'_def - tcb_in_cur_domain'_def ct_idle_or_in_cur_domain'_def - bitmapQ_defs valid_queues_no_bitmap_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 @@ -1967,7 +2021,7 @@ lemma switchToThread_ct_not_queued_2: apply (simp add: Thread_H.switchToThread_def) apply (wp) apply (simp add: RISCV64_H.switchToThread_def setCurThread_def) - apply (wp tcbSchedDequeue_not_tcbQueued | simp )+ + apply (wp tcbSchedDequeue_not_tcbQueued hoare_drop_imp | simp )+ done lemma setCurThread_obj_at': @@ -1981,11 +2035,12 @@ proof - qed lemma switchToIdleThread_ct_not_queued_no_cicd': - "\ invs_no_cicd' \ switchToIdleThread \\rv s. obj_at' (Not \ tcbQueued) (ksCurThread s) s \" + "\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 (rule idle'_not_tcbQueued') - apply (simp add: invs_no_cicd'_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]: @@ -2002,7 +2057,7 @@ lemma switchToThread_tcb_in_cur_domain': ThreadDecls_H.switchToThread thread \\y s. tcb_in_cur_domain' (ksCurThread s) s\" apply (simp add: Thread_H.switchToThread_def setCurThread_def) - apply (wpsimp wp: tcbSchedDequeue_not_tcbQueued) + apply (wpsimp wp: tcbSchedDequeue_not_tcbQueued hoare_drop_imps) done lemma chooseThread_invs_no_cicd'_posts: (* generic version *) @@ -2024,11 +2079,14 @@ proof - by (simp add: all_invs_but_ct_idle_or_in_cur_domain'_def maxDomain_def) show ?thesis - unfolding chooseThread_def Let_def curDomain_def + apply (clarsimp simp: chooseThread_def Let_def curDomain_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp])+ apply (simp only: return_bind, simp) - apply (rule hoare_seq_ext[where B="\rv s. invs_no_cicd' s \ rv = ksCurDomain s"]) + apply (rule hoare_seq_ext[where B="\rv s. invs_no_cicd' s \ rv = ksCurDomain s + \ ksReadyQueues_asrt s \ ready_qs_runnable s"]) apply (rule_tac B="\rv s. invs_no_cicd' s \ curdom = ksCurDomain s \ - rv = ksReadyQueuesL1Bitmap s curdom" in hoare_seq_ext) + rv = ksReadyQueuesL1Bitmap s curdom \ + ksReadyQueues_asrt s \ ready_qs_runnable s" in hoare_seq_ext) apply (rename_tac l1) apply (case_tac "l1 = 0") (* switch to idle thread *) @@ -2042,12 +2100,10 @@ proof - 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 - apply (clarsimp dest!: invs_no_cicd'_queues - simp: valid_queues_def lookupBitmapPriority_def[symmetric]) - 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 (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 @@ -2086,11 +2142,14 @@ proof - (* FIXME this is almost identical to the chooseThread_invs_no_cicd'_posts proof, can generalise? *) show ?thesis - unfolding chooseThread_def Let_def curDomain_def + apply (clarsimp simp: chooseThread_def Let_def curDomain_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp])+ apply (simp only: return_bind, simp) - apply (rule hoare_seq_ext[where B="\rv s. invs_no_cicd' s \ rv = ksCurDomain s"]) + apply (rule hoare_seq_ext[where B="\rv s. invs_no_cicd' s \ rv = ksCurDomain s + \ ksReadyQueues_asrt s \ ready_qs_runnable s"]) apply (rule_tac B="\rv s. invs_no_cicd' s \ curdom = ksCurDomain s \ - rv = ksReadyQueuesL1Bitmap s curdom" in hoare_seq_ext) + rv = ksReadyQueuesL1Bitmap s curdom \ + ksReadyQueues_asrt s \ ready_qs_runnable s" in hoare_seq_ext) apply (rename_tac l1) apply (case_tac "l1 = 0") (* switch to idle thread *) @@ -2098,7 +2157,10 @@ proof - (* we have a thread to switch to *) apply (clarsimp simp: bitmap_fun_defs) apply (wp assert_inv) - apply (clarsimp dest!: invs_no_cicd'_queues simp: valid_queues_def) + 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 @@ -2248,12 +2310,15 @@ lemma sbn_sch_act_sane: lemma possibleSwitchTo_corres: "corres dc - (valid_etcbs and weak_valid_sched_action and cur_tcb and st_tcb_at runnable t - and pspace_aligned and pspace_distinct) - (valid_queues and valid_queues' and (\s. weak_sch_act_wf (ksSchedulerAction s) s) - and valid_objs') - (possible_switch_to t) - (possibleSwitchTo t)" + (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) @@ -2266,12 +2331,12 @@ lemma possibleSwitchTo_corres: apply (clarsimp simp: etcb_relation_def) apply (rule corres_split[OF getSchedulerAction_corres]) apply (rule corres_if, simp) - apply (rule tcbSchedEnqueue_corres) + 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) - apply (wp rescheduleRequired_valid_queues'_weak)+ + 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])+ @@ -2280,7 +2345,7 @@ lemma possibleSwitchTo_corres: 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 (simp add: tcb_at_is_etcb_at) + apply (fastforce simp: tcb_at_is_etcb_at) done end diff --git a/proof/refine/RISCV64/StateRelation.thy b/proof/refine/RISCV64/StateRelation.thy index 18b70fc2b3..c02b8cbbb0 100644 --- a/proof/refine/RISCV64/StateRelation.thy +++ b/proof/refine/RISCV64/StateRelation.thy @@ -155,13 +155,20 @@ definition tcb_relation :: "Structures_A.tcb \ Structures_H.tcb \ tcb_bound_notification tcb = tcbBoundNotification tcb' \ tcb_mcpriority tcb = tcbMCP tcb'" +\ \ + A pair of objects @{term "(obj, obj')"} should satisfy the following relation when, under further + mild assumptions, a @{term corres_underlying} lemma for @{term "set_object obj"} + and @{term "setObject obj'"} can be stated: see setObject_other_corres in KHeap_R. + + TCBs do not satisfy this relation because the tcbSchedPrev and tcbSchedNext fields of a TCB are + used to model the ready queues, and so an update to such a field would correspond to an update + to a ready queue (see ready_queues_relation below).\ definition other_obj_relation :: "Structures_A.kernel_object \ Structures_H.kernel_object \ bool" where "other_obj_relation obj obj' \ (case (obj, obj') of - (TCB tcb, KOTCB tcb') \ tcb_relation tcb tcb' - | (Endpoint ep, KOEndpoint ep') \ ep_relation ep ep' + (Endpoint ep, KOEndpoint ep') \ ep_relation ep ep' | (Notification ntfn, KONotification ntfn') \ ntfn_relation ntfn ntfn' | (ArchObj (RISCV64_A.ASIDPool ap), KOArch (KOASIDPool ap')) \ asid_pool_relation ap ap' | _ \ False)" @@ -188,22 +195,28 @@ primrec aobj_relation_cuts :: "RISCV64_A.arch_kernel_obj \ machine_w | "aobj_relation_cuts (PageTable pt) x = (\y. (x + (ucast y << pteBits), pte_relation y)) ` UNIV" +definition tcb_relation_cut :: "Structures_A.kernel_object \ kernel_object \ bool" where + "tcb_relation_cut obj obj' \ + case (obj, obj') of + (TCB t, KOTCB t') \ tcb_relation t t' + | _ \ False" + primrec obj_relation_cuts :: "Structures_A.kernel_object \ machine_word \ obj_relation_cuts" where "obj_relation_cuts (CNode sz cs) x = (if well_formed_cnode_n sz cs then {(cte_map (x, y), cte_relation y) | y. y \ dom cs} else {(x, \\)})" -| "obj_relation_cuts (TCB tcb) x = {(x, other_obj_relation)}" +| "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 (ArchObj ao) x = aobj_relation_cuts ao x" - lemma obj_relation_cuts_def2: "obj_relation_cuts ko x = (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, \\)} + | TCB tcb \ {(x, tcb_relation_cut)} | ArchObj (PageTable pt) \ (\y. (x + (ucast y << pteBits), pte_relation y)) ` UNIV | ArchObj (DataPage dev sz) \ {(x + (n << pageBits), \_ obj. obj =(if dev then KOUserDataDevice else KOUserData)) @@ -216,6 +229,7 @@ lemma obj_relation_cuts_def3: "obj_relation_cuts ko x = (case a_type ko of ACapTable n \ {(cte_map (x, y), cte_relation y) | y. length y = n} + | ATCB \ {(x, tcb_relation_cut)} | AArch APageTable \ (\y. (x + (ucast y << pteBits), pte_relation y)) ` UNIV | AArch (AUserData sz) \ {(x + (n << pageBits), \_ obj. obj = KOUserData) | n . n < 2 ^ (pageBitsForSize sz - pageBits) } @@ -230,6 +244,7 @@ definition is_other_obj_relation_type :: "a_type \ bool" where "is_other_obj_relation_type tp \ case tp of ACapTable n \ False + | ATCB \ False | AArch APageTable \ False | AArch (AUserData _) \ False | AArch (ADeviceData _) \ False @@ -240,6 +255,10 @@ 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_TCB: + "\ is_other_obj_relation_type ATCB" + by (simp add: is_other_obj_relation_type_def) + lemma is_other_obj_relation_type_UserData: "\ is_other_obj_relation_type (AArch (AUserData sz))" unfolding is_other_obj_relation_type_def by simp @@ -279,10 +298,55 @@ primrec sched_act_relation :: "Deterministic_A.scheduler_action \ sc "sched_act_relation choose_new_thread a' = (a' = ChooseNewThread)" | "sched_act_relation (switch_thread x) a' = (a' = SwitchToThread x)" -definition ready_queues_relation :: - "(Deterministic_A.domain \ Structures_A.priority \ Deterministic_A.ready_queue) \ - (domain \ priority \ KernelStateData_H.ready_queue) \ bool" where - "ready_queues_relation qs qs' \ \d p. (qs d p = qs' (d, p))" +definition queue_end_valid :: "obj_ref list \ tcb_queue \ bool" where + "queue_end_valid ts q \ + (ts = [] \ tcbQueueEnd q = None) \ (ts \ [] \ tcbQueueEnd q = Some (last ts))" + +definition prev_queue_head :: "tcb_queue \ (obj_ref \ 'a) \ bool" where + "prev_queue_head q prevs \ \head. tcbQueueHead q = Some head \ prevs head = None" + +lemma prev_queue_head_heap_upd: + "\prev_queue_head q prevs; Some r \ tcbQueueHead q\ \ prev_queue_head q (prevs(r := x))" + by (clarsimp simp: prev_queue_head_def) + +definition list_queue_relation :: + "obj_ref list \ tcb_queue \ (obj_ref \ obj_ref) \ (obj_ref \ obj_ref) \ bool" + where + "list_queue_relation ts q nexts prevs \ + heap_ls nexts (tcbQueueHead q) ts \ queue_end_valid ts q \ prev_queue_head q prevs" + +lemma list_queue_relation_nil: + "list_queue_relation ts q nexts prevs \ ts = [] \ tcbQueueEmpty q" + by (fastforce dest: heap_path_head simp: tcbQueueEmpty_def list_queue_relation_def) + +definition ready_queue_relation :: + "Deterministic_A.domain \ Structures_A.priority + \ Deterministic_A.ready_queue \ ready_queue + \ (obj_ref \ obj_ref) \ (obj_ref \ obj_ref) + \ (obj_ref \ bool) \ bool" + where + "ready_queue_relation d p q q' nexts prevs flag \ + list_queue_relation q q' nexts prevs + \ (\t. flag t \ t \ set q) + \ (d > maxDomain \ p > maxPriority \ tcbQueueEmpty q')" + +definition ready_queues_relation_2 :: + "(Deterministic_A.domain \ Structures_A.priority \ Deterministic_A.ready_queue) + \ (domain \ priority \ ready_queue) + \ (obj_ref \ obj_ref) \ (obj_ref \ obj_ref) + \ (domain \ priority \ obj_ref \ bool) \ bool" + where + "ready_queues_relation_2 qs qs' nexts prevs inQs \ + \d p. let q = qs d p; q' = qs' (d, p); flag = inQs d p in + ready_queue_relation d p q q' nexts prevs flag" + +abbreviation ready_queues_relation :: "det_state \ kernel_state \ bool" where + "ready_queues_relation s s' \ + ready_queues_relation_2 + (ready_queues s) (ksReadyQueues s') (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + (\d p. inQ d p |< tcbs_of' s')" + +lemmas ready_queues_relation_def = ready_queues_relation_2_def definition ghost_relation :: "Structures_A.kheap \ (machine_word \ vmpage_size) \ (machine_word \ nat) \ bool" where @@ -337,6 +401,8 @@ lemma obj_relation_cutsE: \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; + \tcb tcb'. \ y = x; ko = TCB tcb; ko' = KOTCB tcb'; tcb_relation tcb tcb' \ + \ R; \pt (z :: pt_index) pte'. \ ko = ArchObj (PageTable pt); y = x + (ucast z << pteBits); ko' = KOArch (KOPTE pte'); pte_relation' (pt z) pte' \ \ R; @@ -346,8 +412,9 @@ lemma obj_relation_cutsE: \ y = x; other_obj_relation ko ko'; is_other_obj_relation_type (a_type ko) \ \ R \ \ R" by (force simp: obj_relation_cuts_def2 is_other_obj_relation_type_def a_type_def - cte_relation_def pte_relation_def - split: Structures_A.kernel_object.splits if_splits RISCV64_A.arch_kernel_obj.splits) + tcb_relation_cut_def cte_relation_def pte_relation_def + split: Structures_A.kernel_object.splits kernel_object.splits if_splits + RISCV64_A.arch_kernel_obj.splits) lemma eq_trans_helper: "\ x = y; P y = Q \ \ P x = Q" @@ -414,7 +481,7 @@ definition state_relation :: "(det_state \ kernel_state) set" where pspace_relation (kheap s) (ksPSpace s') \ ekheap_relation (ekheap s) (ksPSpace s') \ sched_act_relation (scheduler_action s) (ksSchedulerAction s') - \ ready_queues_relation (ready_queues s) (ksReadyQueues s') + \ ready_queues_relation s 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') @@ -436,6 +503,10 @@ lemma curthread_relation: "(a, b) \ state_relation \ ksCurThread b = cur_thread a" by (simp add: state_relation_def) +lemma curdomain_relation[elim!]: + "(s, s') \ state_relation \ cur_domain s = ksCurDomain s'" + by (clarsimp simp: state_relation_def) + lemma state_relation_pspace_relation[elim!]: "(s,s') \ state_relation \ pspace_relation (kheap s) (ksPSpace s')" by (simp add: state_relation_def) @@ -444,12 +515,24 @@ 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')" + by (clarsimp simp: state_relation_def) + +lemma state_relation_ready_queues_relation[elim!]: + "(s, s') \ state_relation \ ready_queues_relation s s'" + by (simp add: state_relation_def) + +lemma state_relation_idle_thread[elim!]: + "(s, s') \ state_relation \ idle_thread s = ksIdleThread s'" + by (clarsimp simp: state_relation_def) + lemma state_relationD: "(s, s') \ state_relation \ pspace_relation (kheap s) (ksPSpace s') \ ekheap_relation (ekheap s) (ksPSpace s') \ sched_act_relation (scheduler_action s) (ksSchedulerAction s') \ - ready_queues_relation (ready_queues s) (ksReadyQueues s') \ + ready_queues_relation s 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') \ @@ -471,7 +554,7 @@ lemma state_relationE [elim?]: and rl: "\ pspace_relation (kheap s) (ksPSpace s'); ekheap_relation (ekheap s) (ksPSpace s'); sched_act_relation (scheduler_action s) (ksSchedulerAction s'); - ready_queues_relation (ready_queues s) (ksReadyQueues s'); + ready_queues_relation s 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'); diff --git a/proof/refine/RISCV64/Syscall_R.thy b/proof/refine/RISCV64/Syscall_R.thy index b4efb3eac8..0cc5baccd4 100644 --- a/proof/refine/RISCV64/Syscall_R.thy +++ b/proof/refine/RISCV64/Syscall_R.thy @@ -351,15 +351,13 @@ lemma threadSet_tcbDomain_update_sch_act_wf[wp]: lemma setDomain_corres: "corres dc (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)" + (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 corres_guard_imp) apply (rule corres_split[OF getCurThread_corres]) - apply (rule corres_split[OF tcbSchedDequeue_corres]) + apply (rule corres_split[OF tcbSchedDequeue_corres], simp) apply (rule corres_split) apply (rule ethread_set_corres; simp) apply (clarsimp simp: etcb_relation_def) @@ -368,26 +366,38 @@ lemma setDomain_corres: apply (rule corres_split) apply clarsimp apply (rule corres_when[OF refl]) - apply (rule tcbSchedEnqueue_corres) + apply (rule tcbSchedEnqueue_corres, simp) apply (rule corres_when[OF refl]) apply (rule rescheduleRequired_corres) - apply ((wp hoare_drop_imps hoare_vcg_conj_lift | clarsimp| assumption)+)[5] - apply clarsimp - apply (rule_tac Q="\_. valid_objs' and valid_queues' and valid_queues and - (\s. sch_act_wf (ksSchedulerAction s) s) and tcb_at' tptr" - in hoare_strengthen_post[rotated]) - apply (auto simp: invs'_def valid_state'_def sch_act_wf_weak st_tcb_at'_def o_def)[1] - apply (wp threadSet_valid_objs' threadSet_valid_queues'_no_state - threadSet_valid_queues_no_state - threadSet_pred_tcb_no_state | simp)+ - apply (rule_tac Q = "\r s. invs' s \ (\p. tptr \ set (ksReadyQueues s p)) \ 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) - apply (drule(1) bspec) - apply (clarsimp simp:tcb_cte_cases_def cteSizeBits_def) + 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 Tcb_R.tcbSchedDequeue_not_in_queue)+ + apply (wp hoare_vcg_all_lift tcbSchedDequeue_not_queued)+ apply clarsimp apply (frule tcb_at_is_etcb_at) apply simp+ @@ -395,7 +405,6 @@ lemma setDomain_corres: simp: valid_sched_def valid_sched_action_def) done - lemma performInvocation_corres: "\ inv_relation i i'; call \ block \ \ corres (dc \ (=)) @@ -762,90 +771,71 @@ 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 - \\rv. invs'\" + doReplyTransfer t' t slot grant + \\_. invs'\" apply (simp add: doReplyTransfer_def liftM_def) apply (rule hoare_seq_ext [OF _ gts_sp']) apply (rule hoare_seq_ext [OF _ assert_sp]) apply (rule hoare_seq_ext [OF _ getCTE_sp]) apply (wp, wpc) - apply (wp) + apply wp apply (wp (once) sts_invs_minor'') - apply (simp) + apply simp apply (wp (once) sts_st_tcb') - apply (wp)[1] - apply (rule_tac Q="\rv s. invs' s - \ t \ ksIdleThread s - \ st_tcb_at' awaiting_reply' t s" + 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 (frule_tac t=t in invs'_not_runnable_not_queued) - apply (erule pred_tcb'_weakenE, case_tac st, clarsimp+) + apply clarsimp apply (rule conjI, erule pred_tcb'_weakenE, case_tac st, clarsimp+) - apply (rule conjI, rule impI, erule pred_tcb'_weakenE, case_tac st) - apply (clarsimp | drule(1) obj_at_conj')+ 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 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 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]) + 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 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="\rv s. invs' s \ sch_act_simple s - \ st_tcb_at' awaiting_reply' t s - \ t \ ksIdleThread s" - in hoare_post_imp) - apply (clarsimp) - apply (frule_tac t=t in invs'_not_runnable_not_queued) - apply (erule pred_tcb'_weakenE, case_tac st, clarsimp+) + 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 (rule conjI, rule impI, erule pred_tcb'_weakenE, case_tac st) - apply (clarsimp | drule(1) obj_at_conj')+ 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 clarsimp apply (erule_tac P="\st. awaiting_reply' st \ activatable' st" - in pred_tcb'_weakenE) + 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 clarsimp apply (rule conjI) - apply (clarsimp simp: invs'_def valid_state'_def valid_idle'_def) - apply (rule conjI) - apply clarsimp - apply (clarsimp simp: obj_at'_def idle_tcb'_def pred_tcb_at'_def) + 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 (rule conjI) apply (clarsimp simp : invs'_def valid_state'_def valid_idle'_def pred_tcb_at'_def obj_at'_def idle_tcb'_def) - apply (rule conjI) - apply clarsimp - apply (frule invs'_not_runnable_not_queued) - apply (erule pred_tcb'_weakenE, clarsimp) - apply (frule (1) not_tcbQueued_not_ksQ) - apply simp - apply clarsimp 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) @@ -855,35 +845,9 @@ lemma ct_active_runnable' [simp]: "ct_active' s \ ct_in_state' runnable' s" by (fastforce simp: ct_in_state'_def elim!: pred_tcb'_weakenE) -lemma valid_irq_node_tcbSchedEnqueue[wp]: - "\\s. valid_irq_node' (irq_node' s) s \ tcbSchedEnqueue ptr - \\rv s'. valid_irq_node' (irq_node' s') s'\" - apply (rule hoare_pre) - apply (simp add:valid_irq_node'_def ) - apply (wp unless_wp hoare_vcg_all_lift | wps)+ - apply (simp add:tcbSchedEnqueue_def) - apply (wp unless_wp| simp)+ - apply (simp add:valid_irq_node'_def) - done - -lemma rescheduleRequired_valid_queues_but_ct_domain: - "\\s. Invariants_H.valid_queues s \ valid_objs' s - \ (\x. ksSchedulerAction s = SwitchToThread x \ st_tcb_at' runnable' x s) \ - rescheduleRequired - \\_. Invariants_H.valid_queues\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp)+ - done - -lemma rescheduleRequired_valid_queues'_but_ct_domain: - "\\s. valid_queues' s - \ (\x. ksSchedulerAction s = SwitchToThread x \ st_tcb_at' runnable' x s) - \ - rescheduleRequired - \\_. valid_queues'\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp | fastforce simp: valid_queues'_def)+ - done +crunches tcbSchedEnqueue + for valid_irq_node[wp]: "\s. valid_irq_node' (irq_node' s) s" + (rule: valid_irq_node_lift) lemma tcbSchedEnqueue_valid_action: "\\s. \x. ksSchedulerAction s = SwitchToThread x \ st_tcb_at' runnable' x s\ @@ -894,9 +858,10 @@ lemma tcbSchedEnqueue_valid_action: done abbreviation (input) "all_invs_but_sch_extra \ - \s. valid_pspace' s \ Invariants_H.valid_queues s \ + \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 \ @@ -908,7 +873,7 @@ abbreviation (input) "all_invs_but_sch_extra \ valid_machine_state' s \ cur_tcb' s \ untyped_ranges_zero' s \ - valid_queues' s \ pspace_domain_valid s \ + pspace_domain_valid s \ ksCurDomain s \ maxDomain \ valid_dom_schedule' s \ (\x. ksSchedulerAction s = SwitchToThread x \ st_tcb_at' runnable' x s)" @@ -917,18 +882,13 @@ lemma rescheduleRequired_all_invs_but_extra: "\\s. all_invs_but_sch_extra s\ rescheduleRequired \\_. invs'\" apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp add:rescheduleRequired_ct_not_inQ - rescheduleRequired_sch_act' - rescheduleRequired_valid_queues_but_ct_domain - rescheduleRequired_valid_queues'_but_ct_domain - valid_irq_node_lift valid_irq_handlers_lift'' - irqs_masked_lift cur_tcb_lift) + 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 (\s. (\p. t \ set (ksReadyQueues s p))) and + shows "\ tcb_at' t and all_invs_but_sch_extra and sch_act_simple and K (ds \ maxDomain) \ threadSet (tcbDomain_update (\_. ds)) t @@ -948,13 +908,11 @@ lemma threadSet_all_invs_but_sch_extra: valid_irq_handlers_lift'' threadSet_ctes_ofT threadSet_not_inQ - threadSet_valid_queues'_no_state threadSet_tcbDomain_update_ct_idle_or_in_cur_domain' - threadSet_valid_queues threadSet_valid_dom_schedule' threadSet_iflive'T threadSet_ifunsafe'T - untyped_ranges_zero_lift + 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) @@ -982,9 +940,7 @@ lemma setDomain_invs': \ (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 (erule st_tcb_ex_cap'') apply simp - apply (case_tac st,simp_all)[1] apply (rule hoare_strengthen_post[OF hoare_vcg_conj_lift]) apply (rule threadSet_all_invs_but_sch_extra) prefer 2 @@ -1002,17 +958,14 @@ lemma setDomain_invs': done lemma performInv_invs'[wp]: - "\invs' and sch_act_simple - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p)) - and ct_active' and valid_invocation' i\ - RetypeDecls_H.performInvocation block call i \\rv. invs'\" + "\invs' and sch_act_simple and ct_active' and valid_invocation' i\ + RetypeDecls_H.performInvocation block call i + \\_. invs'\" unfolding performInvocation_def apply (cases i) - apply ((clarsimp simp: simple_sane_strg sch_act_simple_def - ct_not_ksQ sch_act_sane_def - | wp tcbinv_invs' arch_performInvocation_invs' - setDomain_invs' - | rule conjI | erule active_ex_cap')+) + 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]: @@ -1240,7 +1193,6 @@ lemma handleInvocation_corres: and (\s. ksSchedulerAction s = ResumeCurrentThread)" in hoare_post_imp) apply (clarsimp simp: ct_in_state'_def) - apply (frule(1) ct_not_ksQ) apply (clarsimp) apply (wp setThreadState_nonqueued_state_update setThreadState_st_tcb setThreadState_rct)[1] @@ -1252,14 +1204,13 @@ lemma handleInvocation_corres: 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) + 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) apply (frule tcb_at_invs') apply (clarsimp simp: invs'_def valid_state'_def ct_in_state'_def ct_not_inQ_def) - apply (frule(1) valid_queues_not_tcbQueued_not_ksQ) 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) @@ -1319,11 +1270,8 @@ lemma hinv_invs'[wp]: and st_tcb_at' active' thread" in hoare_post_imp) apply (clarsimp simp: ct_in_state'_def) - apply (frule(1) ct_not_ksQ) - apply (clarsimp) apply (wp sts_invs_minor' setThreadState_st_tcb setThreadState_rct | simp)+ apply (clarsimp) - apply (frule(1) ct_not_ksQ) apply (fastforce simp add: tcb_at_invs' ct_in_state'_def simple_sane_strg sch_act_simple_def @@ -1467,7 +1415,6 @@ lemma handleRecv_isBlocking_corres': and (\s. ex_nonz_cap_to (cur_thread s) s)) (invs' and ct_in_state' simple' and sch_act_sane - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p)) and (\s. ex_nonz_cap_to' (ksCurThread s) s)) (handle_recv isBlocking) (handleRecv isBlocking)" (is "corres dc (?pre1) (?pre2) (handle_recv _) (handleRecv _)") @@ -1530,8 +1477,7 @@ lemma handleRecv_isBlocking_corres': lemma handleRecv_isBlocking_corres: "corres dc (einvs and ct_active) - (invs' and ct_active' and sch_act_sane and - (\s. \p. ksCurThread s \ set (ksReadyQueues s p))) + (invs' and ct_active' and sch_act_sane) (handle_recv isBlocking) (handleRecv isBlocking)" apply (rule corres_guard_imp) apply (rule handleRecv_isBlocking_corres') @@ -1546,42 +1492,27 @@ lemma lookupCap_refs[wp]: "\invs'\ lookupCap t ref \\rv s. \r\zobj_refs' rv. ex_nonz_cap_to' r s\,-" by (simp add: lookupCap_def split_def | wp | simp add: o_def)+ -lemma deleteCallerCap_ksQ_ct': - "\invs' and ct_in_state' simple' and sch_act_sane and - (\s. ksCurThread s \ set (ksReadyQueues s p) \ thread = ksCurThread s)\ - deleteCallerCap thread - \\rv s. thread \ set (ksReadyQueues s p)\" - apply (rule_tac Q="\rv s. thread = ksCurThread s \ ksCurThread s \ set (ksReadyQueues s p)" - in hoare_strengthen_post) - apply (wp deleteCallerCap_ct_not_ksQ) - apply auto - done - lemma hw_invs'[wp]: "\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) - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p))\ + 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 - deleteCallerCap_ksQ_ct' hoare_lift_Pf2[OF deleteCallerCap_simple deleteCallerCap_ct'] | wpc | simp)+)[1] apply simp apply (wp deleteCallerCap_nonz_cap hoare_vcg_all_lift - deleteCallerCap_ksQ_ct' 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 - \ (\p. ksCurThread s \ set (ksReadyQueues s p)) \ thread = ksCurThread s \ ct_in_state' simple' s \ ex_nonz_cap_to' thread s @@ -1605,34 +1536,45 @@ lemma setSchedulerAction_obj_at'[wp]: by (wp, clarsimp elim!: obj_at'_pspaceI) lemma handleYield_corres: - "corres dc einvs (invs' and ct_active' and (\s. ksSchedulerAction s = ResumeCurrentThread)) handle_yield handleYield" + "corres dc + (einvs and ct_active) + (invs' and (\s. ksSchedulerAction s = ResumeCurrentThread)) + handle_yield handleYield" apply (clarsimp simp: handle_yield_def handleYield_def) apply (rule corres_guard_imp) apply (rule corres_split[OF getCurThread_corres]) apply simp - apply (rule corres_split[OF tcbSchedDequeue_corres]) - apply (rule corres_split[OF tcbSchedAppend_corres]) + apply (rule corres_split[OF tcbSchedDequeue_corres], simp) + apply (rule corres_split[OF tcbSchedAppend_corres], simp) apply (rule rescheduleRequired_corres) - apply (wp weak_sch_act_wf_lift_linear tcbSchedDequeue_valid_queues | simp add: )+ + 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) - apply clarsimp - apply (frule ct_active_runnable') - apply (clarsimp simp: invs'_def valid_state'_def ct_in_state'_def sch_act_wf_weak 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) - apply (erule(1) valid_objs_valid_tcbE[OF valid_pspace_valid_objs']) - apply (simp add:valid_tcb'_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 hy_invs': "\invs' and ct_active'\ handleYield \\r. invs' and ct_active'\" apply (simp add: handleYield_def) - apply (wp ct_in_state_thread_state_lift' - rescheduleRequired_all_invs_but_ct_not_inQ - tcbSchedAppend_invs_but_ct_not_inQ' | simp)+ - apply (clarsimp simp add: 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 - ) + 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 @@ -1828,7 +1770,7 @@ 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 haskell_assert_wp doReplyTransfer_sane getCTE_wp'| wpc)+ + apply (wp doReplyTransfer_sane getCTE_wp'| wpc)+ apply (clarsimp simp: cte_wp_at_ctes_of) done @@ -1844,74 +1786,6 @@ lemma handleReply_nonz_cap_to_ct: crunch ksQ[wp]: handleFaultReply "\s. P (ksReadyQueues s p)" -lemma doReplyTransfer_ct_not_ksQ: - "\ invs' and sch_act_simple - and tcb_at' thread and tcb_at' word - and ct_in_state' simple' - and (\s. ksCurThread s \ word) - and (\s. \p. ksCurThread s \ set(ksReadyQueues s p))\ - doReplyTransfer thread word callerSlot g - \\rv s. \p. ksCurThread s \ set(ksReadyQueues s p)\" -proof - - have astct: "\t p. - \(\s. ksCurThread s \ set(ksReadyQueues s p) \ sch_act_sane s) - and (\s. ksCurThread s \ t)\ - possibleSwitchTo t \\rv s. ksCurThread s \ set(ksReadyQueues s p)\" - apply (rule hoare_weaken_pre) - apply (wps possibleSwitchTo_ct') - apply (wp possibleSwitchTo_ksQ') - apply (clarsimp simp: sch_act_sane_def) - done - have stsct: "\t st p. - \(\s. ksCurThread s \ set(ksReadyQueues s p)) and sch_act_simple\ - setThreadState st t - \\rv s. ksCurThread s \ set(ksReadyQueues s p)\" - apply (rule hoare_weaken_pre) - apply (wps setThreadState_ct') - apply (wp hoare_vcg_all_lift sts_ksQ) - apply (clarsimp) - done - show ?thesis - apply (simp add: doReplyTransfer_def) - apply (wp, wpc) - apply (wp astct stsct hoare_vcg_all_lift - cteDeleteOne_ct_not_ksQ hoare_drop_imp - hoare_lift_Pf2 [OF cteDeleteOne_sch_act_not cteDeleteOne_ct'] - hoare_lift_Pf2 [OF doIPCTransfer_pred_tcb_at' doIPCTransfer_ct'] - hoare_lift_Pf2 [OF doIPCTransfer_ksQ doIPCTransfer_ct'] - hoare_lift_Pf2 [OF threadSet_ksQ threadSet_ct] - hoare_lift_Pf2 [OF handleFaultReply_ksQ handleFaultReply_ct'] - | simp add: ct_in_state'_def)+ - apply (fastforce simp: sch_act_simple_def sch_act_sane_def ct_in_state'_def)+ - done -qed - -lemma handleReply_ct_not_ksQ: - "\invs' and sch_act_simple - and ct_in_state' simple' - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p))\ - handleReply - \\rv s. \p. ksCurThread s \ set (ksReadyQueues s p)\" - apply (simp add: handleReply_def del: split_paired_All) - apply (subst haskell_assert_def) - apply (wp | wpc)+ - apply (wp doReplyTransfer_ct_not_ksQ getThreadCallerSlot_inv)+ - apply (rule_tac Q="\cap. - (\s. \p. ksCurThread s \ set(ksReadyQueues s p)) - and invs' - and sch_act_simple - and (\s. thread = ksCurThread s) - and tcb_at' thread - and ct_in_state' simple' - and cte_wp_at' (\c. cteCap c = cap) callerSlot" - in hoare_post_imp) - apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def - cte_wp_at_ctes_of valid_cap'_def - dest!: ctes_of_valid') - apply (wp getSlotCap_cte_wp_at getThreadCallerSlot_inv)+ - apply (clarsimp) - done - crunch valid_etcbs[wp]: handle_recv "valid_etcbs" (wp: crunch_wps simp: crunch_simps) @@ -1924,11 +1798,10 @@ lemma handleReply_handleRecv_corres: 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 handleReply_ct_not_ksQ handle_reply_valid_sched)+ + 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 (frule(1) ct_not_ksQ) apply (fastforce elim: pred_tcb'_weakenE) done @@ -1936,7 +1809,6 @@ lemma handleHypervisorFault_corres: "corres dc (einvs and st_tcb_at active thread and ex_nonz_cap_to thread and (%_. valid_fault f)) (invs' and sch_act_not thread - and (\s. \p. thread \ set(ksReadyQueues s p)) and st_tcb_at' simple' thread and ex_nonz_cap_to' thread) (handle_hypervisor_fault w fault) (handleHypervisorFault w fault)" apply (cases fault; clarsimp simp add: handleHypervisorFault_def returnOk_def2) @@ -1952,14 +1824,13 @@ lemma handleEvent_corres: (is "?handleEvent_corres") proof - have hw: - "\isBlocking. corres dc (einvs and ct_running and (\s. scheduler_action s = resume_cur_thread)) + "\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 - dest!: ct_not_ksQ)+ + elim!: st_tcb_weakenE pred_tcb'_weakenE)+ done show ?thesis apply (case_tac event) @@ -1974,7 +1845,7 @@ proof - corres_guard_imp[OF handleCall_corres] corres_guard_imp[OF handleYield_corres] active_from_running active_from_running' - simp: simple_sane_strg)[8] + 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) @@ -1985,7 +1856,6 @@ proof - simp: ct_in_state_def) apply wp apply (clarsimp) - apply (frule(1) ct_not_ksQ) apply (auto simp: ct_in_state'_def sch_act_simple_def sch_act_sane_def elim: pred_tcb'_weakenE st_tcb_ex_cap'')[1] @@ -1998,12 +1868,11 @@ proof - simp: ct_in_state_def valid_fault_def) apply wp apply clarsimp - apply (frule(1) ct_not_ksQ) 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="\rv. einvs" + 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) @@ -2013,7 +1882,6 @@ proof - apply (rule handleInterrupt_corres) apply (wp hoare_vcg_all_lift doMachineOp_getActiveIRQ_IRQ_active' - | simp | simp add: imp_conjR | wp (once) hoare_drop_imps)+ apply (simp add: invs'_def valid_state'_def) apply (rule_tac corres_underlying_split) @@ -2030,7 +1898,6 @@ proof - apply (fastforce elim!: st_tcb_ex_cap st_tcb_weakenE simp: ct_in_state_def) apply wp apply (clarsimp) - apply (frule(1) ct_not_ksQ) 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) @@ -2042,7 +1909,6 @@ proof - simp: ct_in_state_def) apply wp apply (clarsimp) - apply (frule(1) ct_not_ksQ) apply (auto simp: ct_in_state'_def sch_act_simple_def sch_act_sane_def elim: pred_tcb'_weakenE st_tcb_ex_cap'')[1] @@ -2129,10 +1995,8 @@ proof - apply (rename_tac syscall) apply (case_tac syscall, (wp handleReply_sane handleReply_nonz_cap_to_ct handleReply_ksCurThread - handleReply_ct_not_ksQ | clarsimp simp: active_from_running' simple_from_running' simple_sane_strg simp del: split_paired_All | rule conjI active_ex_cap' - | drule ct_not_ksQ[rotated] | strengthen nidle)+) apply (rule hoare_strengthen_post, rule hoare_weaken_pre, @@ -2144,7 +2008,6 @@ proof - | 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' - | drule ct_not_ksQ[rotated] | wpc | wp (once) hoare_drop_imps)+ done qed diff --git a/proof/refine/RISCV64/TcbAcc_R.thy b/proof/refine/RISCV64/TcbAcc_R.thy index f2d9fbb4e4..c86796f3bb 100644 --- a/proof/refine/RISCV64/TcbAcc_R.thy +++ b/proof/refine/RISCV64/TcbAcc_R.thy @@ -58,10 +58,8 @@ lemma getHighestPrio_inv[wp]: unfolding bitmap_fun_defs by simp lemma valid_bitmapQ_bitmapQ_simp: - "\ valid_bitmapQ s \ \ - bitmapQ d p s = (ksReadyQueues s (d, p) \ [])" - unfolding valid_bitmapQ_def - by simp + "valid_bitmapQ s \ bitmapQ d p s = (\ tcbQueueEmpty (ksReadyQueues s (d, p)))" + by (simp add: valid_bitmapQ_def) lemma prioToL1Index_l1IndexToPrio_or_id: "\ unat (w'::priority) < 2 ^ wordRadix ; w < 2^(size w' - wordRadix) \ @@ -84,34 +82,18 @@ 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 :: "machine_word \ 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 and runnable' \ tcbState) t s) - \ distinct (ksReadyQueues s (d, p)) - \ (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 - 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 objBits_simps) - 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 - RISCV64_A.arch_kernel_obj.split_asm)+ - apply fastforce - done + 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" @@ -132,10 +114,11 @@ lemma pspace_relation_tcb_at': assumes t: "tcb_at t a" assumes aligned: "pspace_aligned' c" assumes distinct: "pspace_distinct' c" - shows "tcb_at' t c" using assms + shows "tcb_at' t c" + using assms apply (clarsimp simp: obj_at_def) apply (drule(1) pspace_relation_absD) - apply (clarsimp simp: is_tcb other_obj_relation_def) + 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) @@ -143,13 +126,24 @@ lemma pspace_relation_tcb_at': 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'" + "\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 is_tcb_def + 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'" @@ -166,24 +160,82 @@ lemma cur_tcb_cross: 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" +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" + using assms apply (clarsimp simp add: 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) done -lemma valid_objs'_maxDomain: - "\s t. \ valid_objs' s; tcb_at' t s \ \ obj_at' (\tcb. tcbDomain tcb \ maxDomain) t s" - apply (erule (1) valid_objs_valid_tcbE) - apply (clarsimp simp: valid_tcb'_def) +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 + 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 objBits_simps') + done + +definition valid_tcbs' :: "kernel_state \ bool" where + "valid_tcbs' s' \ \ptr tcb. ksPSpace s' ptr = Some (KOTCB tcb) \ valid_tcb' tcb s'" + +lemma valid_objs'_valid_tcbs'[elim!]: + "valid_objs' s \ valid_tcbs' s" + by (auto simp: valid_objs'_def valid_tcbs'_def valid_obj'_def split: kernel_object.splits) + +lemma invs'_valid_tcbs'[elim!]: + "invs' s \ valid_tcbs' s" + by (fastforce intro: valid_objs'_valid_tcbs') + +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 valid_tcb'_def) + 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 valid_tcb'_def) done -lemma valid_objs'_maxPriority: - "\s t. \ valid_objs' s; tcb_at' t s \ \ obj_at' (\tcb. tcbPriority tcb \ maxPriority) t s" - apply (erule (1) valid_objs_valid_tcbE) - apply (clarsimp simp: valid_tcb'_def) +lemmas valid_objs'_maxPriority = valid_tcbs'_maxPriority[OF valid_objs'_valid_tcbs'] + +lemma valid_tcbs'_obj_at': + assumes "valid_tcbs' 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" + using assms + 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) done +lemma update_valid_tcb'[simp]: + "\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" + "\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_valid_tcbs'[simp]: + "\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': assumes masks: "\P. \\s. P (irq_masks s)\ f \\_ s. P (irq_masks s)\" shows "\valid_irq_states'\ doMachineOp f \\rv. valid_irq_states'\" @@ -281,49 +333,109 @@ lemma updateObject_tcb_inv: by simp (rule updateObject_default_inv) lemma setObject_update_TCB_corres': - assumes tcbs: "tcb_relation tcb tcb' \ tcb_relation tcbu tcbu'" - assumes tables: "\(getF, v) \ ran tcb_cap_cases. getF tcbu = getF tcb" - assumes tables': "\(getF, v) \ ran tcb_cte_cases. getF tcbu' = getF tcb'" + 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" + assumes tables': "\(getF, v) \ ran tcb_cte_cases. getF new_tcb' = getF tcb'" + assumes sched_pointers: "tcbSchedPrev new_tcb' = tcbSchedPrev tcb'" + "tcbSchedNext new_tcb' = tcbSchedNext tcb'" + assumes flag: "tcbQueued new_tcb' = tcbQueued tcb'" assumes r: "r () ()" - assumes exst: "exst_same tcb' tcbu'" - 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' \ exst_same tcb' tcbu'" 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: other_obj_relation_def exst) - 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 - 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: 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) + 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 + 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 () (); exst_same tcb' tcbu'\ - \ 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 fastforce - apply (clarsimp simp: getObject_def in_monad split_def obj_at'_def - loadObject_default_def objBits_simps' in_magnitude_check) + apply (erule (7) setObject_update_TCB_corres') + apply (clarsimp simp: getObject_def in_monad split_def obj_at'_def + loadObject_default_def objBits_simps' in_magnitude_check)+ done lemma getObject_TCB_corres: @@ -363,7 +475,8 @@ lemma ball_tcb_cte_casesI: by (simp add: tcb_cte_cases_def cteSizeBits_def) lemma all_tcbI: - "\ \a b c d e f g h i j k l m n p q. P (Thread a b c d e f g h i j k l m n p q) \ \ \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: @@ -372,6 +485,9 @@ 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" + 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) \ @@ -380,10 +496,13 @@ lemma threadset_corresT: 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 (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+ @@ -413,6 +532,9 @@ lemma threadSet_corres_noopT: tcb_relation tcb (fn tcb')" assumes y: "\tcb. \(getF, setF) \ ran tcb_cte_cases. getF (fn tcb) = getF tcb" + 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)" @@ -431,9 +553,12 @@ proof - defer apply (subst bind_return [symmetric], rule corres_underlying_split [OF threadset_corresT]) - apply (simp add: x) - apply simp - apply (rule y) + 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 @@ -452,14 +577,20 @@ 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'\" + 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)+ @@ -686,16 +817,23 @@ lemma threadSet_valid_pspace'T_P: assumes v: "\tcb. (P \ Q' (tcbBoundNotification tcb)) \ (\s. valid_bound_ntfn' (tcbBoundNotification tcb) s \ valid_bound_ntfn' (tcbBoundNotification (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)\ - threadSet F t - \\rv. valid_pspace'\" + "\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 + \\_. valid_pspace'\" apply (simp add: valid_pspace'_def threadSet_def) apply (rule hoare_pre, wp setObject_tcb_valid_objs getObject_tcb_wp) @@ -703,7 +841,7 @@ lemma threadSet_valid_pspace'T_P: 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 v w') + split_paired_Ball y u w v w' p n) done lemmas threadSet_valid_pspace'T = @@ -777,6 +915,10 @@ lemma threadSet_iflive'T: \ tcbState (F tcb) \ Inactive \ tcbState (F tcb) \ IdleThreadState \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) + \ ((\tcb. tcbSchedNext tcb = None \ tcbSchedNext (F tcb) \ None + \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) + \ ((\tcb. tcbSchedPrev tcb = None \ tcbSchedPrev (F tcb) \ None + \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) \ ((\tcb. \ tcbQueued tcb \ tcbQueued (F tcb) \ ko_at' tcb t s) \ ex_nonz_cap_to' t s)\ threadSet F t @@ -784,8 +926,7 @@ lemma threadSet_iflive'T: apply (simp add: threadSet_def) apply (wp setObject_tcb_iflive' getObject_tcb_wp) apply (clarsimp simp: obj_at'_def) - apply (subst conj_assoc[symmetric], subst imp_disjL[symmetric]) - apply (subst conj_assoc[symmetric], subst imp_disjL[symmetric]) + apply (subst conj_assoc[symmetric], subst imp_disjL[symmetric])+ apply (rule conjI) apply (rule impI, clarsimp) apply (erule if_live_then_nonz_capE') @@ -831,6 +972,12 @@ lemmas threadSet_ctes_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) + \ 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 objBits_simps') + lemma threadSet_idle'T: assumes x: "\tcb. \(getF, setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" shows @@ -868,30 +1015,6 @@ lemma set_tcb_bitmapQ_no_L2_orphans[wp]: apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp add: bitmapQ_def)+ done -lemma threadSet_valid_queues_no_bitmap: - "\ valid_queues_no_bitmap and - (\s. \d p. (\tcb. (inQ d p tcb \ runnable' (tcbState tcb)) \ - \(inQ d p (f tcb) \ runnable' (tcbState (f tcb)))) - \ obj_at' (\tcb. (inQ d p tcb \ runnable' (tcbState tcb)) \ - \(inQ d p (f tcb) \ runnable' (tcbState (f tcb)))) t s - \ t \ set (ksReadyQueues s (d, p)) - )\ - threadSet f t - \\rv. valid_queues_no_bitmap \" - apply (simp add: threadSet_def) - apply wp - apply (simp add: Invariants_H.valid_queues_no_bitmap_def' pred_tcb_at'_def) - - apply (wp setObject_queues_unchanged_tcb - hoare_Ball_helper - hoare_vcg_all_lift - setObject_tcb_strongest)[1] - apply (wp getObject_tcb_wp) - apply (clarsimp simp: valid_queues_no_bitmap_def' pred_tcb_at'_def) - apply (clarsimp simp: obj_at'_def) - apply (fastforce) - done - lemma threadSet_valid_bitmapQ[wp]: "\ valid_bitmapQ \ threadSet f t \ \rv. valid_bitmapQ \" unfolding bitmapQ_defs threadSet_def @@ -910,72 +1033,6 @@ lemma threadSet_valid_bitmapQ_no_L2_orphans[wp]: by (clarsimp simp: setObject_def split_def) (wp | simp add: updateObject_default_def)+ -lemma threadSet_valid_queues: - "\Invariants_H.valid_queues and - (\s. \d p. (\tcb. (inQ d p tcb \ runnable' (tcbState tcb)) \ - \(inQ d p (f tcb) \ runnable' (tcbState (f tcb)))) - \ obj_at' (\tcb. (inQ d p tcb \ runnable' (tcbState tcb)) \ - \(inQ d p (f tcb) \ runnable' (tcbState (f tcb)))) t s - \ t \ set (ksReadyQueues s (d, p)) - )\ - threadSet f t - \\rv. Invariants_H.valid_queues\" - unfolding valid_queues_def - by (wp threadSet_valid_queues_no_bitmap;simp) - -definition - addToQs :: "(Structures_H.tcb \ Structures_H.tcb) - \ machine_word \ (domain \ priority \ machine_word list) - \ (domain \ priority \ machine_word list)" -where - "addToQs F t \ \qs (qdom, prio). if (\ko. \ inQ qdom prio (F ko)) - then t # qs (qdom, prio) - else qs (qdom, prio)" - -lemma addToQs_set_def: - "(t' \ set (addToQs F t qs (qdom, prio))) = (t' \ set (qs (qdom, prio)) - \ (t' = t \ (\ko. \ inQ qdom prio (F ko))))" - by (auto simp add: addToQs_def) - -lemma threadSet_valid_queues_addToQs: - "\\s. (\ko qdom prio. ko_at' ko t s \ inQ qdom prio (F ko) \ \ inQ qdom prio ko - \ t \ set (ksReadyQueues s (qdom, prio))) - \ valid_queues' (ksReadyQueues_update (addToQs F t) s)\ - threadSet F t - \\rv. 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 objBits_simps addToQs_set_def - split del: if_split cong: if_cong) - apply (fastforce split: if_split_asm) - done - -lemma threadSet_valid_queues_Qf: - "\\s. (\ko qdom prio. ko_at' ko t s \ inQ qdom prio (F ko) \ \ inQ qdom prio ko - \ t \ set (ksReadyQueues s (qdom, prio))) - \ valid_queues' (ksReadyQueues_update Qf s) - \ (\prio. set (Qf (ksReadyQueues s) prio) - \ set (addToQs F t (ksReadyQueues s) prio))\ - threadSet F t - \\rv. valid_queues'\" - apply (wp threadSet_valid_queues_addToQs) - apply (clarsimp simp: valid_queues'_def subset_iff) - done - -lemma addToQs_subset: - "set (qs p) \ set (addToQs F t qs p)" -by (clarsimp simp: addToQs_def split_def) - -lemmas threadSet_valid_queues' - = threadSet_valid_queues_Qf - [where Qf=id, simplified ksReadyQueues_update_id - id_apply addToQs_subset simp_thms] - lemma threadSet_cur: "\\s. cur_tcb' s\ threadSet f t \\rv s. cur_tcb' s\" apply (simp add: threadSet_def cur_tcb'_def) @@ -991,7 +1048,7 @@ lemma modifyReadyQueuesL1Bitmap_obj_at[wp]: crunches setThreadState, setBoundNotification for valid_arch' [wp]: valid_arch_state' - (simp: unless_def crunch_simps) + (simp: unless_def crunch_simps wp: crunch_wps) crunch ksInterrupt'[wp]: threadSet "\s. P (ksInterruptState s)" (wp: setObject_ksInterrupt updateObject_default_inv) @@ -1244,56 +1301,103 @@ lemma threadSet_valid_dom_schedule': unfolding threadSet_def by (wp setObject_ksDomSchedule_inv hoare_Ball_helper) +lemma threadSet_wp: + "\\s. \tcb. ko_at' tcb t s \ P (s\ksPSpace := (ksPSpace s)(t \ injectKO (f tcb))\)\ + threadSet f t + \\_. P\" + unfolding threadSet_def setObject_def + apply (wpsimp wp: getObject_tcb_wp simp: updateObject_default_def) + apply (auto simp: obj_at'_def split: if_splits) + apply (erule rsubst[where P=P]) + apply (clarsimp simp: fun_upd_def) + apply (prop_tac "\ptr. psMap (ksPSpace s) ptr = ksPSpace s ptr") + apply fastforce + apply metis + done + +lemma threadSet_sched_pointers: + "\\tcb. tcbSchedNext (F tcb) = tcbSchedNext tcb; \tcb. tcbSchedPrev (F tcb) = tcbSchedPrev tcb\ + \ threadSet F tcbPtr \\s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + apply (erule rsubst2[where P=P]) + apply (fastforce simp: opt_map_def obj_at'_def) + apply (fastforce simp: opt_map_def obj_at'_def) + done + +lemma threadSet_valid_sched_pointers: + "\\tcb. tcbSchedNext (F tcb) = tcbSchedNext tcb; \tcb. tcbSchedPrev (F tcb) = tcbSchedPrev tcb; + \tcb. tcbQueued (F tcb) = tcbQueued tcb\ + \ threadSet F tcbPtr \valid_sched_pointers\" + unfolding valid_sched_pointers_def + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + by (fastforce simp: opt_pred_def opt_map_def obj_at'_def split: option.splits if_splits) + +lemma threadSet_tcbSchedNexts_of: + "(\tcb. tcbSchedNext (F tcb) = tcbSchedNext tcb) \ + threadSet F t \\s. P (tcbSchedNexts_of s)\" + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + apply (erule rsubst[where P=P]) + apply (fastforce simp: opt_map_def obj_at'_def) + done + +lemma threadSet_tcbSchedPrevs_of: + "(\tcb. tcbSchedPrev (F tcb) = tcbSchedPrev tcb) \ + threadSet F t \\s. P (tcbSchedPrevs_of s)\" + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + apply (erule rsubst[where P=P]) + apply (fastforce simp: opt_map_def obj_at'_def) + done + +lemma threadSet_tcbQueued: + "(\tcb. tcbQueued (F tcb) = tcbQueued tcb) \ + threadSet F t \\s. P (tcbQueued |< tcbs_of' s)\" + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + apply (erule rsubst[where P=P]) + apply (fastforce simp: opt_pred_def opt_map_def obj_at'_def) + done + +crunches threadSet + for ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" + and ksReadyQueuesL1Bitmap[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" + and ksReadyQueuesL2Bitmap[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" + lemma threadSet_invs_trivialT: - assumes x: "\tcb. \(getF,setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" - assumes z: "\tcb. tcbState (F tcb) = tcbState tcb \ tcbDomain (F tcb) = tcbDomain tcb" - assumes w: "\tcb. is_aligned (tcbIPCBuffer tcb) msg_align_bits \ is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits" - assumes a: "\tcb. tcbBoundNotification (F tcb) = tcbBoundNotification tcb" - assumes w: "\tcb. is_aligned (tcbIPCBuffer tcb) msg_align_bits \ is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits" - 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" - shows - "\\s. invs' 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. \ tcbQueued tcb \ tcbQueued (F tcb)) \ ex_nonz_cap_to' t s \ t \ ksCurThread s) \ - (\tcb. tcbQueued (F tcb) \ ksSchedulerAction s = ResumeCurrentThread \ tcbQueued tcb \ t \ ksCurThread s)\ - threadSet F t - \\rv. invs'\" -proof - - from z have domains: "\tcb. tcbDomain (F tcb) = tcbDomain tcb" by blast - note threadSet_sch_actT_P[where P=False, simplified] - have y: "\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 valid_state'_def split del: if_split) - apply (rule hoare_pre) - apply (wp x w v u b - threadSet_valid_pspace'T - threadSet_sch_actT_P[where P=False, simplified] - threadSet_valid_queues - 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_cur - untyped_ranges_zero_lift - |clarsimp simp: y z a domains cteCaps_of_def |rule refl)+ - apply (clarsimp simp: obj_at'_def pred_tcb_at'_def) - apply (clarsimp simp: cur_tcb'_def valid_irq_node'_def valid_queues'_def o_def) - by (fastforce simp: domains ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def z a) -qed + assumes + "\tcb. \(getF,setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" + "\tcb. tcbState (F tcb) = tcbState tcb" + "\tcb. is_aligned (tcbIPCBuffer tcb) msg_align_bits + \ is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits" + "\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. tcbMCP tcb \ maxPriority \ tcbMCP (F tcb) \ maxPriority" + shows "threadSet F t \invs'\" + apply (simp add: invs'_def valid_state'_def split del: if_split) + apply (wp threadSet_valid_pspace'T + threadSet_sch_actT_P[where P=False, simplified] + 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_cur + untyped_ranges_zero_lift + sym_heap_sched_pointers_lift threadSet_valid_sched_pointers + threadSet_tcbQueued + threadSet_tcbSchedPrevs_of threadSet_tcbSchedNexts_of valid_bitmaps_lift + | clarsimp simp: assms cteCaps_of_def | rule refl)+ + apply (clarsimp simp: o_def) + by (auto simp: assms obj_at'_def) lemmas threadSet_invs_trivial = threadSet_invs_trivialT [OF all_tcbI all_tcbI all_tcbI all_tcbI, OF ball_tcb_cte_casesI] @@ -1333,6 +1437,70 @@ lemma threadSet_valid_objs': apply (clarsimp elim!: obj_at'_weakenE) done +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'] + +lemma setObject_valid_tcbs': + assumes preserve_valid_tcb': "\s s' ko ko' x n tcb tcb'. + \ (ko', s') \ fst (updateObject val ko ptr x n s); P s; + lookupAround2 ptr (ksPSpace s) = (Some (x, ko), n); + projectKO_opt ko = Some tcb; projectKO_opt ko' = Some tcb'; + valid_tcb' tcb s \ \ valid_tcb' tcb' s" + shows "\valid_tcbs' and P\ setObject ptr val \\rv. valid_tcbs'\" + unfolding valid_tcbs'_def + apply (clarsimp simp: valid_def) + apply (rename_tac s s' ptr' tcb) + apply (prop_tac "\tcb'. valid_tcb' tcb s \ valid_tcb' tcb s'") + apply clarsimp + apply (erule (1) use_valid[OF _ setObject_valid_tcb']) + apply (drule spec, erule mp) + apply (clarsimp simp: setObject_def in_monad split_def lookupAround2_char1) + apply (rename_tac s ptr' new_tcb' ptr'' old_tcb_ko' s' f) + apply (case_tac "ptr'' = ptr'"; clarsimp) + apply (prop_tac "\old_tcb' :: tcb. projectKO_opt old_tcb_ko' = Some old_tcb'") + apply (frule updateObject_type) + apply (case_tac old_tcb_ko'; clarsimp simp: project_inject) + apply (erule exE) + apply (rule preserve_valid_tcb', assumption+) + apply (simp add: prod_eqI lookupAround2_char1) + apply force + apply (clarsimp simp: project_inject) + apply (clarsimp simp: project_inject) + done + +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 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 + \\_. valid_tcb' tcb\" + apply (simp add: threadSet_def) + apply (wpsimp wp: setObject_valid_tcb') + done + +lemma threadSet_valid_tcbs': + "\valid_tcbs' and (\s. \tcb. valid_tcb' tcb s \ valid_tcb' (f tcb) s)\ + threadSet f t + \\_. valid_tcbs'\" + apply (simp add: threadSet_def) + apply (rule hoare_seq_ext[OF _ getObject_tcb_sp]) + apply (wpsimp wp: setObject_tcb_valid_tcbs') + apply (clarsimp simp: obj_at'_def valid_tcbs'_def) + 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 objBits_simps') + done + lemma asUser_corres': assumes y: "corres_underlying Id False True r \ \ f g" shows "corres r (tcb_at t and pspace_aligned and pspace_distinct) \ @@ -1472,14 +1640,6 @@ lemma asUser_valid_pspace'[wp]: apply (wp threadSet_valid_pspace' hoare_drop_imps | simp)+ done -lemma asUser_valid_queues[wp]: - "\Invariants_H.valid_queues\ asUser t m \\rv. Invariants_H.valid_queues\" - apply (simp add: asUser_def split_def) - apply (wp hoare_drop_imps | simp)+ - - apply (wp threadSet_valid_queues hoare_drop_imps | simp)+ - done - lemma asUser_ifunsafe'[wp]: "\if_unsafe_then_cap'\ asUser t m \\rv. if_unsafe_then_cap'\" apply (simp add: asUser_def split_def) @@ -1756,19 +1916,22 @@ lemma ethreadget_corres: apply (simp add: x) done -lemma setQueue_corres: - "corres dc \ \ (set_tcb_queue d p q) (setQueue d p q)" - apply (rule corres_no_failI) - apply wp - apply (clarsimp simp: setQueue_def in_monad set_tcb_queue_def return_def simpler_modify_def) - apply (fastforce simp: state_relation_def ready_queues_relation_def) - done - - -lemma getQueue_corres: "corres (=) \ \ (get_tcb_queue qdom prio) (getQueue qdom prio)" - apply (clarsimp simp add: getQueue_def state_relation_def ready_queues_relation_def get_tcb_queue_def gets_def) - apply (fold gets_def) - apply simp +lemma getQueue_corres: + "corres (\ls q. (ls = [] \ tcbQueueEmpty q) \ (ls \ [] \ tcbQueueHead q = Some (hd ls)) + \ queue_end_valid ls q) + \ \ (get_tcb_queue qdom prio) (getQueue qdom prio)" + apply (clarsimp simp: get_tcb_queue_def getQueue_def tcbQueueEmpty_def) + apply (rule corres_bind_return2) + apply (rule corres_symb_exec_l[OF _ _ gets_sp]) + apply (rule corres_symb_exec_r[OF _ gets_sp]) + apply clarsimp + apply (drule state_relation_ready_queues_relation) + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def + list_queue_relation_def) + apply (drule_tac x=qdom in spec) + apply (drule_tac x=prio in spec) + apply (fastforce dest: heap_path_head) + apply wpsimp+ done lemma no_fail_return: @@ -1783,8 +1946,8 @@ lemma addToBitmap_noop_corres: (wp | simp add: state_relation_def | rule no_fail_pre)+ lemma addToBitmap_if_null_noop_corres: (* used this way in Haskell code *) - "corres dc \ \ (return ()) (if null queue then addToBitmap d p else return ())" - by (cases "null queue", simp_all add: addToBitmap_noop_corres) + "corres dc \ \ (return ()) (if tcbQueueEmpty queue then addToBitmap d p else return ())" + by (cases "tcbQueueHead queue", simp_all add: addToBitmap_noop_corres) lemma removeFromBitmap_corres_noop: "corres dc \ \ (return ()) (removeFromBitmap tdom prioa)" @@ -1801,56 +1964,701 @@ crunch typ_at'[wp]: removeFromBitmap "\s. P (typ_at' T p s)" 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 ekheap_relation_tcb_domain_priority: + "\ekheap_relation (ekheap s) (ksPSpace s'); ekheap s t = Some (tcb); + ksPSpace s' t = Some (KOTCB tcb')\ + \ 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 (clarsimp simp: other_obj_relation_def etcb_relation_def) + done + +lemma no_fail_thread_get[wp]: + "no_fail (tcb_at tcb_ptr) (thread_get f tcb_ptr)" + unfolding thread_get_def + apply wpsimp + apply (clarsimp simp: tcb_at_def) + done + +lemma pspace_relation_tcb_relation: + "\pspace_relation (kheap s) (ksPSpace s'); kheap s ptr = Some (TCB tcb); + ksPSpace s' ptr = Some (KOTCB tcb')\ + \ 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) + apply (frule (1) pspace_relation_tcb_relation) + apply (fastforce simp: obj_at'_def) + 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) + apply (frule (1) ekheap_relation_etcb_relation) + apply (fastforce simp: obj_at'_def) + apply (fastforce dest!: etcb_rel) + done + +lemma tcbQueued_update_pspace_relation[wp]: + fixes s :: det_state + shows "threadSet (tcbQueued_update f) tcbPtr \\s'. pspace_relation (kheap s) (ksPSpace s')\" + by (wpsimp wp: threadSet_pspace_relation simp: tcb_relation_def) + +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 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 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 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) + +crunches 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) + +crunches 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 + +crunches 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) + +crunches 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 pspace_canonical'[wp]: pspace_canonical' + 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 pspace_in_kernel_mappings'[wp]: pspace_in_kernel_mappings' + and ksIdleThread[wp]: "\s. P (ksIdleThread s)" + (wp: crunch_wps threadSet_state_refs_of'[where f'=id and g'=id] + 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 ready_queue_relation_def Let_def) + apply (wpsimp wp: threadSet_wp) + apply (clarsimp simp: list_queue_relation_def obj_at'_def) + apply (rename_tac tcb' d p) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: list_queue_relation_def) + apply (rule conjI) + apply (drule_tac x=tcbPtr in spec) + apply (fastforce intro: heap_path_heap_upd_not_in + simp: inQ_def opt_map_def opt_pred_def obj_at'_def) + apply (rule conjI) + apply (drule_tac x=tcbPtr in spec) + apply (clarsimp simp: prev_queue_head_def) + apply (prop_tac "ready_queues s d p \ []", fastforce) + apply (fastforce dest: heap_path_head simp: inQ_def opt_pred_def opt_map_def fun_upd_apply) + apply (auto simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + done + +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\ + isRunnable tcb_ptr + \\rv s. \tcb'. ko_at' tcb' tcb_ptr s + \ (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_def) + apply (fastforce simp: obj_at'_def split: Structures_H.thread_state.splits) + done + +crunch (no_fail) no_fail[wp]: isRunnable + +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) + +crunches 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 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 in_set_ready_queues_inQ_eq: + "ready_queues_relation s s' \ t \ set (ready_queues s d p) \ (inQ d p |< tcbs_of' s') t" + by (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def) + +lemma in_ready_q_tcbQueued_eq: + "ready_queues_relation s s' + \ (\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_queues_relation_def ready_queue_relation_def Let_def inQ_def + opt_pred_def + split: option.splits) + done + lemma tcbSchedEnqueue_corres: - "corres dc (tcb_at t and is_etcb_at t and pspace_aligned and pspace_distinct) - (Invariants_H.valid_queues and valid_queues') - (tcb_sched_action (tcb_sched_enqueue) t) (tcbSchedEnqueue t)" -proof - - have ready_queues_helper: - "\t tcb a b. \ ekheap a t = Some tcb; obj_at' tcbQueued t b ; valid_queues' b ; - ekheap_relation (ekheap a) (ksPSpace b) \ - \ t \ set (ksReadyQueues b (tcb_domain tcb, tcb_priority tcb))" - unfolding valid_queues'_def - by (fastforce dest: ekheap_relation_absD simp: obj_at'_def inQ_def etcb_relation_def) - - show ?thesis unfolding tcbSchedEnqueue_def tcb_sched_action_def - apply (rule corres_cross_over_guard[where P'=Q and Q="tcb_at' t and Q" for Q]) - apply (fastforce simp: tcb_at_cross state_relation_def) - apply (rule corres_symb_exec_r [OF _ _ threadGet_inv, - 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 (rule no_fail_pre, wp, blast) - apply (case_tac queued; simp_all) - apply (rule corres_no_failI; simp add: no_fail_return) - apply (clarsimp simp: in_monad ethread_get_def gets_the_def bind_assoc - assert_opt_def exec_gets is_etcb_at_def get_etcb_def get_tcb_queue_def - set_tcb_queue_def simpler_modify_def ready_queues_relation_def - state_relation_def tcb_sched_enqueue_def) - apply (rule ready_queues_helper; auto) - apply (clarsimp simp: when_def) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split[where r'="(=)", OF ethreadget_corres]) - apply (simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)", OF ethreadget_corres]) - apply (simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply simp - apply (rule getQueue_corres) - apply (rule corres_split_noop_rhs2) - apply simp - 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 - apply (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 exst_same_def) - apply (wp getObject_tcb_wp | simp add: threadGet_def)+ - apply (fastforce simp: valid_queues_def valid_queues_no_bitmap_def obj_at'_def inQ_def - project_inject) - done -qed + "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) + 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)?) + + \ \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) + + 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) + + 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) + 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) + 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 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 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) + apply (frule valid_tcbs'_maxPriority[where t=tcbPtr], simp add: obj_at'_def) + 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) + 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 + 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 fun_upd_apply split: if_splits) + apply (clarsimp simp: fun_upd_apply 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 + split: if_splits option.splits) definition weak_sch_act_wf :: "scheduler_action \ kernel_state \ bool" @@ -1877,8 +2685,10 @@ lemma getSchedulerAction_corres: done lemma rescheduleRequired_corres: - "corres dc (weak_valid_sched_action and valid_etcbs and pspace_aligned and pspace_distinct) - (Invariants_H.valid_queues and valid_queues') + "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) @@ -1889,7 +2699,7 @@ lemma rescheduleRequired_corres: apply (case_tac action) apply simp apply simp - apply (rule tcbSchedEnqueue_corres) + apply (rule tcbSchedEnqueue_corres, simp) apply simp apply (rule setSchedulerAction_corres) apply simp @@ -1964,20 +2774,18 @@ lemmas addToBitmap_weak_sch_act_wf[wp] = weak_sch_act_wf_lift[OF addToBitmap_nosch] crunch st_tcb_at'[wp]: removeFromBitmap "st_tcb_at' P t" -crunch pred_tcb_at'[wp]: removeFromBitmap "pred_tcb_at' proj P t" +crunch pred_tcb_at'[wp]: removeFromBitmap "\s. Q (pred_tcb_at' proj P t s)" crunch not_st_tcb_at'[wp]: removeFromBitmap "\s. \ (st_tcb_at' P' t) s" -crunch not_pred_tcb_at'[wp]: removeFromBitmap "\s. \ (pred_tcb_at' proj P' t) s" crunch st_tcb_at'[wp]: addToBitmap "st_tcb_at' P' t" -crunch pred_tcb_at'[wp]: addToBitmap "pred_tcb_at' proj P' t" +crunch pred_tcb_at'[wp]: addToBitmap "\s. Q (pred_tcb_at' proj P t s)" crunch not_st_tcb_at'[wp]: addToBitmap "\s. \ (st_tcb_at' P' t) s" -crunch not_pred_tcb_at'[wp]: addToBitmap "\s. \ (pred_tcb_at' proj P' t) s" -crunch obj_at'[wp]: removeFromBitmap "obj_at' P t" +crunch obj_at'[wp]: removeFromBitmap "\s. Q (obj_at' P t s)" -crunch obj_at'[wp]: addToBitmap "obj_at' P t" +crunch obj_at'[wp]: addToBitmap "\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\" @@ -1994,9 +2802,11 @@ lemma addToBitmap_tcb_in_cur_domain'[wp]: done lemma tcbSchedDequeue_weak_sch_act_wf[wp]: - "\ \s. weak_sch_act_wf (ksSchedulerAction s) s \ tcbSchedDequeue a \ \_ s. weak_sch_act_wf (ksSchedulerAction s) s \" - apply (simp add: tcbSchedDequeue_def) - apply (wp threadSet_weak_sch_act_wf removeFromBitmap_weak_sch_act_wf | simp add: crunch_simps)+ + "tcbSchedDequeue tcbPtr \\s. weak_sch_act_wf (ksSchedulerAction s) s\" + apply (simp add: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wp threadSet_weak_sch_act_wf getObject_tcb_wp removeFromBitmap_weak_sch_act_wf + | simp add: crunch_simps threadGet_def)+ + apply (clarsimp simp: obj_at'_def) done lemma dequeue_nothing_eq[simp]: @@ -2012,47 +2822,342 @@ lemma gets_the_exec: "f s \ None \ (do x \ ge return_def assert_opt_def) done +lemma tcbQueueRemove_no_fail: + "no_fail (\s. tcb_at' tcbPtr s + \ (\ts. list_queue_relation ts queue (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ tcbPtr \ set ts) + \ sym_heap_sched_pointers s \ valid_objs' s) + (tcbQueueRemove queue tcbPtr)" + unfolding tcbQueueRemove_def + apply (wpsimp wp: getObject_tcb_wp) + apply normalise_obj_at' + apply (frule (1) ko_at_valid_objs') + apply fastforce + apply (clarsimp simp: list_queue_relation_def) + apply (prop_tac "tcbQueueHead queue \ Some tcbPtr \ tcbSchedPrevs_of s tcbPtr \ None") + apply (rule impI) + apply (frule not_head_prev_not_None[where p=tcbPtr]) + apply (fastforce simp: inQ_def opt_pred_def opt_map_def obj_at'_def) + apply (fastforce dest: heap_path_head) + apply fastforce + apply (fastforce simp: opt_map_def obj_at'_def valid_tcb'_def valid_bound_tcb'_def) + by (fastforce dest!: not_last_next_not_None[where p=tcbPtr] + simp: queue_end_valid_def opt_map_def obj_at'_def valid_obj'_def valid_tcb'_def) + +crunch (no_fail) no_fail[wp]: removeFromBitmap + +crunches removeFromBitmap + for ready_queues_relation[wp]: "ready_queues_relation s" + and list_queue_relation[wp]: + "\s'. list_queue_relation ts (P (ksReadyQueues s')) + (tcbSchedNexts_of s') (tcbSchedPrevs_of s')" + (simp: bitmap_fun_defs ready_queues_relation_def) + +\ \ + A direct analogue of tcbQueueRemove, used in tcb_sched_dequeue' below, so that within the proof of + tcbQueueRemove_corres, we may reason in terms of the list operations used within this function + rather than @{term filter}.\ +definition tcb_queue_remove :: "'a \ 'a list \ 'a list" where + "tcb_queue_remove a ls \ + if ls = [a] + then [] + else if a = hd ls + then tl ls + else if a = last ls + then butlast ls + else list_remove ls a" + +definition tcb_sched_dequeue' :: "obj_ref \ unit det_ext_monad" where + "tcb_sched_dequeue' tcb_ptr \ do + d \ ethread_get tcb_domain tcb_ptr; + prio \ ethread_get tcb_priority tcb_ptr; + queue \ get_tcb_queue d prio; + when (tcb_ptr \ set queue) $ set_tcb_queue d prio (tcb_queue_remove tcb_ptr queue) + od" + +lemma filter_tcb_queue_remove: + "\a \ set ls; distinct ls \ \ filter ((\) a) ls = tcb_queue_remove a ls" + apply (clarsimp simp: tcb_queue_remove_def) + apply (intro conjI impI) + apply (fastforce elim: filter_hd_equals_tl) + apply (fastforce elim: filter_last_equals_butlast) + apply (fastforce elim: filter_hd_equals_tl) + apply (frule split_list) + apply (clarsimp simp: list_remove_middle_distinct) + apply (subst filter_True | clarsimp simp: list_remove_none)+ + done + +lemma tcb_sched_dequeue_monadic_rewrite: + "monadic_rewrite False True (is_etcb_at t and (\s. \d p. distinct (ready_queues s d p))) + (tcb_sched_action tcb_sched_dequeue t) (tcb_sched_dequeue' t)" + supply if_split[split del] + apply (clarsimp simp: tcb_sched_dequeue'_def tcb_sched_dequeue_def tcb_sched_action_def + set_tcb_queue_def) + apply (rule monadic_rewrite_bind_tail)+ + apply (clarsimp simp: when_def) + apply (rule monadic_rewrite_if_r) + apply (rule_tac P="\_. distinct queue" in monadic_rewrite_guard_arg_cong) + apply (frule (1) filter_tcb_queue_remove) + apply (metis (mono_tags, lifting) filter_cong) + apply (rule monadic_rewrite_modify_noop) + apply (wpsimp wp: thread_get_wp)+ + apply (clarsimp simp: etcb_at_def split: option.splits) + apply (prop_tac "(\d' p. if d' = tcb_domain x2 \ p = tcb_priority x2 + then filter (\x. x \ t) (ready_queues s (tcb_domain x2) (tcb_priority x2)) + else ready_queues s d' p) + = ready_queues s") + apply (subst filter_True) + apply fastforce + apply (clarsimp intro!: ext split: if_splits) + apply fastforce + done + +crunches removeFromBitmap + for ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" + +lemma list_queue_relation_neighbour_in_set: + "\list_queue_relation ls q hp hp'; sym_heap hp hp'; p \ set ls\ + \ \nbr. (hp p = Some nbr \ nbr \ set ls) \ (hp' p = Some nbr \ nbr \ set ls)" + apply (rule heap_ls_neighbour_in_set) + apply (fastforce simp: list_queue_relation_def) + apply fastforce + apply (clarsimp simp: list_queue_relation_def prev_queue_head_def) + apply fastforce + done + +lemma in_queue_not_head_or_not_tail_length_gt_1: + "\tcbPtr \ set ls; tcbQueueHead q \ Some tcbPtr \ tcbQueueEnd q \ Some tcbPtr; + list_queue_relation ls q nexts prevs\ + \ Suc 0 < length ls" + apply (clarsimp simp: list_queue_relation_def) + apply (cases ls; fastforce simp: queue_end_valid_def) + done + lemma tcbSchedDequeue_corres: - "corres dc (is_etcb_at t and tcb_at t and pspace_aligned and pspace_distinct) - (Invariants_H.valid_queues) - (tcb_sched_action tcb_sched_dequeue t) (tcbSchedDequeue t)" - apply (rule corres_cross_over_guard[where P'=Q and Q="tcb_at' t and Q" for Q]) - apply (fastforce simp: tcb_at_cross state_relation_def) - apply (simp only: tcbSchedDequeue_def tcb_sched_action_def) - apply (rule corres_symb_exec_r[OF _ _ threadGet_inv, where Q'="\rv. tcb_at' t and Invariants_H.valid_queues and obj_at' (\obj. tcbQueued obj = rv) t"]) - defer - apply (wp threadGet_obj_at', simp, simp) - apply (rule no_fail_pre, wp, simp) - apply (case_tac queued) - defer - apply (simp add: when_def) - apply (rule corres_no_failI) - apply (wp) - apply (clarsimp simp: in_monad ethread_get_def set_tcb_queue_def is_etcb_at_def state_relation_def) - apply (subgoal_tac "t \ set (ready_queues a (tcb_domain y) (tcb_priority y))") - prefer 2 - subgoal by (force simp: tcb_sched_dequeue_def Invariants_H.valid_queues_def valid_queues_no_bitmap_def - ready_queues_relation_def obj_at'_def inQ_def project_inject) - apply (subst gets_the_exec) - apply (simp add: get_etcb_def) - apply (subst gets_the_exec) - apply (simp add: get_etcb_def) - apply (simp add: exec_gets simpler_modify_def get_etcb_def ready_queues_relation_def cong: if_cong get_tcb_queue_def) - apply (simp add: when_def) - apply (rule corres_guard_imp) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres, simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres, simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply (simp, rule getQueue_corres) - apply (rule corres_split_noop_rhs2) - apply (simp add: tcb_sched_dequeue_def) - apply (rule setQueue_corres) - apply (rule corres_split_noop_rhs) - apply (clarsimp, rule removeFromBitmap_corres_noop) - apply (rule threadSet_corres_noop; simp_all add: tcb_relation_def exst_same_def) - apply (wp | simp)+ + "tcb_ptr = tcbPtr \ + corres dc + (in_correct_ready_q and ready_qs_distinct and valid_etcbs and tcb_at tcb_ptr + and pspace_aligned and pspace_distinct) + (sym_heap_sched_pointers and valid_objs') + (tcb_sched_action tcb_sched_dequeue tcb_ptr) (tcbSchedDequeue tcbPtr)" + supply heap_path_append[simp del] fun_upd_apply[simp del] distinct_append[simp del] + list_remove_append[simp del] + apply (rule_tac Q'="tcb_at' tcbPtr" in corres_cross_add_guard) + apply (fastforce intro!: tcb_at_cross simp: obj_at_def is_tcb_def) + apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) + apply (fastforce dest: pspace_aligned_cross) + apply (rule_tac Q'=pspace_distinct' in corres_cross_add_guard) + apply (fastforce dest: pspace_distinct_cross) + apply (rule monadic_rewrite_corres_l[where P=P and Q=P for P, simplified]) + apply (rule monadic_rewrite_guard_imp[OF tcb_sched_dequeue_monadic_rewrite]) + apply (fastforce dest: tcb_at_is_etcb_at simp: in_correct_ready_q_def ready_qs_distinct_def) + apply (clarsimp simp: tcb_sched_dequeue'_def get_tcb_queue_def tcbSchedDequeue_def getQueue_def + unless_def when_def) + apply (rule corres_symb_exec_l[OF _ _ ethread_get_sp]; wpsimp?) + apply (rename_tac dom) + apply (rule corres_symb_exec_l[OF _ _ ethread_get_sp]; wpsimp?) + apply (rename_tac prio) + 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 _ threadGet_sp]; (solves wpsimp)?) + apply (rule corres_if_strong'; fastforce?) + apply (frule state_relation_ready_queues_relation) + apply (frule in_ready_q_tcbQueued_eq[where t=tcbPtr]) + apply (fastforce 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) + apply (rule corres_symb_exec_r[OF _ threadGet_sp]; wpsimp?) + apply (rule corres_symb_exec_r[OF _ threadGet_sp]; wpsimp?) + apply (rule corres_symb_exec_r[OF _ gets_sp]; wpsimp?) + apply (rule corres_from_valid_det) + apply (fastforce intro: det_wp_modify det_wp_pre simp: set_tcb_queue_def) + apply (wpsimp wp: tcbQueueRemove_no_fail) + apply (fastforce dest: state_relation_ready_queues_relation + simp: ex_abs_underlying_def ready_queues_relation_def ready_queue_relation_def + Let_def inQ_def opt_pred_def opt_map_def obj_at'_def) + apply (clarsimp simp: state_relation_def) + apply (intro hoare_vcg_conj_lift_pre_fix; + (solves \frule singleton_eqD, frule set_tcb_queue_projs_inv, wpsimp simp: swp_def\)?) + + \ \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 tcbQueueRemove_def + split_del: if_split) + apply (frule (1) tcb_at_is_etcb_at) + apply (clarsimp simp: obj_at_def is_etcb_at_def etcb_at_def) + apply normalise_obj_at' + 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) + + apply (case_tac "d \ tcb_domain etcb \ p \ tcb_priority etcb") + apply clarsimp + apply (cut_tac p=tcbPtr and ls="ready_queues s (tcb_domain etcb) (tcb_priority etcb)" + in list_queue_relation_neighbour_in_set) + apply (fastforce dest!: spec) + apply fastforce + apply fastforce + apply (cut_tac xs="ready_queues s d p" in heap_path_head') + apply (force dest!: spec simp: ready_queues_relation_def Let_def list_queue_relation_def) + 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 (cut_tac ts="ready_queues s d p" in list_queue_relation_nil) + apply fast + apply (clarsimp simp: tcbQueueEmpty_def) + apply (prop_tac "Some tcbPtr \ tcbQueueHead (ksReadyQueues s' (d, p))") + apply (metis hd_in_set not_emptyI option.sel option.simps(2)) + apply (prop_tac "tcbPtr \ set (ready_queues s d p)") + apply blast + apply (clarsimp simp: list_queue_relation_def) + apply (intro conjI; clarsimp) + + \ \the ready queue is the singleton consisting of tcbPtr\ + apply (intro conjI) + apply (force intro!: heap_path_heap_upd_not_in simp: fun_upd_apply) + apply (clarsimp simp: queue_end_valid_def fun_upd_apply) + apply (force simp: prev_queue_head_heap_upd fun_upd_apply) + apply (clarsimp simp: inQ_def in_opt_pred fun_upd_apply) + apply (clarsimp simp: fun_upd_apply) + apply (clarsimp simp: fun_upd_apply) + + apply (clarsimp simp: etcb_at_def obj_at'_def) + apply (intro conjI; clarsimp) + + \ \tcbPtr is the head of the ready queue\ + apply (intro conjI) + apply (intro heap_path_heap_upd_not_in) + apply (force simp: fun_upd_apply) + apply (force simp: not_emptyI opt_map_red) + apply assumption + apply (clarsimp simp: queue_end_valid_def fun_upd_apply) + apply (clarsimp simp: prev_queue_head_def fun_upd_apply) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + apply (clarsimp simp: fun_upd_apply) + apply (clarsimp simp: fun_upd_apply) + apply (intro conjI; clarsimp) + + \ \tcbPtr is the end of the ready queue\ + apply (intro conjI) + apply (intro heap_path_heap_upd_not_in) + apply (simp add: fun_upd_apply split: if_splits) + apply (force simp: not_emptyI opt_map_red) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + apply (clarsimp simp: queue_end_valid_def fun_upd_apply) + apply (force simp: prev_queue_head_def fun_upd_apply opt_map_red opt_map_upd_triv) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + apply (clarsimp simp: fun_upd_apply) + apply (clarsimp simp: fun_upd_apply) + + \ \tcbPtr is in the middle of the ready queue\ + apply (intro conjI) + apply (intro heap_path_heap_upd_not_in) + apply (simp add: fun_upd_apply) + apply (force simp: not_emptyI opt_map_red) + apply (force simp: not_emptyI opt_map_red) + apply fastforce + apply (clarsimp simp: opt_map_red opt_map_upd_triv) + apply (intro prev_queue_head_heap_upd) + apply (force dest!: spec) + apply (metis hd_in_set not_emptyI option.sel option.simps(2)) + apply fastforce + subgoal + by (clarsimp simp: inQ_def opt_map_def opt_pred_def fun_upd_apply + split: if_splits option.splits) + + \ \d = tcb_domain tcb \ p = tcb_priority tcb\ + apply clarsimp + apply (drule_tac x="tcb_domain etcb" in spec) + apply (drule_tac x="tcb_priority etcb" in spec) + apply (clarsimp simp: list_queue_relation_def) + apply (frule heap_path_head') + apply (frule heap_ls_distinct) + apply (intro conjI; clarsimp simp: tcbQueueEmpty_def) + + \ \the ready queue is the singleton consisting of tcbPtr\ + apply (intro conjI) + apply (simp add: fun_upd_apply tcb_queue_remove_def queue_end_valid_def heap_ls_unique + heap_path_last_end) + apply (simp add: fun_upd_apply tcb_queue_remove_def queue_end_valid_def heap_ls_unique + heap_path_last_end) + apply (simp add: fun_upd_apply prev_queue_head_def) + apply (case_tac "ready_queues s (tcb_domain etcb) (tcb_priority etcb)"; + clarsimp simp: tcb_queue_remove_def inQ_def opt_pred_def fun_upd_apply) + apply (intro conjI; clarsimp) + + \ \tcbPtr is the head of the ready queue\ + apply (frule set_list_mem_nonempty) + apply (frule in_queue_not_head_or_not_tail_length_gt_1) + apply fastforce + apply (fastforce simp: list_queue_relation_def) + apply (frule list_not_head) + apply (clarsimp simp: tcb_queue_remove_def) + apply (frule length_tail_nonempty) + apply (frule (2) heap_ls_next_of_hd) + apply (clarsimp simp: obj_at'_def) + apply (intro conjI impI allI) + apply (drule (1) heap_ls_remove_head_not_singleton) + apply (clarsimp simp: opt_map_red opt_map_upd_triv fun_upd_apply) + apply (clarsimp simp: queue_end_valid_def fun_upd_apply last_tl) + apply (clarsimp simp: prev_queue_head_def fun_upd_apply) + apply (case_tac "ready_queues s (tcb_domain etcb) (tcb_priority etcb)"; + clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + apply (intro conjI; clarsimp) + + \ \tcbPtr is the end of the ready queue\ + apply (frule set_list_mem_nonempty) + apply (frule in_queue_not_head_or_not_tail_length_gt_1) + apply fast + apply (force dest!: spec simp: list_queue_relation_def) + apply (clarsimp simp: queue_end_valid_def) + apply (frule list_not_last) + apply (clarsimp simp: tcb_queue_remove_def) + apply (frule length_gt_1_imp_butlast_nonempty) + apply (frule (3) heap_ls_prev_of_last) + apply (clarsimp simp: obj_at'_def) + apply (intro conjI impI; clarsimp?) + apply (drule (1) heap_ls_remove_last_not_singleton) + apply (force elim!: rsubst3[where P=heap_ls] simp: opt_map_def fun_upd_apply) + apply (clarsimp simp: opt_map_def fun_upd_apply) + apply (clarsimp simp: prev_queue_head_def fun_upd_apply opt_map_def) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + apply (meson distinct_in_butlast_not_last in_set_butlastD last_in_set not_last_in_set_butlast) + + \ \tcbPtr is in the middle of the ready queue\ + apply (clarsimp simp: obj_at'_def) + apply (frule set_list_mem_nonempty) + apply (frule split_list) + apply clarsimp + apply (rename_tac xs ys) + apply (prop_tac "xs \ [] \ ys \ []", fastforce simp: queue_end_valid_def) + apply clarsimp + apply (frule (2) ptr_in_middle_prev_next) + apply fastforce + apply (clarsimp simp: tcb_queue_remove_def) + apply (prop_tac "tcbPtr \ last xs") + apply (clarsimp simp: distinct_append) + apply (prop_tac "tcbPtr \ hd ys") + apply (fastforce dest: hd_in_set simp: distinct_append) + apply (prop_tac "last xs \ hd ys") + apply (metis distinct_decompose2 hd_Cons_tl last_in_set) + apply (prop_tac "list_remove (xs @ tcbPtr # ys) tcbPtr = xs @ ys") + apply (simp add: list_remove_middle_distinct del: list_remove_append) + apply (intro conjI impI allI; (solves \clarsimp simp: distinct_append\)?) + apply (fastforce elim!: rsubst3[where P=heap_ls] + dest!: heap_ls_remove_middle hd_in_set last_in_set + simp: distinct_append not_emptyI opt_map_def fun_upd_apply) + apply (clarsimp simp: queue_end_valid_def fun_upd_apply) + apply (case_tac xs; + fastforce simp: prev_queue_head_def opt_map_def fun_upd_apply distinct_append) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply distinct_append + split: option.splits) done lemma thread_get_test: "do cur_ts \ get_thread_state cur; g (test cur_ts) od = @@ -2112,30 +3217,84 @@ lemma setBoundNotification_corres: crunches rescheduleRequired, tcbSchedDequeue, setThreadState, setBoundNotification for tcb'[wp]: "tcb_at' addr" +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 + +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 + +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) + +crunches addToBitmap + for valid_objs'[wp]: valid_objs' + (simp: unless_def crunch_simps wp: crunch_wps) + +lemma tcbSchedEnqueue_valid_objs'[wp]: + "\valid_objs' and pspace_aligned' and pspace_distinct'\ + tcbSchedEnqueue tcbPtr + \\_. valid_objs'\" + 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 + crunches rescheduleRequired, removeFromBitmap for valid_objs'[wp]: valid_objs' - (simp: unless_def crunch_simps) + (simp: crunch_simps) +lemmas ko_at_valid_objs'_pre = + ko_at_valid_objs'[simplified project_inject, atomized, simplified, rule_format] -lemma tcbSchedDequeue_valid_objs' [wp]: "\ valid_objs' \ tcbSchedDequeue t \\_. valid_objs' \" - unfolding tcbSchedDequeue_def - apply (wp threadSet_valid_objs') - apply (clarsimp simp add: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) - apply wp - apply (simp add: if_apply_def2) - apply (wp hoare_drop_imps) - apply (wp | simp cong: if_cong add: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def if_apply_def2)+ +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] + +lemma tcbQueueRemove_valid_objs'[wp]: + "tcbQueueRemove queue tcbPtr \valid_objs'\" + unfolding tcbQueueRemove_def + apply (wpsimp wp: getObject_tcb_wp) + apply normalise_obj_at' + apply (fastforce dest!: tcb_ko_at_valid_objs_valid_tcb' + simp: valid_tcb'_def valid_bound_tcb'_def obj_at'_def) done +lemma tcbSchedDequeue_valid_objs'[wp]: + "tcbSchedDequeue t \valid_objs'\" + unfolding tcbSchedDequeue_def setQueue_def + by (wpsimp wp: threadSet_valid_objs') + lemma sts_valid_objs': - "\valid_objs' and valid_tcb_state' st\ - setThreadState st t - \\rv. valid_objs'\" - apply (simp add: setThreadState_def setQueue_def isRunnable_def isStopped_def) - apply (wp threadSet_valid_objs') - apply (simp add: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) - apply (wp threadSet_valid_objs' | simp)+ - apply (clarsimp simp: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) + "\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') + 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': @@ -2223,18 +3382,6 @@ lemma setQueue_valid_bitmapQ_except[wp]: unfolding setQueue_def bitmapQ_defs by (wp, clarsimp simp: bitmapQ_def) -lemma setQueue_valid_bitmapQ: (* enqueue only *) - "\ valid_bitmapQ and (\s. (ksReadyQueues s (d, p) = []) = (ts = [])) \ - setQueue d p ts - \\_. valid_bitmapQ \" - unfolding setQueue_def bitmapQ_defs - by (wp, clarsimp simp: bitmapQ_def) - -lemma setQueue_valid_queues': - "\valid_queues' and (\s. \t. obj_at' (inQ d p) t s \ t \ set ts)\ - setQueue d p ts \\_. valid_queues'\" - by (wp | simp add: valid_queues'_def setQueue_def)+ - lemma setQueue_cur: "\\s. cur_tcb' s\ setQueue d p ts \\rv s. cur_tcb' s\" unfolding setQueue_def cur_tcb'_def @@ -2372,9 +3519,17 @@ lemma threadSet_queued_sch_act_wf[wp]: apply (wp tcb_in_cur_domain'_lift | simp add: obj_at'_def)+ done +lemma tcbSchedNext_update_pred_tcb_at'[wp]: + "threadSet (tcbSchedNext_update f) t \\s. P (pred_tcb_at' proj P' t' s)\" + by (wp threadSet_pred_tcb_no_state crunch_wps | clarsimp simp: tcb_to_itcb'_def)+ + +lemma tcbSchedPrev_update_pred_tcb_at'[wp]: + "threadSet (tcbSchedPrev_update f) t \\s. P (pred_tcb_at' proj P' t' s)\" + by (wp threadSet_pred_tcb_no_state crunch_wps | clarsimp simp: tcb_to_itcb'_def)+ + lemma tcbSchedEnqueue_pred_tcb_at'[wp]: "\\s. pred_tcb_at' proj P' t' s \ tcbSchedEnqueue t \\_ s. pred_tcb_at' proj P' t' s\" - apply (simp add: tcbSchedEnqueue_def when_def unless_def) + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def when_def unless_def) apply (wp threadSet_pred_tcb_no_state crunch_wps | clarsimp simp: tcb_to_itcb'_def)+ done @@ -2382,8 +3537,9 @@ lemma tcbSchedDequeue_sch_act_wf[wp]: "\\s. sch_act_wf (ksSchedulerAction s) s\ tcbSchedDequeue t \\_ s. sch_act_wf (ksSchedulerAction s) s\" - unfolding tcbSchedDequeue_def - by (wp setQueue_sch_act | wp sch_act_wf_lift | simp add: if_apply_def2)+ + unfolding tcbSchedDequeue_def tcbQueueRemove_def + by (wp setQueue_sch_act threadSet_tcbDomain_triv hoare_drop_imps + | wp sch_act_wf_lift | simp add: if_apply_def2)+ crunch nosch: tcbSchedDequeue "\s. P (ksSchedulerAction s)" @@ -2479,21 +3635,22 @@ lemma tcbSchedEnqueue_sch_act[wp]: "\\s. sch_act_wf (ksSchedulerAction s) s\ tcbSchedEnqueue t \\_ s. sch_act_wf (ksSchedulerAction s) s\" - by (simp add: tcbSchedEnqueue_def unless_def) - (wp setQueue_sch_act | wp sch_act_wf_lift | clarsimp)+ + by (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_def) + (wp setQueue_sch_act threadSet_tcbDomain_triv | wp sch_act_wf_lift | clarsimp)+ lemma tcbSchedEnqueue_weak_sch_act[wp]: "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ tcbSchedEnqueue t \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: tcbSchedEnqueue_def unless_def) + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_def) apply (wp setQueue_sch_act threadSet_weak_sch_act_wf | clarsimp)+ done -lemma threadGet_wp: "\\s. tcb_at' t s \ (\tcb. ko_at' tcb t s \ P (f tcb) s)\ threadGet f t \P\" +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 + apply (clarsimp simp: obj_at'_def) done lemma threadGet_const: @@ -2539,14 +3696,6 @@ lemma addToBitmap_bitmapQ: by (wpsimp simp: bitmap_fun_defs bitmapQ_def prioToL1Index_bit_set prioL2Index_bit_set simp_del: bit_exp_iff) -lemma addToBitmap_valid_queues_no_bitmap_except: -" \ valid_queues_no_bitmap_except t \ - addToBitmap d p - \\_. valid_queues_no_bitmap_except t \" - unfolding addToBitmap_def modifyReadyQueuesL1Bitmap_def modifyReadyQueuesL2Bitmap_def - getReadyQueuesL1Bitmap_def getReadyQueuesL2Bitmap_def valid_queues_no_bitmap_except_def - by (wp, clarsimp) - crunch norq[wp]: addToBitmap "\s. P (ksReadyQueues s)" (wp: updateObject_cte_inv hoare_drop_imps) crunch norq[wp]: removeFromBitmap "\s. P (ksReadyQueues s)" @@ -2578,9 +3727,8 @@ lemma prioToL1Index_complement_nth_w2p: lemma valid_bitmapQ_exceptE: "\ valid_bitmapQ_except d' p' s ; d \ d' \ p \ p' \ - \ bitmapQ d p s = (ksReadyQueues s (d, p) \ [])" - unfolding valid_bitmapQ_except_def - by blast + \ bitmapQ d p s = (\ tcbQueueEmpty (ksReadyQueues s (d, p)))" + by (fastforce simp: valid_bitmapQ_except_def) lemma invertL1Index_eq_cancelD: "\ invertL1Index i = invertL1Index j ; i < l2BitmapSize ; j < l2BitmapSize \ @@ -2695,22 +3843,15 @@ lemma addToBitmap_valid_bitmapQ_except: done lemma addToBitmap_valid_bitmapQ: -" \ valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and - (\s. ksReadyQueues s (d,p) \ []) \ - addToBitmap d p - \\_. valid_bitmapQ \" -proof - - have "\ valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and - (\s. ksReadyQueues s (d,p) \ []) \ - addToBitmap d p - \\_. valid_bitmapQ_except d p and - bitmapQ_no_L2_orphans and (\s. bitmapQ d p s \ ksReadyQueues s (d,p) \ []) \" - by (wp addToBitmap_valid_queues_no_bitmap_except addToBitmap_valid_bitmapQ_except - addToBitmap_bitmapQ_no_L2_orphans addToBitmap_bitmapQ; simp) - - thus ?thesis - by - (erule hoare_strengthen_post; fastforce elim: valid_bitmap_valid_bitmapQ_exceptE) -qed + "\valid_bitmapQ_except d p and bitmapQ_no_L2_orphans + and (\s. \ tcbQueueEmpty (ksReadyQueues s (d,p)))\ + addToBitmap d p + \\_. valid_bitmapQ\" + (is "\?pre\ _ \_\") + apply (rule_tac Q="\_ s. ?pre s \ bitmapQ d p s" in hoare_strengthen_post) + apply (wpsimp wp: addToBitmap_valid_bitmapQ_except addToBitmap_bitmapQ) + apply (fastforce elim: valid_bitmap_valid_bitmapQ_exceptE) + done 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 \" @@ -2728,12 +3869,6 @@ lemma threadGet_const_tcb_at_imp_lift: apply (clarsimp simp: obj_at'_def) done -lemma valid_queues_no_bitmap_objD: - "\ valid_queues_no_bitmap s; t \ set (ksReadyQueues s (d, p))\ - \ obj_at' (inQ d p and runnable' \ tcbState) t s" - unfolding valid_queues_no_bitmap_def - by metis - lemma setQueue_bitmapQ_no_L1_orphans[wp]: "\ bitmapQ_no_L1_orphans \ setQueue d p ts @@ -2753,126 +3888,6 @@ lemma setQueue_sets_queue[wp]: unfolding setQueue_def by (wp, simp) -lemma tcbSchedEnqueueOrAppend_valid_queues: - (* f is either (t#ts) or (ts @ [t]), so we define its properties generally *) - assumes f_set[simp]: "\ts. t \ set (f ts)" - assumes f_set_insert[simp]: "\ts. set (f ts) = insert t (set ts)" - assumes f_not_empty[simp]: "\ts. f ts \ []" - assumes f_distinct: "\ts. \ distinct ts ; t \ set ts \ \ distinct (f ts)" - shows "\Invariants_H.valid_queues and st_tcb_at' runnable' t and valid_objs' \ - do queued \ threadGet tcbQueued t; - unless queued $ - do tdom \ threadGet tcbDomain t; - prio \ threadGet tcbPriority t; - queue \ getQueue tdom prio; - setQueue tdom prio $ f queue; - when (null queue) $ addToBitmap tdom prio; - threadSet (tcbQueued_update (\_. True)) t - od - od - \\_. Invariants_H.valid_queues\" -proof - - - define could_run where "could_run == - \d p t. obj_at' (\tcb. inQ d p (tcbQueued_update (\_. True) tcb) \ runnable' (tcbState tcb)) t" - - have addToBitmap_could_run: - "\d p. \\s. \d p. t \ set (ksReadyQueues s (d, p)) \ could_run d p t s\ - addToBitmap d p - \\_ s. \d p. t \ set (ksReadyQueues s (d, p)) \ could_run d p t s\" - unfolding bitmap_fun_defs - by (wp, clarsimp simp: could_run_def) - - have setQueue_valid_queues_no_bitmap_except: - "\d p ts. - \ valid_queues_no_bitmap_except t and - (\s. ksReadyQueues s (d, p) = ts \ p \ maxPriority \ d \ maxDomain \ t \ set ts) \ - setQueue d p (f ts) - \\rv. valid_queues_no_bitmap_except t\" - unfolding setQueue_def valid_queues_no_bitmap_except_def null_def - by (wp, auto intro: f_distinct) - - have threadSet_valid_queues_could_run: - "\f. \ valid_queues_no_bitmap_except t and - (\s. \d p. t \ set (ksReadyQueues s (d,p)) \ could_run d p t s) and - valid_bitmapQ and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans \ - threadSet (tcbQueued_update (\_. True)) t - \\rv. Invariants_H.valid_queues \" - unfolding threadSet_def could_run_def - apply (rule hoare_seq_ext[OF _ getObject_tcb_sp]) - apply (rule hoare_pre) - apply (simp add: valid_queues_def valid_queues_no_bitmap_def) - apply (wp setObject_queues_unchanged_tcb hoare_Ball_helper hoare_vcg_all_lift - setObject_tcb_strongest) - apply (clarsimp simp: valid_queues_no_bitmap_except_def obj_at'_def) - done - - have setQueue_could_run: "\d p ts. - \ valid_queues and (\_. t \ set ts) and - (\s. could_run d p t s) \ - setQueue d p ts - \\rv s. (\d p. t \ set (ksReadyQueues s (d, p)) \ could_run d p t s)\" - unfolding setQueue_def valid_queues_def could_run_def - by wp (fastforce dest: valid_queues_no_bitmap_objD simp: obj_at'_def inQ_def) - - note hoare_vcg_if_lift[wp] hoare_vcg_conj_lift[wp] hoare_vcg_const_imp_lift[wp] - - show ?thesis - unfolding tcbSchedEnqueue_def null_def - apply (rule hoare_pre) - apply (rule hoare_seq_ext) - apply (simp add: unless_def) - apply (wp threadSet_valid_queues_could_run) - apply (wp addToBitmap_could_run addToBitmap_valid_bitmapQ - addToBitmap_valid_queues_no_bitmap_except addToBitmap_bitmapQ_no_L2_orphans)+ - apply (wp setQueue_valid_queues_no_bitmap_except setQueue_could_run - setQueue_valid_bitmapQ_except setQueue_sets_queue setQueue_valid_bitmapQ)+ - apply (wp threadGet_const_tcb_at_imp_lift | simp add: if_apply_def2)+ - apply clarsimp - apply (frule pred_tcb_at') - apply (frule (1) valid_objs'_maxDomain) - apply (frule (1) valid_objs'_maxPriority) - apply (clarsimp simp: valid_queues_def st_tcb_at'_def obj_at'_def valid_queues_no_bitmap_exceptI) - apply (fastforce dest!: valid_queues_no_bitmap_objD simp: obj_at'_def inQ_def could_run_def) - done -qed - -lemma tcbSchedEnqueue_valid_queues[wp]: - "\Invariants_H.valid_queues - and st_tcb_at' runnable' t - and valid_objs' \ - tcbSchedEnqueue t - \\_. Invariants_H.valid_queues\" - unfolding tcbSchedEnqueue_def - by (fastforce intro: tcbSchedEnqueueOrAppend_valid_queues) - -lemma tcbSchedAppend_valid_queues[wp]: - "\Invariants_H.valid_queues - and st_tcb_at' runnable' t - and valid_objs' \ - tcbSchedAppend t - \\_. Invariants_H.valid_queues\" - unfolding tcbSchedAppend_def - by (fastforce intro: tcbSchedEnqueueOrAppend_valid_queues) - -lemma rescheduleRequired_valid_queues[wp]: - "\\s. Invariants_H.valid_queues s \ valid_objs' s \ - weak_sch_act_wf (ksSchedulerAction s) s\ - rescheduleRequired - \\_. Invariants_H.valid_queues\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp)+ - apply (fastforce simp: weak_sch_act_wf_def elim: valid_objs'_maxDomain valid_objs'_maxPriority) - done - -lemma rescheduleRequired_valid_queues_sch_act_simple: - "\Invariants_H.valid_queues and sch_act_simple\ - rescheduleRequired - \\_. Invariants_H.valid_queues\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp | fastforce simp: Invariants_H.valid_queues_def sch_act_simple_def)+ - done - lemma rescheduleRequired_valid_bitmapQ_sch_act_simple: "\ valid_bitmapQ and sch_act_simple\ rescheduleRequired @@ -2914,151 +3929,32 @@ lemma rescheduleRequired_bitmapQ_no_L2_orphans_sch_act_simple: lemma sts_valid_bitmapQ_sch_act_simple: "\valid_bitmapQ and sch_act_simple\ - setThreadState st t + setThreadState st t \\_. valid_bitmapQ \" 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 Invariants_H.valid_queues_def inQ_def)+ + 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 \" + "\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 Invariants_H.valid_queues_def inQ_def)+ + 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 and sch_act_simple\ + setThreadState st t \\_. bitmapQ_no_L1_orphans \" 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 Invariants_H.valid_queues_def inQ_def)+ - done - -lemma sts_valid_queues: - "\\s. Invariants_H.valid_queues s \ - ((\p. t \ set(ksReadyQueues s p)) \ runnable' st)\ - setThreadState st t \\rv. Invariants_H.valid_queues\" - apply (simp add: setThreadState_def) - apply (wp rescheduleRequired_valid_queues_sch_act_simple - threadSet_valid_queues [THEN hoare_strengthen_post]) - apply (clarsimp simp: sch_act_simple_def Invariants_H.valid_queues_def inQ_def)+ - done - -lemma sbn_valid_queues: - "\\s. Invariants_H.valid_queues s\ - setBoundNotification ntfn t \\rv. Invariants_H.valid_queues\" - apply (simp add: setBoundNotification_def) - apply (wp threadSet_valid_queues [THEN hoare_strengthen_post]) - apply (clarsimp simp: sch_act_simple_def Invariants_H.valid_queues_def inQ_def)+ - done - - - -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]: - "\valid_queues' and st_tcb_at' runnable' t \ - tcbSchedEnqueue t - \\_. valid_queues'\" - apply (simp add: tcbSchedEnqueue_def) - apply (rule hoare_pre) - apply (rule_tac B="\rv. valid_queues' and obj_at' (\obj. tcbQueued obj = rv) t" - in hoare_seq_ext) - 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 inQ_def) - apply (wp setQueue_valid_queues' | simp | simp add: setQueue_def)+ - apply (wp getObject_tcb_wp | simp add: threadGet_def)+ - apply (clarsimp simp: obj_at'_def inQ_def valid_queues'_def) - apply (wp getObject_tcb_wp | simp add: threadGet_def)+ - apply (clarsimp simp: obj_at'_def) - done - -lemma rescheduleRequired_valid_queues'_weak[wp]: - "\\s. valid_queues' s \ weak_sch_act_wf (ksSchedulerAction s) s\ - rescheduleRequired - \\_. valid_queues'\" - apply (simp add: rescheduleRequired_def) - apply wpsimp - apply (clarsimp simp: weak_sch_act_wf_def) - done - -lemma rescheduleRequired_valid_queues'_sch_act_simple: - "\valid_queues' and sch_act_simple\ - rescheduleRequired - \\_. valid_queues'\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp | fastforce simp: valid_queues'_def sch_act_simple_def)+ - done - -lemma setThreadState_valid_queues'[wp]: - "\\s. valid_queues' s\ setThreadState st t \\rv. valid_queues'\" - apply (simp add: setThreadState_def) - apply (wp rescheduleRequired_valid_queues'_sch_act_simple) - apply (rule_tac Q="\_. valid_queues'" in hoare_post_imp) - apply (clarsimp simp: sch_act_simple_def) - apply (wp threadSet_valid_queues') - apply (fastforce simp: inQ_def obj_at'_def pred_tcb_at'_def) - 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 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 cteSizeBits_def valid_tcb_state'_def) - done - -lemma setThreadState_valid_objs'[wp]: - "\ valid_tcb_state' st and valid_objs' \ setThreadState st t \ \_. valid_objs' \" - apply (simp add: setThreadState_def) - apply (wp threadSet_valid_objs' | clarsimp simp: valid_tcb'_tcbState_update)+ - done - -lemma rescheduleRequired_ksQ: - "\\s. sch_act_simple s \ P (ksReadyQueues s p)\ - rescheduleRequired - \\_ s. P (ksReadyQueues s p)\" - including no_pre - apply (simp add: rescheduleRequired_def sch_act_simple_def) - apply (rule_tac B="\rv s. (rv = ResumeCurrentThread \ rv = ChooseNewThread) - \ P (ksReadyQueues s p)" in hoare_seq_ext) - apply wpsimp - apply (case_tac x; simp) - apply wp + apply (clarsimp simp: sch_act_simple_def inQ_def)+ done lemma setSchedulerAction_ksQ[wp]: @@ -3073,17 +3969,6 @@ lemma sbn_ksQ: "\\s. P (ksReadyQueues s p)\ setBoundNotification ntfn t \\rv s. P (ksReadyQueues s p)\" by (simp add: setBoundNotification_def, wp) -lemma sts_ksQ: - "\\s. sch_act_simple s \ P (ksReadyQueues s p)\ - setThreadState st t - \\_ s. P (ksReadyQueues s p)\" - apply (simp add: setThreadState_def) - apply (wp rescheduleRequired_ksQ) - apply (rule_tac Q="\_ s. P (ksReadyQueues s p)" in hoare_post_imp) - apply (clarsimp simp: sch_act_simple_def)+ - apply (wp, simp) - done - lemma setQueue_ksQ[wp]: "\\s. P ((ksReadyQueues s)((d, p) := q))\ setQueue d p q @@ -3091,22 +3976,6 @@ lemma setQueue_ksQ[wp]: by (simp add: setQueue_def fun_upd_def[symmetric] | wp)+ -lemma tcbSchedEnqueue_ksQ: - "\\s. t' \ set (ksReadyQueues s p) \ t' \ t \ - tcbSchedEnqueue t \\_ s. t' \ set (ksReadyQueues s p)\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wpsimp wp: hoare_vcg_imp_lift threadGet_wp) - apply (drule obj_at_ko_at') - apply fastforce - done - -lemma rescheduleRequired_ksQ': - "\\s. t \ set (ksReadyQueues s p) \ sch_act_not t s \ - rescheduleRequired \\_ s. t \ set (ksReadyQueues s p)\" - apply (simp add: rescheduleRequired_def) - apply (wpsimp wp: tcbSchedEnqueue_ksQ) - done - lemma threadSet_tcbState_st_tcb_at': "\\s. P st \ threadSet (tcbState_update (\_. st)) t \\_. st_tcb_at' P t\" apply (simp add: threadSet_def pred_tcb_at'_def) @@ -3117,36 +3986,6 @@ lemma isRunnable_const: "\st_tcb_at' runnable' t\ isRunnable t \\runnable _. runnable \" by (rule isRunnable_wp) -lemma sts_ksQ': - "\\s. (runnable' st \ ksCurThread s \ t) \ P (ksReadyQueues s p)\ - setThreadState st t - \\_ s. P (ksReadyQueues s p)\" - apply (simp add: setThreadState_def) - apply (rule hoare_pre_disj') - apply (rule hoare_seq_ext [OF _ - hoare_vcg_conj_lift - [OF threadSet_tcbState_st_tcb_at' [where P=runnable'] - threadSet_ksQ]]) - apply (rule hoare_seq_ext [OF _ - hoare_vcg_conj_lift [OF isRunnable_const isRunnable_inv]]) - apply (clarsimp simp: when_def) - apply (case_tac x) - apply (clarsimp, wp)[1] - apply (clarsimp) - apply (rule hoare_seq_ext [OF _ - hoare_vcg_conj_lift - [OF threadSet_ct threadSet_ksQ]]) - apply (rule hoare_seq_ext [OF _ isRunnable_inv]) - apply (rule hoare_seq_ext [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 valid_ipc_buffer_ptr'D: assumes yv: "y < unat max_ipc_words" and buf: "valid_ipc_buffer_ptr' a s" @@ -3720,7 +4559,7 @@ lemma ct_in_state'_set: crunches setQueue, rescheduleRequired, tcbSchedDequeue for idle'[wp]: "valid_idle'" - (simp: crunch_simps) + (simp: crunch_simps wp: crunch_wps) lemma sts_valid_idle'[wp]: "\valid_idle' and valid_pspace' and @@ -3760,8 +4599,9 @@ lemma gbn_sp': lemma tcbSchedDequeue_tcbState_obj_at'[wp]: "\obj_at' (P \ tcbState) t'\ tcbSchedDequeue t \\rv. obj_at' (P \ tcbState) t'\" - apply (simp add: tcbSchedDequeue_def) - apply (wp | simp add: o_def split del: if_split cong: if_cong)+ + apply (simp add: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wpsimp wp: getObject_tcb_wp simp: o_def threadGet_def) + apply (clarsimp simp: obj_at'_def) done crunch typ_at'[wp]: setQueue "\s. P' (typ_at' P t s)" @@ -3780,10 +4620,14 @@ lemma setQueue_pred_tcb_at[wp]: lemma tcbSchedDequeue_pred_tcb_at'[wp]: "\\s. P' (pred_tcb_at' proj P t' s)\ tcbSchedDequeue t \\_ s. P' (pred_tcb_at' proj P t' s)\" apply (rule_tac P=P' in P_bool_lift) - apply (simp add: tcbSchedDequeue_def) - apply (wp threadSet_pred_tcb_no_state | clarsimp simp: tcb_to_itcb'_def)+ - apply (simp add: tcbSchedDequeue_def) - apply (wp threadSet_pred_tcb_no_state | clarsimp simp: tcb_to_itcb'_def)+ + apply (simp add: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wpsimp wp: threadSet_pred_tcb_no_state getObject_tcb_wp + simp: threadGet_def tcb_to_itcb'_def) + apply (clarsimp simp: obj_at'_def) + apply (simp add: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wpsimp wp: threadSet_pred_tcb_no_state getObject_tcb_wp + simp: threadGet_def tcb_to_itcb'_def) + apply (clarsimp simp: obj_at'_def) done lemma sts_st_tcb': @@ -3879,39 +4723,154 @@ crunch nonz_cap[wp]: addToBitmap "ex_nonz_cap_to' t" crunch iflive'[wp]: removeFromBitmap if_live_then_nonz_cap' crunch nonz_cap[wp]: removeFromBitmap "ex_nonz_cap_to' t" -lemma tcbSchedEnqueue_iflive'[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' tcb\ - tcbSchedEnqueue tcb \\_. if_live_then_nonz_cap'\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wp threadSet_iflive' hoare_drop_imps | simp add: crunch_simps)+ +crunches rescheduleRequired + for cap_to'[wp]: "ex_nonz_cap_to' p" + +lemma tcbQueued_update_tcb_cte_cases: + "(getF, setF) \ ran tcb_cte_cases \ getF (tcbQueued_update f tcb) = getF tcb" + unfolding tcb_cte_cases_def + by (case_tac tcb; fastforce simp: objBits_simps') + +lemma tcbSchedNext_update_tcb_cte_cases: + "(getF, setF) \ ran tcb_cte_cases \ getF (tcbSchedNext_update f tcb) = getF tcb" + unfolding tcb_cte_cases_def + by (case_tac tcb; fastforce simp: objBits_simps') + +lemma tcbSchedPrev_update_tcb_cte_cases: + "(getF, setF) \ ran tcb_cte_cases \ getF (tcbSchedPrev_update f tcb) = getF tcb" + unfolding tcb_cte_cases_def + by (case_tac tcb; fastforce simp: objBits_simps') + +lemma tcbSchedNext_update_ctes_of[wp]: + "threadSet (tcbSchedNext_update f) tptr \\s. P (ctes_of s)\" + by (wpsimp wp: threadSet_ctes_ofT simp: tcbSchedNext_update_tcb_cte_cases) + +lemma tcbSchedPrev_update_ctes_of[wp]: + "threadSet (tcbSchedPrev_update f) tptr \\s. P (ctes_of s)\" + by (wpsimp wp: threadSet_ctes_ofT simp: tcbSchedPrev_update_tcb_cte_cases) + +lemma tcbSchedNext_ex_nonz_cap_to'[wp]: + "threadSet (tcbSchedNext_update f) tptr \ex_nonz_cap_to' p\" + by (wpsimp wp: threadSet_cap_to simp: tcbSchedNext_update_tcb_cte_cases) + +lemma tcbSchedPrev_ex_nonz_cap_to'[wp]: + "threadSet (tcbSchedPrev_update f) tptr \ex_nonz_cap_to' p\" + by (wpsimp wp: threadSet_cap_to simp: tcbSchedPrev_update_tcb_cte_cases) + +lemma tcbSchedNext_update_iflive': + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' t s\ + threadSet (tcbSchedNext_update f) t + \\_. if_live_then_nonz_cap'\" + by (wpsimp wp: threadSet_iflive'T simp: tcbSchedNext_update_tcb_cte_cases) + +lemma tcbSchedPrev_update_iflive': + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' t s\ + threadSet (tcbSchedPrev_update f) t + \\_. if_live_then_nonz_cap'\" + by (wpsimp wp: threadSet_iflive'T simp: tcbSchedPrev_update_tcb_cte_cases) + +lemma tcbQueued_update_iflive'[wp]: + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' t s\ + threadSet (tcbQueued_update f) t + \\_. if_live_then_nonz_cap'\" + by (wpsimp wp: threadSet_iflive'T simp: tcbQueued_update_tcb_cte_cases) + +lemma getTCB_wp: + "\\s. \ko :: tcb. ko_at' ko p s \ Q ko s\ getObject p \Q\" + apply (wpsimp wp: getObject_tcb_wp) + apply (clarsimp simp: obj_at'_def) done -lemma rescheduleRequired_iflive'[wp]: - "\if_live_then_nonz_cap' - and (\s. \t. ksSchedulerAction s = SwitchToThread t - \ st_tcb_at' runnable' t s)\ - rescheduleRequired - \\rv. if_live_then_nonz_cap'\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp)+ - apply (clarsimp simp: pred_tcb_at'_def obj_at'_real_def) - apply (erule(1) if_live_then_nonz_capD') - apply fastforce +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 ko_wp_at'_def) + done + +lemma tcbQueueRemove_ex_nonz_cap_to'[wp]: + "tcbQueueRemove q tcbPtr \ex_nonz_cap_to' tcbPtr'\" + unfolding tcbQueueRemove_def + by (wpsimp wp: threadSet_cap_to' hoare_drop_imps getTCB_wp) + +(* We could write this one as "\t. tcbQueueHead t \ ..." instead, but we can't do the same in + tcbQueueAppend_if_live_then_nonz_cap', and it's nicer if the two lemmas are symmetric *) +lemma tcbQueuePrepend_if_live_then_nonz_cap': + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' tcbPtr s + \ (\ tcbQueueEmpty q \ ex_nonz_cap_to' (the (tcbQueueHead q)) s)\ + tcbQueuePrepend q tcbPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbQueuePrepend_def + by (wpsimp wp: tcbSchedPrev_update_iflive' tcbSchedNext_update_iflive' + hoare_vcg_if_lift2 hoare_vcg_imp_lift') + +lemma tcbQueueAppend_if_live_then_nonz_cap': + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' tcbPtr s + \ (\ tcbQueueEmpty q \ ex_nonz_cap_to' (the (tcbQueueEnd q)) s)\ + tcbQueueAppend q tcbPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbQueueAppend_def + by (wpsimp wp: tcbSchedPrev_update_iflive' tcbSchedNext_update_iflive') + +lemma tcbQueueInsert_if_live_then_nonz_cap': + "\if_live_then_nonz_cap' and ex_nonz_cap_to' tcbPtr and valid_objs' and sym_heap_sched_pointers\ + tcbQueueInsert tcbPtr afterPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbQueueInsert_def + apply (wpsimp wp: tcbSchedPrev_update_iflive' tcbSchedNext_update_iflive' getTCB_wp) + apply (intro conjI) + apply (erule if_live_then_nonz_capE') + apply (clarsimp simp: ko_wp_at'_def obj_at'_def) + apply (erule if_live_then_nonz_capE') + apply (frule_tac p'=afterPtr in sym_heapD2) + apply (fastforce simp: opt_map_def obj_at'_def) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (clarsimp simp: valid_tcb'_def ko_wp_at'_def obj_at'_def opt_map_def) done +lemma tcbSchedEnqueue_iflive'[wp]: + "\if_live_then_nonz_cap' and pspace_aligned' and pspace_distinct'\ + tcbSchedEnqueue tcbPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbSchedEnqueue_def + apply (wpsimp wp: tcbQueuePrepend_if_live_then_nonz_cap' threadGet_wp) + apply normalise_obj_at' + apply (rename_tac tcb) + apply (frule_tac p=tcbPtr in if_live_then_nonz_capE') + apply (fastforce simp: ko_wp_at'_def obj_at'_def) + apply clarsimp + apply (erule if_live_then_nonz_capE') + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (fastforce dest!: obj_at'_tcbQueueHead_ksReadyQueues + simp: ko_wp_at'_def inQ_def opt_pred_def opt_map_def obj_at'_def + split: option.splits) + done + +crunches rescheduleRequired + for iflive'[wp]: if_live_then_nonz_cap' + lemma sts_iflive'[wp]: "\\s. if_live_then_nonz_cap' s - \ (st \ Inactive \ \ idle' st \ ex_nonz_cap_to' t s)\ + \ (st \ Inactive \ \ idle' st \ ex_nonz_cap_to' t s) + \ pspace_aligned' s \ pspace_distinct' s\ setThreadState st t \\rv. if_live_then_nonz_cap'\" apply (simp add: setThreadState_def setQueue_def) - apply (rule hoare_pre) - apply (wp | simp)+ - apply (rule_tac Q="\rv. if_live_then_nonz_cap'" in hoare_post_imp) - apply clarsimp - apply (wp threadSet_iflive' | simp)+ - apply auto - done + 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 + done lemma sbn_iflive'[wp]: "\\s. if_live_then_nonz_cap' s @@ -4030,6 +4989,18 @@ lemma setBoundNotification_vms'[wp]: apply (intro hoare_vcg_all_lift hoare_vcg_disj_lift; wp) done +lemma threadSet_ct_not_inQ: + "(\tcb. tcbQueued tcb = tcbQueued (F tcb)) + \ threadSet F tcbPtr \\s. P (ct_not_inQ s)\" + unfolding threadSet_def + apply (wpsimp wp: getTCB_wp simp: setObject_def updateObject_default_def) + apply (erule rsubst[where P=P]) + by (fastforce simp: ct_not_inQ_def obj_at'_def objBits_simps ps_clear_def split: if_splits) + +crunches tcbQueuePrepend, tcbQueueAppend, tcbQueueInsert, tcbQueueRemove, addToBitmap + for ct_not_inQ[wp]: ct_not_inQ + (wp: threadSet_ct_not_inQ crunch_wps) + lemma tcbSchedEnqueue_ct_not_inQ: "\ct_not_inQ and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ tcbSchedEnqueue t \\_. ct_not_inQ\" @@ -4053,12 +5024,7 @@ lemma tcbSchedEnqueue_ct_not_inQ: done show ?thesis apply (simp add: tcbSchedEnqueue_def unless_def null_def) - apply (wp ts sq hoare_convert_imp [OF addToBitmap_nosch addToBitmap_ct'])+ - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, clarsimp) - apply (wp sq hoare_convert_imp [OF setQueue_nosch setQueue_ct])+ - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, clarsimp) - apply wp - apply assumption + apply (wpsimp wp: ts sq hoare_vcg_imp_lift' getTCB_wp simp: threadGet_def)+ done qed @@ -4085,12 +5051,7 @@ lemma tcbSchedAppend_ct_not_inQ: done show ?thesis apply (simp add: tcbSchedAppend_def unless_def null_def) - apply (wp ts sq hoare_convert_imp [OF addToBitmap_nosch addToBitmap_ct'])+ - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, clarsimp) - apply (wp sq hoare_convert_imp [OF setQueue_nosch setQueue_ct])+ - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, clarsimp) - apply wp - apply assumption + apply (wpsimp wp: ts sq hoare_vcg_imp_lift' getTCB_wp simp: threadGet_def)+ done qed @@ -4119,12 +5080,10 @@ lemma rescheduleRequired_sa_cnt[wp]: lemma possibleSwitchTo_ct_not_inQ: "\ct_not_inQ and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ possibleSwitchTo t \\_. ct_not_inQ\" - (is "\?PRE\ _ \_\") apply (simp add: possibleSwitchTo_def curDomain_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) + | (rule hoare_post_imp[OF _ rescheduleRequired_sa_cnt], fastforce))+ done lemma threadSet_tcbState_update_ct_not_inQ[wp]: @@ -4204,29 +5163,6 @@ lemma tcbSchedDequeue_ct_not_inQ[wp]: done qed -lemma tcbSchedEnqueue_not_st: - "(\tcb st qd. P (tcb\tcbState := st, tcbQueued := qd\) \ P tcb) - \ \obj_at' P t'\ tcbSchedEnqueue t \\_. obj_at' P t'\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wp threadGet_wp | simp)+ - apply (clarsimp simp: obj_at'_def) - apply (case_tac obja) - apply fastforce - done - -lemma setThreadState_not_st: - "(\tcb st qd. P (tcb\tcbState := st, tcbQueued := qd\) \ P tcb) - \ \obj_at' P t'\ setThreadState st t \\_. obj_at' P t'\" - apply (simp add: setThreadState_def rescheduleRequired_def) - apply (wp hoare_vcg_conj_lift tcbSchedEnqueue_not_st - | wpc - | rule hoare_drop_imps - | simp)+ - apply (clarsimp simp: obj_at'_def) - apply (case_tac obj) - apply fastforce - done - crunch ct_idle_or_in_cur_domain'[wp]: setQueue ct_idle_or_in_cur_domain' (simp: ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) @@ -4255,17 +5191,8 @@ lemma removeFromBitmap_ct_idle_or_in_cur_domain'[wp]: | clarsimp simp: updateObject_default_def in_monad setNotification_def)+ done -lemma tcbSchedEnqueue_ksCurDomain[wp]: - "\ \s. P (ksCurDomain s)\ tcbSchedEnqueue tptr \\_ s. P (ksCurDomain s)\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply wpsimp - done - -lemma tcbSchedEnqueue_ksDomSchedule[wp]: - "\ \s. P (ksDomSchedule s)\ tcbSchedEnqueue tptr \\_ s. P (ksDomSchedule s)\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply wpsimp - done +crunches tcbQueuePrepend + for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' lemma tcbSchedEnqueue_ct_idle_or_in_cur_domain'[wp]: "\ct_idle_or_in_cur_domain'\ tcbSchedEnqueue tptr \\_. ct_idle_or_in_cur_domain'\" @@ -4343,12 +5270,375 @@ lemma sts_utr[wp]: apply (wp untyped_ranges_zero_lift) done +lemma removeFromBitmap_bitmapQ: + "\\\ removeFromBitmap d p \\_ s. \ bitmapQ d p s \" + unfolding bitmapQ_defs bitmap_fun_defs + by (wpsimp simp: bitmap_fun_defs) + +lemma removeFromBitmap_valid_bitmapQ[wp]: + "\valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans + and (\s. tcbQueueEmpty (ksReadyQueues s (d,p)))\ + removeFromBitmap d p + \\_. valid_bitmapQ\" + (is "\?pre\ _ \_\") + apply (rule_tac Q="\_ s. ?pre s \ \ bitmapQ d p s" in hoare_strengthen_post) + apply (wpsimp wp: removeFromBitmap_valid_bitmapQ_except removeFromBitmap_bitmapQ) + apply (fastforce elim: valid_bitmap_valid_bitmapQ_exceptE) + done + +crunches tcbSchedDequeue + for bitmapQ_no_L1_orphans[wp]: bitmapQ_no_L1_orphans + and bitmapQ_no_L2_orphans[wp]: bitmapQ_no_L2_orphans + (wp: crunch_wps simp: crunch_simps) + +lemma setQueue_nonempty_valid_bitmapQ': + "\\s. valid_bitmapQ s \ \ tcbQueueEmpty (ksReadyQueues s (d, p))\ + setQueue d p queue + \\_ s. \ tcbQueueEmpty queue \ valid_bitmapQ s\" + apply (wpsimp simp: setQueue_def) + apply (fastforce simp: valid_bitmapQ_def bitmapQ_def) + done + +lemma threadSet_valid_bitmapQ_except[wp]: + "threadSet f tcbPtr \valid_bitmapQ_except d p\" + unfolding threadSet_def + apply (wpsimp wp: getTCB_wp simp: setObject_def updateObject_default_def) + apply (clarsimp simp: valid_bitmapQ_except_def bitmapQ_def) + done + +lemma threadSet_bitmapQ: + "threadSet F t \bitmapQ domain priority\" + unfolding threadSet_def + apply (wpsimp wp: getTCB_wp simp: setObject_def updateObject_default_def) + by (clarsimp simp: bitmapQ_def) + +crunches tcbQueueRemove, tcbQueuePrepend, tcbQueueAppend + for valid_bitmapQ_except[wp]: "valid_bitmapQ_except d p" + and valid_bitmapQ[wp]: valid_bitmapQ + and bitmapQ[wp]: "bitmapQ tdom prio" + (wp: crunch_wps) + +lemma tcbQueued_imp_queue_nonempty: + "\list_queue_relation ts (ksReadyQueues s (tcbDomain tcb, tcbPriority tcb)) nexts prevs; + \t. t \ set ts \ (inQ (tcbDomain tcb) (tcbPriority tcb) |< tcbs_of' s) t; + ko_at' tcb tcbPtr s; tcbQueued tcb\ + \ \ tcbQueueEmpty (ksReadyQueues s (tcbDomain tcb, tcbPriority tcb))" + apply (clarsimp simp: list_queue_relation_def tcbQueueEmpty_def) + apply (drule_tac x=tcbPtr in spec) + apply (fastforce dest: heap_path_head simp: inQ_def opt_map_def opt_pred_def obj_at'_def) + done + +lemma tcbSchedDequeue_valid_bitmapQ[wp]: + "\valid_bitmaps\ tcbSchedDequeue tcbPtr \\_. valid_bitmapQ\" + unfolding tcbSchedDequeue_def tcbQueueRemove_def + apply (wpsimp wp: setQueue_nonempty_valid_bitmapQ' hoare_vcg_conj_lift + hoare_vcg_if_lift2 hoare_vcg_const_imp_lift threadGet_wp + | wp (once) hoare_drop_imps)+ + by (fastforce dest!: tcbQueued_imp_queue_nonempty + simp: ready_queue_relation_def ksReadyQueues_asrt_def obj_at'_def) + +lemma tcbSchedDequeue_valid_bitmaps[wp]: + "tcbSchedDequeue tcbPtr \valid_bitmaps\" + by (wpsimp simp: valid_bitmaps_def) + +lemma setQueue_valid_bitmapQ': (* enqueue only *) + "\valid_bitmapQ_except d p and bitmapQ d p and K (\ tcbQueueEmpty q)\ + setQueue d p q + \\_. valid_bitmapQ\" + unfolding setQueue_def bitmapQ_defs + by (wpsimp simp: bitmapQ_def) + +lemma tcbSchedEnqueue_valid_bitmapQ[wp]: + "\valid_bitmaps\ tcbSchedEnqueue tcbPtr \\_. valid_bitmapQ\" + supply if_split[split del] + unfolding tcbSchedEnqueue_def + apply (wpsimp simp: tcbQueuePrepend_def + wp: setQueue_valid_bitmapQ' addToBitmap_valid_bitmapQ_except addToBitmap_bitmapQ + threadGet_wp) + apply (fastforce simp: valid_bitmaps_def valid_bitmapQ_def tcbQueueEmpty_def split: if_splits) + done + +crunches tcbSchedEnqueue, tcbSchedAppend + for bitmapQ_no_L1_orphans[wp]: bitmapQ_no_L1_orphans + and bitmapQ_no_L2_orphans[wp]: bitmapQ_no_L2_orphans + +lemma tcbSchedEnqueue_valid_bitmaps[wp]: + "tcbSchedEnqueue tcbPtr \valid_bitmaps\" + unfolding valid_bitmaps_def + apply wpsimp + apply (clarsimp simp: valid_bitmaps_def) + done + +crunches rescheduleRequired, threadSet, setThreadState + for valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift) + +lemma tcbSchedEnqueue_valid_sched_pointers[wp]: + "tcbSchedEnqueue tcbPtr \valid_sched_pointers\" + apply (clarsimp simp: tcbSchedEnqueue_def getQueue_def unless_def) + \ \we step forwards until we can step over the addToBitmap in order to avoid state blow-up\ + apply (intro hoare_seq_ext[OF _ stateAssert_sp] hoare_seq_ext[OF _ isRunnable_inv] + hoare_seq_ext[OF _ assert_sp] hoare_seq_ext[OF _ threadGet_sp] + hoare_seq_ext[OF _ gets_sp] + | rule hoare_when_cases, fastforce)+ + apply (forward_inv_step wp: hoare_vcg_ex_lift) + supply if_split[split del] + apply (wpsimp wp: getTCB_wp + simp: threadSet_def setObject_def updateObject_default_def tcbQueuePrepend_def + setQueue_def) + apply (clarsimp simp: valid_sched_pointers_def) + apply (intro conjI impI) + apply (fastforce simp: opt_pred_def opt_map_def split: if_splits) + apply normalise_obj_at' + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (clarsimp simp: valid_sched_pointers_def list_queue_relation_def) + apply (case_tac "ts = []", fastforce simp: tcbQueueEmpty_def) + by (intro conjI impI; + force dest!: hd_in_set heap_path_head + simp: inQ_def opt_pred_def opt_map_def obj_at'_def split: if_splits) + +lemma tcbSchedAppend_valid_sched_pointers[wp]: + "tcbSchedAppend tcbPtr \valid_sched_pointers\" + apply (clarsimp simp: tcbSchedAppend_def getQueue_def unless_def) + \ \we step forwards until we can step over the addToBitmap in order to avoid state blow-up\ + apply (intro hoare_seq_ext[OF _ stateAssert_sp] hoare_seq_ext[OF _ isRunnable_inv] + hoare_seq_ext[OF _ assert_sp] hoare_seq_ext[OF _ threadGet_sp] + hoare_seq_ext[OF _ gets_sp] + | rule hoare_when_cases, fastforce)+ + apply (forward_inv_step wp: hoare_vcg_ex_lift) + supply if_split[split del] + apply (wpsimp wp: getTCB_wp + simp: threadSet_def setObject_def updateObject_default_def tcbQueueAppend_def + setQueue_def) + apply (clarsimp simp: valid_sched_pointers_def) + apply (intro conjI impI) + apply (fastforce simp: opt_pred_def opt_map_def split: if_splits) + apply normalise_obj_at' + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + by (intro conjI impI; + clarsimp dest: last_in_set + simp: valid_sched_pointers_def opt_map_def list_queue_relation_def tcbQueueEmpty_def + queue_end_valid_def inQ_def opt_pred_def obj_at'_def + split: if_splits option.splits; + fastforce) + +lemma tcbSchedDequeue_valid_sched_pointers[wp]: + "\valid_sched_pointers and sym_heap_sched_pointers\ + tcbSchedDequeue tcbPtr + \\_. valid_sched_pointers\" + supply if_split[split del] fun_upd_apply[simp del] + apply (clarsimp simp: tcbSchedDequeue_def getQueue_def setQueue_def) + apply (wpsimp wp: threadSet_wp getTCB_wp threadGet_wp simp: tcbQueueRemove_def) + apply normalise_obj_at' + apply (rename_tac tcb) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (clarsimp split: if_splits) + apply (frule (1) list_queue_relation_neighbour_in_set[where p=tcbPtr]) + apply (fastforce simp: inQ_def opt_pred_def opt_map_def obj_at'_def) + apply (clarsimp simp: list_queue_relation_def) + apply (intro conjI impI) + \ \the ready queue is the singleton consisting of tcbPtr\ + apply (clarsimp simp: valid_sched_pointers_def) + apply (case_tac "ptr = tcbPtr") + apply (force dest!: heap_ls_last_None + simp: prev_queue_head_def queue_end_valid_def inQ_def opt_map_def obj_at'_def) + apply (simp add: fun_upd_def opt_pred_def) + \ \tcbPtr is the head of the ready queue\ + subgoal + by (auto dest!: heap_ls_last_None + simp: valid_sched_pointers_def fun_upd_apply prev_queue_head_def + inQ_def opt_pred_def opt_map_def obj_at'_def + split: if_splits option.splits) + \ \tcbPtr is the end of the ready queue\ + subgoal + by (auto dest!: heap_ls_last_None + simp: valid_sched_pointers_def queue_end_valid_def inQ_def opt_pred_def + opt_map_def fun_upd_apply obj_at'_def + split: if_splits option.splits) + \ \tcbPtr is in the middle of the ready queue\ + apply (intro conjI impI allI) + by (clarsimp simp: valid_sched_pointers_def inQ_def opt_pred_def opt_map_def fun_upd_apply obj_at'_def + split: if_splits option.splits; + auto) + +lemma tcbQueueRemove_sym_heap_sched_pointers: + "\\s. sym_heap_sched_pointers s + \ (\ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ tcbPtr \ set ts)\ + tcbQueueRemove q tcbPtr + \\_. sym_heap_sched_pointers\" + supply heap_path_append[simp del] + apply (clarsimp simp: tcbQueueRemove_def) + apply (wpsimp wp: threadSet_wp getTCB_wp) + apply (rename_tac tcb ts) + + \ \tcbPtr is the head of q, which is not a singleton\ + apply (rule conjI) + apply clarsimp + apply (clarsimp simp: list_queue_relation_def Let_def) + apply (prop_tac "tcbSchedNext tcb \ Some tcbPtr") + apply (fastforce dest: heap_ls_no_loops[where p=tcbPtr] simp: opt_map_def obj_at'_def) + apply (fastforce intro: sym_heap_remove_only' + simp: prev_queue_head_def opt_map_red opt_map_upd_triv obj_at'_def) + + \ \tcbPtr is the end of q, which is not a singleton\ + apply (intro impI) + apply (rule conjI) + apply clarsimp + apply (prop_tac "tcbSchedPrev tcb \ Some tcbPtr") + apply (fastforce dest!: heap_ls_prev_no_loops[where p=tcbPtr] + simp: list_queue_relation_def opt_map_def obj_at'_def) + apply (subst fun_upd_swap, fastforce) + apply (fastforce intro: sym_heap_remove_only simp: opt_map_red opt_map_upd_triv obj_at'_def) + + \ \tcbPtr is in the middle of q\ + apply (intro conjI impI allI) + apply (frule (2) list_queue_relation_neighbour_in_set[where p=tcbPtr]) + apply (frule split_list) + apply clarsimp + apply (rename_tac xs ys) + apply (prop_tac "xs \ [] \ ys \ []") + apply (fastforce simp: list_queue_relation_def queue_end_valid_def) + apply (clarsimp simp: list_queue_relation_def) + apply (frule (3) ptr_in_middle_prev_next) + apply (frule heap_ls_distinct) + apply (rename_tac afterPtr beforePtr xs ys) + apply (frule_tac before=beforePtr and middle=tcbPtr and after=afterPtr + in sym_heap_remove_middle_from_chain) + apply (fastforce dest: last_in_set simp: opt_map_def obj_at'_def) + apply (fastforce dest: hd_in_set simp: opt_map_def obj_at'_def) + apply (rule_tac hp="tcbSchedNexts_of s" in sym_heapD2) + apply fastforce + apply (fastforce simp: opt_map_def obj_at'_def) + apply (fastforce simp: opt_map_def obj_at'_def) + apply (fastforce simp: fun_upd_swap opt_map_red opt_map_upd_triv obj_at'_def split: if_splits) + done + +lemma tcbQueuePrepend_sym_heap_sched_pointers: + "\\s. sym_heap_sched_pointers s + \ (\ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ tcbPtr \ set ts) + \ tcbSchedNexts_of s tcbPtr = None \ tcbSchedPrevs_of s tcbPtr = None\ + tcbQueuePrepend q tcbPtr + \\_. sym_heap_sched_pointers\" + supply if_split[split del] + apply (clarsimp simp: tcbQueuePrepend_def) + apply (wpsimp wp: threadSet_wp) + apply (prop_tac "tcbPtr \ the (tcbQueueHead q)") + apply (case_tac "ts = []"; + fastforce dest: heap_path_head simp: list_queue_relation_def tcbQueueEmpty_def) + apply (drule_tac a=tcbPtr and b="the (tcbQueueHead q)" in sym_heap_connect) + apply assumption + apply (clarsimp simp: list_queue_relation_def prev_queue_head_def tcbQueueEmpty_def) + apply (fastforce simp: fun_upd_swap opt_map_red opt_map_upd_triv obj_at'_def tcbQueueEmpty_def) + done + +lemma tcbQueueInsert_sym_heap_sched_pointers: + "\\s. sym_heap_sched_pointers s + \ tcbSchedNexts_of s tcbPtr = None \ tcbSchedPrevs_of s tcbPtr = None\ + tcbQueueInsert tcbPtr afterPtr + \\_. sym_heap_sched_pointers\" + apply (clarsimp simp: tcbQueueInsert_def) + \ \forwards step in order to name beforePtr below\ + apply (rule hoare_seq_ext[OF _ getObject_tcb_sp]) + apply (rule hoare_seq_ext[OF _ assert_sp]) + apply (rule hoare_ex_pre_conj[simplified conj_commute], rename_tac beforePtr) + apply (rule hoare_seq_ext[OF _ assert_sp]) + apply (wpsimp wp: threadSet_wp) + apply normalise_obj_at' + apply (prop_tac "tcbPtr \ afterPtr") + apply (clarsimp simp: list_queue_relation_def opt_map_red obj_at'_def) + apply (prop_tac "tcbPtr \ beforePtr") + apply (fastforce dest: sym_heap_None simp: opt_map_def obj_at'_def split: option.splits) + apply (prop_tac "tcbSchedNexts_of s beforePtr = Some afterPtr") + apply (fastforce intro: sym_heapD2 simp: opt_map_def obj_at'_def) + apply (fastforce dest: sym_heap_insert_into_middle_of_chain + simp: fun_upd_swap opt_map_red opt_map_upd_triv obj_at'_def) + done + +lemma tcbQueueAppend_sym_heap_sched_pointers: + "\\s. sym_heap_sched_pointers s + \ (\ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ tcbPtr \ set ts) + \ tcbSchedNexts_of s tcbPtr = None \ tcbSchedPrevs_of s tcbPtr = None\ + tcbQueueAppend q tcbPtr + \\_. sym_heap_sched_pointers\" + supply if_split[split del] + apply (clarsimp simp: tcbQueueAppend_def) + apply (wpsimp wp: threadSet_wp) + apply (clarsimp simp: tcbQueueEmpty_def list_queue_relation_def queue_end_valid_def obj_at'_def + split: if_splits) + apply fastforce + apply (drule_tac a="last ts" and b=tcbPtr in sym_heap_connect) + apply (fastforce dest: heap_ls_last_None) + apply assumption + apply (simp add: opt_map_red tcbQueueEmpty_def) + apply (subst fun_upd_swap, simp) + apply (fastforce simp: opt_map_red opt_map_upd_triv) + done + +lemma tcbQueued_update_sym_heap_sched_pointers[wp]: + "threadSet (tcbQueued_update f) tcbPtr \sym_heap_sched_pointers\" + by (rule sym_heap_sched_pointers_lift; + wpsimp wp: threadSet_tcbSchedPrevs_of threadSet_tcbSchedNexts_of) + +lemma tcbSchedEnqueue_sym_heap_sched_pointers[wp]: + "\sym_heap_sched_pointers and valid_sched_pointers\ + tcbSchedEnqueue tcbPtr + \\_. sym_heap_sched_pointers\" + unfolding tcbSchedEnqueue_def + apply (wpsimp wp: tcbQueuePrepend_sym_heap_sched_pointers threadGet_wp + simp: addToBitmap_def bitmap_fun_defs) + apply (normalise_obj_at', rename_tac tcb) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (fastforce dest!: spec[where x=tcbPtr] inQ_implies_tcbQueueds_of + simp: valid_sched_pointers_def opt_pred_def opt_map_def obj_at'_def) + done + +lemma tcbSchedAppend_sym_heap_sched_pointers[wp]: + "\sym_heap_sched_pointers and valid_sched_pointers\ + tcbSchedAppend tcbPtr + \\_. sym_heap_sched_pointers\" + unfolding tcbSchedAppend_def + apply (wpsimp wp: tcbQueueAppend_sym_heap_sched_pointers threadGet_wp + simp: addToBitmap_def bitmap_fun_defs) + apply (normalise_obj_at', rename_tac tcb) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (fastforce dest!: spec[where x=tcbPtr] inQ_implies_tcbQueueds_of + simp: valid_sched_pointers_def opt_pred_def opt_map_def obj_at'_def) + done + +lemma tcbSchedDequeue_sym_heap_sched_pointers[wp]: + "\sym_heap_sched_pointers and valid_sched_pointers\ + tcbSchedDequeue tcbPtr + \\_. sym_heap_sched_pointers\" + unfolding tcbSchedDequeue_def + apply (wpsimp wp: tcbQueueRemove_sym_heap_sched_pointers hoare_vcg_if_lift2 threadGet_wp + simp: bitmap_fun_defs) + apply (fastforce simp: ready_queue_relation_def ksReadyQueues_asrt_def inQ_def opt_pred_def + opt_map_def obj_at'_def) + done + +crunches setThreadState + for valid_sched_pointers[wp]: valid_sched_pointers + and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + (simp: crunch_simps wp: crunch_wps threadSet_valid_sched_pointers threadSet_sched_pointers) + 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. (\p. t \ set(ksReadyQueues s p)) \ runnable' st) and (\s. runnable' st \ obj_at' tcbQueued t s \ st_tcb_at' runnable' t s) and sch_act_simple and invs'\ @@ -4357,21 +5647,21 @@ lemma sts_invs_minor': including no_pre apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) - apply (wp sts_valid_queues valid_irq_node_lift irqs_masked_lift - setThreadState_ct_not_inQ + apply (wp valid_irq_node_lift irqs_masked_lift + setThreadState_ct_not_inQ | simp add: cteCaps_of_def o_def)+ apply (clarsimp simp: sch_act_simple_def) apply (intro conjI) - apply clarsimp - defer - apply (clarsimp dest!: st_tcb_at_state_refs_ofD' - elim!: rsubst[where P=sym_refs] - intro!: ext) - apply (clarsimp elim!: st_tcb_ex_cap'') + apply clarsimp + defer + apply (clarsimp dest!: st_tcb_at_state_refs_ofD' + elim!: rsubst[where P=sym_refs] + intro!: ext) + apply (clarsimp elim!: st_tcb_ex_cap'') + apply fastforce + apply fastforce apply (frule tcb_in_valid_state', clarsimp+) - apply (cases st, simp_all add: valid_tcb_state'_def - split: Structures_H.thread_state.split_asm) - done + by (cases st; simp add: valid_tcb_state'_def split: Structures_H.thread_state.split_asm) lemma sts_cap_to'[wp]: "\ex_nonz_cap_to' p\ setThreadState st t \\rv. ex_nonz_cap_to' p\" @@ -4416,12 +5706,56 @@ lemma threadSet_ct_running': apply wp done +lemma tcbQueuePrepend_tcbPriority_obj_at'[wp]: + "tcbQueuePrepend queue tptr \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + unfolding tcbQueuePrepend_def + apply (wpsimp wp: threadSet_wp) + by (auto simp: obj_at'_def objBits_simps ps_clear_def split: if_splits) + +lemma tcbQueuePrepend_tcbDomain_obj_at'[wp]: + "tcbQueuePrepend queue tptr \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding tcbQueuePrepend_def + apply (wpsimp wp: threadSet_wp) + by (auto simp: obj_at'_def objBits_simps ps_clear_def split: if_splits) + +lemma tcbSchedDequeue_tcbPriority[wp]: + "tcbSchedDequeue t \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + unfolding tcbSchedDequeue_def tcbQueueRemove_def + by (wpsimp wp: hoare_when_weak_wp hoare_drop_imps) + +lemma tcbSchedDequeue_tcbDomain[wp]: + "tcbSchedDequeue t \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding tcbSchedDequeue_def tcbQueueRemove_def + by (wpsimp wp: hoare_when_weak_wp hoare_drop_imps) + +lemma tcbSchedEnqueue_tcbPriority_obj_at'[wp]: + "tcbSchedEnqueue tcbPtr \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + unfolding tcbSchedEnqueue_def setQueue_def + by wpsimp + +lemma tcbSchedEnqueue_tcbDomain_obj_at'[wp]: + "tcbSchedEnqueue tcbPtr \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding tcbSchedEnqueue_def setQueue_def + by wpsimp + +crunches rescheduleRequired + for tcbPriority_obj_at'[wp]: "obj_at' (\tcb. P (tcbPriority tcb)) t'" + and tcbDomain_obj_at'[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t'" + +lemma setThreadState_tcbPriority_obj_at'[wp]: + "setThreadState ts tptr \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + unfolding setThreadState_def + apply (wpsimp wp: threadSet_wp) + apply (fastforce simp: obj_at'_def objBits_simps ps_clear_def) + done + lemma setThreadState_tcb_in_cur_domain'[wp]: "\tcb_in_cur_domain' t'\ setThreadState st t \\_. tcb_in_cur_domain' t'\" apply (simp add: tcb_in_cur_domain'_def) apply (rule hoare_pre) apply wps - apply (wp setThreadState_not_st | simp)+ + apply (simp add: setThreadState_def) + apply (wpsimp wp: threadSet_ct_idle_or_in_cur_domain' hoare_drop_imps)+ done lemma asUser_global_refs': "\valid_global_refs'\ asUser t f \\rv. valid_global_refs'\" @@ -4567,10 +5901,13 @@ 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) - (set_eobject ptr etcb) (setObject ptr tcb')" + 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 @@ -4591,21 +5928,34 @@ lemma set_eobject_corres': 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 cte_relation_def tcb_relation_def + apply (clarsimp simp: obj_at'_def other_obj_relation_def tcb_relation_cut_def cte_relation_def + tcb_relation_def split: if_split_asm)+ apply (clarsimp simp: aobj_relation_cuts_def split: RISCV64_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 is_tcb_def split: if_split_asm)+ - 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 + 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 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 non_exst_same_def split: option.splits) + apply (clarsimp simp: ready_queue_relation_def opt_map_def opt_pred_def obj_at'_def inQ_def + non_exst_same_def + split: option.splits) + apply metis done lemma set_eobject_corres: @@ -4613,9 +5963,13 @@ lemma set_eobject_corres: 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) - (set_eobject add etcbu) (setObject add tcbu')" + 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) @@ -4642,24 +5996,27 @@ lemma set_eobject_corres: 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) - (ethread_set f t) (threadSet f' t)" + 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+ + 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 simp + apply (clarsimp simp: obj_at'_def) done lemmas ethread_set_corres = diff --git a/proof/refine/RISCV64/Tcb_R.thy b/proof/refine/RISCV64/Tcb_R.thy index 101d292c3a..8f9b36617b 100644 --- a/proof/refine/RISCV64/Tcb_R.thy +++ b/proof/refine/RISCV64/Tcb_R.thy @@ -191,18 +191,13 @@ lemma setupReplyMaster_weak_sch_act_wf[wp]: apply assumption done -crunches setupReplyMaster - for valid_queues[wp]: "Invariants_H.valid_queues" - and valid_queues'[wp]: "valid_queues'" - (wp: crunch_wps simp: crunch_simps) - crunches 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) (invs' and tcb_at' t) + "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) @@ -213,19 +208,20 @@ lemma restart_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_valid_queues sts_st_tcb' - | clarsimp simp: valid_tcb_state'_def)+ - apply (rule_tac Q="\rv. valid_sched and cur_tcb and pspace_aligned and pspace_distinct" - in hoare_strengthen_post) - apply wp - apply (simp add: valid_sched_def valid_sched_action_def) - apply (rule_tac Q="\rv. invs' and tcb_at' t" in hoare_strengthen_post) - apply wp - apply (clarsimp simp: invs'_def valid_state'_def sch_act_wf_weak valid_pspace'_def) - apply wp+ + 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 simp add: invs'_def valid_state'_def sch_act_wf_weak) + apply clarsimp done lemma restart_invs': @@ -312,6 +308,11 @@ lemma asUser_postModifyRegisters_corres: apply (rule corres_stateAssert_assume) by simp+ +crunches restart + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + (simp: crunch_simps wp: crunch_wps threadSet_sched_pointers threadSet_valid_sched_pointers) + lemma invokeTCB_WriteRegisters_corres: "corres (dc \ (=)) (einvs and tcb_at dest and ex_nonz_cap_to dest) (invs' and sch_act_simple and tcb_at' dest and ex_nonz_cap_to' dest) @@ -338,10 +339,12 @@ lemma invokeTCB_WriteRegisters_corres: apply simp apply (wp+)[2] apply ((wp hoare_weak_lift_imp restart_invs' - | strengthen valid_sched_weak_strg einvs_valid_etcbs invs_valid_queues' invs_queues - invs_weak_sch_act_wf - | 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] + | 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_post_imp) apply (fastforce simp: invs_def valid_sched_weak_strg valid_sched_def valid_state_def dest!: idle_no_ex_cap) prefer 2 @@ -370,6 +373,10 @@ lemma suspend_ResumeCurrentThread_imp_notct[wp]: \\rv s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" by (wpsimp simp: suspend_def) +crunches restart, suspend + for cur_tcb'[wp]: cur_tcb' + (wp: crunch_wps threadSet_cur ignore: threadSet) + 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 @@ -434,7 +441,7 @@ proof - apply (simp add: frame_registers_def frameRegisters_def) apply (simp add: getRestartPC_def setNextPC_def dc_def[symmetric]) apply (rule Q[OF refl refl]) - apply (wp mapM_x_wp' | simp)+ + apply (wp mapM_x_wp' hoare_weak_lift_imp | simp)+ apply (rule corres_split_nor) apply (rule corres_when[OF refl]) apply (rule R[OF refl refl]) @@ -446,11 +453,11 @@ proof - apply simp apply (solves \wp hoare_weak_lift_imp\)+ apply (rule_tac Q="\_. einvs and tcb_at dest" in hoare_post_imp) - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def valid_sched_weak_strg valid_sched_def) + 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_post_imp) - apply (clarsimp simp: invs'_def valid_state'_def invs_weak_sch_act_wf cur_tcb'_def) - apply ((wp mapM_x_wp' hoare_weak_lift_imp | simp+)+)[4] + 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 @@ -499,38 +506,6 @@ lemma copyreg_invs': \\rv. invs'\" by (rule hoare_strengthen_post, rule copyreg_invs'', simp) -lemma threadSet_valid_queues_no_state: - "\Invariants_H.valid_queues and (\s. \p. t \ set (ksReadyQueues s p))\ - threadSet f t \\_. Invariants_H.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 setObject_queues_unchanged_tcb - 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 - objBits_simps addToQs_def - split del: if_split cong: if_cong) - apply (fastforce simp: inQ_def split: if_split_asm) - done - lemma isRunnable_corres: "corres (\ts runn. runnable ts = runn) (tcb_at t and pspace_aligned and pspace_distinct) \ @@ -555,16 +530,6 @@ lemma tcbSchedDequeue_not_queued: apply (wp tg_sp' [where P=\, simplified] | simp)+ done -lemma tcbSchedDequeue_not_in_queue: - "\p. \Invariants_H.valid_queues and tcb_at' t and valid_objs'\ tcbSchedDequeue t - \\rv s. t \ set (ksReadyQueues s p)\" - apply (rule_tac Q="\rv. Invariants_H.valid_queues and obj_at' (Not \ tcbQueued) t" - in hoare_post_imp) - apply (fastforce simp: valid_queues_def valid_queues_no_bitmap_def obj_at'_def inQ_def ) - apply (wp tcbSchedDequeue_not_queued tcbSchedDequeue_valid_queues | - simp add: valid_objs'_maxDomain valid_objs'_maxPriority)+ - done - lemma threadSet_ct_in_state': "(\tcb. tcbState (f tcb) = tcbState tcb) \ \ct_in_state' test\ threadSet f t \\rv. ct_in_state' test\" @@ -610,14 +575,19 @@ lemma tcbSchedDequeue_ct_in_state'[wp]: crunch cur[wp]: tcbSchedDequeue cur_tcb' +crunches tcbSchedDequeue + for st_tcb_at'[wp]: "\s. P (st_tcb_at' st tcbPtr s)" + lemma sp_corres2: - "corres dc (valid_etcbs and weak_valid_sched_action and cur_tcb and pspace_aligned and pspace_distinct) - (Invariants_H.valid_queues and valid_queues' and tcb_at' t and - (\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_objs' and (\_. x \ maxPriority)) - (set_priority t x) (setPriority t x)" + "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]) + 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]) @@ -629,25 +599,28 @@ lemma sp_corres2: 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) - apply clarsimp - apply ((wp hoare_drop_imps hoare_vcg_if_lift hoare_vcg_all_lift - isRunnable_wp threadSet_pred_tcb_no_state threadSet_valid_queues_no_state - threadSet_valid_queues'_no_state threadSet_cur threadSet_valid_objs_tcbPriority_update - threadSet_weak_sch_act_wf threadSet_ct_in_state'[simplified ct_in_state'_def] - | simp add: etcb_relation_def)+)[1] - apply ((wp hoare_vcg_imp_lift' hoare_vcg_if_lift hoare_vcg_all_lift hoare_vcg_disj_lift - tcbSchedDequeue_not_in_queue tcbSchedDequeue_valid_queues - tcbSchedDequeue_ct_in_state'[simplified ct_in_state'_def] - | simp add: etcb_relation_def)+)[2] + 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 (force simp: state_relation_def elim: valid_objs'_maxDomain valid_objs'_maxPriority) + apply clarsimp done 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)" + "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) @@ -673,6 +646,9 @@ 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' \ @@ -680,10 +656,8 @@ lemma out_corresT: \ (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 - apply (clarsimp simp add: threadset_corresT [OF _ x y e]) + 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] @@ -692,32 +666,40 @@ lemma tcbSchedDequeue_sch_act_simple[wp]: "tcbSchedDequeue t \sch_act_simple\" by (wpsimp simp: sch_act_simple_def) +lemma tcbSchedNext_update_tcb_cte_cases: + "(a, b) \ ran tcb_cte_cases \ a (tcbPriority_update f tcb) = a tcb" + unfolding tcb_cte_cases_def + by (case_tac tcb; fastforce simp: objBits_simps') + +lemma threadSet_priority_invs': + "\invs' and tcb_at' t and K (p \ maxPriority)\ + threadSet (tcbPriority_update (\_. p)) t + \\_. invs'\" + apply (rule hoare_gen_asm) + apply (simp add: invs'_def valid_state'_def split del: if_split) + apply (wp threadSet_valid_pspace' + threadSet_sch_actT_P[where P=False, simplified] + threadSet_state_refs_of'T[where f'=id] + threadSet_iflive'T + threadSet_ifunsafe'T + threadSet_idle'T + valid_irq_node_lift + valid_irq_handlers_lift'' + threadSet_ctes_ofT + threadSet_not_inQ + threadSet_ct_idle_or_in_cur_domain' + threadSet_cur + untyped_ranges_zero_lift + sym_heap_sched_pointers_lift threadSet_valid_sched_pointers + threadSet_tcbSchedPrevs_of threadSet_tcbSchedNexts_of + | clarsimp simp: cteCaps_of_def tcbSchedNext_update_tcb_cte_cases | rule refl)+ + apply (clarsimp simp: o_def) + by (auto simp: obj_at'_def) + lemma setP_invs': "\invs' and tcb_at' t and K (p \ maxPriority)\ setPriority t p \\rv. invs'\" - apply (rule hoare_gen_asm) - apply (simp add: setPriority_def) - apply (wp rescheduleRequired_all_invs_but_ct_not_inQ) - apply simp - apply (wp hoare_vcg_conj_lift hoare_vcg_imp_lift') - unfolding st_tcb_at'_def - apply (strengthen not_obj_at'_strengthen, wp) - apply (wp hoare_vcg_imp_lift') - apply (rule_tac Q="\rv s. invs' s" in hoare_post_imp) - apply (clarsimp simp: invs_sch_act_wf' invs'_def invs_queues) - apply (clarsimp simp: valid_state'_def) - apply (wp hoare_drop_imps threadSet_invs_trivial, - simp_all add: inQ_def cong: conj_cong)[1] - apply (wp hoare_drop_imps threadSet_invs_trivial, - simp_all add: inQ_def cong: conj_cong)[1] - apply (wp hoare_drop_imps threadSet_invs_trivial, - simp_all add: inQ_def cong: conj_cong)[1] - apply (rule_tac Q="\_. invs' and obj_at' (Not \ tcbQueued) t - and (\s. \d p. t \ set (ksReadyQueues s (d,p)))" - in hoare_post_imp) - apply (clarsimp simp: obj_at'_def inQ_def) - apply (wp tcbSchedDequeue_not_queued)+ - apply clarsimp - done + unfolding setPriority_def + by (wpsimp wp: rescheduleRequired_invs' threadSet_priority_invs') crunches setPriority, setMCPriority for typ_at'[wp]: "\s. P (typ_at' T p s)" @@ -984,13 +966,6 @@ lemma setMCPriority_valid_objs'[wp]: crunch sch_act_simple[wp]: setMCPriority sch_act_simple (wp: ssa_sch_act_simple crunch_wps rule: sch_act_simple_lift simp: crunch_simps) -(* For some reason, when this was embedded in a larger expression clarsimp wouldn't remove it. - Adding it as a simp rule does *) -lemma inQ_tc_corres_helper: - "(\d p. (\tcb. tcbQueued tcb \ tcbPriority tcb = p \ tcbDomain tcb = d \ - (tcbQueued tcb \ tcbDomain tcb \ d)) \ a \ set (ksReadyQueues s (d, p)))" - by clarsimp - abbreviation "valid_option_prio \ case_option True (\(p, auth). p \ maxPriority)" definition valid_tcb_invocation :: "tcbinvocation \ bool" where @@ -1012,35 +987,29 @@ lemma thread_set_ipc_weak_valid_sched_action: 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_helper2: - "is_aligned a msg_align_bits \ - \invs' and tcb_at' t\ - threadSet (tcbIPCBuffer_update (\_. a)) t - \\x s. Invariants_H.valid_queues s \ valid_queues' s\" - by (wp threadSet_invs_trivial - | strengthen invs_valid_queues' invs_queues invs_weak_sch_act_wf - | clarsimp simp: inQ_def )+ - lemma threadcontrol_corres_helper3: - "\ einvs and simple_sched_action\ + "\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))) - \\x. weak_valid_sched_action and valid_etcbs \" - apply (rule hoare_pre) - apply (wp check_cap_inv | simp add:)+ - by (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) + \\_ 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 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))))) - \\x. Invariants_H.valid_queues and valid_queues'\" - apply (wp - | strengthen invs_valid_queues' invs_queues invs_weak_sch_act_wf - | clarsimp simp: )+ + 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))))) + \\_ 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) @@ -1059,73 +1028,45 @@ lemma is_valid_vtable_root_simp: by (simp add: is_valid_vtable_root_def split: cap.splits arch_cap.splits option.splits) 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 \ tcbDomain (F tcb) = tcbDomain tcb" - assumes a: "\tcb. tcbBoundNotification (F tcb) = tcbBoundNotification 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_at' t s \ (\tcb. is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits) - \ (\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. \ tcbQueued tcb \ tcbQueued (F tcb)) \ ex_nonz_cap_to' t s \ t \ ksCurThread s) - \ (\tcb. tcbQueued (F tcb) \ ksSchedulerAction s = ResumeCurrentThread \ tcbQueued tcb \ t \ ksCurThread s)\ - threadSet F t - \\rv. invs'\" -proof - - from z have domains: "\tcb. tcbDomain (F tcb) = tcbDomain tcb" by blast - note threadSet_sch_actT_P[where P=False, simplified] - have y: "\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 valid_state'_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_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_cur - untyped_ranges_zero_lift - |clarsimp simp: y z a domains cteCaps_of_def |rule refl)+ - apply (clarsimp simp: obj_at'_def pred_tcb_at'_def) - apply (clarsimp simp: cur_tcb'_def valid_irq_node'_def valid_queues'_def o_def) - by (fastforce simp: domains ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def z a) -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 objBits_simps addToQs_def - split del: if_split cong: if_cong) - apply (fastforce simp: 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\" @@ -1179,6 +1120,12 @@ crunches option_update_thread for aligned[wp]: "pspace_aligned" and distinct[wp]: "pspace_distinct" +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'" and y: "newroot_rel f f'" and z: "(case g of None \ g' = None @@ -1370,10 +1317,20 @@ proof - apply (rule corres_split[OF getCurThread_corres], clarsimp) apply (rule corres_when[OF refl rescheduleRequired_corres]) apply (wpsimp wp: gct_wp)+ - apply (wp thread_set_ipc_weak_valid_sched_action|wp (once) hoare_drop_imp)+ - apply simp - apply (wp threadcontrol_corres_helper2 | wpc | simp)+ - apply (wp|strengthen einvs_valid_etcbs)+ + 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)+ + 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 @@ -1402,7 +1359,7 @@ proof - cap_delete_valid_cap cteDelete_deletes cteDelete_invs' | strengthen use_no_cap_to_obj_asid_strg - | clarsimp simp: inQ_def inQ_tc_corres_helper)+ + | 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) @@ -1485,36 +1442,16 @@ proof - 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 - cap_delete_deletes + check_cap_inv[where P=simple_sched_action] + cap_delete_deletes hoare_drop_imps cap_delete_valid_cap - simp: ran_tcb_cap_cases) + 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_drop_imps) - apply ((wpsimp wp: hoare_vcg_const_imp_lift hoare_vcg_imp_lift' hoare_vcg_all_lift - threadSet_cte_wp_at' threadSet_invs_trivialT2 cteDelete_invs' - simp: tcb_cte_cases_def cteSizeBits_def), (fastforce+)[6]) - apply wpsimp - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - threadSet_invs_trivialT2 threadSet_cte_wp_at' - simp: tcb_cte_cases_def cteSizeBits_def, (fastforce+)[6]) - apply wpsimp - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - rescheduleRequired_invs' threadSet_cte_wp_at' - simp: tcb_cte_cases_def) - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - rescheduleRequired_invs' threadSet_invs_trivialT2 threadSet_cte_wp_at' - simp: tcb_cte_cases_def cteSizeBits_def, (fastforce+)[6]) - apply wpsimp - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - rescheduleRequired_invs' threadSet_invs_trivialT2 threadSet_cte_wp_at' - simp: tcb_cte_cases_def cteSizeBits_def, (fastforce+)[6]) - apply wpsimp - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - rescheduleRequired_invs' threadSet_cap_to' threadSet_invs_trivialT2 - threadSet_cte_wp_at' hoare_drop_imps - simp: tcb_cte_cases_def cteSizeBits_def) - apply (clarsimp) + 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_lift_R hoare_vcg_all_lift hoare_vcg_const_imp_lift_R hoare_vcg_const_imp_lift threadSet_valid_objs' thread_set_not_state_valid_sched @@ -1527,9 +1464,9 @@ proof - | strengthen tcb_cap_always_valid_strg tcb_at_invs use_no_cap_to_obj_asid_strg - | (erule exE, clarsimp simp: word_bits_def))+) + | (erule exE, clarsimp simp: word_bits_def) | wp (once) hoare_drop_imps)+) apply (strengthen valid_tcb_ipc_buffer_update) - apply (strengthen invs_valid_objs') + 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 @@ -1653,7 +1590,7 @@ lemma setSchedulerAction_invs'[wp]: apply (simp add: setSchedulerAction_def) apply wp apply (clarsimp simp add: invs'_def valid_state'_def valid_irq_node'_def - valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs cur_tcb'_def + valid_queues_def bitmapQ_defs cur_tcb'_def ct_not_inQ_def) apply (simp add: ct_idle_or_in_cur_domain'_def) done @@ -1783,8 +1720,8 @@ lemma invokeTCB_corres: apply (rule TcbAcc_R.rescheduleRequired_corres) apply (rule corres_trivial, simp) apply (wpsimp wp: hoare_drop_imp)+ - apply (clarsimp simp: valid_sched_weak_strg einvs_valid_etcbs invs_distinct) - apply (clarsimp simp: invs_valid_queues' invs_queues) + apply (fastforce dest: valid_sched_valid_queues simp: valid_sched_weak_strg einvs_valid_etcbs) + apply fastforce done lemma tcbBoundNotification_caps_safe[simp]: @@ -1799,6 +1736,10 @@ lemma valid_bound_ntfn_lift: apply (wp typ_at_lifts[OF P])+ done +crunches 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 @@ -1811,7 +1752,7 @@ lemma bindNotification_invs': apply (simp add: bindNotification_def invs'_def valid_state'_def) apply (rule hoare_seq_ext[OF _ get_ntfn_sp']) apply (rule hoare_pre) - apply (wp set_ntfn_valid_pspace' sbn_sch_act' sbn_valid_queues valid_irq_node_lift + 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)+ @@ -2037,12 +1978,6 @@ lemma decodeSetMCPriority_corres: apply (clarsimp simp: newroot_rel_def elim!: is_thread_cap.elims(2)) by (wpsimp simp: valid_cap_def valid_cap'_def)+ -lemma valid_objs'_maxPriority': - "\s t. \ valid_objs' s; tcb_at' t s \ \ obj_at' (\tcb. tcbMCP tcb \ maxPriority) t s" - apply (erule (1) valid_objs_valid_tcbE) - apply (clarsimp simp: valid_tcb'_def) - done - lemma getMCP_sp: "\P\ threadGet tcbMCP t \\rv. mcpriority_tcb_at' (\st. st = rv) t and P\" apply (simp add: threadGet_def) diff --git a/proof/refine/RISCV64/Untyped_R.thy b/proof/refine/RISCV64/Untyped_R.thy index 2f1d77bac5..09b5873f65 100644 --- a/proof/refine/RISCV64/Untyped_R.thy +++ b/proof/refine/RISCV64/Untyped_R.thy @@ -1340,16 +1340,6 @@ crunch nosch[wp]: insertNewCaps "\s. P (ksSchedulerAction s)" crunch exst[wp]: set_cdt "\s. P (exst s)" -(*FIXME: Move to StateRelation*) -lemma state_relation_schact[elim!]: - "(s,s') \ state_relation \ sched_act_relation (scheduler_action s) (ksSchedulerAction s')" - apply (simp add: state_relation_def) - done - -lemma state_relation_queues[elim!]: "(s,s') \ state_relation \ ready_queues_relation (ready_queues s) (ksReadyQueues s')" - apply (simp add: state_relation_def) - done - lemma set_original_symb_exec_l: "corres_underlying {(s, s'). f (kheap s) (exst s) s'} nf 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) @@ -1376,6 +1366,10 @@ lemma updateNewFreeIndex_noop_psp_corres: | simp add: updateTrackedFreeIndex_def getSlotCap_def)+ done +crunches updateMDB, updateNewFreeIndex, setCTE + for rdyq_projs[wp]: + "\s. P (ksReadyQueues s) (tcbSchedNexts_of s) (tcbSchedPrevs_of s) (\d p. inQ d p |< tcbs_of' s)" + lemma insertNewCap_corres: notes if_cong[cong del] if_weak_cong[cong] shows @@ -3622,8 +3616,8 @@ lemma updateFreeIndex_clear_invs': apply (simp add:updateCap_def) apply (wp setCTE_irq_handlers' getCTE_wp) apply (simp add:updateCap_def) - apply (wp irqs_masked_lift valid_queues_lift' cur_tcb_lift ct_idle_or_in_cur_domain'_lift - hoare_vcg_disj_lift untyped_ranges_zero_lift getCTE_wp + apply (wp irqs_masked_lift cur_tcb_lift ct_idle_or_in_cur_domain'_lift + hoare_vcg_disj_lift untyped_ranges_zero_lift getCTE_wp valid_bitmaps_lift | wp (once) hoare_use_eq[where f="gsUntypedZeroRanges"] | simp add: getSlotCap_def | simp add: cte_wp_at_ctes_of)+ @@ -4203,14 +4197,12 @@ context begin interpretation Arch . (*FIXME: arch_split*) lemma resetUntypedCap_corres: "untypinv_relation ui ui' \ corres (dc \ dc) - (invs 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) apply (rule corres_guard_imp) @@ -5059,7 +5051,7 @@ lemma inv_untyped_corres': apply (clarsimp simp only: pred_conj_def invs ui) apply (strengthen vui) apply (cut_tac vui invs invs') - apply (clarsimp simp: cte_wp_at_caps_of_state valid_sched_etcbs) + 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 @@ -5109,7 +5101,6 @@ crunches insertNewCap and global_refs': "\s. P (global_refs' s)" and gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" and irq_states' [wp]: valid_irq_states' - and vq'[wp]: valid_queues' and irqs_masked' [wp]: irqs_masked' and valid_machine_state'[wp]: valid_machine_state' and pspace_domain_valid[wp]: pspace_domain_valid @@ -5117,6 +5108,9 @@ crunches insertNewCap and tcbState_inv[wp]: "obj_at' (\tcb. P (tcbState tcb)) t" and tcbDomain_inv[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t" and tcbPriority_inv[wp]: "obj_at' (\tcb. P (tcbPriority tcb)) t" + and sched_queues_projs[wp]: "\s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)" + and tcbQueueds_of[wp]: "\s. P (tcbQueued |< tcbs_of' s)" + and valid_sched_pointers[wp]: valid_sched_pointers (wp: crunch_wps) crunch if_unsafe_then_cap'[wp]: updateNewFreeIndex "if_unsafe_then_cap'" @@ -5273,8 +5267,8 @@ lemma insertNewCap_invs': apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) apply (wp insertNewCap_valid_pspace' sch_act_wf_lift - valid_queues_lift cur_tcb_lift tcb_in_cur_domain'_lift - insertNewCap_valid_global_refs' + cur_tcb_lift tcb_in_cur_domain'_lift valid_bitmaps_lift + insertNewCap_valid_global_refs' sym_heap_sched_pointers_lift valid_arch_state_lift' valid_irq_node_lift insertNewCap_valid_irq_handlers) apply (clarsimp simp: cte_wp_at_ctes_of) diff --git a/proof/refine/RISCV64/VSpace_R.thy b/proof/refine/RISCV64/VSpace_R.thy index 67c56baa2f..d92b4ee74c 100644 --- a/proof/refine/RISCV64/VSpace_R.thy +++ b/proof/refine/RISCV64/VSpace_R.thy @@ -794,10 +794,6 @@ crunch norqL1[wp]: storePTE "\s. P (ksReadyQueuesL1Bitmap s)" crunch norqL2[wp]: storePTE "\s. P (ksReadyQueuesL2Bitmap s)" (simp: updateObject_default_def) -lemma storePTE_valid_queues' [wp]: - "\valid_queues'\ storePTE p pte \\_. valid_queues'\" - by (wp valid_queues_lift') - lemma storePTE_iflive [wp]: "\if_live_then_nonz_cap'\ storePTE p pte \\rv. if_live_then_nonz_cap'\" apply (simp add: storePTE_def) @@ -908,6 +904,11 @@ crunches storePTE and gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" (wp: setObject_ksPSpace_only updateObject_default_inv) +lemma storePTE_tcbs_of'[wp]: + "storePTE c (pte::pte) \\s. P' (tcbs_of' s)\" + unfolding storePTE_def + by setObject_easy_cases + crunches storePTE for pspace_canonical'[wp]: "pspace_canonical'" and pspace_in_kernel_mappings'[wp]: "pspace_in_kernel_mappings'" @@ -920,15 +921,12 @@ lemma storePTE_valid_objs[wp]: apply simp done -lemma storePTE_valid_queues [wp]: - "\Invariants_H.valid_queues\ storePTE p pde \\_. Invariants_H.valid_queues\" - by (wp valid_queues_lift | simp add: pred_tcb_at'_def)+ - lemma storePTE_invs[wp]: "storePTE p pte \invs'\" unfolding invs'_def valid_state'_def valid_pspace'_def by (wpsimp wp: sch_act_wf_lift valid_global_refs_lift' irqs_masked_lift valid_arch_state_lift' valid_irq_node_lift cur_tcb_lift valid_irq_handlers_lift'' untyped_ranges_zero_lift + valid_bitmaps_lift simp: cteCaps_of_def o_def) lemma setASIDPool_valid_objs [wp]: @@ -975,14 +973,6 @@ lemma setASIDPool_tcb_obj_at'[wp]: apply (clarsimp simp add: updateObject_default_def in_monad) done -lemma setASIDPool_valid_queues [wp]: - "\Invariants_H.valid_queues\ setObject p (ap::asidpool) \\_. Invariants_H.valid_queues\" - by (wp valid_queues_lift | simp add: pred_tcb_at'_def)+ - -lemma setASIDPool_valid_queues' [wp]: - "\valid_queues'\ setObject p (ap::asidpool) \\_. valid_queues'\" - by (wp valid_queues_lift') - 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 @@ -1097,6 +1087,10 @@ 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]: "setObject p (ap::asidpool) \invs'\" apply (simp add: invs'_def valid_state'_def valid_pspace'_def) @@ -1104,7 +1098,7 @@ lemma setASIDPool_invs [wp]: valid_arch_state_lift' valid_irq_node_lift cur_tcb_lift valid_irq_handlers_lift'' untyped_ranges_zero_lift - updateObject_default_inv + updateObject_default_inv valid_bitmaps_lift | simp add: cteCaps_of_def | rule setObject_ksPSpace_only)+ apply (clarsimp simp: o_def) diff --git a/proof/refine/RISCV64/orphanage/Orphanage.thy b/proof/refine/RISCV64/orphanage/Orphanage.thy index 5d7f35c110..a26007ad1b 100644 --- a/proof/refine/RISCV64/orphanage/Orphanage.thy +++ b/proof/refine/RISCV64/orphanage/Orphanage.thy @@ -59,8 +59,7 @@ where definition all_queued_tcb_ptrs :: "kernel_state \ machine_word set" where - "all_queued_tcb_ptrs s \ - { tcb_ptr. \ priority. tcb_ptr : set ((ksReadyQueues s) priority) }" + "all_queued_tcb_ptrs s \ { tcb_ptr. obj_at' tcbQueued tcb_ptr s }" lemma st_tcb_at_neg': "(st_tcb_at' (\ ts. \ P ts) t s) = (tcb_at' t s \ \ st_tcb_at' P t s)" @@ -107,8 +106,8 @@ lemma no_orphans_lift: "\ tcb_ptr. \ \s. tcb_ptr = ksCurThread s \ f \ \_ s. tcb_ptr = ksCurThread s \" assumes st_tcb_at'_is_lifted: "\P p. \ \s. st_tcb_at' P p s\ f \ \_ s. st_tcb_at' P p s \" - assumes ksReadyQueues_is_lifted: - "\P. \ \s. P (ksReadyQueues s)\ f \ \_ s. P (ksReadyQueues s) \" + assumes tcbQueued_is_lifted: + "\P tcb_ptr. f \ \s. obj_at' (\tcb. P (tcbQueued tcb)) tcb_ptr s \" assumes ksSchedulerAction_is_lifted: "\P. \ \s. P (ksSchedulerAction s)\ f \ \_ s. P (ksSchedulerAction s) \" shows @@ -119,7 +118,7 @@ lemma no_orphans_lift: apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) apply (rule ksCurThread_is_lifted) apply (wp hoare_vcg_disj_lift) - apply (rule ksReadyQueues_is_lifted) + apply (wpsimp wp: tcbQueued_is_lifted) apply (wp hoare_vcg_disj_lift) apply (rule typ_at'_is_lifted) apply (wp hoare_vcg_disj_lift) @@ -139,13 +138,12 @@ lemma st_tcb_at'_all_active_tcb_ptrs_lift: by (clarsimp simp: all_active_tcb_ptrs_def) (rule st_tcb_at'_is_active_tcb_ptr_lift [OF assms]) -lemma ksQ_all_queued_tcb_ptrs_lift: - assumes "\P p. \\s. P (ksReadyQueues s p)\ f \\rv s. P (ksReadyQueues s p)\" +lemma tcbQueued_all_queued_tcb_ptrs_lift: + assumes "\Q P tcb_ptr. f \\s. Q (obj_at' (\tcb. P (tcbQueued tcb)) tcb_ptr s)\" shows "\\s. P (t \ all_queued_tcb_ptrs s)\ f \\_ s. P (t \ all_queued_tcb_ptrs s)\" apply (clarsimp simp: all_queued_tcb_ptrs_def) apply (rule_tac P=P in P_bool_lift) apply (wp hoare_vcg_ex_lift assms) - apply (clarsimp) apply (wp hoare_vcg_all_lift assms) done @@ -180,6 +178,11 @@ lemma almost_no_orphans_disj: apply (auto intro: pred_tcb_at') done +lemma all_queued_tcb_ptrs_ksReadyQueues_update[simp]: + "tcb_ptr \ all_queued_tcb_ptrs (ksReadyQueues_update f s) = (tcb_ptr \ all_queued_tcb_ptrs s)" + unfolding all_queued_tcb_ptrs_def + by (clarsimp simp: obj_at'_def) + lemma no_orphans_update_simps[simp]: "no_orphans (gsCNodes_update f s) = no_orphans s" "no_orphans (gsUserPages_update g s) = no_orphans s" @@ -243,6 +246,12 @@ crunch no_orphans [wp]: removeFromBitmap "no_orphans" crunch almost_no_orphans [wp]: addToBitmap "almost_no_orphans x" crunch almost_no_orphans [wp]: removeFromBitmap "almost_no_orphans x" +lemma setCTE_tcbQueued[wp]: + "setCTE ptr v \\s. Q (obj_at' (\tcb. P (tcbQueued tcb)) t s)\" + apply (simp add: setCTE_def) + apply (rule setObject_cte_obj_at_tcb', simp_all) + done + lemma setCTE_no_orphans [wp]: "\ \s. no_orphans s \ setCTE p cte @@ -256,7 +265,7 @@ lemma setCTE_almost_no_orphans [wp]: setCTE p cte \ \rv s. almost_no_orphans tcb_ptr s \" unfolding almost_no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift setCTE_typ_at' setCTE_pred_tcb_at') + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift setCTE_typ_at' setCTE_pred_tcb_at') done crunch no_orphans [wp]: activateIdleThread "no_orphans" @@ -266,128 +275,131 @@ lemma asUser_no_orphans [wp]: asUser thread f \ \rv s. no_orphans s \" unfolding no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift) done +lemma threadSet_all_queued_tcb_ptrs: + "\tcb. tcbQueued (F tcb) = tcbQueued tcb \ threadSet F tptr \\s. P (t \ all_queued_tcb_ptrs s)\" + unfolding almost_no_orphans_disj all_queued_tcb_ptrs_def + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_st_tcb_at2 threadSet_wp) + apply (erule rsubst[where P=P]) + apply (clarsimp simp: obj_at'_def ps_clear_upd objBits_simps) + done + +crunches removeFromBitmap, addToBitmap, setQueue + for all_queued_tcb_ptrs[wp]: "\s. P (t \ all_queued_tcb_ptrs s)" + (wp: tcbQueued_all_queued_tcb_ptrs_lift) + +crunches tcbQueuePrepend, tcbQueueAppend + for all_queued_tcb_ptrs[wp]: "\s. P (t \ all_queued_tcb_ptrs s)" + (wp: threadSet_all_queued_tcb_ptrs ignore: threadSet) + +lemma tcbQueued_update_True_all_queued_tcb_ptrs[wp]: + "\\s. tcb_ptr \ tcb_ptr' \ tcb_ptr' \ all_queued_tcb_ptrs s\ + threadSet (tcbQueued_update (\_. True)) tcb_ptr + \\_ s. tcb_ptr' \ all_queued_tcb_ptrs s\" + apply (wpsimp wp: threadSet_wp) + apply (fastforce simp: all_queued_tcb_ptrs_def obj_at'_def ps_clear_upd objBits_simps) + done + +lemma tcbSchedEnqueue_all_queued_tcb_ptrs[wp]: + "\\s. tcb_ptr \ tcb_ptr' \ tcb_ptr \ all_queued_tcb_ptrs s\ + tcbSchedEnqueue tcb_ptr' + \\_ s. tcb_ptr \ all_queued_tcb_ptrs s\" + unfolding tcbSchedEnqueue_def tcbQueuePrepend_def + apply (wpsimp wp: hoare_vcg_imp_lift' threadGet_wp + | wpsimp wp: threadSet_all_queued_tcb_ptrs)+ + apply (clarsimp simp: all_queued_tcb_ptrs_def obj_at'_def) + done + +lemmas tcbSchedEnqueue_all_queued_tcb_ptrs'[wp] = + tcbSchedEnqueue_all_queued_tcb_ptrs[simplified all_queued_tcb_ptrs_def, simplified] + +lemma tcbSchedAppend_all_queued_tcb_ptrs[wp]: + "\\s. tcb_ptr \ tcb_ptr' \ tcb_ptr \ all_queued_tcb_ptrs s\ + tcbSchedAppend tcb_ptr' + \\_ s. tcb_ptr \ all_queued_tcb_ptrs s\" + unfolding tcbSchedAppend_def tcbQueueAppend_def + apply (wpsimp wp: hoare_vcg_imp_lift' threadGet_wp + | wpsimp wp: threadSet_all_queued_tcb_ptrs)+ + apply (clarsimp simp: all_queued_tcb_ptrs_def obj_at'_def) + done + +lemmas tcbSchedAppend_all_queued_tcb_ptrs'[wp] = + tcbSchedAppend_all_queued_tcb_ptrs[simplified all_queued_tcb_ptrs_def, simplified] + lemma threadSet_no_orphans: - "\tcb. \ is_active_thread_state (tcbState tcb) \ \ is_active_thread_state (tcbState (F tcb)) \ - \ \s. no_orphans s \ - threadSet F tptr - \ \rv s. no_orphans s \" + "\\tcb. \ is_active_thread_state (tcbState tcb) \ \ is_active_thread_state (tcbState (F tcb)); + \tcb. tcbQueued (F tcb) = tcbQueued tcb\ + \ threadSet F tptr \no_orphans\" unfolding no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_st_tcb_at2 | clarsimp)+ - done + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_st_tcb_at2) -lemma threadSet_almost_no_orphans: - "\tcb. \ is_active_thread_state (tcbState tcb) \ \ is_active_thread_state (tcbState (F tcb)) \ - \ \s. almost_no_orphans ptr s \ - threadSet F tptr - \ \rv s. almost_no_orphans ptr s \" - unfolding almost_no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_st_tcb_at2 | clarsimp)+ +lemma tcbQueued_update_True_no_orphans: + "\almost_no_orphans tptr and tcb_at' tptr\ + threadSet (tcbQueued_update (\_. True)) tptr + \\_. no_orphans\" + unfolding no_orphans_disj + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_st_tcb_at2) + apply (fastforce simp: almost_no_orphans_def all_active_tcb_ptrs_def + tcb_at_typ_at' st_tcb_at_neg' is_active_tcb_ptr_def) done -lemma setQueue_no_orphans_enq: - "\ \s. no_orphans s \ set (ksReadyQueues s (d, prio)) \ set qs \ - setQueue d prio qs - \ \_ s. no_orphans s \" - unfolding setQueue_def - apply wp - apply (clarsimp simp: no_orphans_def all_queued_tcb_ptrs_def - split: if_split_asm) +lemma tcbQueued_update_True_almost_no_orphans: + "threadSet (tcbQueued_update (\_. True)) tptr' \almost_no_orphans tptr\" + unfolding almost_no_orphans_disj + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift threadSet_st_tcb_at2) apply fastforce done -lemma setQueue_almost_no_orphans_enq: - "\ \s. almost_no_orphans tcb_ptr s \ set (ksReadyQueues s (d, prio)) \ set qs \ tcb_ptr \ set qs \ - setQueue d prio qs - \ \_ s. no_orphans s \" +lemma threadSet_almost_no_orphans: + "\\tcb. \ is_active_thread_state (tcbState tcb) \ \ is_active_thread_state (tcbState (F tcb)); + \tcb. tcbQueued (F tcb) = tcbQueued tcb\ + \ threadSet F tptr \almost_no_orphans ptr\" + unfolding almost_no_orphans_disj all_queued_tcb_ptrs_def + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_st_tcb_at2) + +lemma setQueue_no_orphans[wp]: + "setQueue d prio qs \no_orphans\" unfolding setQueue_def apply wp - apply (clarsimp simp: no_orphans_def almost_no_orphans_def all_queued_tcb_ptrs_def - split: if_split_asm) - apply fastforce + apply (clarsimp simp: no_orphans_def) done -lemma setQueue_almost_no_orphans_enq_lift: - "\ \s. almost_no_orphans tcb_ptr s \ set (ksReadyQueues s (d, prio)) \ set qs \ - setQueue d prio qs - \ \_ s. almost_no_orphans tcb_ptr s \" +lemma setQueue_almost_no_orphans[wp]: + "setQueue d prio qs \almost_no_orphans tptr\" unfolding setQueue_def apply wp - apply (clarsimp simp: almost_no_orphans_def all_queued_tcb_ptrs_def - split: if_split_asm) - apply fastforce + apply (clarsimp simp: almost_no_orphans_def) done lemma tcbSchedEnqueue_no_orphans[wp]: - "\ \s. no_orphans s \ - tcbSchedEnqueue tcb_ptr - \ \rv s. no_orphans s \" - unfolding tcbSchedEnqueue_def - apply (wp setQueue_no_orphans_enq threadSet_no_orphans | clarsimp simp: unless_def)+ - apply (wp getObject_tcb_wp | clarsimp simp: threadGet_def)+ - apply (drule obj_at_ko_at') - apply auto + "tcbSchedEnqueue tcb_ptr \no_orphans\" + unfolding tcbSchedEnqueue_def tcbQueuePrepend_def + apply (wpsimp wp: tcbQueued_update_True_no_orphans threadSet_almost_no_orphans threadGet_wp) + apply (fastforce simp: no_orphans_strg_almost) done lemma tcbSchedAppend_no_orphans[wp]: - "\ \s. no_orphans s \ - tcbSchedAppend tcb_ptr - \ \rv s. no_orphans s \" - unfolding tcbSchedAppend_def - apply (wp setQueue_no_orphans_enq threadSet_no_orphans | clarsimp simp: unless_def)+ - apply (wp getObject_tcb_wp | clarsimp simp: threadGet_def)+ - apply (drule obj_at_ko_at') - apply auto - done - -lemma ko_at_obj_at': - "ko_at' ko p s \ P ko \ obj_at' P p s" - unfolding obj_at'_def - apply clarsimp - done - -lemma queued_in_queue: - "\valid_queues' s; ko_at' tcb tcb_ptr s; tcbQueued tcb\ \ - \ p. tcb_ptr \ set (ksReadyQueues s p)" - unfolding valid_queues'_def - apply (drule_tac x="tcbDomain tcb" in spec) - apply (drule_tac x="tcbPriority tcb" in spec) - apply (drule_tac x="tcb_ptr" in spec) - apply (drule mp) - apply (rule ko_at_obj_at') - apply (auto simp: inQ_def) + "tcbSchedAppend tcb_ptr \no_orphans\" + unfolding tcbSchedAppend_def tcbQueueAppend_def + apply (wpsimp wp: tcbQueued_update_True_no_orphans threadSet_almost_no_orphans threadGet_wp) + apply (fastforce simp: no_orphans_strg_almost) done lemma tcbSchedEnqueue_almost_no_orphans: - "\ \s. almost_no_orphans tcb_ptr s \ valid_queues' s \ + "\almost_no_orphans tcb_ptr\ tcbSchedEnqueue tcb_ptr - \ \rv s. no_orphans s \" - unfolding tcbSchedEnqueue_def - apply simp - apply (wp setQueue_almost_no_orphans_enq[where tcb_ptr=tcb_ptr] threadSet_no_orphans - | clarsimp)+ - apply (wp getObject_tcb_wp | clarsimp simp: threadGet_def)+ - apply normalise_obj_at' - apply (rule_tac x=ko in exI) - apply (clarsimp simp: subset_insertI) - apply (unfold no_orphans_def almost_no_orphans_def) - apply clarsimp - apply (drule(2) queued_in_queue) - apply (fastforce simp: all_queued_tcb_ptrs_def) + \\_. no_orphans\" + unfolding tcbSchedEnqueue_def tcbQueuePrepend_def + apply (wpsimp wp: tcbQueued_update_True_no_orphans threadSet_almost_no_orphans threadGet_wp) + apply (fastforce simp: no_orphans_def almost_no_orphans_def all_queued_tcb_ptrs_def obj_at'_def) done lemma tcbSchedEnqueue_almost_no_orphans_lift: - "\ \s. almost_no_orphans ptr s \ - tcbSchedEnqueue tcb_ptr - \ \rv s. almost_no_orphans ptr s \" - unfolding tcbSchedEnqueue_def - apply (wp setQueue_almost_no_orphans_enq_lift threadSet_almost_no_orphans | clarsimp simp: unless_def)+ - apply (wp getObject_tcb_wp | clarsimp simp: threadGet_def)+ - apply (drule obj_at_ko_at') - apply auto - done + "tcbSchedEnqueue tcb_ptr \almost_no_orphans ptr\" + unfolding tcbSchedEnqueue_def tcbQueuePrepend_def + by (wpsimp wp: tcbQueued_update_True_almost_no_orphans threadSet_almost_no_orphans) lemma ssa_no_orphans: "\ \s. no_orphans s \ @@ -419,124 +431,70 @@ lemma ssa_almost_no_orphans_lift [wp]: apply auto done -lemma tcbSchedEnqueue_inQueue [wp]: - "\ \s. valid_queues' s \ - tcbSchedEnqueue tcb_ptr - \ \rv s. tcb_ptr \ all_queued_tcb_ptrs s \" - unfolding tcbSchedEnqueue_def all_queued_tcb_ptrs_def - apply (wp | clarsimp simp: unless_def)+ - apply (rule_tac Q="\rv. \" in hoare_post_imp) - apply fastforce - apply (wp getObject_tcb_wp | clarsimp simp: threadGet_def)+ - apply (fastforce simp: obj_at'_def valid_queues'_def inQ_def) - done - -lemma tcbSchedAppend_inQueue [wp]: - "\ \s. valid_queues' s \ - tcbSchedAppend tcb_ptr - \ \rv s. tcb_ptr \ all_queued_tcb_ptrs s \" - unfolding tcbSchedAppend_def all_queued_tcb_ptrs_def - apply (wp | clarsimp simp: unless_def)+ - apply (rule_tac Q="\rv. \" in hoare_post_imp) - apply fastforce - apply (wp getObject_tcb_wp | clarsimp simp: threadGet_def)+ - apply (fastforce simp: obj_at'_def valid_queues'_def inQ_def) - done - lemma rescheduleRequired_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ - rescheduleRequired - \ \rv s. no_orphans s \" + "rescheduleRequired \no_orphans\" unfolding rescheduleRequired_def - apply (wp tcbSchedEnqueue_no_orphans hoare_vcg_all_lift ssa_no_orphans | wpc | clarsimp)+ - apply (wps tcbSchedEnqueue_nosch, wp hoare_weak_lift_imp) - apply (rename_tac word t p) - apply (rule_tac P="word = t" in hoare_gen_asm) - apply (wp hoare_disjI1 | clarsimp)+ - done + by (wpsimp wp: ssa_no_orphans hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift | wpc)+ lemma rescheduleRequired_almost_no_orphans [wp]: - "\ \s. almost_no_orphans tcb_ptr s \ valid_queues' s \ - rescheduleRequired - \ \rv s. almost_no_orphans tcb_ptr s \" + "rescheduleRequired \almost_no_orphans tcb_ptr\" unfolding rescheduleRequired_def - apply (wp tcbSchedEnqueue_almost_no_orphans_lift hoare_vcg_all_lift | wpc | clarsimp)+ - apply (wps tcbSchedEnqueue_nosch, wp hoare_weak_lift_imp) - apply (rename_tac word t p) - apply (rule_tac P="word = t" in hoare_gen_asm) - apply (wp hoare_disjI1 | clarsimp)+ - done + by (wpsimp wp: ssa_almost_no_orphans_lift hoare_vcg_all_lift tcbSchedEnqueue_almost_no_orphans_lift + hoare_vcg_imp_lift' hoare_vcg_disj_lift) lemma setThreadState_current_no_orphans: - "\ \s. no_orphans s \ ksCurThread s = tcb_ptr \ valid_queues' s \ + "\\s. no_orphans s \ ksCurThread s = tcb_ptr\ setThreadState state tcb_ptr - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding setThreadState_def - apply (wp | clarsimp)+ - apply (rule_tac Q="\rv s. valid_queues' s \ no_orphans s" in hoare_post_imp) - apply clarsimp - apply (wp threadSet_valid_queues') - apply (unfold no_orphans_disj all_queued_tcb_ptrs_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state) - apply (auto simp: inQ_def) + apply wpsimp + unfolding no_orphans_disj + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state + threadSet_all_queued_tcb_ptrs + | fastforce)+ done lemma setThreadState_isRestart_no_orphans: - "\ \s. no_orphans s \ st_tcb_at' isRestart tcb_ptr s \ valid_queues' s\ + "\no_orphans and st_tcb_at' isRestart tcb_ptr\ setThreadState state tcb_ptr - \ \rv s. no_orphans s \" + \\_ . no_orphans\" unfolding setThreadState_def - apply (wp | clarsimp)+ - apply (rule_tac Q="\rv s. valid_queues' s \ no_orphans s" in hoare_post_imp) - apply clarsimp - apply (wp threadSet_valid_queues') - apply (unfold no_orphans_disj all_queued_tcb_ptrs_def is_active_thread_state_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state) - apply (auto simp: st_tcb_at_double_neg' st_tcb_at_neg' inQ_def) + apply wpsimp + unfolding no_orphans_disj + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state + threadSet_all_queued_tcb_ptrs + | fastforce)+ + apply (auto simp: is_active_thread_state_def st_tcb_at_double_neg' st_tcb_at_neg') done lemma setThreadState_almost_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s\ - setThreadState state tcb_ptr - \ \rv s. almost_no_orphans tcb_ptr s \" + "\no_orphans\ setThreadState state tcb_ptr \\_. almost_no_orphans tcb_ptr\" unfolding setThreadState_def - apply (wp | clarsimp)+ - apply (rule_tac Q="\rv s. valid_queues' s \ almost_no_orphans tcb_ptr s" in hoare_post_imp) - apply clarsimp - apply (wp threadSet_valid_queues') - apply (unfold no_orphans_disj almost_no_orphans_disj all_queued_tcb_ptrs_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state) - apply (auto simp: inQ_def) + apply wpsimp + apply (unfold no_orphans_disj almost_no_orphans_disj) + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state + threadSet_all_queued_tcb_ptrs + | fastforce)+ done lemma setThreadState_not_active_no_orphans: - "\ is_active_thread_state state \ - \ \s. no_orphans s \ valid_queues' s \ - setThreadState state tcb_ptr - \ \rv s. no_orphans s \" + "\ is_active_thread_state state \ setThreadState state tcb_ptr \no_orphans\" unfolding setThreadState_def - apply (wp | clarsimp)+ - apply (rule_tac Q="\rv s. valid_queues' s \ no_orphans s" in hoare_post_imp) - apply clarsimp - apply (wp threadSet_valid_queues') - apply (unfold no_orphans_disj all_queued_tcb_ptrs_def is_active_thread_state_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state) - apply (auto simp: isRunning_def isRestart_def inQ_def) + apply wpsimp + apply (unfold no_orphans_disj) + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state + threadSet_all_queued_tcb_ptrs + | fastforce)+ done lemma setThreadState_not_active_almost_no_orphans: - "\ is_active_thread_state state \ - \ \s. almost_no_orphans thread s \ valid_queues' s \ - setThreadState state tcb_ptr - \ \rv s. almost_no_orphans thread s \" + "\ is_active_thread_state state \ setThreadState state tcb_ptr \almost_no_orphans thread\" unfolding setThreadState_def - apply (wp | clarsimp)+ - apply (rule_tac Q="\rv s. valid_queues' s \ almost_no_orphans thread s" in hoare_post_imp) - apply clarsimp - apply (wp threadSet_valid_queues') - apply (unfold almost_no_orphans_disj all_queued_tcb_ptrs_def is_active_thread_state_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state) - apply (auto simp: isRunning_def isRestart_def inQ_def) + apply wpsimp + apply (unfold almost_no_orphans_disj) + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift threadSet_pred_tcb_at_state + threadSet_all_queued_tcb_ptrs + | fastforce)+ done lemma activateThread_no_orphans [wp]: @@ -548,46 +506,63 @@ lemma activateThread_no_orphans [wp]: apply (auto simp: ct_in_state'_def pred_tcb_at'_def obj_at'_def isRestart_def) done -lemma setQueue_no_orphans_deq: - "\ \s. \ tcb_ptr. no_orphans s \ \ is_active_tcb_ptr tcb_ptr s \ - queue = [x\((ksReadyQueues s) (d, priority)). x \ tcb_ptr] \ - setQueue d priority queue - \ \rv s. no_orphans s \" - unfolding setQueue_def - apply (wp | clarsimp)+ - apply (fastforce simp: no_orphans_def all_queued_tcb_ptrs_def - all_active_tcb_ptrs_def is_active_tcb_ptr_def) +crunches removeFromBitmap, tcbQueueRemove, setQueue + for almost_no_orphans[wp]: "almost_no_orphans thread" + and no_orphans[wp]: no_orphans + and all_queued_tcb_ptrs[wp]: "\s. tcb_ptr \ all_queued_tcb_ptrs s" + (wp: crunch_wps) + +lemma tcbQueued_update_False_all_queued_tcb_ptrs: + "\\s. tcb_ptr \ tcb_ptr' \ tcb_ptr' \ all_queued_tcb_ptrs s\ + threadSet (tcbQueued_update (\_. False)) tcb_ptr + \\_ s. tcb_ptr' \ all_queued_tcb_ptrs s\" + apply (wpsimp wp: threadSet_wp) + apply (clarsimp simp: all_queued_tcb_ptrs_def obj_at'_def projectKOs ps_clear_upd) done -lemma setQueue_almost_no_orphans_deq [wp]: - "\ \s. almost_no_orphans tcb_ptr s \ - queue = [x\((ksReadyQueues s) (d, priority)). x \ tcb_ptr] \ - setQueue d priority queue - \ \rv s. almost_no_orphans tcb_ptr s \" - unfolding setQueue_def - apply (wp | clarsimp)+ - apply (fastforce simp: almost_no_orphans_def all_queued_tcb_ptrs_def - all_active_tcb_ptrs_def is_active_tcb_ptr_def) +lemma tcbSchedDequeue_all_queued_tcb_ptrs_other: + "\\s. tcb_ptr \ tcb_ptr' \ tcb_ptr' \ all_queued_tcb_ptrs s\ + tcbSchedDequeue tcb_ptr + \\_ s. tcb_ptr' \ all_queued_tcb_ptrs s\" + unfolding tcbSchedDequeue_def + by (wpsimp wp: tcbQueued_update_False_all_queued_tcb_ptrs threadGet_wp) + +lemma tcbQueued_update_False_almost_no_orphans: + "\no_orphans\ + threadSet (tcbQueued_update (\_. False)) tptr + \\_. almost_no_orphans tptr\" + apply (wpsimp wp: threadSet_wp) + apply (clarsimp simp: no_orphans_def almost_no_orphans_def) + apply (rename_tac tcb_ptr) + apply (case_tac "tcb_ptr = tptr") + apply fastforce + apply (fastforce simp: all_queued_tcb_ptrs_def obj_at'_def projectKOs all_active_tcb_ptrs_def + is_active_tcb_ptr_def st_tcb_at'_def ps_clear_upd) done lemma tcbSchedDequeue_almost_no_orphans [wp]: - "\ \s. no_orphans s \ - tcbSchedDequeue thread - \ \rv s. almost_no_orphans thread s \" + "\no_orphans\ tcbSchedDequeue thread \\_. almost_no_orphans thread\" unfolding tcbSchedDequeue_def - apply (wp threadSet_almost_no_orphans | simp cong: if_cong)+ - apply (simp add:no_orphans_strg_almost cong: if_cong) + apply (wpsimp wp: tcbQueued_update_False_almost_no_orphans threadGet_wp) + apply (simp add: no_orphans_strg_almost) done -lemma tcbSchedDequeue_no_orphans [wp]: - "\ \s. no_orphans s \ \ is_active_tcb_ptr tcb_ptr s \ - tcbSchedDequeue tcb_ptr - \ \rv s. no_orphans s \" - unfolding tcbSchedDequeue_def - apply (wp setQueue_no_orphans_deq threadSet_no_orphans | clarsimp)+ - apply (wp getObject_tcb_wp | clarsimp simp: threadGet_def)+ - apply (drule obj_at_ko_at') - apply auto +lemma tcbSchedDequeue_no_orphans[wp]: + "\\s. no_orphans s \ \ is_active_tcb_ptr tcbPtr s \ tcb_at' tcbPtr s\ + tcbSchedDequeue tcbPtr + \\_. no_orphans\" + supply disj_not1[simp del] + unfolding no_orphans_disj almost_no_orphans_disj + apply (rule hoare_allI) + apply (rename_tac tcb_ptr) + apply (case_tac "tcb_ptr = tcbPtr") + apply (rule_tac Q="\_ s. st_tcb_at' (\state. \ is_active_thread_state state) tcbPtr s" + in hoare_post_imp) + apply fastforce + apply wpsimp + apply (clarsimp simp: st_tcb_at'_def obj_at'_def projectKOs is_active_tcb_ptr_def disj_not1) + apply (wpsimp wp: tcbQueued_update_False_all_queued_tcb_ptrs hoare_vcg_disj_lift + simp: tcbSchedDequeue_def) done crunches setVMRoot @@ -595,17 +570,15 @@ crunches setVMRoot (wp: crunch_wps) lemma switchToIdleThread_no_orphans' [wp]: - "\ \s. no_orphans s \ - (is_active_tcb_ptr (ksCurThread s) s - \ ksCurThread s \ all_queued_tcb_ptrs s) \ + "\\s. no_orphans s + \ (is_active_tcb_ptr (ksCurThread s) s \ ksCurThread s \ all_queued_tcb_ptrs s)\ switchToIdleThread - \ \rv s. no_orphans s \" - unfolding switchToIdleThread_def setCurThread_def RISCV64_H.switchToIdleThread_def + \\_. no_orphans\" + supply disj_not1[simp del] + apply (clarsimp simp: switchToIdleThread_def setCurThread_def RISCV64_H.switchToIdleThread_def) apply (simp add: no_orphans_disj all_queued_tcb_ptrs_def) - apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift hoare_vcg_disj_lift - | clarsimp)+ - apply (auto simp: no_orphans_disj all_queued_tcb_ptrs_def is_active_tcb_ptr_def - st_tcb_at_neg' tcb_at_typ_at') + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift hoare_drop_imps) + apply (force simp: is_active_tcb_ptr_def st_tcb_at_neg' typ_at_tcb') done crunch no_orphans [wp]: "Arch.switchToThread" "no_orphans" @@ -613,13 +586,9 @@ crunch no_orphans [wp]: "Arch.switchToThread" "no_orphans" crunch ksCurThread [wp]: "Arch.switchToThread" "\ s. P (ksCurThread s)" -lemma ArchThreadDecls_H_switchToThread_all_queued_tcb_ptrs [wp]: - "\ \s. P (all_queued_tcb_ptrs s) \ - Arch.switchToThread tcb_ptr - \ \rv s. P (all_queued_tcb_ptrs s) \" - unfolding RISCV64_H.switchToThread_def all_queued_tcb_ptrs_def - apply (wp | clarsimp)+ - done +crunches Arch.switchToThread + for all_queued_tcb_ptrs[wp]: "\s. P (t \ all_queued_tcb_ptrs s)" + (wp: tcbQueued_all_queued_tcb_ptrs_lift) crunch ksSchedulerAction [wp]: "Arch.switchToThread" "\s. P (ksSchedulerAction s)" @@ -635,22 +604,6 @@ lemma setCurThread_no_orphans [wp]: apply auto done -lemma tcbSchedDequeue_all_queued_tcb_ptrs: - "\\s. x \ all_queued_tcb_ptrs s \ x \ t \ - tcbSchedDequeue t \\_ s. x \ all_queued_tcb_ptrs s\" - apply (rule_tac Q="(\s. x \ all_queued_tcb_ptrs s) and K (x \ t)" - in hoare_pre_imp, clarsimp) - apply (rule hoare_gen_asm) - apply (clarsimp simp: tcbSchedDequeue_def all_queued_tcb_ptrs_def) - apply (rule hoare_pre) - apply (wp, clarsimp) - apply (wp hoare_vcg_ex_lift)+ - apply (rename_tac d p) - apply (rule_tac Q="\_ s. x \ set (ksReadyQueues s (d, p))" - in hoare_post_imp, clarsimp) - apply (wp hoare_vcg_all_lift | simp)+ - done - lemma tcbSchedDequeue_all_active_tcb_ptrs[wp]: "\\s. P (t' \ all_active_tcb_ptrs s)\ tcbSchedDequeue t \\_ s. P (t' \ all_active_tcb_ptrs s)\" by (clarsimp simp: all_active_tcb_ptrs_def is_active_tcb_ptr_def) wp @@ -673,8 +626,11 @@ lemma setCurThread_almost_no_orphans: lemmas ArchThreadDecls_H_switchToThread_all_active_tcb_ptrs[wp] = st_tcb_at'_all_active_tcb_ptrs_lift [OF Arch_switchToThread_pred_tcb'] -lemmas ArchThreadDecls_H_switchToThread_all_queued_tcb_ptrs_lift[wp] = - ksQ_all_queued_tcb_ptrs_lift [OF ArchThreadDecls_H_RISCV64_H_switchToThread_ksQ] +lemma arch_switch_thread_tcbQueued[wp]: + "Arch.switchToThread t \\s. Q (obj_at' (\tcb. P (tcbQueued tcb)) tcb_ptr s)\" + apply (simp add: RISCV64_H.switchToThread_def) + apply (wp) + done lemma ThreadDecls_H_switchToThread_no_orphans: "\ \s. no_orphans s \ @@ -684,16 +640,9 @@ lemma ThreadDecls_H_switchToThread_no_orphans: ThreadDecls_H.switchToThread tcb_ptr \ \rv s. no_orphans s \" unfolding Thread_H.switchToThread_def - apply (wp setCurThread_almost_no_orphans - tcbSchedDequeue_almost_no_orphans) - apply (wps tcbSchedDequeue_ct') - apply (wp tcbSchedDequeue_all_queued_tcb_ptrs hoare_convert_imp)+ - apply (wps) - apply (wp)+ - apply (wps) - apply (wp) - apply (clarsimp) - done + by (wpsimp wp: setCurThread_almost_no_orphans hoare_vcg_imp_lift' + tcbSchedDequeue_all_queued_tcb_ptrs_other + | wps)+ lemma findM_failure': "\ \x S. \ \s. P S s \ f x \ \rv s. \ rv \ P (insert x S) s \ \ \ @@ -711,22 +660,6 @@ lemma findM_failure': lemmas findM_failure = findM_failure'[where S="{}", simplified] -lemma tcbSchedEnqueue_inQueue_eq: - "\ valid_queues' and K (tcb_ptr = tcb_ptr') \ - tcbSchedEnqueue tcb_ptr - \ \rv s. tcb_ptr' \ all_queued_tcb_ptrs s \" - apply (rule hoare_gen_asm, simp) - apply wp - done - -lemma tcbSchedAppend_inQueue_eq: - "\ valid_queues' and K (tcb_ptr = tcb_ptr') \ - tcbSchedAppend tcb_ptr - \ \rv s. tcb_ptr' \ all_queued_tcb_ptrs s \" - apply (rule hoare_gen_asm, simp) - apply wp - done - lemma findM_on_success: "\ \x. \ P x \ f x \ \rv s. rv \; \x y. \ P x \ f y \ \rv. P x \ \ \ \ \s. \x \ set xs. P x s \ findM f xs \ \rv s. \ y. rv = Some y \" @@ -738,66 +671,32 @@ lemma findM_on_success: crunch st_tcb' [wp]: switchToThread "\s. P' (st_tcb_at' P t s)" -lemma setQueue_deq_not_empty: - "\ \s. (\tcb. tcb \ set (ksReadyQueues s p) \ st_tcb_at' P tcb s) \ - (\tcb_ptr. \ st_tcb_at' P tcb_ptr s \ - queue = [x\((ksReadyQueues s) (d, priority)). x \ tcb_ptr]) \ - setQueue d priority queue - \ \rv s. \tcb. tcb \ set (ksReadyQueues s p) \ st_tcb_at' P tcb s \" - unfolding setQueue_def - apply wp - apply auto - done - -lemma tcbSchedDequeue_not_empty: - "\ \s. (\tcb. tcb \ set (ksReadyQueues s p) \ st_tcb_at' P tcb s) \ \ st_tcb_at' P thread s \ - tcbSchedDequeue thread - \ \rv s. \tcb. tcb \ set (ksReadyQueues s p) \ st_tcb_at' P tcb s \" - unfolding tcbSchedDequeue_def - apply wp - apply (wp hoare_vcg_ex_lift threadSet_pred_tcb_no_state) - apply clarsimp - apply (wp setQueue_deq_not_empty) - apply clarsimp - apply (rule hoare_pre_post, assumption) - apply (clarsimp simp: bitmap_fun_defs) - apply wp - apply clarsimp - apply clarsimp - apply (wp setQueue_deq_not_empty)+ - apply (rule_tac Q="\rv s. \ st_tcb_at' P thread s" in hoare_post_imp) - apply fastforce - apply (wp weak_if_wp | clarsimp)+ - done - lemmas switchToThread_all_active_tcb_ptrs[wp] = st_tcb_at'_all_active_tcb_ptrs_lift [OF switchToThread_st_tcb'] (* ksSchedulerAction s = ChooseNewThread *) lemma chooseThread_no_orphans [wp]: - notes hoare_TrueI[simp] - shows - "\\s. no_orphans s \ all_invs_but_ct_idle_or_in_cur_domain' s \ - (is_active_tcb_ptr (ksCurThread s) s - \ ksCurThread s \ all_queued_tcb_ptrs s)\ + "\\s. no_orphans s \ all_invs_but_ct_idle_or_in_cur_domain' s + \ (is_active_tcb_ptr (ksCurThread s) s \ ksCurThread s \ all_queued_tcb_ptrs s)\ chooseThread - \ \rv s. no_orphans s \" + \\_. no_orphans\" (is "\?PRE\ _ \_\") unfolding chooseThread_def Let_def supply if_split[split del] apply (simp only: return_bind, simp) - apply (rule hoare_seq_ext[where B="\rv s. ?PRE s \ rv = ksCurDomain s"]) - apply (rule_tac B="\rv s. ?PRE s \ curdom = ksCurDomain s \ - rv = ksReadyQueuesL1Bitmap s curdom" in hoare_seq_ext) + apply (intro hoare_seq_ext[OF _ stateAssert_sp]) + apply (rule hoare_seq_ext[where B="\rv s. ?PRE s \ ksReadyQueues_asrt s \ ready_qs_runnable s + \ rv = ksCurDomain s"]) + apply (rule_tac B="\rv s. ?PRE s \ ksReadyQueues_asrt s \ ready_qs_runnable s + \ curdom = ksCurDomain s \ rv = ksReadyQueuesL1Bitmap s curdom" + in hoare_seq_ext) apply (rename_tac l1) apply (case_tac "l1 = 0") (* switch to idle thread *) apply (simp, wp, simp) (* we have a thread to switch to *) - apply (clarsimp simp: bitmap_fun_defs) apply (wp assert_inv ThreadDecls_H_switchToThread_no_orphans) - apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def - valid_queues_def st_tcb_at'_def) + apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def st_tcb_at'_def) apply (fastforce dest!: lookupBitmapPriority_obj_at' elim: obj_at'_weaken simp: all_active_tcb_ptrs_def) apply (wpsimp simp: bitmap_fun_defs) @@ -805,42 +704,6 @@ lemma chooseThread_no_orphans [wp]: apply (wpsimp simp: curDomain_def simp: invs_no_cicd_ksCurDomain_maxDomain')+ done -lemma valid_queues'_ko_atD: - "valid_queues' s \ ko_at' tcb t s \ tcbQueued tcb - \ t \ set (ksReadyQueues s (tcbDomain tcb, tcbPriority tcb))" - apply (simp add: valid_queues'_def) - apply (elim allE, erule mp) - apply normalise_obj_at' - apply (simp add: inQ_def) - done - -lemma tcbSchedAppend_in_ksQ: - "\valid_queues' and tcb_at' t\ tcbSchedAppend t - \\r s. \domain priority. t \ set (ksReadyQueues s (domain, priority))\" - apply (rule_tac Q="\s. \d p. valid_queues' s \ - obj_at' (\tcb. tcbPriority tcb = p) t s \ - obj_at' (\tcb. tcbDomain tcb = d) t s" - in hoare_pre_imp) - apply (clarsimp simp: tcb_at'_has_tcbPriority tcb_at'_has_tcbDomain) - apply (rule hoare_vcg_ex_lift)+ - apply (simp add: tcbSchedAppend_def unless_def) - apply wpsimp - apply (rule_tac Q="\rv s. tdom = d \ rv = p \ obj_at' (\tcb. tcbPriority tcb = p) t s - \ obj_at' (\tcb. tcbDomain tcb = d) t s" - in hoare_post_imp, clarsimp) - apply (wp, (wp threadGet_const)+) - apply (rule_tac Q="\rv s. - obj_at' (\tcb. tcbPriority tcb = p) t s \ - obj_at' (\tcb. tcbDomain tcb = d) t s \ - obj_at' (\tcb. tcbQueued tcb = rv) t s \ - (rv \ t \ set (ksReadyQueues s (d, p)))" in hoare_post_imp) - apply (clarsimp simp: o_def elim!: obj_at'_weakenE) - apply (wp threadGet_obj_at' hoare_vcg_imp_lift threadGet_const) - apply clarsimp - apply normalise_obj_at' - apply (drule(1) valid_queues'_ko_atD, simp+) - done - lemma hoare_neg_imps: "\P\ f \\ rv s. \ R rv s\ \ \P\ f \\r s. R r s \ Q r s\" by (auto simp: valid_def) @@ -864,7 +727,7 @@ lemma ThreadDecls_H_switchToThread_ct [wp]: crunch no_orphans [wp]: nextDomain no_orphans (wp: no_orphans_lift simp: Let_def) -crunch ksQ [wp]: nextDomain "\s. P (ksReadyQueues s p)" +crunch tcbQueued[wp]: nextDomain "\s. Q (obj_at' (\tcb. P (tcbQueued tcb)) tcb_ptr s)" (simp: Let_def) crunch st_tcb_at' [wp]: nextDomain "\s. P (st_tcb_at' P' p s)" @@ -876,41 +739,6 @@ crunch ct' [wp]: nextDomain "\s. P (ksCurThread s)" crunch sch_act_not [wp]: nextDomain "sch_act_not t" (simp: Let_def) -lemma tcbSchedEnqueue_in_ksQ: - "\valid_queues' and tcb_at' t\ tcbSchedEnqueue t - \\r s. \domain priority. t \ set (ksReadyQueues s (domain, priority))\" - apply (rule_tac Q="\s. \d p. valid_queues' s \ - obj_at' (\tcb. tcbPriority tcb = p) t s \ - obj_at' (\tcb. tcbDomain tcb = d) t s" - in hoare_pre_imp) - apply (clarsimp simp: tcb_at'_has_tcbPriority tcb_at'_has_tcbDomain) - apply (rule hoare_vcg_ex_lift)+ - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wpsimp simp: if_apply_def2) - apply (rule_tac Q="\rv s. tdom = d \ rv = p \ obj_at' (\tcb. tcbPriority tcb = p) t s - \ obj_at' (\tcb. tcbDomain tcb = d) t s" - in hoare_post_imp, clarsimp) - apply (wp, (wp threadGet_const)+) - apply (rule_tac Q="\rv s. - obj_at' (\tcb. tcbPriority tcb = p) t s \ - obj_at' (\tcb. tcbDomain tcb = d) t s \ - obj_at' (\tcb. tcbQueued tcb = rv) t s \ - (rv \ t \ set (ksReadyQueues s (d, p)))" in hoare_post_imp) - apply (clarsimp simp: o_def elim!: obj_at'_weakenE) - apply (wp threadGet_obj_at' hoare_vcg_imp_lift threadGet_const) - apply clarsimp - apply normalise_obj_at' - apply (frule(1) valid_queues'_ko_atD, simp+) - done - -lemma tcbSchedEnqueue_in_ksQ': - "\valid_queues' and tcb_at' t and K (t = t')\ - tcbSchedEnqueue t' - \\r s. \domain priority. t \ set (ksReadyQueues s (domain, priority))\" - apply (rule hoare_gen_asm) - apply (wp tcbSchedEnqueue_in_ksQ | clarsimp)+ - done - lemma all_invs_but_ct_idle_or_in_cur_domain'_strg: "invs' s \ all_invs_but_ct_idle_or_in_cur_domain' s" by (clarsimp simp: invs'_to_invs_no_cicd'_def) @@ -919,67 +747,6 @@ lemma setSchedulerAction_cnt_sch_act_not[wp]: "\ \ \ setSchedulerAction ChooseNewThread \\rv s. sch_act_not x s\" by (rule hoare_pre, rule hoare_strengthen_post[OF setSchedulerAction_direct]) auto -lemma tcbSchedEnqueue_in_ksQ_aqtp[wp]: - "\valid_queues' and tcb_at' t\ tcbSchedEnqueue t - \\r s. t \ all_queued_tcb_ptrs s\" - apply (clarsimp simp: all_queued_tcb_ptrs_def) - apply (rule tcbSchedEnqueue_in_ksQ) - done - -lemma tcbSchedEnqueue_in_ksQ_already_queued: - "\\s. valid_queues' s \ tcb_at' t s \ - (\domain priority. t' \ set (ksReadyQueues s (domain, priority))) \ - tcbSchedEnqueue t - \\r s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))\" - apply (case_tac "t'=t", wpsimp wp: tcbSchedEnqueue_in_ksQ) - apply (wpsimp simp: tcbSchedEnqueue_def unless_def) - apply (rule_tac Q="\_ s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))" - in hoare_post_imp) - apply metis - apply wpsimp+ - done - -lemma tcbSchedAppend_in_ksQ_already_queued: - "\\s. valid_queues' s \ tcb_at' t s \ - (\domain priority. t' \ set (ksReadyQueues s (domain, priority))) \ - tcbSchedAppend t - \\r s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))\" - apply (case_tac "t'=t", wpsimp wp: tcbSchedAppend_in_ksQ) - apply (wpsimp simp: tcbSchedAppend_def unless_def) - apply (rule_tac Q="\_ s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))" - in hoare_post_imp) - apply metis - apply wpsimp+ - done - -lemma tcbSchedEnqueue_in_ksQ'': - "\\s. valid_queues' s \ tcb_at' t s \ - (t' \ t \ (\domain priority. t' \ set (ksReadyQueues s (domain, priority)))) \ - tcbSchedEnqueue t - \\r s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))\" - apply (case_tac "t'=t", wpsimp wp: tcbSchedEnqueue_in_ksQ) - apply clarsimp - apply (wpsimp simp: tcbSchedEnqueue_def unless_def) - apply (rule_tac Q="\_ s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))" - in hoare_post_imp) - apply metis - apply wpsimp+ - done - -lemma tcbSchedAppend_in_ksQ'': - "\\s. valid_queues' s \ tcb_at' t s \ - (t' \ t \ (\domain priority. t' \ set (ksReadyQueues s (domain, priority)))) \ - tcbSchedAppend t - \\r s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))\" - apply (case_tac "t'=t", wpsimp wp: tcbSchedAppend_in_ksQ) - apply clarsimp - apply (wpsimp simp: tcbSchedAppend_def unless_def) - apply (rule_tac Q="\_ s. \domain priority. t' \ set (ksReadyQueues s (domain, priority))" - in hoare_post_imp) - apply metis - apply wpsimp+ - done - crunches setSchedulerAction for pred_tcb_at': "\s. P (pred_tcb_at' proj Q t s)" and ct': "\s. P (ksCurThread s)" @@ -998,12 +765,6 @@ lemma ct_active_st_tcb_at': apply (case_tac st, auto) done -lemma tcbSchedEnqueue_in_ksQ_already_queued_aqtp: - "\\s. valid_queues' s \ tcb_at' t s \ - t' \ all_queued_tcb_ptrs s \ tcbSchedEnqueue t - \\r s. t' \ all_queued_tcb_ptrs s \" - by (clarsimp simp: all_queued_tcb_ptrs_def tcbSchedEnqueue_in_ksQ_already_queued) - (* FIXME move *) lemma invs_switchToThread_runnable': "\ invs' s ; ksSchedulerAction s = SwitchToThread t \ \ st_tcb_at' runnable' t s" @@ -1036,17 +797,16 @@ lemma chooseThread_nosch: done lemma scheduleChooseNewThread_no_orphans: - "\ invs' and no_orphans - and (\s. ksSchedulerAction s = ChooseNewThread - \ (st_tcb_at' runnable' (ksCurThread s) s - \ (\d p. ksCurThread s \ set (ksReadyQueues s (d, p))))) \ + "\invs' and no_orphans + and (\s. ksSchedulerAction s = ChooseNewThread + \ (st_tcb_at' runnable' (ksCurThread s) s \ ksCurThread s \ all_queued_tcb_ptrs s))\ scheduleChooseNewThread - \\_. no_orphans \" + \\_. no_orphans\" unfolding scheduleChooseNewThread_def apply (wp add: ssa_no_orphans hoare_vcg_all_lift) apply (wp hoare_disjI1 chooseThread_nosch)+ apply (wp nextDomain_invs_no_cicd' hoare_vcg_imp_lift - hoare_lift_Pf2 [OF ksQ_all_queued_tcb_ptrs_lift[OF nextDomain_ksQ] + hoare_lift_Pf2 [OF tcbQueued_all_queued_tcb_ptrs_lift[OF nextDomain_tcbQueued] nextDomain_ct'] hoare_lift_Pf2 [OF st_tcb_at'_is_active_tcb_ptr_lift[OF nextDomain_st_tcb_at'] nextDomain_ct'] @@ -1055,24 +815,25 @@ lemma scheduleChooseNewThread_no_orphans: is_active_tcb_ptr_runnable')+ done +lemma setSchedulerAction_tcbQueued[wp]: + "setSchedulerAction sa \\s. Q (obj_at' (\tcb. P (tcbQueued tcb)) tcb_ptr s)\" + by wpsimp + lemma schedule_no_orphans[wp]: notes ssa_wp[wp del] shows - "\ \s. no_orphans s \ invs' s \ - schedule - \ \rv s. no_orphans s \" + "\no_orphans and invs'\ schedule \\_. no_orphans\" proof - have do_switch_to: "\candidate. \\s. no_orphans s \ ksSchedulerAction s = SwitchToThread candidate \ st_tcb_at' runnable' candidate s - \ (st_tcb_at' runnable' (ksCurThread s) s - \ (\d p. ksCurThread s \ set (ksReadyQueues s (d, p)))) \ - do ThreadDecls_H.switchToThread candidate; - setSchedulerAction ResumeCurrentThread - od - \\rv. no_orphans\" + \ (st_tcb_at' runnable' (ksCurThread s) s \ ksCurThread s \ all_queued_tcb_ptrs s) \ + do ThreadDecls_H.switchToThread candidate; + setSchedulerAction ResumeCurrentThread + od + \\_. no_orphans\" apply (wpsimp wp: scheduleChooseNewThread_no_orphans ssa_no_orphans hoare_vcg_all_lift ThreadDecls_H_switchToThread_no_orphans)+ apply (rule_tac Q="\_ s. (t = candidate \ ksCurThread s = candidate) \ @@ -1084,56 +845,43 @@ proof - have abort_switch_to_enq: "\candidate. - \\s. no_orphans s \ invs' s \ valid_queues' s + \\s. no_orphans s \ invs' s \ ksSchedulerAction s = SwitchToThread candidate - \ (st_tcb_at' runnable' (ksCurThread s) s - \ (\d p. ksCurThread s \ set (ksReadyQueues s (d, p)))) \ - do tcbSchedEnqueue candidate; - setSchedulerAction ChooseNewThread; - scheduleChooseNewThread - od - \\rv. no_orphans\" - apply (rule hoare_pre) - apply (wp scheduleChooseNewThread_no_orphans ssa_no_orphans setSchedulerAction_direct) + \ (st_tcb_at' runnable' (ksCurThread s) s \ ksCurThread s \ all_queued_tcb_ptrs s) \ + do tcbSchedEnqueue candidate; + setSchedulerAction ChooseNewThread; + scheduleChooseNewThread + od + \\_. no_orphans\" + apply (wpsimp wp: scheduleChooseNewThread_no_orphans ssa_no_orphans setSchedulerAction_direct) apply (wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_ex_lift - simp: is_active_tcb_ptr_runnable' all_queued_tcb_ptrs_def - | rule hoare_lift_Pf2[where f=ksCurThread, OF setSchedulerAction_ksQ])+ - apply (wp tcbSchedEnqueue_in_ksQ' tcbSchedEnqueue_no_orphans hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift) - apply (wp hoare_lift_Pf2[where f=ksCurThread, OF tcbSchedEnqueue_pred_tcb_at'] - hoare_lift_Pf2[where f=ksCurThread, OF tcbSchedEnqueue_in_ksQ_already_queued] - tcbSchedEnqueue_no_orphans - | strengthen not_pred_tcb_at'_strengthen - | wp (once) hoare_vcg_imp_lift')+ - apply (clarsimp) - apply (frule invs_sch_act_wf', clarsimp simp: pred_tcb_at') - apply (simp add: st_tcb_at_neg' tcb_at_invs') + simp: is_active_tcb_ptr_runnable' all_queued_tcb_ptrs_def + | rule hoare_lift_Pf2[where f=ksCurThread, OF setSchedulerAction_tcbQueued])+ + apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift + | strengthen not_pred_tcb_at'_strengthen + | rule hoare_lift_Pf2[where f=ksCurThread])+ + apply (simp add: st_tcb_at_neg' tcb_at_invs' all_queued_tcb_ptrs_def) done have abort_switch_to_app: "\candidate. - \\s. no_orphans s \ invs' s \ valid_queues' s + \\s. no_orphans s \ invs' s \ ksSchedulerAction s = SwitchToThread candidate \ (st_tcb_at' runnable' (ksCurThread s) s - \ (\d p. ksCurThread s \ set (ksReadyQueues s (d, p))) ) \ - do tcbSchedAppend candidate; - setSchedulerAction ChooseNewThread; - scheduleChooseNewThread - od - \\rv. no_orphans\" - apply (rule hoare_pre) - apply (wp scheduleChooseNewThread_no_orphans ssa_no_orphans setSchedulerAction_direct) + \ ksCurThread s \ all_queued_tcb_ptrs s ) \ + do tcbSchedAppend candidate; + setSchedulerAction ChooseNewThread; + scheduleChooseNewThread + od + \\_. no_orphans\" + apply (wpsimp wp: scheduleChooseNewThread_no_orphans ssa_no_orphans setSchedulerAction_direct) apply (wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_ex_lift - simp: is_active_tcb_ptr_runnable' all_queued_tcb_ptrs_def - | rule hoare_lift_Pf2[where f=ksCurThread, OF setSchedulerAction_ksQ])+ - apply (wp tcbSchedAppend_in_ksQ'' tcbSchedAppend_no_orphans hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift) - apply (wp hoare_lift_Pf2[where f=ksCurThread, OF tcbSchedAppend_pred_tcb_at'] - hoare_lift_Pf2[where f=ksCurThread, OF tcbSchedAppend_in_ksQ_already_queued] - tcbSchedAppend_no_orphans - | strengthen not_pred_tcb_at'_strengthen - | wp (once) hoare_vcg_imp_lift')+ - apply (clarsimp) - apply (frule invs_sch_act_wf', clarsimp simp: pred_tcb_at') - apply (simp add: st_tcb_at_neg' tcb_at_invs') + simp: is_active_tcb_ptr_runnable' all_queued_tcb_ptrs_def + | rule hoare_lift_Pf2[where f=ksCurThread, OF setSchedulerAction_tcbQueued])+ + apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift + | strengthen not_pred_tcb_at'_strengthen + | rule hoare_lift_Pf2[where f=ksCurThread])+ + apply (simp add: st_tcb_at_neg' tcb_at_invs' all_queued_tcb_ptrs_def) done show ?thesis @@ -1147,24 +895,20 @@ proof - apply (wp ssa_no_orphans hoare_vcg_all_lift) apply (wp hoare_disjI1 chooseThread_nosch) apply (wp nextDomain_invs_no_cicd' hoare_vcg_imp_lift - hoare_lift_Pf2 [OF ksQ_all_queued_tcb_ptrs_lift - [OF nextDomain_ksQ] - nextDomain_ct'] + hoare_lift_Pf2 [OF tcbQueued_all_queued_tcb_ptrs_lift + [OF nextDomain_tcbQueued] + nextDomain_ct'] hoare_lift_Pf2 [OF st_tcb_at'_is_active_tcb_ptr_lift [OF nextDomain_st_tcb_at'] nextDomain_ct'] hoare_vcg_all_lift getDomainTime_wp)[2] - apply ((wp tcbSchedEnqueue_no_orphans tcbSchedEnqueue_in_ksQ' - hoare_drop_imp - | clarsimp simp: all_queued_tcb_ptrs_def - | strengthen all_invs_but_ct_idle_or_in_cur_domain'_strg - | wps tcbSchedEnqueue_ct')+)[1] - apply ((wp tcbSchedEnqueue_no_orphans tcbSchedEnqueue_in_ksQ' + apply wpsimp + apply ((wp tcbSchedEnqueue_no_orphans tcbSchedEnqueue_all_queued_tcb_ptrs' hoare_drop_imp - | clarsimp simp: all_queued_tcb_ptrs_def - | strengthen all_invs_but_ct_idle_or_in_cur_domain'_strg - | wps tcbSchedEnqueue_ct')+)[1] - apply wp[1] + | clarsimp simp: all_queued_tcb_ptrs_def + | strengthen all_invs_but_ct_idle_or_in_cur_domain'_strg + | wps)+)[1] + apply wpsimp \ \action = SwitchToThread candidate\ apply (clarsimp) apply (rename_tac candidate) @@ -1173,14 +917,11 @@ proof - apply (wp hoare_drop_imps) apply (wp add: tcbSchedEnqueue_no_orphans)+ apply (clarsimp simp: conj_comms cong: conj_cong imp_cong split del: if_split) - apply (wp hoare_lift_Pf2[where f=ksCurThread, OF tcbSchedEnqueue_pred_tcb_at'] - hoare_lift_Pf2[where f=ksCurThread, OF tcbSchedEnqueue_in_ksQ'] - hoare_vcg_imp_lift' + apply (wp hoare_vcg_imp_lift' | strengthen not_pred_tcb_at'_strengthen)+ - apply (clarsimp simp: comp_def) - apply (frule invs_queues) - apply (clarsimp simp: invs_valid_queues' tcb_at_invs' st_tcb_at_neg' is_active_tcb_ptr_runnable') - apply (fastforce simp: all_invs_but_ct_idle_or_in_cur_domain'_strg invs_switchToThread_runnable') + apply (wps | wpsimp wp: tcbSchedEnqueue_all_queued_tcb_ptrs')+ + apply (fastforce simp: is_active_tcb_ptr_runnable' all_invs_but_ct_idle_or_in_cur_domain'_strg + invs_switchToThread_runnable') done qed @@ -1201,47 +942,42 @@ crunch no_orphans [wp]: completeSignal "no_orphans" (simp: crunch_simps wp: crunch_wps) lemma possibleSwitchTo_almost_no_orphans [wp]: - "\ \s. almost_no_orphans target s \ valid_queues' s \ st_tcb_at' runnable' target s - \ weak_sch_act_wf (ksSchedulerAction s) s \ + "\\s. almost_no_orphans target s \ st_tcb_at' runnable' target s + \ weak_sch_act_wf (ksSchedulerAction s) s\ possibleSwitchTo target - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding possibleSwitchTo_def - by (wp rescheduleRequired_valid_queues'_weak tcbSchedEnqueue_almost_no_orphans + by (wp tcbSchedEnqueue_almost_no_orphans ssa_almost_no_orphans hoare_weak_lift_imp | wpc | clarsimp | wp (once) hoare_drop_imp)+ lemma possibleSwitchTo_almost_no_orphans': - "\ \s. almost_no_orphans target s \ valid_queues' s \ st_tcb_at' runnable' target s - \ sch_act_wf (ksSchedulerAction s) s \ + "\\s. almost_no_orphans target s \ st_tcb_at' runnable' target s + \ sch_act_wf (ksSchedulerAction s) s \ possibleSwitchTo target - \ \rv s. no_orphans s \" + \\_. no_orphans\" by wp (strengthen sch_act_wf_weak, assumption) +crunches tcbQueueAppend, tcbQueuePrepend + for almost_no_orphans[wp]: "almost_no_orphans tcbPtr" + lemma tcbSchedAppend_almost_no_orphans: - "\ \s. almost_no_orphans thread s \ valid_queues' s \ + "\almost_no_orphans thread\ tcbSchedAppend thread - \ \_ s. no_orphans s \" + \\_. no_orphans\" unfolding tcbSchedAppend_def - apply (wp setQueue_almost_no_orphans_enq[where tcb_ptr=thread] threadSet_no_orphans - | clarsimp simp: unless_def | simp only: subset_insertI)+ - apply (unfold threadGet_def) - apply (wp getObject_tcb_wp | clarsimp)+ - apply (drule obj_at_ko_at', clarsimp) - apply (rule_tac x=ko in exI) - apply (clarsimp simp: almost_no_orphans_def no_orphans_def) - apply (drule queued_in_queue | simp)+ - apply (auto simp: all_queued_tcb_ptrs_def) + apply (wpsimp wp: tcbQueued_update_True_no_orphans threadGet_wp) + apply (fastforce simp: almost_no_orphans_def no_orphans_def all_queued_tcb_ptrs_def obj_at'_def) done lemma no_orphans_is_almost[simp]: "no_orphans s \ almost_no_orphans t s" by (clarsimp simp: no_orphans_def almost_no_orphans_def) -crunch no_orphans [wp]: decDomainTime no_orphans -(wp: no_orphans_lift) - -crunch valid_queues' [wp]: decDomainTime valid_queues' +crunches decDomainTime + for no_orphans [wp]: no_orphans + (wp: no_orphans_lift) lemma timerTick_no_orphans [wp]: "\ \s. no_orphans s \ invs' s \ @@ -1250,28 +986,18 @@ lemma timerTick_no_orphans [wp]: unfolding timerTick_def getDomainTime_def supply if_split[split del] apply (subst threadState_case_if) - apply (wpsimp wp: threadSet_no_orphans threadSet_valid_queues' - threadSet_valid_queues' tcbSchedAppend_almost_no_orphans threadSet_sch_act + apply (wpsimp wp: threadSet_no_orphans tcbSchedAppend_almost_no_orphans threadSet_almost_no_orphans threadSet_no_orphans tcbSchedAppend_sch_act_wf hoare_drop_imp simp: if_apply_def2 | strengthen sch_act_wf_weak)+ - apply (rule_tac Q="\rv s. no_orphans s \ valid_queues' s \ tcb_at' thread s - \ sch_act_wf (ksSchedulerAction s) s" in hoare_post_imp) - apply (clarsimp simp: inQ_def) - apply (wp hoare_drop_imps | clarsimp)+ - apply (auto split: if_split) done - lemma handleDoubleFault_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ - handleDoubleFault tptr ex1 ex2 - \ \rv s. no_orphans s \" + "\no_orphans\ handleDoubleFault tptr ex1 ex2 \\_. no_orphans \" unfolding handleDoubleFault_def - apply (wp setThreadState_not_active_no_orphans - | clarsimp simp: is_active_thread_state_def isRestart_def isRunning_def)+ - done + by (wpsimp wp: setThreadState_not_active_no_orphans + simp: is_active_thread_state_def isRestart_def isRunning_def)+ crunch st_tcb' [wp]: getThreadCallerSlot "st_tcb_at' (\st. P st) t" @@ -1307,82 +1033,50 @@ lemma setupCallerCap_almost_no_orphans [wp]: | clarsimp simp: is_active_thread_state_def isRestart_def isRunning_def)+ done -crunches doIPCTransfer, setMRs - for no_orphans [wp]: "no_orphans" - (wp: no_orphans_lift) - -crunch ksQ'[wp]: setEndpoint "\s. P (ksReadyQueues s)" - (wp: setObject_queues_unchanged_tcb updateObject_default_inv) +crunches cteInsert, setExtraBadge, setMessageInfo, transferCaps, copyMRs, + doNormalTransfer, doFaultTransfer, copyGlobalMappings + for tcbQueued[wp]: "obj_at' (\tcb. P (tcbQueued tcb)) tcb_ptr" + (wp: crunch_wps simp: crunch_simps) -crunch no_orphans [wp]: setEndpoint "no_orphans" - (wp: no_orphans_lift) +crunches doIPCTransfer, setMRs, setEndpoint + for ksReadyQueues [wp]: "\s. P (ksReadyQueues s)" + and no_orphans [wp]: "no_orphans" + (wp: no_orphans_lift updateObject_default_inv) lemma sendIPC_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s \ + "\\s. no_orphans s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s\ sendIPC blocking call badge canGrant canGrantReply thread epptr - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding sendIPC_def apply (wp hoare_drop_imps setThreadState_not_active_no_orphans sts_st_tcb' possibleSwitchTo_almost_no_orphans' | wpc | clarsimp simp: is_active_thread_state_def isRestart_def isRunning_def)+ - - apply (rule_tac Q="\rv. no_orphans and valid_queues' and valid_objs' and ko_at' rv epptr + apply (rule_tac Q="\rv. no_orphans and valid_objs' and ko_at' rv epptr and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) apply (fastforce simp: valid_objs'_def valid_obj'_def valid_ep'_def obj_at'_def) apply (wp get_ep_sp' | clarsimp)+ done lemma sendFaultIPC_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s \ + "\\s. no_orphans s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s\ sendFaultIPC tptr fault - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding sendFaultIPC_def apply (rule hoare_pre) - apply (wp threadSet_valid_queues' threadSet_no_orphans threadSet_valid_objs' + apply (wp threadSet_no_orphans threadSet_valid_objs' threadSet_sch_act | wpc | clarsimp)+ - apply (rule_tac Q'="\handlerCap s. no_orphans s \ valid_queues' s - \ valid_objs' s - \ sch_act_wf (ksSchedulerAction s) s" - in hoare_post_imp_R) + apply (rule_tac Q'="\_ s. no_orphans s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s" + in hoare_post_imp_R) apply (wp | clarsimp simp: inQ_def valid_tcb'_def tcb_cte_cases_def)+ done -lemma sendIPC_valid_queues' [wp]: - "\ \s. valid_queues' s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s \ - sendIPC blocking call badge canGrant canGrantReply thread epptr - \ \rv s. valid_queues' s \" - unfolding sendIPC_def - apply (wpsimp wp: hoare_drop_imps) - apply (wpsimp | wp (once) sts_st_tcb' hoare_drop_imps)+ - apply (rule_tac Q="\rv. valid_queues' and valid_objs' and ko_at' rv epptr - and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) - apply (clarsimp) - apply (wp get_ep_sp' | clarsimp)+ - done - -lemma sendFaultIPC_valid_queues' [wp]: - "\ \s. valid_queues' s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s \ - sendFaultIPC tptr fault - \ \rv s. valid_queues' s \" - unfolding sendFaultIPC_def - apply (rule hoare_pre) - apply (wp threadSet_valid_queues' threadSet_valid_objs' threadSet_sch_act - | wpc | clarsimp)+ - apply (rule_tac Q'="\handlerCap s. valid_queues' s \ valid_objs' s - \ sch_act_wf (ksSchedulerAction s) s" - in hoare_post_imp_R) - apply (wp | clarsimp simp: inQ_def valid_tcb'_def tcb_cte_cases_def)+ - done - -lemma handleFault_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s \ +lemma handleFault_no_orphans[wp]: + "\\s. no_orphans s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s\ handleFault tptr ex1 - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding handleFault_def - apply (rule hoare_pre) - apply (wp | clarsimp)+ - done + by wpsimp lemma replyFromKernel_no_orphans [wp]: "\ \s. no_orphans s \ @@ -1394,32 +1088,24 @@ lemma replyFromKernel_no_orphans [wp]: crunch inv [wp]: alignError "P" -lemma createObjects_no_orphans [wp]: - "\ \s. no_orphans s \ pspace_aligned' s \ pspace_no_overlap' ptr sz s \ pspace_distinct' s - \ n \ 0 \ range_cover ptr sz (objBitsKO val + gbits) n - \ \ case_option False (is_active_thread_state \ tcbState) (projectKO_opt val) \ +lemma createObjects_no_orphans[wp]: + "\\s. no_orphans s \ pspace_aligned' s \ pspace_no_overlap' ptr sz s \ pspace_distinct' s + \ n \ 0 \ range_cover ptr sz (objBitsKO val + gbits) n + \ \ case_option False (is_active_thread_state \ tcbState) (projectKO_opt val) + \ \ case_option False tcbQueued (projectKO_opt val)\ createObjects ptr n val gbits - \ \rv s. no_orphans s \" + \\_ s. no_orphans s\" apply (clarsimp simp: no_orphans_def all_active_tcb_ptrs_def is_active_tcb_ptr_def all_queued_tcb_ptrs_def) apply (simp only: imp_conv_disj pred_tcb_at'_def createObjects_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift createObjects_orig_obj_at2') - apply clarsimp - apply (erule(1) impE) - apply clarsimp - apply (drule_tac x = x in spec) - apply (erule impE) - apply (clarsimp simp: obj_at'_def split: option.splits) - apply simp + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift createObjects_orig_obj_at2'[where sz=sz]) + apply (clarsimp simp: comp_def split: option.splits) done -lemma copyGlobalMappings_no_orphans [wp]: - "\ \s. no_orphans s \ - copyGlobalMappings newPD - \ \rv s. no_orphans s \" +lemma copyGlobalMappings_no_orphans[wp]: + "copyGlobalMappings newPD \no_orphans\" unfolding no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - done + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift) crunch no_orphans [wp]: insertNewCap "no_orphans" (wp: hoare_drop_imps) @@ -1565,43 +1251,45 @@ lemma mapM_x_match: by assumption lemma cancelAllIPC_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ - cancelAllIPC epptr - \ \rv s. no_orphans s \" + "\\s. no_orphans s \ valid_objs' s \ pspace_aligned' s \ pspace_distinct' s\ + cancelAllIPC epptr + \\_. no_orphans\" unfolding cancelAllIPC_def apply (wp sts_valid_objs' set_ep_valid_objs' sts_st_tcb' hoare_vcg_const_Ball_lift tcbSchedEnqueue_almost_no_orphans | wpc | rule mapM_x_match, rename_tac list, - rule_tac V="\_. valid_queues' and valid_objs'" + rule_tac V="\_. valid_objs' and pspace_aligned' and pspace_distinct'" and I="no_orphans and (\s. \t\set list. tcb_at' t s)" in mapM_x_inv_wp2 | clarsimp simp: valid_tcb_state'_def)+ - apply (rule_tac Q="\rv. no_orphans and valid_objs' and valid_queues' and ko_at' rv epptr" + apply (rule_tac Q="\rv. no_orphans and valid_objs' and pspace_aligned' and pspace_distinct' and + ko_at' rv epptr" in hoare_post_imp) apply (fastforce simp: valid_obj'_def valid_ep'_def obj_at'_def) apply (wp get_ep_sp' | clarsimp)+ done lemma cancelAllSignals_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ + "\\s. no_orphans s \ valid_objs' s \ pspace_aligned' s \ pspace_distinct' s\ cancelAllSignals ntfn - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding cancelAllSignals_def apply (wp sts_valid_objs' set_ntfn_valid_objs' sts_st_tcb' hoare_vcg_const_Ball_lift tcbSchedEnqueue_almost_no_orphans | wpc | clarsimp simp: valid_tcb_state'_def)+ apply (rename_tac list) - apply (rule_tac V="\_. valid_queues' and valid_objs'" + apply (rule_tac V="\_. valid_objs' and pspace_aligned' and pspace_distinct'" and I="no_orphans and (\s. \t\set list. tcb_at' t s)" in mapM_x_inv_wp2) apply simp apply (wp sts_valid_objs' set_ntfn_valid_objs' sts_st_tcb' hoare_vcg_const_Ball_lift tcbSchedEnqueue_almost_no_orphans| clarsimp simp: valid_tcb_state'_def)+ - apply (rule_tac Q="\rv. no_orphans and valid_objs' and valid_queues' and ko_at' rv ntfn" + apply (rule_tac Q="\rv. no_orphans and valid_objs' and pspace_aligned' and pspace_distinct' and + ko_at' rv ntfn" in hoare_post_imp) apply (fastforce simp: valid_obj'_def valid_ntfn'_def obj_at'_def) apply (wp get_ntfn_sp' | clarsimp)+ @@ -1627,43 +1315,36 @@ lemma unbindMaybeNotification_no_orphans[wp]: unfolding unbindMaybeNotification_def by (wp getNotification_wp | simp | wpc)+ -lemma finaliseCapTrue_standin_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ - finaliseCapTrue_standin cap final - \ \rv s. no_orphans s \" +lemma finaliseCapTrue_standin_no_orphans[wp]: + "\no_orphans and valid_objs' and pspace_aligned' and pspace_distinct'\ + finaliseCapTrue_standin cap final + \\_. no_orphans\" unfolding finaliseCapTrue_standin_def - apply (rule hoare_pre) - apply (wp | clarsimp simp: Let_def | wpc)+ - done + by (wpsimp | clarsimp simp: Let_def | wpc)+ -lemma cteDeleteOne_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ +lemma cteDeleteOne_no_orphans[wp]: + "\no_orphans and valid_objs' and pspace_aligned' and pspace_distinct'\ cteDeleteOne slot - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding cteDeleteOne_def - apply (wp assert_inv isFinalCapability_inv weak_if_wp | clarsimp simp: unless_def)+ - done + by (wp assert_inv isFinalCapability_inv weak_if_wp | clarsimp simp: unless_def)+ crunch valid_objs' [wp]: getThreadReplySlot "valid_objs'" -lemma cancelSignal_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ - cancelSignal t ntfn - \ \rv s. no_orphans s \" +lemma cancelSignal_no_orphans[wp]: + "cancelSignal t ntfn \no_orphans\" unfolding cancelSignal_def Let_def - apply (rule hoare_pre) - apply (wp hoare_drop_imps setThreadState_not_active_no_orphans | wpc - | clarsimp simp: is_active_thread_state_def isRestart_def isRunning_def)+ - done + by (wpsimp wp: hoare_drop_imps setThreadState_not_active_no_orphans + simp: is_active_thread_state_def isRestart_def isRunning_def) lemma cancelIPC_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ + "\no_orphans and valid_objs' and pspace_aligned' and pspace_distinct'\ cancelIPC t \ \rv s. no_orphans s \" unfolding cancelIPC_def Let_def apply (rule hoare_pre) apply (wp setThreadState_not_active_no_orphans hoare_drop_imps weak_if_wp - threadSet_valid_queues' threadSet_valid_objs' threadSet_no_orphans | wpc + threadSet_valid_objs' threadSet_no_orphans | wpc | clarsimp simp: is_active_thread_state_def isRestart_def isRunning_def inQ_def valid_tcb'_def tcb_cte_cases_def cteSizeBits_def)+ done @@ -1672,30 +1353,26 @@ lemma cancelIPC_no_orphans [wp]: lemma asUser_almost_no_orphans: "\almost_no_orphans t\ asUser a f \\_. almost_no_orphans t\" unfolding almost_no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - done + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift) -lemma sendSignal_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s\ +lemma sendSignal_no_orphans[wp]: + "\\s. no_orphans s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s + \ pspace_aligned' s \ pspace_distinct' s\ sendSignal ntfnptr badge - \ \_ s. no_orphans s \" + \\_. no_orphans\" unfolding sendSignal_def - apply (rule hoare_pre) - apply (wp sts_st_tcb' gts_wp' getNotification_wp asUser_almost_no_orphans - cancelIPC_weak_sch_act_wf - | wpc | clarsimp simp: sch_act_wf_weak)+ + apply (wp sts_st_tcb' gts_wp' getNotification_wp asUser_almost_no_orphans + cancelIPC_weak_sch_act_wf + | wpc | clarsimp simp: sch_act_wf_weak)+ done -lemma handleInterrupt_no_orphans [wp]: - "\ \s. no_orphans s \ invs' s \ +lemma handleInterrupt_no_orphans[wp]: + "\no_orphans and invs' and pspace_aligned' and pspace_distinct'\ handleInterrupt irq - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding handleInterrupt_def - apply (rule hoare_pre) - apply (wp hoare_drop_imps hoare_vcg_all_lift getIRQState_inv - | wpc | clarsimp simp: invs'_def valid_state'_def maskIrqSignal_def - handleReservedIRQ_def)+ - done + by (wp hoare_drop_imps hoare_vcg_all_lift getIRQState_inv + | wpc | clarsimp simp: invs'_def valid_state'_def maskIrqSignal_def handleReservedIRQ_def)+ lemma updateRestartPC_no_orphans[wp]: "\ \s. no_orphans s \ invs' s \ @@ -1703,20 +1380,6 @@ lemma updateRestartPC_no_orphans[wp]: \ \rv s. no_orphans s \" by (wpsimp simp: updateRestartPC_def asUser_no_orphans) -lemma updateRestartPC_valid_queues'[wp]: - "\ \s. valid_queues' s \ - updateRestartPC t - \ \rv s. valid_queues' s \" - unfolding updateRestartPC_def - apply (rule asUser_valid_queues') - done - -lemma updateRestartPC_no_orphans_invs'_valid_queues'[wp]: - "\\s. no_orphans s \ invs' s \ valid_queues' s \ - updateRestartPC t - \\rv s. no_orphans s \ valid_queues' s \" - by (wpsimp simp: updateRestartPC_def asUser_no_orphans) - lemma suspend_no_orphans [wp]: "\ \s. no_orphans s \ invs' s \ sch_act_simple s \ tcb_at' t s \ suspend t @@ -1742,13 +1405,10 @@ lemma deleteASIDPool_no_orphans [wp]: apply (wp mapM_wp_inv getObject_inv loadObject_default_inv | clarsimp)+ done -lemma storePTE_no_orphans [wp]: - "\ \s. no_orphans s \ - storePTE ptr val - \ \rv s. no_orphans s \" +lemma storePTE_no_orphans[wp]: + "storePTE ptr val \no_orphans\" unfolding no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - done + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift) crunch no_orphans [wp]: unmapPage "no_orphans" (wp: crunch_wps) @@ -1757,13 +1417,10 @@ crunches unmapPageTable, prepareThreadDelete for no_orphans [wp]: "no_orphans" (wp: lookupPTSlotFromLevel_inv) -lemma setASIDPool_no_orphans [wp]: - "\ \s. no_orphans s \ - setObject p (ap :: asidpool) - \ \rv s. no_orphans s \" +lemma setASIDPool_no_orphans[wp]: + "setObject p (ap :: asidpool) \no_orphans\" unfolding no_orphans_disj all_queued_tcb_ptrs_def - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - done + by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift) lemma deleteASID_no_orphans [wp]: "\ \s. no_orphans s \ @@ -1851,9 +1508,7 @@ lemma cteRevoke_no_orphans [wp]: done lemma cancelBadgedSends_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ - cancelBadgedSends epptr badge - \ \rv s. no_orphans s \" + "cancelBadgedSends epptr badge \no_orphans\" unfolding cancelBadgedSends_def apply (wpsimp wp: filterM_preserved tcbSchedEnqueue_almost_no_orphans gts_wp' sts_st_tcb' | wp (once) hoare_drop_imps)+ @@ -1867,25 +1522,16 @@ lemma doReplyTransfer_no_orphans[wp]: \\rv. no_orphans\" unfolding doReplyTransfer_def apply (wp sts_st_tcb' setThreadState_not_active_no_orphans threadSet_no_orphans - threadSet_valid_queues' threadSet_weak_sch_act_wf + threadSet_weak_sch_act_wf | wpc | clarsimp simp: is_active_thread_state_def isRunning_def isRestart_def | wp (once) hoare_drop_imps - | strengthen sch_act_wf_weak invs_valid_queues')+ + | strengthen sch_act_wf_weak)+ apply (rule_tac Q="\rv. invs' and no_orphans" in hoare_post_imp) apply (fastforce simp: inQ_def) apply (wp hoare_drop_imps | clarsimp)+ apply (clarsimp simp:invs'_def valid_state'_def valid_pspace'_def) done -lemma cancelSignal_valid_queues' [wp]: - "\ \s. valid_queues' s \ valid_objs' s \ - cancelSignal t ntfn - \ \rv s. valid_queues' s \" - unfolding cancelSignal_def Let_def - apply (rule hoare_pre) - apply (wp hoare_drop_imps | wpc | clarsimp)+ - done - crunch no_orphans [wp]: setupReplyMaster "no_orphans" (wp: crunch_wps simp: crunch_simps) @@ -1897,7 +1543,6 @@ lemma restart_no_orphans [wp]: apply (wp tcbSchedEnqueue_almost_no_orphans sts_st_tcb' cancelIPC_weak_sch_act_wf | clarsimp simp: o_def if_apply_def2 | strengthen no_orphans_strg_almost - | strengthen invs_valid_queues' | wp (once) hoare_drop_imps)+ apply auto done @@ -1911,15 +1556,12 @@ lemma readreg_no_orphans: done lemma writereg_no_orphans: - "\ \s. no_orphans s \ invs' s \ sch_act_simple s - \ tcb_at' dest s \ ex_nonz_cap_to' dest s\ - invokeTCB (tcbinvocation.WriteRegisters dest resume values arch) - \ \rv s. no_orphans s \" + "\\s. no_orphans s \ invs' s \ sch_act_simple s \ tcb_at' dest s \ ex_nonz_cap_to' dest s\ + invokeTCB (tcbinvocation.WriteRegisters dest resume values arch) + \\_. no_orphans\" unfolding invokeTCB_def performTransfer_def postModifyRegisters_def - apply simp - apply (rule hoare_pre) - by (wp hoare_vcg_if_lift hoare_vcg_conj_lift restart_invs' hoare_weak_lift_imp - | strengthen invs_valid_queues' | clarsimp simp: invs'_def valid_state'_def dest!: global'_no_ex_cap )+ + by (wpsimp wp: hoare_vcg_if_lift hoare_vcg_conj_lift restart_invs' hoare_weak_lift_imp + | clarsimp simp: invs'_def valid_state'_def dest!: global'_no_ex_cap )+ lemma copyreg_no_orphans: "\ \s. no_orphans s \ invs' s \ sch_act_simple s \ tcb_at' src s @@ -1930,8 +1572,8 @@ lemma copyreg_no_orphans: apply simp apply (wp hoare_vcg_if_lift hoare_weak_lift_imp) apply (wp hoare_weak_lift_imp hoare_vcg_conj_lift hoare_drop_imp mapM_x_wp' restart_invs' - restart_no_orphans asUser_no_orphans suspend_nonz_cap_to_tcb - | strengthen invs_valid_queues' | wpc | simp add: if_apply_def2)+ + restart_no_orphans asUser_no_orphans suspend_nonz_cap_to_tcb + | wpc | simp add: if_apply_def2)+ apply (fastforce simp: invs'_def valid_state'_def dest!: global'_no_ex_cap) done @@ -1953,22 +1595,19 @@ lemma almost_no_orphans_no_orphans': "\ almost_no_orphans t s; ksCurThread s = t\ \ no_orphans s" by (auto simp: almost_no_orphans_def no_orphans_def all_active_tcb_ptrs_def) -lemma setPriority_no_orphans [wp]: - "\ \s. no_orphans s \ invs' s \ tcb_at' tptr s \ +lemma setPriority_no_orphans[wp]: + "\no_orphans and invs' and tcb_at' tptr\ setPriority tptr prio - \ \rv s. no_orphans s \" + \\_. no_orphans\" unfolding setPriority_def apply wpsimp - apply (rule_tac Q="\rv s. almost_no_orphans tptr s \ valid_queues' s \ weak_sch_act_wf (ksSchedulerAction s) s" in hoare_post_imp) + apply (rule_tac Q="\_ s. almost_no_orphans tptr s \ weak_sch_act_wf (ksSchedulerAction s) s" in hoare_post_imp) apply clarsimp apply (clarsimp simp: is_active_tcb_ptr_runnable' pred_tcb_at'_def obj_at'_def almost_no_orphans_no_orphans elim!: almost_no_orphans_no_orphans') - apply (wp threadSet_almost_no_orphans threadSet_valid_queues' | clarsimp simp: inQ_def)+ + apply (wp threadSet_almost_no_orphans | clarsimp simp: inQ_def)+ apply (wpsimp wp: threadSet_weak_sch_act_wf) apply (wp tcbSchedDequeue_almost_no_orphans| clarsimp)+ - apply (rule_tac Q="\rv. obj_at' (Not \ tcbQueued) tptr and invs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) - apply (clarsimp simp: obj_at'_def inQ_def) - apply (wp tcbSchedDequeue_not_queued | clarsimp)+ done lemma setMCPriority_no_orphans[wp]: @@ -2020,7 +1659,6 @@ lemma tc_no_orphans: checkCap_inv[where P=no_orphans] checkCap_inv[where P="tcb_at' a"] threadSet_cte_wp_at' hoare_vcg_all_lift_R hoare_vcg_all_lift threadSet_no_orphans hoare_vcg_const_imp_lift_R hoare_weak_lift_imp hoare_drop_imp threadSet_ipcbuffer_invs - | strengthen invs_valid_queues' | (simp add: locateSlotTCB_def locateSlotBasic_def objBits_def objBitsKO_def tcbIPCBufferSlot_def tcb_cte_cases_def, wp hoare_return_sp) @@ -2051,13 +1689,12 @@ lemma invokeTCB_no_orphans [wp]: done lemma invokeCNode_no_orphans [wp]: - "\ \s. no_orphans s \ invs' s \ valid_cnode_inv' cinv s \ sch_act_simple s \ + "\no_orphans and invs' and valid_cnode_inv' cinv and sch_act_simple\ invokeCNode cinv - \ \rv. no_orphans \" + \\_. no_orphans\" unfolding invokeCNode_def apply (rule hoare_pre) apply (wp hoare_drop_imps unless_wp | wpc | clarsimp split del: if_split)+ - apply (simp add: invs_valid_queues') done lemma invokeIRQControl_no_orphans [wp]: @@ -2190,17 +1827,15 @@ lemma arch_performInvocation_no_orphans [wp]: done lemma setDomain_no_orphans [wp]: - "\no_orphans and valid_queues and valid_queues' and cur_tcb'\ - setDomain tptr newdom + "\no_orphans and cur_tcb' and tcb_at' tptr\ + setDomain tptr newdom \\_. no_orphans\" apply (simp add: setDomain_def when_def) apply (wp tcbSchedEnqueue_almost_no_orphans hoare_vcg_imp_lift threadSet_almost_no_orphans - threadSet_valid_queues'_no_state threadSet_st_tcb_at2 hoare_vcg_disj_lift + threadSet_st_tcb_at2 hoare_vcg_disj_lift threadSet_no_orphans - | clarsimp simp: st_tcb_at_neg2 not_obj_at')+ - apply (auto simp: tcb_at_typ_at' st_tcb_at_neg' is_active_tcb_ptr_runnable' - cur_tcb'_def obj_at'_def - dest: pred_tcb_at') + | clarsimp simp: st_tcb_at_neg2 not_obj_at')+ + apply (fastforce simp: tcb_at_typ_at' is_active_tcb_ptr_runnable') done lemma performInvocation_no_orphans [wp]: @@ -2227,8 +1862,6 @@ lemma K_bind_hoareE [wp]: "\P\ f \Q\,\E\ \ \P\ K_bind f x \Q\,\E\" by simp -crunch valid_queues' [wp]: replyFromKernel "valid_queues'" - lemma handleInvocation_no_orphans [wp]: "\ \s. no_orphans s \ invs' s \ ct_active' s \ ksSchedulerAction s = ResumeCurrentThread \ @@ -2246,20 +1879,12 @@ lemma handleInvocation_no_orphans [wp]: ct_in_state'_set setThreadState_st_tcb hoare_vcg_all_lift | simp add: split_def split del: if_split)+ - apply (wps setThreadState_ct') - apply (wp sts_ksQ - setThreadState_current_no_orphans sts_invs_minor' - ct_in_state'_set setThreadState_st_tcb - | simp add: split_def split del: if_split)+ apply (clarsimp simp: if_apply_def2) - apply (frule(1) ct_not_ksQ) by (auto simp: ct_in_state'_def pred_tcb_at'_def obj_at'_def invs'_def cur_tcb'_def valid_state'_def valid_idle'_def) lemma receiveSignal_no_orphans [wp]: - "\ \s. no_orphans s \ valid_queues' s \ - receiveSignal thread cap isBlocking - \ \rv s. no_orphans s \" + "receiveSignal thread cap isBlocking \no_orphans\" unfolding receiveSignal_def apply (wp hoare_drop_imps setThreadState_not_active_no_orphans | wpc | clarsimp simp: is_active_thread_state_def isRunning_def isRestart_def @@ -2277,7 +1902,7 @@ lemma receiveIPC_no_orphans [wp]: hoare_vcg_all_lift sts_st_tcb' | wpc | clarsimp simp: is_active_thread_state_def isRunning_def isRestart_def - doNBRecvFailedTransfer_def invs_valid_queues' + doNBRecvFailedTransfer_def | strengthen sch_act_wf_weak)+ done @@ -2368,7 +1993,8 @@ theorem callKernel_no_orphans [wp]: callKernel e \ \rv s. no_orphans s \" unfolding callKernel_def - by (wpsimp wp: weak_if_wp schedule_invs' hoare_drop_imps) + by (wpsimp wp: weak_if_wp schedule_invs' hoare_drop_imps + | strengthen invs_pspace_aligned' invs_pspace_distinct')+ end diff --git a/proof/refine/X64/ADT_H.thy b/proof/refine/X64/ADT_H.thy index d4c1ed75ff..b83baca500 100644 --- a/proof/refine/X64/ADT_H.thy +++ b/proof/refine/X64/ADT_H.thy @@ -243,61 +243,61 @@ lemma apply (clarsimp simp add: absHeapArch_def) apply (rename_tac arch_kernel_object) apply (case_tac arch_kernel_object) - apply (rule_tac x=y in exI) - apply (clarsimp split: asidpool.splits) - using fst_pte - apply (erule_tac x=y in allE) - apply (clarsimp split: if_split_asm) - apply (rule_tac x="(y && ~~ mask pt_bits)" in exI, simp) - apply (simp add: range_composition[symmetric]) - apply (rule_tac x="ucast (y >> 3)" in range_eqI) - apply (simp add: pt_bits_def pageBits_def bit_simps) - apply (simp add: word_size ucast_ucast_mask and_mask_shiftl_comm) - using pspace_aligned' - apply (simp add: pspace_aligned'_def dom_def) - apply (erule_tac x=y in allE) - apply (simp add: objBitsKO_def archObjSize_def is_aligned_neg_mask_eq - and_not_mask[symmetric] AND_NOT_mask_plus_AND_mask_eq) - using fst_pde - apply (erule_tac x=y in allE) - apply (clarsimp split: if_split_asm) - apply (rule_tac x="(y && ~~ mask pd_bits)" in exI, simp) - apply (simp add: range_composition[symmetric]) - apply (rule_tac x="ucast (y >> 3)" in range_eqI) - apply (simp add: pt_bits_def pageBits_def bit_simps) - apply (simp add: word_size ucast_ucast_mask and_mask_shiftl_comm) - using pspace_aligned' - apply (simp add: pspace_aligned'_def dom_def) - apply (erule_tac x=y in allE) - apply (simp add: objBitsKO_def archObjSize_def is_aligned_neg_mask_eq - and_not_mask[symmetric] AND_NOT_mask_plus_AND_mask_eq) - using fst_pdpte + apply (rule_tac x=y in exI) + apply (clarsimp split: asidpool.splits) + using fst_pte apply (erule_tac x=y in allE) apply (clarsimp split: if_split_asm) - apply (rule_tac x="(y && ~~ mask pdpt_bits)" in exI, simp) + apply (rule_tac x="(y && ~~ mask pt_bits)" in exI, simp) apply (simp add: range_composition[symmetric]) apply (rule_tac x="ucast (y >> 3)" in range_eqI) - apply (simp add: pt_bits_def pageBits_def bit_simps) + apply (simp add: pt_bits_def bit_simps) apply (simp add: word_size ucast_ucast_mask and_mask_shiftl_comm) - using pspace_aligned' + using pspace_aligned' apply (simp add: pspace_aligned'_def dom_def) apply (erule_tac x=y in allE) - apply (simp add: objBitsKO_def archObjSize_def is_aligned_neg_mask_eq - and_not_mask[symmetric] AND_NOT_mask_plus_AND_mask_eq) - using fst_pml4e + apply (simp add: objBitsKO_def archObjSize_def + and_not_mask[symmetric] AND_NOT_mask_plus_AND_mask_eq) + using fst_pde apply (erule_tac x=y in allE) apply (clarsimp split: if_split_asm) - apply (rule_tac x="(y && ~~ mask pml4_bits)" in exI, simp) + apply (rule_tac x="(y && ~~ mask pd_bits)" in exI, simp) apply (simp add: range_composition[symmetric]) apply (rule_tac x="ucast (y >> 3)" in range_eqI) - apply (simp add: pt_bits_def pageBits_def bit_simps) + apply (simp add: pt_bits_def bit_simps) apply (simp add: word_size ucast_ucast_mask and_mask_shiftl_comm) - using pspace_aligned' + using pspace_aligned' apply (simp add: pspace_aligned'_def dom_def) apply (erule_tac x=y in allE) - apply (simp add: objBitsKO_def archObjSize_def is_aligned_neg_mask_eq - and_not_mask[symmetric] AND_NOT_mask_plus_AND_mask_eq) - apply (simp split: option.splits Structures_H.kernel_object.splits) + apply (simp add: objBitsKO_def archObjSize_def + and_not_mask[symmetric] AND_NOT_mask_plus_AND_mask_eq) + using fst_pdpte + apply (erule_tac x=y in allE) + apply (clarsimp split: if_split_asm) + apply (rule_tac x="(y && ~~ mask pdpt_bits)" in exI, simp) + apply (simp add: range_composition[symmetric]) + apply (rule_tac x="ucast (y >> 3)" in range_eqI) + apply (simp add: pt_bits_def bit_simps) + apply (simp add: word_size ucast_ucast_mask and_mask_shiftl_comm) + using pspace_aligned' + apply (simp add: pspace_aligned'_def dom_def) + apply (erule_tac x=y in allE) + apply (simp add: objBitsKO_def archObjSize_def + and_not_mask[symmetric] AND_NOT_mask_plus_AND_mask_eq) + using fst_pml4e + apply (erule_tac x=y in allE) + apply (clarsimp split: if_split_asm) + apply (rule_tac x="y && ~~ mask pml4_bits" in exI, simp) + apply (simp add: range_composition[symmetric]) + apply (rule_tac x="ucast (y >> 3)" in range_eqI) + apply (simp add: pt_bits_def bit_simps) + apply (simp add: word_size ucast_ucast_mask and_mask_shiftl_comm) + using pspace_aligned' + apply (simp add: pspace_aligned'_def dom_def) + apply (erule_tac x=y in allE) + apply (simp add: objBitsKO_def archObjSize_def + and_not_mask[symmetric] AND_NOT_mask_plus_AND_mask_eq) + apply (simp split: option.splits Structures_H.kernel_object.splits) apply (intro allI) apply (intro impI) apply (elim exE) @@ -305,56 +305,56 @@ lemma apply (simp add: absHeapArch_def) apply (rename_tac arch_kernel_object z a b) apply (case_tac arch_kernel_object) - apply (clarsimp split: asidpool.splits) - apply (simp add: other_obj_relation_def asid_pool_relation_def o_def inv_def) - apply simp - apply (clarsimp simp: pte_relation_def - split: if_split_asm) - using ptes - apply (erule_tac x=x in allE) - apply simp - apply (erule_tac x=y in allE) - apply (clarsimp simp: bit_simps) - apply (simp add: absPageTable_def split: option.splits X64_H.pte.splits) - apply (clarsimp simp add: vmrights_map_def vm_rights_of_def - vm_kernel_only_def vm_read_only_def vm_read_write_def - split: vmrights.splits) - apply simp - apply (clarsimp simp: pde_relation_def - split: if_split_asm) - using pdes - apply (erule_tac x=x in allE) - apply simp - apply (erule_tac x=y in allE) - apply (clarsimp simp: bit_simps) - apply (simp add: absPageDirectory_def split: option.splits X64_H.pde.splits) - apply (clarsimp simp add: vmrights_map_def vm_rights_of_def - vm_kernel_only_def vm_read_only_def vm_read_write_def - split: vmrights.splits) - apply simp - apply (clarsimp simp: pdpte_relation_def - split: if_split_asm) - using pdptes - apply (erule_tac x=x in allE) - apply simp - apply (erule_tac x=y in allE) - apply (clarsimp simp: bit_simps) - apply (simp add: absPDPT_def split: option.splits X64_H.pdpte.splits) - apply (clarsimp simp add: vmrights_map_def vm_rights_of_def - vm_kernel_only_def vm_read_only_def vm_read_write_def - split: vmrights.splits) - apply simp - apply (clarsimp simp: pml4e_relation_def - split: if_split_asm) - using pml4es - apply (erule_tac x=x in allE) - apply simp - apply (erule_tac x=y in allE) - apply (clarsimp simp: bit_simps) - apply (simp add: absPML4_def split: option.splits X64_H.pml4e.splits) - apply (clarsimp simp add: vmrights_map_def vm_rights_of_def - vm_kernel_only_def vm_read_only_def vm_read_write_def - split: vmrights.splits) + apply (clarsimp split: asidpool.splits) + apply (simp add: other_obj_relation_def asid_pool_relation_def o_def inv_def) + apply simp + apply (clarsimp simp: pte_relation_def + split: if_split_asm) + using ptes + apply (erule_tac x=x in allE) + apply simp + apply (erule_tac x=y in allE) + apply (clarsimp simp: bit_simps) + apply (simp add: absPageTable_def split: option.splits X64_H.pte.splits) + apply (clarsimp simp add: vmrights_map_def vm_rights_of_def + vm_kernel_only_def vm_read_only_def vm_read_write_def + split: vmrights.splits) + apply simp + apply (clarsimp simp: pde_relation_def + split: if_split_asm) + using pdes + apply (erule_tac x=x in allE) + apply simp + apply (erule_tac x=y in allE) + apply (clarsimp simp: bit_simps) + apply (simp add: absPageDirectory_def split: option.splits X64_H.pde.splits) + apply (clarsimp simp add: vmrights_map_def vm_rights_of_def + vm_kernel_only_def vm_read_only_def vm_read_write_def + split: vmrights.splits) + apply simp + apply (clarsimp simp: pdpte_relation_def + split: if_split_asm) + using pdptes + apply (erule_tac x=x in allE) + apply simp + apply (erule_tac x=y in allE) + apply (clarsimp simp: bit_simps) + apply (simp add: absPDPT_def split: option.splits X64_H.pdpte.splits) + apply (clarsimp simp add: vmrights_map_def vm_rights_of_def + vm_kernel_only_def vm_read_only_def vm_read_write_def + split: vmrights.splits) + apply simp + apply (clarsimp simp: pml4e_relation_def + split: if_split_asm) + using pml4es + apply (erule_tac x=x in allE) + apply simp + apply (erule_tac x=y in allE) + apply (clarsimp simp: bit_simps) + apply (simp add: absPML4_def split: option.splits X64_H.pml4e.splits) + apply (clarsimp simp add: vmrights_map_def vm_rights_of_def + vm_kernel_only_def vm_read_only_def vm_read_write_def + split: vmrights.splits) done definition @@ -673,13 +673,12 @@ 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 add: 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) @@ -691,97 +690,72 @@ proof - 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 add: 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 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_all add: image_def) - apply (erule_tac x=0 in allE, simp) apply (erule_tac x=0 in allE, simp) 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: bit_simps) - apply (rename_tac vmpage_size) - apply (case_tac vmpage_size, simp_all add: bit_simps) + apply (erule_tac x=0 in allE, simp) + apply clarsimp + apply (erule_tac x=0 in allE, simp add: bit_simps) + apply (rename_tac vmpage_size) + apply (case_tac vmpage_size, simp_all add: bit_simps) apply clarsimp apply (intro conjI impI allI) apply (erule pspace_dom_relatedE[OF _ pspace_relation]) apply clarsimp apply (case_tac ko, simp_all add: other_obj_relation_def) - apply (clarsimp simp add: cte_relation_def split: if_split_asm) + apply (clarsimp simp add: cte_relation_def split: if_split_asm) + apply (clarsimp simp: tcb_relation_cut_def) apply (clarsimp simp add: ep_relation_def EndpointMap_def - split: Structures_A.endpoint.splits) + split: Structures_A.endpoint.splits) apply (clarsimp simp add: EndpointMap_def - split: Structures_A.endpoint.splits) + 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 simp add: pdpte_relation_def) - apply (clarsimp simp add: pml4e_relation_def) - apply (clarsimp split: if_split_asm)+ + apply (clarsimp simp add: pte_relation_def) + apply (clarsimp simp add: pde_relation_def) + apply (clarsimp simp add: pdpte_relation_def) + apply (clarsimp simp add: pml4e_relation_def) + apply (clarsimp split: if_split_asm)+ apply (erule pspace_dom_relatedE[OF _ pspace_relation]) apply (case_tac ko, simp_all add: other_obj_relation_def) - apply (clarsimp simp add: cte_relation_def split: if_split_asm) + apply (clarsimp simp add: cte_relation_def split: if_split_asm) + apply (clarsimp simp: tcb_relation_cut_def) apply (clarsimp simp add: ntfn_relation_def AEndpointMap_def - split: Structures_A.ntfn.splits) + split: Structures_A.ntfn.splits) apply (clarsimp simp add: AEndpointMap_def - split: Structures_A.ntfn.splits) + 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 simp add: pdpte_relation_def) - apply (clarsimp simp add: pml4e_relation_def) - apply (clarsimp split: if_split_asm)+ - - apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko, simp_all add: 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 simp add: pdpte_relation_def) apply (clarsimp simp add: pml4e_relation_def) apply (clarsimp split: if_split_asm)+ - apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko, simp_all add: 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 (erule pspace_dom_relatedE[OF _ pspace_relation]) + apply (case_tac ko, simp_all add: other_obj_relation_def) + apply (clarsimp simp add: cte_relation_def split: if_split_asm) + apply (clarsimp simp: tcb_relation_cut_def) + 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 simp add: pdpte_relation_def) apply (clarsimp simp add: pml4e_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 (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 add: bit_simps) - apply ((frule_tac i=n and k="0x1000" in word_mult_less_mono1, simp+)+)[4] + apply (clarsimp split: if_split_asm)+ + apply (erule pspace_dom_relatedE[OF _ pspace_relation]) apply (case_tac ko, simp_all add: other_obj_relation_def) - apply (clarsimp simp add: cte_relation_def split: if_split_asm) + apply (clarsimp simp add: cte_relation_def split: if_split_asm) + apply (clarsimp simp: tcb_relation_cut_def) 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) @@ -793,241 +767,261 @@ proof - 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]) + 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 (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 (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 bit_simps) - apply (case_tac vmpage_size; simp add: bit_simps) + apply (clarsimp simp add: pageBits_def mask_def ) + apply (case_tac vmpage_size; simp add: bit_simps) 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: 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 simp add: pdpte_relation_def) - apply (clarsimp simp add: pml4e_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 - 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 (clarsimp simp: tcb_relation_cut_def) + 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 simp add: pdpte_relation_def) + apply (clarsimp simp add: pml4e_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 pspace_aligned) 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 (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: mask_def bit_simps) + apply (case_tac vmpage_size; simp add: bit_simps) + apply ((frule_tac k="0x1000" in word_mult_less_mono1, simp+)+)[4] apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko, simp_all add: other_obj_relation_def - split: if_split_asm) + apply (case_tac ko, simp_all add: other_obj_relation_def) + apply (clarsimp simp add: cte_relation_def split: if_split_asm) + apply (clarsimp simp: tcb_relation_cut_def) 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 simp add: pdpte_relation_def) - apply (clarsimp simp add: pml4e_relation_def) + apply (clarsimp simp add: pte_relation_def) + apply (clarsimp simp add: pde_relation_def) + apply (clarsimp simp add: pdpte_relation_def) + apply (clarsimp simp add: pml4e_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::machine_word) * 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 objBits_defs)+ - apply (subgoal_tac "kheap s (y + of_bl ya * 2^cte_level_bits) = None") + 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 + 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 (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: other_obj_relation_def + split: if_split_asm) + prefer 2 + apply (clarsimp simp: tcb_relation_cut_def) + 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 simp add: pdpte_relation_def) + apply (clarsimp simp add: pml4e_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::machine_word) * 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) - 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 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 objBits_defs)+ + 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: other_obj_relation_def) - apply (clarsimp simp add: cte_relation_def split: if_split_asm) + apply (clarsimp simp add: cte_relation_def split: if_split_asm) + apply (clarsimp simp: tcb_relation_cut_def) 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) + 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 simp add: pdpte_relation_def) + apply (clarsimp simp add: pml4e_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 bit_simps) + apply (rule conjI) + prefer 2 + apply clarsimp + apply (rule sym) + apply (rule pspace_aligned_distinct_None' [OF pspace_aligned pspace_distinct], + (simp add: bit_simps)+) + apply (cut_tac x=ya and n="2^12" in + ucast_less_shiftl_helper'[where 'a=machine_word_len and a=3,simplified word_bits_conv], simp+) + apply (clarsimp simp add: word_gt_0) + apply clarsimp + apply (subgoal_tac "ucast ya << 3 = 0") + prefer 2 + apply (rule ccontr) + apply (frule_tac x=y in unaligned_helper, assumption) + apply (rule ucast_less_shiftl_helper'[where a=3], simp_all) + apply (rule ext) + apply (frule pspace_relation_absD[OF _ pspace_relation]) + apply simp + apply (erule_tac x=offs in allE) + apply (clarsimp simp add: pte_relation_def word_size_bits_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:)[1] + apply (clarsimp split: X64_A.pte.splits) + apply (rule set_eqI, clarsimp) + apply (case_tac x, simp_all)[1] + apply (clarsimp split: X64_A.pte.splits) + apply (case_tac x1, simp_all)[1] + apply (clarsimp simp add: pde_relation_def) + apply (clarsimp simp add: pdpte_relation_def) + apply (clarsimp simp: pml4e_relation_def) + apply (clarsimp split: if_split_asm)+ - 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 simp add: pdpte_relation_def) - apply (clarsimp simp add: pml4e_relation_def) + apply (simp add: other_obj_relation_def asid_pool_relation_def inv_def o_def) + apply (clarsimp simp: pte_relation_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 bit_simps) + apply (rule conjI) + prefer 2 + apply clarsimp + apply (rule sym) + apply (rule pspace_aligned_distinct_None'[OF pspace_aligned pspace_distinct], + (simp add: bit_simps)+) + apply (cut_tac x=ya and n="2^12" in + ucast_less_shiftl_helper'[where 'a=machine_word_len and a=3,simplified word_bits_conv], simp+) + apply (clarsimp simp add: word_gt_0) + apply clarsimp + apply (subgoal_tac "ucast ya << 3 = 0") + prefer 2 + apply (rule ccontr) + apply (frule_tac x=y in unaligned_helper, assumption) + apply (rule ucast_less_shiftl_helper'[where a=3], simp_all) + apply (rule ext) + apply (frule pspace_relation_absD[OF _ pspace_relation]) + apply simp + apply (erule_tac x=offs in allE) + apply (clarsimp simp add: pde_relation_def word_size_bits_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:)[1] + apply (clarsimp split: X64_A.pde.splits) + apply (rule set_eqI, clarsimp) + apply (case_tac x, simp_all)[1] + apply (clarsimp split: X64_A.pde.splits) + apply (rule set_eqI, clarsimp) + apply (case_tac x, simp_all)[1] + apply (case_tac x1, simp_all)[1] + apply (clarsimp simp add: pdpte_relation_def) + apply (clarsimp simp: pml4e_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 - bit_simps) - apply (rule conjI) - prefer 2 - apply clarsimp - apply (rule sym) - apply (rule pspace_aligned_distinct_None' - [OF pspace_aligned pspace_distinct], (simp add: bit_simps)+) - apply (cut_tac x=ya and n="2^12" in - ucast_less_shiftl_helper'[where 'a=machine_word_len and a=3,simplified word_bits_conv], simp+) - apply (clarsimp simp add: word_gt_0) - apply clarsimp - apply (subgoal_tac "ucast ya << 3 = 0") - prefer 2 - apply (rule ccontr) - apply (frule_tac x=y in unaligned_helper, assumption) - apply (rule ucast_less_shiftl_helper'[where a=3], simp_all) - apply (rule ext) - apply (frule pspace_relation_absD[OF _ pspace_relation]) - apply simp - apply (erule_tac x=offs in allE) - apply (clarsimp simp add: pte_relation_def word_size_bits_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:)[1] - apply (clarsimp split: X64_A.pte.splits) - apply (rule set_eqI, clarsimp) - apply (case_tac x, simp_all)[1] - apply (clarsimp split: X64_A.pte.splits) - apply (case_tac x1, simp_all)[1] - apply (clarsimp simp add: pde_relation_def) -apply (clarsimp simp add: pdpte_relation_def) -apply (clarsimp simp: pml4e_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: pte_relation_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 - bit_simps) - apply (rule conjI) - prefer 2 - apply clarsimp - apply (rule sym) - apply (rule pspace_aligned_distinct_None' - [OF pspace_aligned pspace_distinct], (simp add: bit_simps)+) - apply (cut_tac x=ya and n="2^12" in - ucast_less_shiftl_helper'[where 'a=machine_word_len and a=3,simplified word_bits_conv], simp+) - apply (clarsimp simp add: word_gt_0) - apply clarsimp - apply (subgoal_tac "ucast ya << 3 = 0") - prefer 2 - apply (rule ccontr) - apply (frule_tac x=y in unaligned_helper, assumption) - apply (rule ucast_less_shiftl_helper'[where a=3], simp_all) - apply (rule ext) - apply (frule pspace_relation_absD[OF _ pspace_relation]) - apply simp - apply (erule_tac x=offs in allE) - apply (clarsimp simp add: pde_relation_def word_size_bits_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:)[1] - apply (clarsimp split: X64_A.pde.splits) - apply (rule set_eqI, clarsimp) - apply (case_tac x, simp_all)[1] - apply (clarsimp split: X64_A.pde.splits) -apply (rule set_eqI, clarsimp) - apply (case_tac x, simp_all)[1] -apply (case_tac x1, simp_all)[1] -apply (clarsimp simp add: pdpte_relation_def) -apply (clarsimp simp: pml4e_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: pte_relation_def) -apply (clarsimp simp: pde_relation_def) + apply (simp add: other_obj_relation_def asid_pool_relation_def inv_def o_def) + apply (clarsimp simp: pte_relation_def) + apply (clarsimp simp: pde_relation_def) using pspace_aligned[simplified pspace_aligned_def Ball_def dom_def] apply (erule_tac x=y in allE) - apply (clarsimp simp add: pdpte_relation_def absPDPT_def - bit_simps) + apply (clarsimp simp add: pdpte_relation_def absPDPT_def bit_simps) apply (rule conjI) prefer 2 apply clarsimp apply (rule sym) - apply (rule pspace_aligned_distinct_None' - [OF pspace_aligned pspace_distinct], (simp add: bit_simps)+) + apply (rule pspace_aligned_distinct_None'[OF pspace_aligned pspace_distinct], + (simp add: bit_simps)+) apply (cut_tac x=ya and n="2^12" in ucast_less_shiftl_helper'[where 'a=machine_word_len and a=3,simplified word_bits_conv], simp+) apply (clarsimp simp add: word_gt_0) @@ -1042,8 +1036,7 @@ apply (clarsimp simp: pde_relation_def) apply simp apply (erule_tac x=offs in allE) apply (clarsimp simp add: pdpte_relation_def word_size_bits_def) - using valid_objs[simplified valid_objs_def fun_app_def dom_def, - simplified] + 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_pdpte_def) apply (erule_tac x=offs in allE) @@ -1053,55 +1046,52 @@ apply (clarsimp simp: pde_relation_def) apply (rule set_eqI, clarsimp) apply (case_tac x, simp_all)[1] apply (clarsimp split: X64_A.pdpte.splits) -apply (rule set_eqI, clarsimp) + apply (rule set_eqI, clarsimp) apply (case_tac x, simp_all)[1] -apply (case_tac x1, simp_all)[1] -apply (clarsimp simp: pml4e_relation_def) + apply (case_tac x1, simp_all)[1] + apply (clarsimp simp: pml4e_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: pte_relation_def) -apply (clarsimp simp: pde_relation_def) -apply (clarsimp simp: pdpte_relation_def) - using pspace_aligned[simplified pspace_aligned_def Ball_def dom_def] - apply (erule_tac x=y in allE) - apply (clarsimp simp add: pml4e_relation_def absPML4_def - bit_simps) - apply (rule conjI) - prefer 2 - apply clarsimp - apply (rule sym) - apply (rule pspace_aligned_distinct_None' - [OF pspace_aligned pspace_distinct], (simp add: bit_simps)+) - apply (cut_tac x=ya and n="2^12" in - ucast_less_shiftl_helper'[where 'a=machine_word_len and a=3,simplified word_bits_conv], simp+) - apply (clarsimp simp add: word_gt_0) - apply clarsimp - apply (subgoal_tac "ucast ya << 3 = 0") - prefer 2 - apply (rule ccontr) - apply (frule_tac x=y in unaligned_helper, assumption) - apply (rule ucast_less_shiftl_helper'[where a=3], simp_all) - apply (rule ext) - apply (frule pspace_relation_absD[OF _ pspace_relation]) - apply simp - apply (erule_tac x=offs in allE) - apply (clarsimp simp add: pml4e_relation_def word_size_bits_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_pml4e_def) - apply (erule_tac x=offs in allE) - apply (rename_tac pml4e') - apply (case_tac pml4e', simp_all add:)[1] -apply (case_tac "pd offs", simp_all)[1] - apply (clarsimp split: X64_A.pml4e.splits) - apply (rule set_eqI, clarsimp) - apply (case_tac x, simp_all)[1] - apply (clarsimp split: if_split_asm)+ -done + apply (case_tac arch_kernel_obj) + apply (simp add: other_obj_relation_def asid_pool_relation_def inv_def o_def) + apply (clarsimp simp: pte_relation_def) + apply (clarsimp simp: pde_relation_def) + apply (clarsimp simp: pdpte_relation_def) + using pspace_aligned[simplified pspace_aligned_def Ball_def dom_def] + apply (erule_tac x=y in allE) + apply (clarsimp simp add: pml4e_relation_def absPML4_def bit_simps) + apply (rule conjI) + prefer 2 + apply clarsimp + apply (rule sym) + apply (rule pspace_aligned_distinct_None'[OF pspace_aligned pspace_distinct], + (simp add: bit_simps)+) + apply (cut_tac x=ya and n="2^12" in + ucast_less_shiftl_helper'[where 'a=machine_word_len and a=3,simplified word_bits_conv], simp+) + apply (clarsimp simp add: word_gt_0) + apply clarsimp + apply (subgoal_tac "ucast ya << 3 = 0") + prefer 2 + apply (rule ccontr) + apply (frule_tac x=y in unaligned_helper, assumption) + apply (rule ucast_less_shiftl_helper'[where a=3], simp_all) + apply (rule ext) + apply (frule pspace_relation_absD[OF _ pspace_relation]) + apply simp + apply (erule_tac x=offs in allE) + apply (clarsimp simp add: pml4e_relation_def word_size_bits_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_pml4e_def) + apply (erule_tac x=offs in allE) + apply (rename_tac pml4e') + apply (case_tac pml4e', simp_all add:)[1] + apply (case_tac "pd offs", simp_all)[1] + apply (clarsimp split: X64_A.pml4e.splits) + apply (rule set_eqI, clarsimp) + apply (case_tac x, simp_all)[1] + apply (clarsimp split: if_split_asm)+ + done qed definition @@ -1136,14 +1126,14 @@ shows 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 (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 (rename_tac ko) apply clarsimp - apply (case_tac a, simp_all add: other_obj_relation_def) + apply (case_tac ko; simp add: other_obj_relation_def tcb_relation_cut_def) apply (insert pspace_relation) apply (clarsimp simp: obj_at'_def projectKOs) apply (erule(1) pspace_dom_relatedE) @@ -1209,10 +1199,9 @@ lemma bin_to_bl_of_bl_eq: lemma TCB_implies_KOTCB: "\pspace_relation (kheap s) (ksPSpace s'); kheap s a = Some (TCB tcb)\ \ \tcb'. ksPSpace s' a = Some (KOTCB tcb') \ tcb_relation tcb tcb'" - apply (clarsimp simp add: pspace_relation_def pspace_dom_def - dom_def UNION_eq Collect_eq) + apply (clarsimp simp add: pspace_relation_def pspace_dom_def dom_def UNION_eq Collect_eq) apply (erule_tac x=a in allE)+ - apply (clarsimp simp add: other_obj_relation_def + apply (clarsimp simp: other_obj_relation_def tcb_relation_cut_def split: Structures_H.kernel_object.splits) apply (drule iffD1) apply (fastforce simp add: dom_def image_def) @@ -1222,12 +1211,11 @@ 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_all) -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) + apply (simp add: well_formed_cnode_n_def dom_def Collect_eq) + done lemma cteMap_correct: assumes rel: "(s,s') \ state_relation" @@ -2007,7 +1995,7 @@ definition domain_index_internal = ksDomScheduleIdx s, cur_domain_internal = ksCurDomain s, domain_time_internal = ksDomainTime s, - ready_queues_internal = curry (ksReadyQueues 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: @@ -2015,12 +2003,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 absEkheap_correct - absCDTList_correct[THEN fun_cong] state_relation_def invs_def valid_state_def - ready_queues_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) + 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 diff --git a/proof/refine/X64/ArchAcc_R.thy b/proof/refine/X64/ArchAcc_R.thy index df214412a0..8ac8caf411 100644 --- a/proof/refine/X64/ArchAcc_R.thy +++ b/proof/refine/X64/ArchAcc_R.thy @@ -70,16 +70,6 @@ lemma getObject_ASIDPool_corres: apply (clarsimp simp: other_obj_relation_def asid_pool_relation_def) done -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 simp - done - lemmas aligned_distinct_asid_pool_atI' = aligned_distinct_obj_atI'[where 'a=asidpool, simplified, OF _ _ _ refl] @@ -595,8 +585,12 @@ lemma setObject_PD_corres: apply (drule(1) ekheap_kheap_dom) apply clarsimp apply (drule_tac x=p in bspec, erule domI) - apply (simp add: other_obj_relation_def + apply (simp add: other_obj_relation_def tcb_relation_cut_def split: Structures_A.kernel_object.splits) + apply (extract_conjunct \match conclusion in "ready_queues_relation_2 _ _ _ _ _" \ -\) + apply (prop_tac "typ_at' (koTypeOf (injectKO pde')) p b") + apply (simp add: typ_at'_def ko_wp_at'_def) + apply (fastforce dest: tcbs_of'_non_tcb_update) apply (rule conjI) apply (clarsimp simp add: ghost_relation_def) apply (erule_tac x="p && ~~ mask pd_bits" in allE)+ @@ -680,12 +674,16 @@ lemma setObject_PT_corres: apply (drule(1) ekheap_kheap_dom) apply clarsimp apply (drule_tac x=p in bspec, erule domI) - apply (simp add: other_obj_relation_def - split: Structures_A.kernel_object.splits) - apply (rule conjI) + apply (simp add: other_obj_relation_def 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 + apply (extract_conjunct \match conclusion in "ready_queues_relation_2 _ _ _ _ _" \ -\) + apply (prop_tac "typ_at' (koTypeOf (injectKO pte')) p b") + apply (simp add: typ_at'_def ko_wp_at'_def) + subgoal by (fastforce dest: tcbs_of'_non_tcb_update) apply (simp add: map_to_ctes_upd_other) apply (simp add: fun_upd_def) apply (simp add: caps_of_state_after_update obj_at_def swp_cte_at_caps_of) @@ -744,20 +742,21 @@ lemma setObject_PDPT_corres: apply (drule bspec, assumption) apply clarsimp apply (erule (1) obj_relation_cutsE) + apply simp + apply simp + apply clarsimp apply simp + apply (frule (1) pspace_alignedD) + apply (drule_tac p=x in pspace_alignedD, assumption) apply simp - apply clarsimp - apply (frule (1) pspace_alignedD) - apply (drule_tac p=x in pspace_alignedD, assumption) - apply simp - apply (drule mask_alignment_ugliness) + apply (drule mask_alignment_ugliness) + apply (simp add: pdpt_bits_def pageBits_def) apply (simp add: pdpt_bits_def pageBits_def) - apply (simp add: pdpt_bits_def pageBits_def) - apply clarsimp - apply (drule test_bit_size) - apply (clarsimp simp: word_size bit_simps) - apply arith - apply ((simp split: if_split_asm)+)[5] + apply clarsimp + apply (drule test_bit_size) + apply (clarsimp simp: word_size bit_simps) + apply arith + apply ((simp split: if_split_asm)+)[5] apply (simp add: other_obj_relation_def split: Structures_A.kernel_object.splits arch_kernel_obj.splits) apply (rule conjI) @@ -765,8 +764,12 @@ lemma setObject_PDPT_corres: apply (drule(1) ekheap_kheap_dom) apply clarsimp apply (drule_tac x=p in bspec, erule domI) - apply (simp add: other_obj_relation_def - split: Structures_A.kernel_object.splits) + apply (simp add: other_obj_relation_def tcb_relation_cut_def + split: Structures_A.kernel_object.splits) + apply (extract_conjunct \match conclusion in "ready_queues_relation_2 _ _ _ _ _" \ -\) + apply (prop_tac "typ_at' (koTypeOf (injectKO pdpte')) p b") + apply (simp add: typ_at'_def ko_wp_at'_def) + apply (fastforce dest: tcbs_of'_non_tcb_update) apply (rule conjI) apply (clarsimp simp add: ghost_relation_def) apply (erule_tac x="p && ~~ mask pdpt_bits" in allE)+ @@ -818,20 +821,21 @@ lemma setObject_PML4_corres: apply clarsimp apply (drule_tac x = x in spec) apply (clarsimp simp: pml4e_relation_def mask_pml4_bits_inner_beauty - dest!: more_pml4_inner_beauty) + dest!: more_pml4_inner_beauty) apply (rule ballI) apply (drule (1) bspec) apply clarsimp apply (rule conjI) apply (clarsimp simp: pml4e_relation_def mask_pml4_bits_inner_beauty - dest!: more_pml4_inner_beauty) + dest!: more_pml4_inner_beauty) apply clarsimp apply (drule bspec, assumption) apply clarsimp apply (erule (1) obj_relation_cutsE) + apply simp apply simp apply simp - apply clarsimp + apply simp apply simp apply (frule (1) pspace_alignedD) apply (drule_tac p=x in pspace_alignedD, assumption) @@ -845,14 +849,18 @@ lemma setObject_PML4_corres: apply arith apply ((simp split: if_split_asm)+)[2] apply (simp add: other_obj_relation_def - split: Structures_A.kernel_object.splits arch_kernel_obj.splits) + split: Structures_A.kernel_object.splits arch_kernel_obj.splits) 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: other_obj_relation_def - split: Structures_A.kernel_object.splits) + apply (simp add: other_obj_relation_def tcb_relation_cut_def + split: Structures_A.kernel_object.splits) + apply (extract_conjunct \match conclusion in "ready_queues_relation_2 _ _ _ _ _" \ -\) + apply (prop_tac "typ_at' (koTypeOf (injectKO pml4e')) p b") + apply (simp add: typ_at'_def ko_wp_at'_def) + apply (fastforce dest: tcbs_of'_non_tcb_update) apply (rule conjI) apply (clarsimp simp add: ghost_relation_def) apply (erule_tac x="p && ~~ mask pml4_bits" in allE)+ diff --git a/proof/refine/X64/Arch_R.thy b/proof/refine/X64/Arch_R.thy index 2693eef7a4..447128bf87 100644 --- a/proof/refine/X64/Arch_R.thy +++ b/proof/refine/X64/Arch_R.thy @@ -267,11 +267,10 @@ lemma performASIDControlInvocation_corres: deleteObjects_cte_wp_at' deleteObjects_null_filter[where p="makePoolParent i'"]) apply (clarsimp simp:invs_mdb max_free_index_def invs_untyped_children) - 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 (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) @@ -344,7 +343,7 @@ lemma performASIDControlInvocation_corres: apply (simp add:pageBits_def) apply clarsimp apply (drule(1) cte_cap_in_untyped_range) - apply (fastforce simp:cte_wp_at_ctes_of) + apply (fastforce simp: cte_wp_at_ctes_of) apply assumption+ apply fastforce apply simp @@ -1374,8 +1373,7 @@ lemma performX64PortInvocation_corres: apply (strengthen invs_mdb'[mk_strg]) apply (wpsimp wp: setIOPortMask_invs') apply (clarsimp simp: invs_valid_objs valid_arch_inv_def valid_iocontrol_inv_def cte_wp_at_caps_of_state) - apply (rule conjI, clarsimp) - apply (clarsimp simp: safe_parent_for_def safe_parent_for_arch_def) + apply (fastforce simp: safe_parent_for_def safe_parent_for_arch_def) apply (clarsimp simp: invs_pspace_distinct' invs_pspace_aligned' valid_arch_inv'_def ioport_control_inv_valid'_def valid_cap'_def capAligned_def word_bits_def) apply (clarsimp simp: safe_parent_for'_def cte_wp_at_ctes_of) @@ -2180,7 +2178,7 @@ lemma arch_performInvocation_invs': apply (drule_tac src=p in valid_ioports_issuedD'[OF invs_valid_ioports']) apply (fastforce simp: cteCaps_of_def) apply force - by (force simp: cteCaps_of_def ran_def valid_ioports'_simps dest!: invs_valid_ioports') + using ranD valid_ioports_issuedD' by fastforce end diff --git a/proof/refine/X64/Bits_R.thy b/proof/refine/X64/Bits_R.thy index 09b416edb4..b211aeaedd 100644 --- a/proof/refine/X64/Bits_R.thy +++ b/proof/refine/X64/Bits_R.thy @@ -77,6 +77,10 @@ lemma projectKO_tcb: "(projectKO_opt ko = Some t) = (ko = KOTCB t)" by (cases ko) (auto simp: projectKO_opts_defs) +lemma tcb_of'_TCB[simp]: + "tcb_of' (KOTCB tcb) = Some tcb" + by (simp add: projectKO_tcb) + lemma projectKO_cte: "(projectKO_opt ko = Some t) = (ko = KOCTE t)" by (cases ko) (auto simp: projectKO_opts_defs) diff --git a/proof/refine/X64/CNodeInv_R.thy b/proof/refine/X64/CNodeInv_R.thy index 7e73232588..753d210960 100644 --- a/proof/refine/X64/CNodeInv_R.thy +++ b/proof/refine/X64/CNodeInv_R.thy @@ -5116,7 +5116,6 @@ lemma cteSwap_urz[wp]: crunches cteSwap for valid_arch_state'[wp]: "valid_arch_state'" and irq_states'[wp]: "valid_irq_states'" - 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" @@ -5125,6 +5124,12 @@ crunches cteSwap and ct_not_inQ[wp]: "ct_not_inQ" and ksDomScheduleIdx [wp]: "\s. P (ksDomScheduleIdx s)" +crunches cteSwap + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + and valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift) + lemma cteSwap_invs'[wp]: "\invs' and valid_cap' c and valid_cap' c' and ex_cte_cap_to' c1 and ex_cte_cap_to' c2 and @@ -5586,6 +5591,10 @@ lemma updateCap_untyped_ranges_zero_simple: crunch tcb_in_cur_domain'[wp]: updateCap "tcb_in_cur_domain' t" (wp: crunch_wps simp: crunch_simps rule: tcb_in_cur_domain'_lift) +crunches updateCap + for valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift) + lemma make_zombie_invs': "\\s. invs' s \ s \' cap \ cte_wp_at' (\cte. isFinal (cteCap cte) sl (cteCaps_of s)) sl s \ @@ -5602,7 +5611,8 @@ lemma make_zombie_invs': st_tcb_at' ((=) Inactive) p s \ bound_tcb_at' ((=) None) p s \ obj_at' (Not \ tcbQueued) p s - \ (\pr. p \ set (ksReadyQueues s pr)))) sl 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_state'_def valid_pspace'_def valid_mdb'_def @@ -5639,7 +5649,9 @@ lemma make_zombie_invs': 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_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 @@ -8652,7 +8664,7 @@ lemma cteMove_ioports' [wp]: apply (clarsimp simp add: modify_map_def split: if_split_asm dest!: weak_derived_cap_ioports') apply (rule conjI, clarsimp) apply (rule conjI, clarsimp) - apply (force simp: isCap_simps) + apply blast subgoal by ((auto | blast)+) apply clarsimp apply (rule conjI, clarsimp) @@ -8717,6 +8729,15 @@ lemma cteMove_urz [wp]: apply auto done +crunches updateMDB + for valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift) + +(* FIXME: arch_split *) +lemma haskell_assert_inv: + "haskell_assert Q L \P\" + by wpsimp + lemma cteMove_invs' [wp]: "\\x. invs' x \ ex_cte_cap_to' word2 x \ cte_wp_at' (\c. weak_derived' (cteCap c) capability) word1 x \ @@ -8794,6 +8815,10 @@ crunch ksDomSchedule[wp]: updateCap "\s. P (ksDomSchedule s)" crunch ksDomScheduleIdx[wp]: updateCap "\s. P (ksDomScheduleIdx s)" crunch ksDomainTime[wp]: updateCap "\s. P (ksDomainTime s)" +crunches updateCap + for rdyq_projs[wp]: + "\s. P (ksReadyQueues s) (tcbSchedNexts_of s) (tcbSchedPrevs_of s) (\d p. inQ d p |< tcbs_of' s)" + lemma corres_null_cap_update: "cap_relation cap cap' \ corres dc (invs and cte_wp_at ((=) cap) slot) diff --git a/proof/refine/X64/CSpace1_R.thy b/proof/refine/X64/CSpace1_R.thy index 9d060788b7..0d4ab8deba 100644 --- a/proof/refine/X64/CSpace1_R.thy +++ b/proof/refine/X64/CSpace1_R.thy @@ -234,7 +234,7 @@ lemma pspace_relation_cte_wp_at: apply (clarsimp elim!: cte_wp_at_weakenE') apply clarsimp apply (drule(1) pspace_relation_absD) - apply (clarsimp simp: other_obj_relation_def) + apply (clarsimp simp: tcb_relation_cut_def) apply (simp split: kernel_object.split_asm) apply (drule(2) aligned_distinct_obj_atI'[where 'a=tcb]) apply simp @@ -1639,10 +1639,10 @@ lemma cte_map_pulls_tcb_to_abstract: \ \tcb'. kheap s x = Some (TCB tcb') \ tcb_relation tcb' tcb \ (z = (x, tcb_cnode_index (unat ((y - x) >> cte_level_bits))))" apply (rule pspace_dom_relatedE, assumption+) - apply (erule(1) obj_relation_cutsE, simp_all split: if_split_asm) - apply (clarsimp simp: other_obj_relation_def + apply (erule(1) obj_relation_cutsE; + clarsimp simp: other_obj_relation_def split: Structures_A.kernel_object.split_asm - X64_A.arch_kernel_obj.split_asm) + X64_A.arch_kernel_obj.split_asm if_split_asm) apply (drule tcb_cases_related2) apply clarsimp apply (frule(1) cte_wp_at_tcbI [OF _ _ TrueI, where t="(a, b)" for a b, simplified]) @@ -1658,8 +1658,7 @@ lemma pspace_relation_update_tcbs: del: dom_fun_upd) apply (erule conjE) apply (rule ballI, drule(1) bspec) - apply (rule conjI, simp add: other_obj_relation_def) - apply (clarsimp split: Structures_A.kernel_object.split_asm) + apply (clarsimp simp: tcb_relation_cut_def split: Structures_A.kernel_object.split_asm) apply (drule bspec, fastforce) apply clarsimp apply (erule(1) obj_relation_cutsE, simp_all split: if_split_asm) @@ -1881,6 +1880,27 @@ lemma descendants_of_eq': apply simp done +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 + +lemma setObject_cte_tcbSchedNexts_of_use_valid_ksPSpace: + assumes step: "(x, s\ksPSpace := ps\) \ fst (setObject p (cte :: cte) s)" + 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_inQ_of_use_valid_ksPSpace: + assumes step: "(x, s\ksPSpace := ps\) \ fst (setObject p (cte :: cte) s)" + 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))) \ @@ -1894,7 +1914,12 @@ lemma updateCap_stuff: ksSchedulerAction s'' = ksSchedulerAction s' \ (ksArchState s'' = ksArchState s') \ (pspace_aligned' s' \ pspace_aligned' s'') \ - (pspace_distinct' s' \ pspace_distinct' s'')" using assms + (pspace_distinct' s' \ pspace_distinct' s'') \ + 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) @@ -1903,8 +1928,11 @@ lemma updateCap_stuff: apply (frule setCTE_pspace_only) apply (clarsimp simp: setCTE_def) apply (intro conjI impI) - apply (erule(1) use_valid [OF _ setObject_aligned]) - apply (erule(1) use_valid [OF _ setObject_distinct]) + 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 *) @@ -1921,16 +1949,15 @@ lemma pspace_relation_cte_wp_atI': apply (simp split: if_split_asm) apply (erule(1) pspace_dom_relatedE) apply (erule(1) obj_relation_cutsE, simp_all split: if_split_asm) + apply (subgoal_tac "n = x - y", clarsimp) + apply (drule tcb_cases_related2, clarsimp) + apply (intro exI, rule conjI) + apply (erule(1) cte_wp_at_tcbI[where t="(a, b)" for a b, simplified]) + apply fastforce + apply simp + apply clarsimp apply (simp add: other_obj_relation_def - split: Structures_A.kernel_object.split_asm - X64_A.arch_kernel_obj.split_asm) - apply (subgoal_tac "n = x - y", clarsimp) - apply (drule tcb_cases_related2, clarsimp) - apply (intro exI, rule conjI) - apply (erule(1) cte_wp_at_tcbI[where t="(a, b)" for a b, simplified]) - apply fastforce - apply simp - apply clarsimp + split: Structures_A.kernel_object.split_asm X64_A.arch_kernel_obj.split_asm) done lemma pspace_relation_cte_wp_atI: @@ -2453,7 +2480,7 @@ lemma updateCap_corres: apply (clarsimp simp: in_set_cap_cte_at_swp pspace_relations_def) apply (drule updateCap_stuff) apply simp - apply (rule conjI) + apply (extract_conjunct \match conclusion in "ghost_relation _ _ _" \ -\) apply (clarsimp simp: ghost_relation_typ_at set_cap_a_type_inv data_at_def) apply (rule conjI) prefer 2 @@ -2536,9 +2563,9 @@ lemma updateMDB_pspace_relation: apply (clarsimp simp: tcb_ctes_clear cte_level_bits_def objBits_defs) apply clarsimp apply (rule pspace_dom_relatedE, assumption+) - apply (rule obj_relation_cutsE, assumption+, simp_all split: if_split_asm)[1] - apply (clarsimp split: Structures_A.kernel_object.split_asm - X64_A.arch_kernel_obj.split_asm + apply (rule obj_relation_cutsE, assumption+; + clarsimp split: Structures_A.kernel_object.split_asm + X64_A.arch_kernel_obj.split_asm if_split_asm simp: other_obj_relation_def) apply (frule(1) tcb_cte_cases_aligned_helpers(1)) apply (frule(1) tcb_cte_cases_aligned_helpers(2)) @@ -2599,6 +2626,25 @@ lemma updateMDB_ctes_of: crunch aligned[wp]: updateMDB "pspace_aligned'" crunch pdistinct[wp]: updateMDB "pspace_distinct'" +crunch tcbSchedPrevs_of[wp]: updateMDB "\s. P (tcbSchedPrevs_of s)" +crunch tcbSchedNexts_of[wp]: updateMDB "\s. P (tcbSchedNexts_of s)" +crunch inQ_opt_pred[wp]: updateMDB "\s. P (inQ d p |< tcbs_of' s)" +crunch inQ_opt_pred'[wp]: updateMDB "\s. P (\d p. inQ d p |< tcbs_of' s)" +crunch ksReadyQueues[wp]: updateMDB "\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 + +crunches 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')" @@ -2621,7 +2667,11 @@ lemma updateMDB_the_lot: ksDomScheduleIdx s'' = ksDomScheduleIdx s' \ ksDomSchedule s'' = ksDomSchedule s' \ ksCurDomain s'' = ksCurDomain s' \ - ksDomainTime s'' = ksDomainTime s'" + ksDomainTime s'' = ksDomainTime s' \ + 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) @@ -2630,9 +2680,8 @@ using assms apply (erule use_valid) apply wp apply simp - 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 is_cap_revocable_eq: @@ -3832,6 +3881,9 @@ lemma updateUntypedCap_descendants_of: apply (clarsimp simp:mdb_next_rel_def mdb_next_def split:if_splits) done +crunches setCTE + for tcbQueued[wp]: "\s. P (tcbQueued |< tcbs_of' s)" + lemma setCTE_UntypedCap_corres: "\cap_relation cap (cteCap cte); is_untyped_cap cap; idx' = idx\ \ corres dc (cte_wp_at ((=) cap) src and valid_objs and @@ -3861,10 +3913,19 @@ lemma setCTE_UntypedCap_corres: apply assumption apply (clarsimp simp: pspace_relations_def) apply (subst conj_assoc[symmetric]) + apply clarsimp 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) @@ -5216,11 +5277,15 @@ lemma updateMDB_the_lot': ksDomScheduleIdx s'' = ksDomScheduleIdx s' \ ksDomSchedule s'' = ksDomSchedule s' \ ksCurDomain s'' = ksCurDomain s' \ - ksDomainTime s'' = ksDomainTime s'" + ksDomainTime s'' = ksDomainTime s' \ + 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 + done lemma cte_map_inj_eq': "\(cte_map p = cte_map p'); @@ -5321,7 +5386,6 @@ lemma cteInsert_corres: 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 "ksReadyQueues t = p" for p t)+ apply (thin_tac "ksSchedulerAction t = p" for p t)+ apply (clarsimp simp: pspace_relations_def) apply (rule conjI) diff --git a/proof/refine/X64/CSpace_R.thy b/proof/refine/X64/CSpace_R.thy index 8917fedb54..4530c97081 100644 --- a/proof/refine/X64/CSpace_R.thy +++ b/proof/refine/X64/CSpace_R.thy @@ -1100,43 +1100,6 @@ lemma bitmapQ_no_L2_orphans_lift: apply (rule hoare_vcg_prop, assumption) done -lemma valid_queues_lift_asm: - assumes tat1: "\d p tcb. \obj_at' (inQ d p) tcb and Q \ f \\_. obj_at' (inQ d p) tcb\" - and tat2: "\tcb. \st_tcb_at' runnable' tcb and Q \ f \\_. st_tcb_at' runnable' tcb\" - and prq: "\P. \\s. P (ksReadyQueues s) \ f \\_ s. P (ksReadyQueues s)\" - and prqL1: "\P. \\s. P (ksReadyQueuesL1Bitmap s)\ f \\_ s. P (ksReadyQueuesL1Bitmap s)\" - and prqL2: "\P. \\s. P (ksReadyQueuesL2Bitmap s)\ f \\_ s. P (ksReadyQueuesL2Bitmap s)\" - shows "\Invariants_H.valid_queues and Q\ f \\_. Invariants_H.valid_queues\" - proof - - have tat: "\d p tcb. \obj_at' (inQ d p) tcb and st_tcb_at' runnable' tcb and Q\ f - \\_. obj_at' (inQ d p) tcb and st_tcb_at' runnable' tcb\" - apply (rule hoare_chain [OF hoare_vcg_conj_lift [OF tat1 tat2]]) - apply (fastforce)+ - done - have tat_combined: "\d p tcb. \obj_at' (inQ d p and runnable' \ tcbState) tcb and Q\ f - \\_. obj_at' (inQ d p and runnable' \ tcbState) tcb\" - apply (rule hoare_chain [OF tat]) - apply (fastforce simp add: obj_at'_and pred_tcb_at'_def o_def)+ - done - show ?thesis unfolding valid_queues_def valid_queues_no_bitmap_def - by (wp tat_combined prq prqL1 prqL2 valid_bitmapQ_lift bitmapQ_no_L2_orphans_lift - bitmapQ_no_L1_orphans_lift hoare_vcg_all_lift hoare_vcg_conj_lift hoare_Ball_helper) - simp_all - qed - -lemmas valid_queues_lift = valid_queues_lift_asm[where Q="\_. True", simplified] - -lemma valid_queues_lift': - assumes tat: "\d p tcb. \\s. \ obj_at' (inQ d p) tcb s\ f \\_ s. \ obj_at' (inQ d p) tcb s\" - and prq: "\P. \\s. P (ksReadyQueues s)\ f \\_ s. P (ksReadyQueues s)\" - shows "\valid_queues'\ f \\_. valid_queues'\" - unfolding valid_queues'_def imp_conv_disj - by (wp hoare_vcg_all_lift hoare_vcg_disj_lift tat prq) - -lemma setCTE_norq [wp]: - "\\s. P (ksReadyQueues s)\ setCTE ptr cte \\r s. P (ksReadyQueues s) \" - by (clarsimp simp: valid_def dest!: setCTE_pspace_only) - lemma setCTE_norqL1 [wp]: "\\s. P (ksReadyQueuesL1Bitmap s)\ setCTE ptr cte \\r s. P (ksReadyQueuesL1Bitmap s) \" by (clarsimp simp: valid_def dest!: setCTE_pspace_only) @@ -2883,12 +2846,6 @@ lemma setCTE_inQ[wp]: apply (simp_all add: inQ_def) done -lemma setCTE_valid_queues'[wp]: - "\valid_queues'\ setCTE p cte \\rv. valid_queues'\" - apply (simp only: valid_queues'_def imp_conv_disj) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - done - crunch inQ[wp]: cteInsert "\s. P (obj_at' (inQ d p) t s)" (wp: crunch_wps) @@ -3476,6 +3433,13 @@ crunch pspace_canonical'[wp]: cteInsert "pspace_canonical'" crunch pspace_in_kernel_mappings'[wp]: cteInsert "pspace_in_kernel_mappings'" (wp: crunch_wps) +crunches cteInsert + 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 (\s. src \ dest) and (\s. cte_wp_at' (is_derived' (ctes_of s) src cap \ cteCap) src s) @@ -3485,9 +3449,9 @@ lemma cteInsert_invs: cteInsert cap src dest \\rv. invs'\" 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 CSpace_R.valid_queues_lift - valid_irq_node_lift valid_queues_lift' irqs_masked_lift cteInsert_norq - simp: st_tcb_at'_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 @@ -3791,10 +3755,13 @@ lemma corres_caps_decomposition: "\P. \\s. P (new_ups' s)\ g \\rv s. P (gsUserPages s)\" "\P. \\s. P (new_cns s)\ f \\rv s. P (cns_of_heap (kheap s))\" "\P. \\s. P (new_cns' s)\ g \\rv s. P (gsCNodes s)\" - "\P. \\s. P (new_queues s)\ f \\rv s. P (ready_queues s)\" + "\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_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)\" @@ -3810,7 +3777,9 @@ lemma corres_caps_decomposition: "\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 (new_queues s) (new_rqs' s')" + \ ready_queues_relation_2 (new_ready_queues s) (new_ksReadyQueues s') + (new_tcbSchedNexts_of s') (new_tcbSchedPrevs_of s') + (\d p. new_inQs d p s')" "\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 \ @@ -3878,8 +3847,9 @@ proof - 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 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 pspace_relations_def swp_cte_at))+ + 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 @@ -3991,7 +3961,7 @@ lemma create_reply_master_corres: apply clarsimp apply (rule corres_caps_decomposition) defer - apply (wp|simp)+ + 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) @@ -4368,6 +4338,9 @@ crunches setupReplyMaster 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]: @@ -4410,7 +4383,8 @@ lemma setupReplyMaster_invs'[wp]: 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 valid_queues_lift' hoare_vcg_disj_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 @@ -4687,8 +4661,8 @@ lemma arch_update_setCTE_invs: 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_ioports' - setCTE_norq hoare_vcg_disj_lift untyped_ranges_zero_lift + setCTE_pred_tcb_at' irqs_masked_lift setCTE_ioports' + 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) @@ -6138,7 +6112,7 @@ lemma cteInsert_simple_invs: apply (rule hoare_pre) 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' irqs_masked_lift + 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 @@ -6277,6 +6251,21 @@ lemma arch_update_updateCap_invs: apply clarsimp 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 @@ -6308,6 +6297,8 @@ lemma updateCap_same_master: apply 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 @@ -6538,8 +6529,9 @@ lemma updateFreeIndex_forward_invs': apply (simp add:updateCap_def) apply (wp setCTE_irq_handlers' getCTE_wp) apply (simp add:updateCap_def) - apply (wp irqs_masked_lift valid_queues_lift' cur_tcb_lift ct_idle_or_in_cur_domain'_lift + apply (wp irqs_masked_lift cur_tcb_lift ct_idle_or_in_cur_domain'_lift hoare_vcg_disj_lift untyped_ranges_zero_lift getCTE_wp setCTE_ioports' + sym_heap_sched_pointers_lift valid_bitmaps_lift | wp (once) hoare_use_eq[where f="gsUntypedZeroRanges"] | simp add: getSlotCap_def)+ apply (clarsimp simp: cte_wp_at_ctes_of fun_upd_def[symmetric]) diff --git a/proof/refine/X64/Detype_R.thy b/proof/refine/X64/Detype_R.thy index dd12d81d99..fc2fc085ed 100644 --- a/proof/refine/X64/Detype_R.thy +++ b/proof/refine/X64/Detype_R.thy @@ -591,7 +591,6 @@ lemma sym_refs_ko_wp_atD: 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 = @@ -611,8 +610,9 @@ lemma valid_objs: "valid_objs' s'" and pc: "pspace_canonical' s'" and pkm: "pspace_in_kernel_mappings' s'" and pd: "pspace_distinct' s'" - and vq: "valid_queues s'" - and vq': "valid_queues' s'" + and vbm: "valid_bitmaps s'" + and sym_sched: "sym_heap_sched_pointers s'" + and vsp: "valid_sched_pointers s'" and sym_refs: "sym_refs (state_refs_of' s')" and iflive: "if_live_then_nonz_cap' s'" and ifunsafe: "if_unsafe_then_cap' s'" @@ -838,7 +838,6 @@ lemma refs_notRange: apply (rule refs_of_live') apply clarsimp done - end context begin interpretation Arch . (*FIXME: arch_split*) @@ -904,6 +903,71 @@ crunches doMachineOp for deletionIsSafe_delete_locale[wp]: "deletionIsSafe_delete_locale base magnitude" (simp: deletionIsSafe_delete_locale_def) +lemma detype_tcbSchedNexts_of: + "\pspace_aligned' s'; pspace_distinct' s'; \p. p \ S \ \ ko_wp_at' live' p s'\ + \ ((\x. if x \ S then None else ksPSpace s' x) |> tcb_of' |> tcbSchedNext) + = tcbSchedNexts_of s'" + using pspace_alignedD' pspace_distinctD' + supply projectKOs[simp] + apply (clarsimp simp: opt_map_def) + apply (rule ext) + apply (rename_tac s) + apply (clarsimp simp: ko_wp_at'_def split: option.splits) + apply (drule_tac x=s in spec) + apply force + done + +lemma detype_tcbSchedPrevs_of: + "\pspace_aligned' s'; pspace_distinct' s'; \p. p \ S \ \ ko_wp_at' live' p s'\ + \ ((\x. if x \ S then None else ksPSpace s' x) |> tcb_of' |> tcbSchedPrev) + = tcbSchedPrevs_of s'" + using pspace_alignedD' pspace_distinctD' + supply projectKOs[simp] + apply (clarsimp simp: opt_map_def) + apply (rule ext) + apply (rename_tac s) + apply (clarsimp simp: ko_wp_at'_def split: option.splits) + apply (drule_tac x=s in spec) + apply force + done + +lemma detype_inQ: + "\pspace_aligned' s'; pspace_distinct' s'; \p. p \ S \ \ ko_wp_at' live' p s'\ + \ \d p. (inQ d p |< ((\x. if x \ S then None else ksPSpace s' x) |> tcb_of')) + = (inQ d p |< tcbs_of' s')" + using pspace_alignedD' pspace_distinctD' + supply projectKOs[simp] + apply (clarsimp simp: opt_map_def) + apply (rule ext) + apply (rename_tac s) + apply (clarsimp simp: inQ_def opt_pred_def ko_wp_at'_def split: option.splits) + apply (drule_tac x=s in spec) + apply force + done + +lemma detype_ready_queues_relation: + "\pspace_aligned' s'; pspace_distinct' s'; + \p. p \ {lower..upper} \ \ ko_wp_at' live' p s'; + ready_queues_relation s s'; upper = upper'\ + \ ready_queues_relation_2 + (ready_queues (detype {lower..upper'} s)) + (ksReadyQueues s') + ((\x. if lower \ x \ x \ upper then None + else ksPSpace s' x) |> + tcb_of' |> + tcbSchedNext) + ((\x. if lower \ x \ x \ upper then None + else ksPSpace s' x) |> + tcb_of' |> + tcbSchedPrev) + (\d p. inQ d p |< ((\x. if lower \ x \ x \ upper then None else ksPSpace s' x) |> tcb_of'))" + apply (clarsimp simp: detype_ext_def ready_queues_relation_def Let_def) + apply (frule (1) detype_tcbSchedNexts_of[where S="{lower..upper}"]; simp) + apply (frule (1) detype_tcbSchedPrevs_of[where S="{lower..upper}"]; simp) + apply (frule (1) detype_inQ[where S="{lower..upper}"]; simp) + apply (fastforce simp add: detype_def detype_ext_def) + done + lemma deleteObjects_corres: "is_aligned base magnitude \ magnitude \ 3 \ corres dc @@ -924,32 +988,33 @@ lemma deleteObjects_corres: apply (rule corres_stateAssert_implied[where P'=\, simplified]) prefer 2 apply clarsimp - 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 p_assoc_help invs_valid_pspace)[1] - apply (simp add:valid_cap_simps) + 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 (fastforce simp: sch_act_simple_def schact_is_rct_def state_relation_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: valid_cap_simps) apply (simp add: bind_assoc[symmetric] ksASIDMapSafe_def) 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 ) \ - 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" and - Q'="\_ s. s \' capability.UntypedCap d base magnitude idx \ - valid_pspace' s" in corres_underlying_split) + (\cref. cte_wp_at ((=) (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" 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]) apply (rule corres_split[OF _ cNodeNoPartialOverlap]) @@ -962,33 +1027,37 @@ 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, rule state.equality; simp add: detype_ext_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 add: null_filter'_def + map_to_ctes_delete[simplified field_simps]) 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 (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 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 (fastforce simp add: detype_def detype_ext_def intro!: ekheap_relation_detype) + 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) @@ -1001,13 +1070,31 @@ lemma deleteObjects_corres: 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' live' p s' \ p = idle_thread_ptr \ p \ base_bits" + apply (case_tac "ko_wp_at' live' 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 invs_valid_idle'[OF invs]) + 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 mask_eq_exp_minus_1) + by fastforce + +lemma untyped_range_live_idle': + "p \ base_bits \ \ (ko_wp_at' live' p s' \ p = idle_thread_ptr)" + using live_idle_untyped_range' by blast + lemma valid_obj': - "\ valid_obj' obj s'; ko_wp_at' ((=) obj) p s' \ \ valid_obj' obj state'" + "\ 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 (rename_tac endpoint) apply (case_tac endpoint, simp_all add: valid_ep'_def)[1] @@ -1034,10 +1121,23 @@ lemma valid_obj': apply (erule(2) cte_wp_at_tcbI') apply fastforce apply simp - 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 (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]) @@ -1049,14 +1149,48 @@ lemma valid_obj': 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 (rename_tac pde) apply (case_tac pde, simp_all add: valid_mapping'_def) - apply(rename_tac pdpte) + apply (rename_tac pdpte) apply (case_tac pdpte, simp_all add: valid_mapping'_def) - apply(rename_tac pml4e) + apply (rename_tac pml4e) apply (case_tac pml4e, simp_all add: valid_mapping'_def) done +lemma tcbSchedNexts_of_pspace': + "\pspace_aligned' s'; pspace_distinct' s'; pspace_distinct' state'\ + \ (pspace' |> tcb_of' |> tcbSchedNext) = tcbSchedNexts_of s'" + supply projectKOs[simp] + apply (rule ext) + apply (rename_tac p) + apply (case_tac "p \ base_bits") + apply (frule untyped_range_live_idle') + apply (clarsimp simp: opt_map_def) + apply (case_tac "ksPSpace s' p"; clarsimp) + apply (rename_tac obj) + apply (case_tac "tcb_of' obj"; clarsimp) + apply (clarsimp simp: ko_wp_at'_def obj_at'_def) + apply (fastforce simp: pspace_alignedD' pspace_distinctD') + apply (clarsimp simp: opt_map_def split: option.splits) + done + +lemma tcbSchedPrevs_of_pspace': + "\pspace_aligned' s'; pspace_distinct' s'; pspace_distinct' state'\ + \ (pspace' |> tcb_of' |> tcbSchedPrev) = tcbSchedPrevs_of s'" + supply projectKOs[simp] + apply (rule ext) + apply (rename_tac p) + apply (case_tac "p \ base_bits") + apply (frule untyped_range_live_idle') + apply (clarsimp simp: opt_map_def) + apply (case_tac "ksPSpace s' p"; clarsimp) + apply (rename_tac obj) + apply (case_tac "tcb_of' obj"; clarsimp) + apply (clarsimp simp: ko_wp_at'_def obj_at'_def) + apply (fastforce simp: pspace_alignedD' pspace_distinctD') + apply (clarsimp simp: opt_map_def split: option.splits) + done + lemma st_tcb: "\P p. \ st_tcb_at' P p s'; \ P Inactive; \ P IdleThreadState \ \ st_tcb_at' P p state'" by (fastforce simp: pred_tcb_at'_def obj_at'_real_def projectKOs dest: live_notRange) @@ -1269,17 +1403,18 @@ proof (simp add: invs'_def valid_state'_def valid_pspace'_def show "pspace_in_kernel_mappings' ?s" using pkm by (simp add: pspace_in_kernel_mappings'_def dom_def) - show "pspace_distinct' ?s" using pd + show pspace_distinct'_state': "pspace_distinct' ?s" using pd by (clarsimp simp add: pspace_distinct'_def ps_clear_def dom_if_None Diff_Int_distrib) - show "valid_objs' ?s" using valid_objs + show "valid_objs' ?s" using valid_objs sym_sched apply (clarsimp simp: valid_objs'_def ran_def) 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 + apply (frule pspace_alignedD'[OF _ pa]) + apply (frule pspace_distinctD'[OF _ pd]) + apply (clarsimp simp: ko_wp_at'_def) + apply fastforce done from sym_refs show "sym_refs (state_refs_of' ?s)" @@ -1291,19 +1426,6 @@ proof (simp add: invs'_def valid_state'_def valid_pspace'_def apply (simp add: refs_notRange[simplified] state_refs_ko_wp_at_eq) done - 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) - done - - from vq' show "valid_queues' ?s" - by (simp add: valid_queues'_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) @@ -1579,6 +1701,20 @@ proof (simp add: invs'_def valid_state'_def valid_pspace'_def apply simp done + from vbm + show "valid_bitmaps state'" + by (simp add: valid_bitmaps_def bitmapQ_defs) + + from sym_sched + show "sym_heap (pspace' |> tcb_of' |> tcbSchedNext) (pspace' |> tcb_of' |> tcbSchedPrev)" + using pa pd pspace_distinct'_state' + by (fastforce simp: tcbSchedNexts_of_pspace' tcbSchedPrevs_of_pspace') + + from vsp show "valid_sched_pointers_2 (pspace' |> tcb_of' |> tcbSchedPrev) + (pspace' |> tcb_of' |> tcbSchedNext) + (tcbQueued |< (pspace' |> tcb_of'))" + by (clarsimp simp: valid_sched_pointers_def opt_pred_def opt_map_def) + qed (clarsimp) lemma (in delete_locale) delete_ko_wp_at': @@ -4925,7 +5061,6 @@ lemma createTCBs_tcb_at': apply simp apply simp apply (clarsimp simp: retype_obj_at_disj') - apply (clarsimp simp: projectKO_opt_tcb) apply (clarsimp simp: new_cap_addrs_def image_def) apply (drule_tac x = "unat x" in bspec) apply (simp add:objBits_simps' shiftl_t2n) diff --git a/proof/refine/X64/EmptyFail_H.thy b/proof/refine/X64/EmptyFail_H.thy index eddb896616..5bf5b76656 100644 --- a/proof/refine/X64/EmptyFail_H.thy +++ b/proof/refine/X64/EmptyFail_H.thy @@ -169,7 +169,7 @@ crunch (empty_fail) empty_fail[intro!, wp, simp]: setBoundNotification, setNotif crunch (empty_fail) empty_fail[intro!, wp, simp]: cancelIPC, setThreadState, tcbSchedDequeue, setupReplyMaster, isStopped, possibleSwitchTo, tcbSchedAppend -(simp: Let_def) + (simp: Let_def wp: empty_fail_getObject) crunch (empty_fail) "_H_empty_fail"[intro!, wp, simp]: "ThreadDecls_H.suspend" (ignore_del: ThreadDecls_H.suspend) diff --git a/proof/refine/X64/Finalise_R.thy b/proof/refine/X64/Finalise_R.thy index bcf40bbbe1..de5d870e4d 100644 --- a/proof/refine/X64/Finalise_R.thy +++ b/proof/refine/X64/Finalise_R.thy @@ -80,20 +80,10 @@ crunch ksRQL1[wp]: emptySlot "\s. P (ksReadyQueuesL1Bitmap s)" crunch ksRQL2[wp]: emptySlot "\s. P (ksReadyQueuesL2Bitmap s)" crunch obj_at'[wp]: postCapDeletion "obj_at' P p" -lemmas postCapDeletion_valid_queues[wp] = - valid_queues_lift [OF postCapDeletion_obj_at' - postCapDeletion_pred_tcb_at' - postCapDeletion_ksRQ] - crunch inQ[wp]: clearUntypedFreeIndex "\s. P (obj_at' (inQ d p) t s)" crunch tcbDomain[wp]: clearUntypedFreeIndex "obj_at' (\tcb. P (tcbDomain tcb)) t" crunch tcbPriority[wp]: clearUntypedFreeIndex "obj_at' (\tcb. P (tcbPriority tcb)) t" -lemma emptySlot_queues [wp]: - "\Invariants_H.valid_queues\ emptySlot sl opt \\rv. Invariants_H.valid_queues\" - unfolding emptySlot_def - by (wp | wpcw | wp valid_queues_lift | simp)+ - crunch nosch[wp]: emptySlot "\s. P (ksSchedulerAction s)" crunch ksCurDomain[wp]: emptySlot "\s. P (ksCurDomain s)" @@ -1179,8 +1169,7 @@ definition "removeable' sl \ \s cap. (\p. p \ sl \ cte_wp_at' (\cte. capMasterCap (cteCap cte) = capMasterCap cap) p s) \ ((\p \ cte_refs' cap (irq_node' s). p \ sl \ cte_wp_at' (\cte. cteCap cte = NullCap) p s) - \ (\p \ zobj_refs' cap. ko_wp_at' (Not \ live') p s) - \ (\t \ threadCapRefs cap. \p. t \ set (ksReadyQueues s p)))" + \ (\p \ zobj_refs' cap. ko_wp_at' (Not \ live') p s))" lemma not_Final_removeable: "\ isFinal cap sl (cteCaps_of s) @@ -1484,11 +1473,6 @@ crunch irq_states' [wp]: emptySlot valid_irq_states' crunch no_0_obj' [wp]: emptySlot no_0_obj' (wp: crunch_wps) -crunch valid_queues'[wp]: setInterruptState "valid_queues'" - (simp: valid_queues'_def) - -crunch valid_queues'[wp]: emptySlot "valid_queues'" - end lemma deletedIRQHandler_irqs_masked'[wp]: @@ -1594,6 +1578,13 @@ lemma emptySlot_valid_arch'[wp]: by (wpsimp simp: emptySlot_def cte_wp_at_ctes_of wp: getCTE_wp hoare_drop_imps hoare_vcg_ex_lift) +crunches emptySlot + 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 \ (info \ NullCap \ post_cap_delete_pre' info sl (cteCaps_of s) )\ @@ -2420,6 +2411,14 @@ 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) +crunches 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]: "\invs'\ unbindNotification tcb \\rv. invs'\" apply (simp add: unbindNotification_def invs'_def valid_state'_def) @@ -2428,8 +2427,8 @@ lemma unbindNotification_invs[wp]: apply clarsimp apply (rule hoare_seq_ext[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 + 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 (clarsimp elim!: obj_atE' @@ -2471,7 +2470,7 @@ lemma unbindMaybeNotification_invs[wp]: apply (simp add: unbindMaybeNotification_def invs'_def valid_state'_def) apply (rule hoare_seq_ext[OF _ get_ntfn_sp']) apply (rule hoare_pre) - apply (wp sbn'_valid_pspace'_inv sbn_sch_act' sbn_valid_queues valid_irq_node_lift + 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)+ @@ -2652,7 +2651,6 @@ lemma cteDeleteOne_isFinal: 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 setQueue_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF setQueue_ctes_of] lemmas threadSet_cteCaps_of = ctes_of_cteCaps_of_lift [OF threadSet_ctes_of] crunch isFinal: suspend, prepareThreadDelete "\s. isFinal cap slot (cteCaps_of s)" @@ -2736,16 +2734,6 @@ lemma unbindNotification_valid_objs'_helper': by (clarsimp simp: valid_bound_tcb'_def valid_ntfn'_def split: option.splits ntfn.splits) -lemma typ_at'_valid_tcb'_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_tcb' tcb s\ f \\rv s. valid_tcb' tcb s\" - including no_pre - apply (simp add: valid_tcb'_def) - apply (case_tac "tcbState tcb", simp_all add: valid_tcb_state'_def split_def valid_bound_ntfn'_def) - apply (wp hoare_vcg_const_Ball_lift typ_at_lifts[OF P] - | case_tac "tcbBoundNotification tcb", simp_all)+ - done - lemmas setNotification_valid_tcb' = typ_at'_valid_tcb'_lift [OF setNotification_typ_at'] lemma unbindNotification_valid_objs'[wp]: @@ -2880,9 +2868,7 @@ lemma unbindNotification_bound_tcb_at': done crunches unbindNotification, unbindMaybeNotification - for valid_queues[wp]: "Invariants_H.valid_queues" - and weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" - (wp: sbn_valid_queues) + for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" lemma unbindNotification_tcb_at'[wp]: "\tcb_at' t'\ unbindNotification t \\rv. tcb_at' t'\" @@ -2925,6 +2911,38 @@ crunch obj_at'[wp]: prepareThreadDelete end +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\" + supply projectKOs[simp] + apply (clarsimp simp: tcbQueueRemove_def) + apply (wpsimp wp: threadSet_wp getTCB_wp) + by (fastforce dest!: heap_ls_last_None + simp: list_queue_relation_def prev_queue_head_def queue_end_valid_def + obj_at'_def opt_map_def ps_clear_def objBits_simps + split: if_splits) + +lemma 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 + supply projectKOs[simp] + 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 + split: option.splits) + +crunches updateRestartPC, cancelIPC + for valid_sched_pointers[wp]: valid_sched_pointers + (simp: crunch_simps wp: crunch_wps) + +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))) @@ -2944,21 +2962,22 @@ 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))))\" + \ 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 (wp prepares_delete_helper'' [OF cancelAllIPC_unlive] prepares_delete_helper'' [OF cancelAllSignals_unlive] - suspend_isFinal prepareThreadDelete_unqueued prepareThreadDelete_nonq + suspend_isFinal prepareThreadDelete_unqueued prepareThreadDelete_inactive prepareThreadDelete_isFinal - suspend_makes_inactive suspend_nonq + 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]], @@ -3025,7 +3044,9 @@ lemma cancelIPC_cte_wp_at': apply (clarsimp simp: cteCaps_of_def cte_wp_at_ctes_of x) done -crunch cte_wp_at'[wp]: tcbSchedDequeue "cte_wp_at' P p" +crunches tcbSchedDequeue + for cte_wp_at'[wp]: "cte_wp_at' P p" + (wp: crunch_wps) lemma suspend_cte_wp_at': assumes x: "\cap final. P cap \ finaliseCap cap final True = fail" @@ -3151,25 +3172,6 @@ crunch sch_act_not[wp]: cteDeleteOne "sch_act_not t" (simp: crunch_simps case_Null_If unless_def wp: crunch_wps getObject_inv loadObject_default_inv) -lemma cancelAllIPC_mapM_x_valid_queues: - "\Invariants_H.valid_queues and valid_objs' and (\s. \t\set q. tcb_at' t s)\ - mapM_x (\t. do - y \ setThreadState Structures_H.thread_state.Restart t; - tcbSchedEnqueue t - od) q - \\rv. Invariants_H.valid_queues\" - apply (rule_tac R="\_ s. (\t\set q. tcb_at' t s) \ valid_objs' s" - in hoare_post_add) - apply (rule hoare_pre) - apply (rule mapM_x_wp') - apply (rule hoare_name_pre_state) - apply (wp hoare_vcg_const_Ball_lift - tcbSchedEnqueue_valid_queues tcbSchedEnqueue_not_st - sts_valid_queues sts_st_tcb_at'_cases setThreadState_not_st - | simp - | ((elim conjE)?, drule (1) bspec, clarsimp elim!: obj_at'_weakenE simp: valid_tcb_state'_def))+ - done - lemma cancelAllIPC_mapM_x_weak_sch_act: "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ mapM_x (\t. do @@ -3183,13 +3185,15 @@ lemma cancelAllIPC_mapM_x_weak_sch_act: done lemma cancelAllIPC_mapM_x_valid_objs': - "\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 (wpsimp wp: mapM_x_wp' sts_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 @@ -3200,57 +3204,29 @@ lemma cancelAllIPC_mapM_x_tcbDomain_obj_at': tcbSchedEnqueue t od) q \\_. obj_at' (\tcb. P (tcbDomain tcb)) t'\" -apply (wp mapM_x_wp' tcbSchedEnqueue_not_st setThreadState_oa_queued | simp)+ -done + by (wpsimp wp: mapM_x_wp' setThreadState_oa_queued) 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) -apply (wp tcbSchedEnqueue_not_st - | wpc - | simp)+ -done + by (wpsimp simp: rescheduleRequired_def tcbSchedEnqueue_def tcbQueuePrepend_def) 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 - -lemma cancelAllIPC_valid_queues[wp]: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - cancelAllIPC ep_ptr - \\rv. Invariants_H.valid_queues\" - apply (simp add: cancelAllIPC_def ep'_Idle_case_helper) - apply (wp hoare_vcg_conj_lift hoare_vcg_const_Ball_lift - cancelAllIPC_mapM_x_valid_queues cancelAllIPC_mapM_x_valid_objs' cancelAllIPC_mapM_x_weak_sch_act - set_ep_valid_objs' getEndpoint_wp) - apply (clarsimp simp: valid_ep'_def) - apply (drule (1) ko_at_valid_objs') - apply (auto simp: valid_obj'_def valid_ep'_def valid_tcb'_def projectKOs - split: endpoint.splits - elim: valid_objs_valid_tcbE) - done + unfolding cancelAllIPC_def + by (wpsimp wp: hoare_vcg_conj_lift hoare_vcg_const_Ball_lift getEndpoint_wp + rescheduleRequired_oa_queued' cancelAllIPC_mapM_x_tcbDomain_obj_at') 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 + unfolding cancelAllSignals_def + by (wpsimp wp: hoare_vcg_conj_lift hoare_vcg_const_Ball_lift getNotification_wp + rescheduleRequired_oa_queued' cancelAllIPC_mapM_x_tcbDomain_obj_at') lemma unbindMaybeNotification_tcbDomain_obj_at': "\obj_at' (\tcb. P (tcbDomain tcb)) t'\ @@ -3260,38 +3236,6 @@ lemma unbindMaybeNotification_tcbDomain_obj_at': apply (wp setBoundNotification_oa_queued getNotification_wp gbn_wp' | wpc | simp)+ done -lemma cancelAllSignals_valid_queues[wp]: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - cancelAllSignals ntfn - \\rv. Invariants_H.valid_queues\" - apply (simp add: cancelAllSignals_def) - apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) - apply (case_tac "ntfnObj ntfna", simp_all) - apply (wp, simp)+ - apply (wp hoare_vcg_conj_lift hoare_vcg_const_Ball_lift - cancelAllIPC_mapM_x_valid_queues cancelAllIPC_mapM_x_valid_objs' cancelAllIPC_mapM_x_weak_sch_act - set_ntfn_valid_objs' - | simp)+ - apply (clarsimp simp: valid_ep'_def) - apply (drule (1) ko_at_valid_objs') - apply (auto simp: valid_obj'_def valid_ntfn'_def valid_tcb'_def projectKOs - split: endpoint.splits - elim: valid_objs_valid_tcbE) - done - -lemma finaliseCapTrue_standin_valid_queues[wp]: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - finaliseCapTrue_standin cap final - \\_. Invariants_H.valid_queues\" - apply (simp add: finaliseCapTrue_standin_def Let_def) - apply (safe) - apply (wp | clarsimp | wpc)+ - done - - -crunch valid_queues[wp]: isFinalCapability "Invariants_H.valid_queues" - (simp: crunch_simps) - crunch sch_act[wp]: isFinalCapability "\s. sch_act_wf (ksSchedulerAction s) s" (simp: crunch_simps) @@ -3299,96 +3243,6 @@ crunch weak_sch_act[wp]: isFinalCapability "\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. \obj_at' (inQ d p) tcb\ f \\_. obj_at' (inQ d p) tcb\" - and prq: "\P. \\s. P (ksReadyQueues s)\ f \\_ s. P (ksReadyQueues s)\" - shows "\valid_inQ_queues\ f \\_. valid_inQ_queues\" - proof - - show ?thesis - apply (clarsimp simp: valid_def valid_inQ_queues_def) - apply safe - apply (rule use_valid [OF _ tat], assumption) - apply (drule spec, drule spec, erule conjE, erule bspec) - apply (rule ccontr) - apply (erule notE[rotated], erule(1) use_valid [OF _ prq]) - apply (erule use_valid [OF _ prq]) - apply simp - done - qed - -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)+ - -crunch valid_inQ_queues[wp]: emptySlot valid_inQ_queues - (simp: crunch_simps) - -lemma cancelAllIPC_mapM_x_valid_inQ_queues: - "\valid_inQ_queues\ - mapM_x (\t. do - y \ setThreadState Structures_H.thread_state.Restart t; - tcbSchedEnqueue t - od) q - \\rv. valid_inQ_queues\" - apply (rule mapM_x_wp_inv) - apply (wp sts_valid_queues [where st="Structures_H.thread_state.Restart", simplified] - setThreadState_st_tcb) - done - -lemma cancelAllIPC_valid_inQ_queues[wp]: - "\valid_inQ_queues\ - cancelAllIPC ep_ptr - \\rv. valid_inQ_queues\" - apply (simp add: cancelAllIPC_def ep'_Idle_case_helper) - apply (wp cancelAllIPC_mapM_x_valid_inQ_queues) - apply (wp hoare_conjI hoare_drop_imp | simp)+ - done - -lemma cancelAllSignals_valid_inQ_queues[wp]: - "\valid_inQ_queues\ - cancelAllSignals ntfn - \\rv. valid_inQ_queues\" - apply (simp add: cancelAllSignals_def) - apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) - apply (case_tac "ntfnObj ntfna", simp_all) - apply (wp, simp)+ - apply (wp cancelAllIPC_mapM_x_valid_inQ_queues)+ - apply (simp) - done - -crunches unbindNotification, unbindMaybeNotification - for valid_inQ_queues[wp]: "valid_inQ_queues" - -lemma finaliseCapTrue_standin_valid_inQ_queues[wp]: - "\valid_inQ_queues\ - finaliseCapTrue_standin cap final - \\_. valid_inQ_queues\" - apply (simp add: finaliseCapTrue_standin_def Let_def) - apply (safe) - apply (wp | clarsimp | wpc)+ - done - -crunch valid_inQ_queues[wp]: isFinalCapability valid_inQ_queues - (simp: crunch_simps) - -lemma cteDeleteOne_valid_inQ_queues[wp]: - "\valid_inQ_queues\ - cteDeleteOne sl - \\_. valid_inQ_queues\" - apply (simp add: cteDeleteOne_def unless_def) - apply (wpsimp wp: hoare_drop_imp hoare_vcg_all_lift) - done - crunch ksCurDomain[wp]: cteDeleteOne "\s. P (ksCurDomain s)" (wp: crunch_wps simp: crunch_simps unless_def) @@ -3452,9 +3306,6 @@ lemma deletingIRQHandler_invs' [wp]: apply simp done -crunches 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\ @@ -3659,7 +3510,7 @@ lemma unbindNotification_corres: 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 - valid_tcb_def valid_bound_ntfn_def + valid_tcb_def valid_bound_ntfn_def invs_distinct invs_psp_aligned 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 @@ -3684,8 +3535,8 @@ lemma unbindMaybeNotification_corres: 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 - valid_tcb_def valid_bound_ntfn_def valid_ntfn_def + simp: valid_obj_def is_tcb tcb_ntfn_is_bound_def invs_psp_aligned + valid_tcb_def valid_bound_ntfn_def valid_ntfn_def 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 @@ -3820,45 +3671,15 @@ lemma finaliseCap_corres: context begin interpretation Arch . (*FIXME: arch_split*) -crunch queues[wp]: copyGlobalMappings "Invariants_H.valid_queues" - (wp: crunch_wps ignore: storePDE) - -crunch queues'[wp]: copyGlobalMappings "Invariants_H.valid_queues'" - (wp: crunch_wps ignore: storePDE) - -crunch ifunsafe'[wp]: copyGlobalMappings "if_unsafe_then_cap'" - (wp: crunch_wps ignore: storePDE) - -crunch pred_tcb_at'[wp]: copyGlobalMappings "pred_tcb_at' proj P t" - (wp: crunch_wps ignore: storePDE) - -crunch vms'[wp]: copyGlobalMappings "valid_machine_state'" - (wp: crunch_wps ignore: storePDE) - -crunch ct_not_inQ[wp]: copyGlobalMappings "ct_not_inQ" +crunches copyGlobalMappings + for ifunsafe'[wp]: "if_unsafe_then_cap'" + and pred_tcb_at'[wp]: "pred_tcb_at' proj P t" + and vms'[wp]: "valid_machine_state'" + and ct_not_inQ[wp]: "ct_not_inQ" + and tcb_in_cur_domain'[wp]: "tcb_in_cur_domain' t" + and ct__in_cur_domain'[wp]: ct_idle_or_in_cur_domain' (wp: crunch_wps ignore: storePDE) -crunch tcb_in_cur_domain'[wp]: copyGlobalMappings "tcb_in_cur_domain' t" - (wp: crunch_wps) - -crunch ct__in_cur_domain'[wp]: copyGlobalMappings ct_idle_or_in_cur_domain' - (wp: crunch_wps) - -crunch gsUntypedZeroRanges[wp]: copyGlobalMappings "\s. P (gsUntypedZeroRanges s)" - (wp: crunch_wps) - -crunch gsMaxObjectSize[wp]: copyGlobalMappings "\s. P (gsMaxObjectSize s)" - (wp: crunch_wps) - -crunch it'[wp]: copyGlobalMappings "\s. P (ksIdleThread s)" - (wp: crunch_wps) - -crunch valid_irq_states'[wp]: copyGlobalMappings "valid_irq_states'" - (wp: crunch_wps) - -crunch ksDomScheduleIdx[wp]: copyGlobalMappings "\s. P (ksDomScheduleIdx 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 @@ -3919,178 +3740,6 @@ lemmas cteCaps_of_ctes_of_lift = ctes_of_cteCaps_of_lift lemmas final_matters'_simps = final_matters'_def [split_simps capability.split arch_capability.split] -definition set_thread_all :: "obj_ref \ Structures_A.tcb \ etcb - \ unit det_ext_monad" where - "set_thread_all ptr tcb etcb \ - do s \ get; - kh \ return $ (kheap s)(ptr \ (TCB tcb)); - ekh \ return $ (ekheap s)(ptr \ etcb); - put (s\kheap := kh, ekheap := ekh\) - od" - -definition thread_gets_the_all :: "obj_ref \ (Structures_A.tcb \ etcb) det_ext_monad" where - "thread_gets_the_all tptr \ - do tcb \ gets_the $ get_tcb tptr; - etcb \ gets_the $ get_etcb tptr; - return $ (tcb, etcb) od" - -definition thread_set_all :: "(Structures_A.tcb \ Structures_A.tcb) \ (etcb \ etcb) - \ obj_ref \ unit det_ext_monad" where - "thread_set_all f g tptr \ - do (tcb, etcb) \ thread_gets_the_all tptr; - set_thread_all tptr (f tcb) (g etcb) - od" - -lemma set_thread_all_corres: - fixes ob' :: "'a :: pspace_storable" - assumes x: "updateObject ob' = updateObject_default ob'" - assumes z: "\s. obj_at' P ptr s - \ map_to_ctes ((ksPSpace s) (ptr \ injectKO ob')) = map_to_ctes (ksPSpace s)" - assumes b: "\ko. P ko \ objBits ko = objBits ob'" - assumes P: "\(v::'a::pspace_storable). (1 :: machine_word) < 2 ^ (objBits v)" - assumes e: "etcb_relation etcb tcb'" - assumes is_t: "injectKO (ob' :: 'a :: pspace_storable) = KOTCB tcb'" - shows "other_obj_relation (TCB tcb) (injectKO (ob' :: 'a :: pspace_storable)) \ - corres dc (obj_at (same_caps (TCB tcb)) ptr and is_etcb_at ptr) - (obj_at' (P :: 'a \ bool) ptr) - (set_thread_all ptr tcb etcb) (setObject ptr ob')" - apply (rule corres_no_failI) - apply (rule no_fail_pre) - apply wp - apply (rule x) - apply (clarsimp simp: b elim!: obj_at'_weakenE) - apply (unfold set_thread_all_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 - updateObject_default_def in_magnitude_check [OF _ P]) - apply (clarsimp simp add: state_relation_def z) - apply (simp add: trans_state_update'[symmetric] trans_state_update[symmetric] - del: trans_state_update) - apply (clarsimp simp add: swp_def fun_upd_def obj_at_def is_etcb_at_def) - apply (subst cte_wp_at_after_update,fastforce simp add: obj_at_def) - apply (subst caps_of_state_after_update,fastforce simp add: obj_at_def) - apply clarsimp - 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 - split: Structures_A.kernel_object.splits if_split_asm) - - apply (fold fun_upd_def) - apply (simp only: pspace_relation_def dom_fun_upd2 simp_thms) - apply (subst pspace_dom_update) - apply assumption - apply simp - 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: is_other_obj_relation_type) - apply (drule(1) bspec) - apply clarsimp - apply (frule_tac ko'="TCB tcb'" and x'=ptr in obj_relation_cut_same_type, - (fastforce simp add: is_other_obj_relation_type)+)[1] - 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 (clarsimp simp: projectKOs) - apply (insert e is_t) - by (clarsimp simp: other_obj_relation_def etcb_relation_def is_other_obj_relation_type split: Structures_A.kernel_object.splits Structures_H.kernel_object.splits X64_A.arch_kernel_obj.splits) - -lemma tcb_update_all_corres': - assumes tcbs: "tcb_relation tcb tcb' \ tcb_relation tcbu tcbu'" - assumes tables: "\(getF, v) \ ran tcb_cap_cases. getF tcbu = getF tcb" - assumes tables': "\(getF, v) \ ran tcb_cte_cases. getF tcbu' = getF tcb'" - assumes r: "r () ()" - assumes e: "etcb_relation etcb tcb' \ etcb_relation etcbu tcbu'" - shows "corres r (ko_at (TCB tcb) add and (\s. ekheap s add = Some etcb)) - (ko_at' tcb' add) - (set_thread_all add tcbu etcbu) (setObject add tcbu')" - apply (rule_tac F="tcb_relation tcb tcb' \ 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 (force simp: projectKOs other_obj_relation_def ekheap_relation_def e) - apply (erule conjE) - apply (rule corres_guard_imp) - apply (rule corres_rel_imp) - apply (rule set_thread_all_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 simp: is_etcb_at_def 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 - done - -lemma thread_gets_the_all_corres: - shows "corres (\(tcb, etcb) tcb'. tcb_relation tcb tcb' \ etcb_relation etcb tcb') - (tcb_at t and is_etcb_at t) (tcb_at' t) - (thread_gets_the_all t) (getObject t)" - apply (rule corres_no_failI) - apply wp - apply (clarsimp simp add: gets_def get_def return_def bind_def get_tcb_def thread_gets_the_all_def threadGet_def ethread_get_def gets_the_def assert_opt_def get_etcb_def is_etcb_at_def tcb_at_def liftM_def split: option.splits Structures_A.kernel_object.splits) - 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 ko) - apply (simp_all add: fail_def return_def) - apply (clarsimp simp add: state_relation_def pspace_relation_def ekheap_relation_def) - apply (drule bspec) - apply clarsimp - apply blast - apply (drule bspec, erule domI) - apply (clarsimp simp add: other_obj_relation_def - lookupAround2_known1) - done - -lemma thread_set_all_corresT: - assumes x: "\tcb tcb'. tcb_relation tcb tcb' \ - tcb_relation (f tcb) (f' tcb')" - 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" - assumes e: "\etcb tcb'. etcb_relation etcb tcb' \ - etcb_relation (g etcb) (f' tcb')" - shows "corres dc (tcb_at t and valid_etcbs) - (tcb_at' t) - (thread_set_all f g t) (threadSet f' t)" - apply (simp add: thread_set_all_def threadSet_def bind_assoc) - apply (rule corres_guard_imp) - apply (rule corres_split[OF thread_gets_the_all_corres]) - apply (simp add: split_def) - apply (rule tcb_update_all_corres') - apply (erule x) - apply (rule y) - apply (clarsimp simp: bspec_split [OF spec [OF z]]) - apply fastforce - apply (erule e) - apply (simp add: thread_gets_the_all_def, wp+) - apply clarsimp - apply (frule(1) tcb_at_is_etcb_at) - apply (clarsimp simp add: tcb_at_def get_etcb_def obj_at_def) - apply (drule get_tcb_SomeD) - apply fastforce - apply simp - done - -lemmas thread_set_all_corres = - thread_set_all_corresT [OF _ _ all_tcbI, OF _ ball_tcb_cap_casesI ball_tcb_cte_casesI] - crunch idle_thread[wp]: deleteCallerCap "\s. P (ksIdleThread s)" (wp: crunch_wps) crunch sch_act_simple: deleteCallerCap sch_act_simple @@ -4101,96 +3750,11 @@ crunch typ_at'[wp]: deleteCallerCap "\s. P (typ_at' T p s)" (wp: crunch_wps) lemmas deleteCallerCap_typ_ats[wp] = typ_at_lifts [OF deleteCallerCap_typ_at'] -crunch ksQ[wp]: emptySlot "\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 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 - -lemma cancelAllIPC_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - cancelAllIPC epptr - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - (is "\?PRE\ _ \\_. ?POST\") - apply (simp add: cancelAllIPC_def) - apply (wp, wpc, wp) - apply (wps rescheduleRequired_ct') - apply (wp rescheduleRequired_ksQ') - apply (clarsimp simp: forM_x_def) - apply (wp cancelAll_ct_not_ksQ_helper mapM_x_wp_inv) - apply (wp hoare_lift_Pf2 [OF setEndpoint_ksQ setEndpoint_ct'])+ - apply (wps rescheduleRequired_ct') - apply (wp rescheduleRequired_ksQ') - apply (clarsimp simp: forM_x_def) - apply (wp cancelAll_ct_not_ksQ_helper mapM_x_wp_inv) - apply (wp hoare_lift_Pf2 [OF setEndpoint_ksQ setEndpoint_ct'])+ - prefer 2 - apply assumption - apply (rule_tac Q="\ep. ?PRE and ko_at' ep epptr" in hoare_post_imp) - apply (clarsimp) - apply (rule conjI) - apply ((clarsimp simp: invs'_def valid_state'_def - sch_act_sane_def - | drule(1) ct_not_in_epQueue)+)[2] - apply (wp get_ep_sp') - done - -lemma cancelAllSignals_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - cancelAllSignals ntfnptr - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - (is "\?PRE\ _ \\_. ?POST\") - apply (simp add: cancelAllSignals_def) - apply (wp, wpc, wp+) - apply (wps rescheduleRequired_ct') - apply (wp rescheduleRequired_ksQ') - apply clarsimp - apply (wp cancelAll_ct_not_ksQ_helper mapM_x_wp_inv) - apply (wp hoare_lift_Pf2 [OF setNotification_ksQ setNotification_ksCurThread]) - apply (wps setNotification_ksCurThread, wp) - prefer 2 - apply assumption - apply (rule_tac Q="\ep. ?PRE and ko_at' ep ntfnptr" in hoare_post_imp) - apply ((clarsimp simp: invs'_def valid_state'_def sch_act_sane_def - | drule(1) ct_not_in_ntfnQueue)+)[1] - apply (wp get_ntfn_sp') - done - -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 hoare_seq_ext[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 setNotification_ksCurThread, wp) - apply clarsimp - done - lemma sbn_ct_in_state'[wp]: "\ct_in_state' P\ setBoundNotification ntfn t \\_. ct_in_state' P\" apply (simp add: ct_in_state'_def) @@ -4223,37 +3787,6 @@ lemma unbindMaybeNotification_sch_act_sane[wp]: apply (wp setNotification_sch_act_sane sbn_sch_act_sane | wpc | clarsimp)+ done -lemma finaliseCapTrue_standin_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - finaliseCapTrue_standin cap final - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - apply (simp add: finaliseCapTrue_standin_def Let_def) - apply (safe) - apply (wp cancelAllIPC_ct_not_ksQ cancelAllSignals_ct_not_ksQ - hoare_drop_imps unbindMaybeNotification_ct_not_ksQ - | wpc - | clarsimp simp: isNotificationCap_def isReplyCap_def split:capability.splits)+ - done - -lemma cteDeleteOne_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - cteDeleteOne slot - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - apply (simp add: cteDeleteOne_def unless_def split_def) - apply (rule hoare_seq_ext [OF _ getCTE_sp]) - apply (case_tac "\final. finaliseCap (cteCap cte) final True = fail") - apply (simp add: finaliseCapTrue_standin_simple_def) - apply wp - apply (clarsimp) - apply (wp emptySlot_cteCaps_of hoare_lift_Pf2 [OF emptySlot_ksRQ emptySlot_ct]) - apply (simp add: cteCaps_of_def) - apply (wp (once) hoare_drop_imps) - apply (wp finaliseCapTrue_standin_ct_not_ksQ isFinalCapability_inv)+ - apply (clarsimp) - done - end end diff --git a/proof/refine/X64/Init_R.thy b/proof/refine/X64/Init_R.thy index e0077afd48..b129d1dc9a 100644 --- a/proof/refine/X64/Init_R.thy +++ b/proof/refine/X64/Init_R.thy @@ -98,7 +98,7 @@ definition zeroed_intermediate_state :: ksDomSchedule = [], ksCurDomain = 0, ksDomainTime = 0, - ksReadyQueues = K [], + ksReadyQueues = K (TcbQueue None None), ksReadyQueuesL1Bitmap = K 0, ksReadyQueuesL2Bitmap = K 0, ksCurThread = 0, @@ -119,9 +119,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: ekheap_relation_def) - apply (clarsimp simp: ready_queues_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/X64/InterruptAcc_R.thy b/proof/refine/X64/InterruptAcc_R.thy index 47d19ccf96..4665f6bfdf 100644 --- a/proof/refine/X64/InterruptAcc_R.thy +++ b/proof/refine/X64/InterruptAcc_R.thy @@ -49,7 +49,6 @@ lemma setIRQState_invs[wp]: apply (simp add: setIRQState_def setInterruptState_def getInterruptState_def) apply (wp dmo_maskInterrupt) apply (clarsimp simp: invs'_def valid_state'_def cur_tcb'_def - Invariants_H.valid_queues_def valid_queues'_def valid_idle'_def valid_irq_node'_def valid_arch_state'_def valid_global_refs'_def global_refs'_def valid_machine_state'_def @@ -57,7 +56,7 @@ lemma setIRQState_invs[wp]: valid_irq_handlers'_def irq_issued'_def cteCaps_of_def valid_irq_masks'_def valid_ioports'_simps - bitmapQ_defs valid_queues_no_bitmap_def) + bitmapQ_defs valid_bitmaps_def) apply (rule conjI, clarsimp) apply (clarsimp simp: irqs_masked'_def ct_not_inQ_def) apply (rule conjI) @@ -147,8 +146,7 @@ lemma invs'_irq_state_independent [simp, intro!]: 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_queues_no_bitmap_def - valid_queues'_def + irqs_masked'_def bitmapQ_defs valid_bitmaps_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 diff --git a/proof/refine/X64/Interrupt_R.thy b/proof/refine/X64/Interrupt_R.thy index 843dd43c89..9c696b7625 100644 --- a/proof/refine/X64/Interrupt_R.thy +++ b/proof/refine/X64/Interrupt_R.thy @@ -439,9 +439,8 @@ lemma invoke_irq_handler_invs'[wp]: InterruptDecls_H.invokeIRQHandler i \\rv. invs'\" apply (cases i, simp_all add: Interrupt_H.invokeIRQHandler_def invokeIRQHandler_def) apply (wp dmo_maskInterrupt) - apply (clarsimp simp add: invs'_def valid_state'_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) apply (wp cteInsert_invs)+ apply (strengthen ntfn_badge_derived_enough_strg isnt_irq_handler_strg safe_ioport_insert'_ntfn_strg) apply (wp cteDeleteOne_other_cap cteDeleteOne_other_cap[unfolded o_def]) @@ -586,14 +585,13 @@ lemma updateIRQState_invs'[wp]: apply (clarsimp simp: X64_H.updateIRQState_def) apply wp apply (fastforce simp: invs'_def valid_state'_def cur_tcb'_def - Invariants_H.valid_queues_def valid_queues'_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 valid_x64_irq_state'_def + bitmapQ_defs valid_x64_irq_state'_def valid_ioports'_def all_ioports_issued'_def issued_ioports'_def) done @@ -664,13 +662,6 @@ lemma decDomainTime_corres: apply (clarsimp simp:state_relation_def) done -lemma tcbSchedAppend_valid_objs': - "\valid_objs'\tcbSchedAppend t \\r. valid_objs'\" - apply (simp add:tcbSchedAppend_def) - apply (wpsimp wp: unless_wp threadSet_valid_objs' threadGet_wp) - apply (clarsimp simp add:obj_at'_def typ_at'_def) - done - lemma thread_state_case_if: "(case state of Structures_A.thread_state.Running \ f | _ \ g) = (if state = Structures_A.thread_state.Running then f else g)" @@ -681,26 +672,20 @@ lemma threadState_case_if: (if state = Structures_H.thread_state.Running then f else g)" by (case_tac state,auto) -lemma tcbSchedAppend_invs_but_ct_not_inQ': - "\invs' and st_tcb_at' runnable' t \ - tcbSchedAppend t \\_. all_invs_but_ct_not_inQ'\" - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp 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 - | fastforce elim!: st_tcb_ex_cap'' split: thread_state.split_asm)+ - done +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 timerTick_corres: - "corres dc (cur_tcb and valid_sched) + "corres dc (cur_tcb and valid_sched and pspace_aligned and pspace_distinct) invs' timer_tick timerTick" supply if_weak_cong[cong] apply (simp add: timerTick_def timer_tick_def) - apply (simp add:thread_state_case_if threadState_case_if) - apply (rule_tac Q="\ and (cur_tcb and valid_sched)" and Q'="\ and invs'" in corres_guard_imp) + 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 @@ -722,67 +707,67 @@ lemma timerTick_corres: apply (rule corres_split) apply (rule ethread_set_corres; simp) apply (simp add: etcb_relation_def) - apply (rule corres_split[OF tcbSchedAppend_corres]) + apply (rule corres_split[OF tcbSchedAppend_corres], simp) apply (rule rescheduleRequired_corres) - apply (wp)[1] - apply (rule hoare_strengthen_post) - apply (rule tcbSchedAppend_invs_but_ct_not_inQ', - clarsimp simp: sch_act_wf_weak) - apply (wp threadSet_timeslice_invs threadSet_valid_queues - threadSet_valid_queues' threadSet_pred_tcb_at_state)+ - apply simp - apply simp - apply (rule corres_when,simp) + 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 (simp add:dec_domain_time_def) - apply wp+ - apply (simp add:decDomainTime_def) - apply wp - apply (wp|wpc|unfold Let_def|simp)+ - apply (wp hoare_weak_lift_imp threadSet_timeslice_invs threadSet_valid_queues threadSet_valid_queues' - threadSet_pred_tcb_at_state threadSet_weak_sch_act_wf tcbSchedAppend_valid_objs' - rescheduleRequired_weak_sch_act_wf tcbSchedAppend_valid_queues| simp)+ - apply (strengthen sch_act_wf_weak) - apply (clarsimp simp:conj_comms) - apply (wp tcbSchedAppend_valid_queues tcbSchedAppend_sch_act_wf) - apply simp - apply (wp threadSet_valid_queues threadSet_pred_tcb_at_state threadSet_sch_act - threadSet_tcbDomain_triv threadSet_valid_queues' threadSet_valid_objs'| simp)+ - apply (wp threadGet_wp gts_wp gts_wp')+ - apply (clarsimp simp: cur_tcb_def tcb_at_is_etcb_at valid_sched_def valid_sched_action_def) - prefer 2 - apply clarsimp - apply (clarsimp simp add:cur_tcb_def valid_sched_def - valid_sched_action_def valid_etcbs_def is_tcb_def - is_etcb_at_def st_tcb_at_def obj_at_def - dest!:get_tcb_SomeD) - apply (clarsimp simp: invs'_def valid_state'_def - sch_act_wf_weak - cur_tcb'_def inQ_def - ct_in_state'_def obj_at'_def) - apply (clarsimp simp:st_tcb_at'_def - valid_idle'_def ct_idle_or_in_cur_domain'_def - obj_at'_def projectKO_eq) - apply simp + 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 + split_del: if_split)+ + 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) (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 (einvs) ?P' ?f ?g") - apply (simp add: handle_interrupt_def handleInterrupt_def ) + (is "corres dc ?P ?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. einvs" + where R="\rv. ?P" 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 )+ @@ -818,7 +803,7 @@ lemma handleInterrupt_corres: apply (rule corres_machine_op) apply (rule corres_eq_trivial, (simp add: no_fail_ackInterrupt)+) apply wp+ - apply clarsimp + apply fastforce apply clarsimp done @@ -841,52 +826,38 @@ lemma updateTimeSlice_valid_pspace[wp]: apply (auto simp:tcb_cte_cases_def) done -lemma updateTimeSlice_valid_queues[wp]: - "\\s. Invariants_H.valid_queues s \ - threadSet (tcbTimeSlice_update (\_. ts')) thread - \\r s. Invariants_H.valid_queues s\" - apply (wp threadSet_valid_queues,simp) - apply (clarsimp simp:obj_at'_def inQ_def) - done - - (* catch up tcbSchedAppend to tcbSchedEnqueue, which has these from crunches on possibleSwitchTo *) -crunch ifunsafe[wp]: tcbSchedAppend if_unsafe_then_cap' crunch irq_handlers'[wp]: tcbSchedAppend valid_irq_handlers' (simp: unless_def tcb_cte_cases_def wp: crunch_wps) -crunch irq_states'[wp]: tcbSchedAppend valid_irq_states' crunch irqs_masked'[wp]: tcbSchedAppend irqs_masked' (simp: unless_def wp: crunch_wps) crunch ct[wp]: tcbSchedAppend cur_tcb' (wp: cur_tcb_lift crunch_wps) -crunch cur_tcb'[wp]: tcbSchedAppend cur_tcb' - (simp: unless_def wp: crunch_wps) - lemma timerTick_invs'[wp]: - "\invs'\ timerTick \\rv. invs'\" + "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 - tcbSchedAppend_invs_but_ct_not_inQ' - simp: tcb_cte_cases_def) - apply (rule_tac Q="\rv. invs'" in hoare_post_imp) - apply (clarsimp simp add:invs'_def valid_state'_def) + 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' - del: tcbSchedAppend_sch_act_wf)+ - apply (rule hoare_strengthen_post[OF tcbSchedAppend_invs_but_ct_not_inQ']) - apply (wpsimp simp: valid_pspace'_def sch_act_wf_weak)+ - apply (wpsimp wp: threadSet_pred_tcb_no_state threadSet_tcbDomain_triv - threadSet_valid_objs' threadSet_timeslice_invs)+ - apply (wp threadGet_wp) + 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 (clarsimp simp: invs'_def st_tcb_at'_def obj_at'_def valid_state'_def) + apply (auto simp: invs'_def st_tcb_at'_def obj_at'_def valid_state'_def cong: conj_cong) done lemma resetTimer_invs'[wp]: diff --git a/proof/refine/X64/InvariantUpdates_H.thy b/proof/refine/X64/InvariantUpdates_H.thy index 25a95f3d15..1406c2ebba 100644 --- a/proof/refine/X64/InvariantUpdates_H.thy +++ b/proof/refine/X64/InvariantUpdates_H.thy @@ -38,8 +38,9 @@ lemma invs'_machine: proof - show ?thesis apply (cases "ksSchedulerAction s") - 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_queues_def valid_queues_no_bitmap_def bitmapQ_defs + 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 @@ -56,12 +57,13 @@ lemma invs_no_cicd'_machine: 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_queues_def valid_queues_no_bitmap_def bitmapQ_defs - vms ct_not_inQ_def - state_refs_of'_def ps_clear_def - valid_irq_node'_def mask - cong: option.case_cong) + 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) done qed @@ -98,14 +100,9 @@ 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_queues_ksSchedulerAction_update[simp]: - "valid_queues (ksSchedulerAction_update f s) = valid_queues s" - unfolding valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs - by simp - -lemma valid_queues'_ksSchedulerAction_update[simp]: - "valid_queues' (ksSchedulerAction_update f s) = valid_queues' s" - by (simp add: valid_queues'_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'" @@ -140,45 +137,25 @@ lemma tcb_in_cur_domain_ct[simp]: "tcb_in_cur_domain' t (ksCurThread_update f s) = tcb_in_cur_domain' t s" by (fastforce simp: tcb_in_cur_domain'_def) -lemma valid_queues'_ksCurDomain[simp]: - "valid_queues' (ksCurDomain_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) - -lemma valid_queues'_ksDomScheduleIdx[simp]: - "valid_queues' (ksDomScheduleIdx_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) +lemma valid_bitmaps_ksCurDomain[simp]: + "valid_bitmaps (ksCurDomain_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) -lemma valid_queues'_ksDomSchedule[simp]: - "valid_queues' (ksDomSchedule_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) +lemma valid_bitmaps_ksDomScheduleIdx[simp]: + "valid_bitmaps (ksDomScheduleIdx_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) -lemma valid_queues'_ksDomainTime[simp]: - "valid_queues' (ksDomainTime_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) +lemma valid_bitmaps_ksDomSchedule[simp]: + "valid_bitmaps (ksDomSchedule_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) -lemma valid_queues'_ksWorkUnitsCompleted[simp]: - "valid_queues' (ksWorkUnitsCompleted_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) +lemma valid_bitmaps_ksDomainTime[simp]: + "valid_bitmaps (ksDomainTime_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) -lemma valid_queues_ksCurDomain[simp]: - "valid_queues (ksCurDomain_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_ksDomScheduleIdx[simp]: - "valid_queues (ksDomScheduleIdx_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_ksDomSchedule[simp]: - "valid_queues (ksDomSchedule_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_ksDomainTime[simp]: - "valid_queues (ksDomainTime_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_ksWorkUnitsCompleted[simp]: - "valid_queues (ksWorkUnitsCompleted_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) +lemma valid_bitmaps_ksWorkUnitsCompleted[simp]: + "valid_bitmaps (ksWorkUnitsCompleted_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) lemma valid_irq_node'_ksCurDomain[simp]: "valid_irq_node' w (ksCurDomain_update f s) = valid_irq_node' w s" @@ -255,6 +232,10 @@ lemma valid_mdb_interrupts'[simp]: "valid_mdb' (ksInterruptState_update f s) = valid_mdb' s" by (simp add: valid_mdb'_def) +lemma valid_mdb'_ksReadyQueues_update[simp]: + "valid_mdb' (ksReadyQueues_update f s) = valid_mdb' s" + by (simp add: valid_mdb'_def) + lemma vms_ksReadyQueues_update[simp]: "valid_machine_state' (ksReadyQueues_update f s) = valid_machine_state' s" by (simp add: valid_machine_state'_def) @@ -279,10 +260,10 @@ lemma ct_in_state_ksSched[simp]: lemma invs'_wu [simp]: "invs' (ksWorkUnitsCompleted_update f s) = invs' s" - apply (simp add: invs'_def cur_tcb'_def valid_state'_def Invariants_H.valid_queues_def - valid_queues'_def valid_irq_node'_def valid_machine_state'_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 valid_queues_no_bitmap_def) + bitmapQ_defs) done lemma valid_arch_state'_interrupt[simp]: @@ -342,9 +323,8 @@ lemma sch_act_simple_ksReadyQueuesL2Bitmap[simp]: lemma ksDomainTime_invs[simp]: "invs' (ksDomainTime_update f s) = invs' s" - 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) + 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" @@ -372,9 +352,7 @@ lemma ct_not_inQ_update_stt[simp]: lemma invs'_update_cnt[elim!]: "invs' s \ invs' (s\ksSchedulerAction := ChooseNewThread\)" - by (clarsimp simp: invs'_def valid_state'_def valid_queues_def valid_queues'_def - valid_irq_node'_def cur_tcb'_def ct_idle_or_in_cur_domain'_def - tcb_in_cur_domain'_def valid_queues_no_bitmap_def - bitmapQ_no_L2_orphans_def bitmapQ_no_L1_orphans_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 \ No newline at end of file diff --git a/proof/refine/X64/Invariants_H.thy b/proof/refine/X64/Invariants_H.thy index 98aa8e5f17..892e995337 100644 --- a/proof/refine/X64/Invariants_H.thy +++ b/proof/refine/X64/Invariants_H.thy @@ -10,6 +10,7 @@ imports "AInvs.Deterministic_AI" "AInvs.AInvs" "Lib.AddUpdSimps" + "Lib.Heap_List" begin context Arch begin @@ -88,6 +89,21 @@ abbreviation abbreviation "ko_at' v \ obj_at' (\k. k = v)" +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 tcbSchedPrevs_of :: "kernel_state \ obj_ref \ obj_ref option" where + "tcbSchedPrevs_of s \ tcbs_of' s |> tcbSchedPrev" + +abbreviation tcbSchedNexts_of :: "kernel_state \ obj_ref \ obj_ref option" where + "tcbSchedNexts_of s \ tcbs_of' s |> tcbSchedNext" + +abbreviation sym_heap_sched_pointers :: "global.kernel_state \ bool" where + "sym_heap_sched_pointers s \ sym_heap (tcbSchedNexts_of s) (tcbSchedPrevs_of s)" + abbreviation "pde_at' \ typ_at' (ArchT PDET)" abbreviation @@ -236,16 +252,17 @@ where then refs_of' ko else {}))" - primrec live' :: "Structures_H.kernel_object \ bool" where "live' (KOTCB tcb) = - (bound (tcbBoundNotification 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) = (bound (ntfnBoundTCB ntfn) \ (\ts. ntfnObj ntfn = WaitingNtfn ts))" +| "live' (KONotification ntfn) = (bound (ntfnBoundTCB ntfn) \ (\ts. ntfnObj ntfn = WaitingNtfn ts))" | "live' (KOUserData) = False" | "live' (KOUserDataDevice) = False" | "live' (KOKernelData) = False" @@ -505,6 +522,11 @@ 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' :: "Structures_H.tcb \ kernel_state \ bool" where @@ -514,7 +536,9 @@ where \ valid_bound_ntfn' (tcbBoundNotification t) s \ tcbDomain t \ maxDomain \ tcbPriority t \ maxPriority - \ tcbMCP 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" @@ -524,7 +548,6 @@ where | Structures_H.SendEP ts \ (ts \ [] \ (\t \ set ts. tcb_at' t s) \ distinct ts) | Structures_H.RecvEP ts \ (ts \ [] \ (\t \ set ts. tcb_at' t s) \ distinct ts)" - definition valid_bound_tcb' :: "machine_word option \ kernel_state \ bool" where @@ -921,10 +944,15 @@ where | "runnable' (Structures_H.BlockedOnSend a b c d e) = False" | "runnable' (Structures_H.BlockedOnNotification x) = False" -definition - inQ :: "domain \ priority \ tcb \ bool" -where - "inQ d p tcb \ tcbQueued tcb \ tcbPriority tcb = p \ tcbDomain tcb = d" +definition inQ :: "domain \ priority \ tcb \ bool" where + "inQ d p tcb \ tcbQueued tcb \ tcbPriority tcb = p \ tcbDomain tcb = d" + +lemma inQ_implies_tcbQueueds_of: + "(inQ domain priority |< tcbs_of' s') tcbPtr \ (tcbQueued |< tcbs_of' s') tcbPtr" + by (clarsimp simp: opt_map_def opt_pred_def inQ_def split: option.splits) + +defs ready_qs_runnable_def: + "ready_qs_runnable s \ \t. obj_at' tcbQueued t s \ st_tcb_at' runnable' t s" definition (* for given domain and priority, the scheduler bitmap indicates a thread is in the queue *) @@ -934,15 +962,6 @@ where "bitmapQ d p s \ ksReadyQueuesL1Bitmap s d !! prioToL1Index p \ ksReadyQueuesL2Bitmap s (d, invertL1Index (prioToL1Index p)) !! unat (p && mask wordRadix)" - -definition - valid_queues_no_bitmap :: "kernel_state \ bool" -where - "valid_queues_no_bitmap \ \s. - (\d p. (\t \ set (ksReadyQueues s (d, p)). obj_at' (inQ d p and runnable' \ tcbState) t s) - \ distinct (ksReadyQueues s (d, p)) - \ (d > maxDomain \ p > maxPriority \ ksReadyQueues s (d,p) = []))" - 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 @@ -966,31 +985,62 @@ where \d i. ksReadyQueuesL1Bitmap s d !! i \ ksReadyQueuesL2Bitmap s (d, invertL1Index i) \ 0 \ i < l2BitmapSize" -definition - valid_bitmapQ :: "kernel_state \ bool" -where - "valid_bitmapQ \ \s. (\d p. bitmapQ d p s \ ksReadyQueues s (d,p) \ [])" +definition valid_bitmapQ :: "kernel_state \ bool" where + "valid_bitmapQ \ \s. \d p. bitmapQ d p s \ \ tcbQueueEmpty (ksReadyQueues s (d,p))" -definition - valid_queues :: "kernel_state \ bool" -where - "valid_queues \ \s. valid_queues_no_bitmap s \ valid_bitmapQ s \ - bitmapQ_no_L2_orphans s \ bitmapQ_no_L1_orphans s" +definition valid_bitmaps :: "kernel_state \ bool" where + "valid_bitmaps \ \s. valid_bitmapQ s \ bitmapQ_no_L2_orphans s \ bitmapQ_no_L1_orphans s" -definition - (* when a thread gets added to / removed from a queue, but before bitmap updated *) - valid_bitmapQ_except :: "domain \ priority \ kernel_state \ bool" -where +lemma valid_bitmaps_valid_bitmapQ[elim!]: + "valid_bitmaps s \ valid_bitmapQ s" + by (simp add: valid_bitmaps_def) + +lemma valid_bitmaps_bitmapQ_no_L2_orphans[elim!]: + "valid_bitmaps s \ bitmapQ_no_L2_orphans s" + by (simp add: valid_bitmaps_def) + +lemma valid_bitmaps_bitmapQ_no_L1_orphans[elim!]: + "valid_bitmaps s \ bitmapQ_no_L1_orphans s" + by (simp add: valid_bitmaps_def) + +lemma valid_bitmaps_lift: + assumes prq: "\P. f \\s. P (ksReadyQueues s)\" + assumes prqL1: "\P. f \\s. P (ksReadyQueuesL1Bitmap s)\" + assumes prqL2: "\P. f \\s. P (ksReadyQueuesL2Bitmap s)\" + shows "f \valid_bitmaps\" + unfolding valid_bitmaps_def valid_bitmapQ_def bitmapQ_def + bitmapQ_no_L1_orphans_def bitmapQ_no_L2_orphans_def + apply (rule hoare_pre) + apply (wps assms | wpsimp)+ + done + +(* when a thread gets added to / removed from a queue, but before bitmap updated *) +definition valid_bitmapQ_except :: "domain \ priority \ kernel_state \ bool" where "valid_bitmapQ_except d' p' \ \s. - (\d p. (d \ d' \ p \ p') \ (bitmapQ d p s \ ksReadyQueues s (d,p) \ []))" + \d p. (d \ d' \ p \ p') \ (bitmapQ d p s \ \ tcbQueueEmpty (ksReadyQueues s (d,p)))" lemmas bitmapQ_defs = valid_bitmapQ_def valid_bitmapQ_except_def bitmapQ_def bitmapQ_no_L2_orphans_def bitmapQ_no_L1_orphans_def -definition - valid_queues' :: "kernel_state \ bool" -where - "valid_queues' \ \s. \d p t. obj_at' (inQ d p) t s \ t \ set (ksReadyQueues s (d, p))" +\ \ + The tcbSchedPrev and tcbSchedNext fields of a TCB are used only to indicate membership in + one of the ready queues. \ +definition valid_sched_pointers_2 :: + "(obj_ref \ obj_ref) \ (obj_ref \ obj_ref) \ (obj_ref \ bool) \ bool " + where + "valid_sched_pointers_2 prevs nexts ready \ + \ptr. prevs ptr \ None \ nexts ptr \ None \ ready ptr" + +abbreviation valid_sched_pointers :: "kernel_state \ bool" where + "valid_sched_pointers s \ + valid_sched_pointers_2 (tcbSchedPrevs_of s) (tcbSchedNexts_of s) (tcbQueued |< tcbs_of' s)" + +lemmas valid_sched_pointers_def = valid_sched_pointers_2_def + +lemma valid_sched_pointersD: + "\valid_sched_pointers s; \ (tcbQueued |< tcbs_of' s) t\ + \ tcbSchedPrevs_of s t = None \ tcbSchedNexts_of s t = None" + by (fastforce simp: valid_sched_pointers_def in_opt_pred opt_map_red) definition tcb_in_cur_domain' :: "machine_word \ kernel_state \ bool" where "tcb_in_cur_domain' t \ \s. obj_at' (\tcb. ksCurDomain s = tcbDomain tcb) t s" @@ -1231,7 +1281,7 @@ definition valid_state' :: "kernel_state \ bool" where "valid_state' \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s - \ valid_queues s \ sym_refs (state_refs_of' 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 @@ -1241,7 +1291,9 @@ where \ valid_machine_state' s \ irqs_masked' s \ valid_ioports' s - \ valid_queues' s + \ sym_heap_sched_pointers s + \ valid_sched_pointers s + \ valid_bitmaps s \ ct_not_inQ s \ ct_idle_or_in_cur_domain' s \ pspace_domain_valid s @@ -1294,6 +1346,11 @@ definition abbreviation "active' st \ st = Structures_H.Running \ st = Structures_H.Restart" +lemma runnable_eq_active': "runnable' = active'" + apply (rule ext) + apply (case_tac st, simp_all) + done + abbreviation "simple' st \ st = Structures_H.Inactive \ st = Structures_H.Running \ @@ -1309,11 +1366,14 @@ abbreviation abbreviation(input) "all_invs_but_sym_refs_ct_not_inQ' \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s - \ valid_queues s \ if_live_then_nonz_cap' s \ if_unsafe_then_cap' 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 - \ cur_tcb' s \ valid_queues' s \ ct_idle_or_in_cur_domain' s + \ valid_irq_states' s \ irqs_masked' s + \ sym_heap_sched_pointers s \ valid_sched_pointers s \ valid_bitmaps s + \ valid_machine_state' s + \ cur_tcb' s \ ct_idle_or_in_cur_domain' s + \ cur_tcb' s \ ct_idle_or_in_cur_domain' s \ pspace_domain_valid s \ valid_ioports' s \ ksCurDomain s \ maxDomain \ valid_dom_schedule' s \ untyped_ranges_zero' s" @@ -1321,12 +1381,14 @@ abbreviation(input) abbreviation(input) "all_invs_but_ct_not_inQ' \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s - \ valid_queues s \ sym_refs (state_refs_of' 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 - \ cur_tcb' s \ valid_queues' s \ ct_idle_or_in_cur_domain' s + \ valid_irq_states' s \ irqs_masked' s + \ sym_heap_sched_pointers s \ valid_sched_pointers s \ valid_bitmaps s + \ valid_machine_state' s + \ cur_tcb' s \ ct_idle_or_in_cur_domain' s \ pspace_domain_valid s \ valid_ioports' s \ ksCurDomain s \ maxDomain \ valid_dom_schedule' s \ untyped_ranges_zero' s" @@ -1342,12 +1404,14 @@ lemma all_invs_but_not_ct_inQ_check': definition "all_invs_but_ct_idle_or_in_cur_domain' \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s - \ valid_queues s \ sym_refs (state_refs_of' 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 - \ cur_tcb' s \ valid_queues' s \ ct_not_inQ s + \ valid_irq_states' s \ irqs_masked' s + \ sym_heap_sched_pointers s \ valid_sched_pointers s \ valid_bitmaps s + \ valid_machine_state' s + \ cur_tcb' s \ ct_not_inQ s \ pspace_domain_valid s \ valid_ioports' s \ ksCurDomain s \ maxDomain \ valid_dom_schedule' s \ untyped_ranges_zero' s" @@ -1424,6 +1488,10 @@ lemma valid_bound_tcb'_Some[simp]: "valid_bound_tcb' (Some x) = tcb_at' x" by (auto simp: valid_bound_tcb'_def) +lemma objBitsKO_Data: + "objBitsKO (if dev then KOUserDataDevice else KOUserData) = pageBits" + by (simp add: objBits_def objBitsKO_def word_size_def) + lemmas objBits_defs = tcbBlockSizeBits_def epSizeBits_def ntfnSizeBits_def cteSizeBits_def lemmas untypedBits_defs = minUntypedSizeBits_def maxUntypedSizeBits_def lemmas objBits_simps = objBits_def objBitsKO_def word_size_def @@ -2510,7 +2578,7 @@ lemma typ_at_lift_valid_cap': apply (case_tac arch_capability, simp_all add: P[where P=id, simplified] vspace_table_at'_defs hoare_vcg_prop All_less_Ball - split del: if_splits) + split del: if_split) apply (wp hoare_vcg_const_Ball_lift P typ_at_lift_valid_untyped' hoare_vcg_all_lift typ_at_lift_cte')+ done @@ -3141,9 +3209,9 @@ lemma sch_act_wf_arch [simp]: "sch_act_wf sa (ksArchState_update f s) = sch_act_wf sa s" by (cases sa) (simp_all add: ct_in_state'_def tcb_in_cur_domain'_def) -lemma valid_queues_arch [simp]: - "valid_queues (ksArchState_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) +lemma valid_bitmaps_arch[simp]: + "valid_bitmaps (ksArchState_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) lemma if_unsafe_then_cap_arch' [simp]: "if_unsafe_then_cap' (ksArchState_update f s) = if_unsafe_then_cap' s" @@ -3161,22 +3229,14 @@ lemma sch_act_wf_machine_state [simp]: "sch_act_wf sa (ksMachineState_update f s) = sch_act_wf sa s" by (cases sa) (simp_all add: ct_in_state'_def tcb_in_cur_domain'_def) -lemma valid_queues_machine_state [simp]: - "valid_queues (ksMachineState_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - -lemma valid_queues_arch' [simp]: - "valid_queues' (ksArchState_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) - -lemma valid_queues_machine_state' [simp]: - "valid_queues' (ksMachineState_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) - lemma valid_irq_node'_machine_state [simp]: "valid_irq_node' x (ksMachineState_update f s) = valid_irq_node' x s" by (simp add: valid_irq_node'_def) +lemma valid_bitmaps_machine_state[simp]: + "valid_bitmaps (ksMachineState_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) + (* these should be reasonable safe for automation because of the 0 pattern *) lemma no_0_ko_wp' [elim!]: "\ ko_wp_at' Q 0 s; no_0_obj' s \ \ P" @@ -3256,19 +3316,6 @@ lemma typ_at_aligned': "\ typ_at' tp p s \ \ is_aligned p (objBitsT tp)" by (clarsimp simp add: typ_at'_def ko_wp_at'_def objBitsT_koTypeOf) -lemma valid_queues_obj_at'D: - "\ t \ set (ksReadyQueues s (d, p)); valid_queues s \ - \ obj_at' (inQ d p) t s" - apply (unfold valid_queues_def valid_queues_no_bitmap_def) - apply (elim conjE) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE) - apply (clarsimp) - done - lemma obj_at'_and: "obj_at' (P and P') t s = (obj_at' P t s \ obj_at' P' t s)" by (rule iffI, (clarsimp simp: obj_at'_def)+) @@ -3310,21 +3357,6 @@ lemma obj_at'_ko_at'_prop: "ko_at' ko t s \ obj_at' P t s = P ko" by (drule obj_at_ko_at', clarsimp simp: obj_at'_def) -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 \ st_tcb_at' runnable' t s) \ - distinct (ksReadyQueues s (d, p)) \ (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_queues_running: - assumes Q: "t \ set(ksReadyQueues s (d, p))" "valid_queues s" - shows "st_tcb_at' runnable' t s" - using assms by (clarsimp simp add: valid_queues_def valid_queues_no_bitmap_def') - 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) @@ -3409,8 +3441,16 @@ lemma invs_sch_act_wf' [elim!]: "invs' s \ sch_act_wf (ksSchedulerAction s) s" by (simp add: invs'_def valid_state'_def) -lemma invs_queues [elim!]: - "invs' s \ valid_queues s" +lemma invs_valid_bitmaps[elim!]: + "invs' s \ valid_bitmaps s" + by (simp add: invs'_def valid_state'_def) + +lemma invs_sym_heap_sched_pointers[elim!]: + "invs' s \ sym_heap_sched_pointers s" + by (simp add: invs'_def valid_state'_def) + +lemma invs_valid_sched_pointers[elim!]: + "invs' s \ valid_sched_pointers s" by (simp add: invs'_def valid_state'_def) lemma invs_valid_idle'[elim!]: @@ -3427,7 +3467,7 @@ lemma invs'_invs_no_cicd: lemma invs'_bitmapQ_no_L1_orphans: "invs' s \ bitmapQ_no_L1_orphans s" - by (drule invs_queues, simp add: valid_queues_def) + by (simp add: invs'_def valid_state'_def valid_bitmaps_def) lemma invs_ksCurDomain_maxDomain' [elim!]: "invs' s \ ksCurDomain s \ maxDomain" @@ -3452,34 +3492,24 @@ lemma invs_no_0_obj'[elim!]: lemma invs'_gsCNodes_update[simp]: "invs' (gsCNodes_update f s') = invs' s'" - apply (clarsimp simp: invs'_def valid_state'_def valid_queues_def valid_queues_no_bitmap_def - bitmapQ_defs - valid_queues'_def valid_irq_node'_def valid_irq_handlers'_def valid_ioports'_def - irq_issued'_def irqs_masked'_def valid_machine_state'_def - cur_tcb'_def) - apply (cases "ksSchedulerAction s'") - apply (simp_all add: ct_in_state'_def tcb_in_cur_domain'_def ct_idle_or_in_cur_domain'_def ct_not_inQ_def) + apply (clarsimp simp: invs'_def valid_state'_def valid_bitmaps_def bitmapQ_defs valid_ioports'_def + 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_state'_def valid_queues_def valid_queues_no_bitmap_def - bitmapQ_defs - valid_queues'_def valid_irq_node'_def valid_irq_handlers'_def valid_ioports'_def - irq_issued'_def irqs_masked'_def valid_machine_state'_def - cur_tcb'_def) - apply (cases "ksSchedulerAction s'") - apply (simp_all add: ct_in_state'_def ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def ct_not_inQ_def) + apply (clarsimp simp: invs'_def valid_state'_def valid_bitmaps_def bitmapQ_defs valid_ioports'_def + 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_queues_tcb_in_cur_domain': - "\ ksReadyQueues s (d, p) = x # xs; invs' s; d = ksCurDomain s\ - \ tcb_in_cur_domain' x s" -apply (subgoal_tac "x \ set (ksReadyQueues s (d, p))") - apply (drule (1) valid_queues_obj_at'D[OF _ invs_queues]) - apply (auto simp: inQ_def tcb_in_cur_domain'_def elim: obj_at'_weakenE) -done - lemma pred_tcb'_neq_contra: "\ pred_tcb_at' proj P p s; pred_tcb_at' proj Q p s; \st. P st \ Q st \ \ False" by (clarsimp simp: pred_tcb_at'_def obj_at'_def) @@ -3493,7 +3523,7 @@ lemma invs'_ksDomScheduleIdx: unfolding invs'_def valid_state'_def by clarsimp lemma valid_bitmap_valid_bitmapQ_exceptE: - "\ valid_bitmapQ_except d p s ; (bitmapQ d p s \ ksReadyQueues s (d,p) \ []) ; + "\ valid_bitmapQ_except d p s; bitmapQ d p s \ \ tcbQueueEmpty (ksReadyQueues s (d,p)); bitmapQ_no_L2_orphans s \ \ valid_bitmapQ s" unfolding valid_bitmapQ_def valid_bitmapQ_except_def diff --git a/proof/refine/X64/IpcCancel_R.thy b/proof/refine/X64/IpcCancel_R.thy index 8894a18267..1bc48323ba 100644 --- a/proof/refine/X64/IpcCancel_R.thy +++ b/proof/refine/X64/IpcCancel_R.thy @@ -48,25 +48,6 @@ lemma set_ep_pred_tcb_at' [wp]: apply (simp add: updateObject_default_def in_monad projectKOs) done -(* valid_queues is too strong *) -definition valid_inQ_queues :: "KernelStateData_H.kernel_state \ bool" where - "valid_inQ_queues \ - \s. \d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) \ distinct (ksReadyQueues s (d, p))" - -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_inQ_queues_ksReadyQueuesL1Bitmap_upd[simp]: - "valid_inQ_queues (ksReadyQueuesL1Bitmap_update f s) = valid_inQ_queues s" - unfolding valid_inQ_queues_def - by simp - -lemma valid_inQ_queues_ksReadyQueuesL2Bitmap_upd[simp]: - "valid_inQ_queues (ksReadyQueuesL2Bitmap_update f s) = valid_inQ_queues s" - unfolding valid_inQ_queues_def - by simp - defs capHasProperty_def: "capHasProperty ptr P \ cte_wp_at' (\c. P (cteCap c)) ptr" end @@ -83,11 +64,6 @@ locale delete_one_conc_pre = "\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_queues: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - cteDeleteOne sl \\rv. Invariants_H.valid_queues\" - assumes delete_one_inQ_queues: - "\valid_inQ_queues\ cteDeleteOne sl \\rv. valid_inQ_queues\" assumes delete_one_sch_act_simple: "\sch_act_simple\ cteDeleteOne sl \\rv. sch_act_simple\" assumes delete_one_sch_act_not: @@ -343,6 +319,7 @@ lemma cancelSignal_corres: apply fastforce apply (clarsimp simp: valid_obj_def valid_tcb_def valid_tcb_state_def) apply (drule sym, simp add: obj_at_def) + apply fastforce apply (clarsimp simp: conj_comms pred_tcb_at' cong: conj_cong) apply (rule conjI) apply (simp add: pred_tcb_at'_def) @@ -547,12 +524,12 @@ lemma (in delete_one) cancelIPC_ReplyCap_corres: and Q'="\_. invs' and st_tcb_at' awaiting_reply' t" in corres_underlying_split) apply (rule corres_guard_imp) - apply (rule threadset_corresT) + 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: tcb_cte_cases_def cteSizeBits_def) apply (simp add: exst_same_def) - apply (clarsimp simp: st_tcb_at_tcb_at) + apply (fastforce simp: st_tcb_at_tcb_at) apply clarsimp defer apply (wp thread_set_invs_trivial thread_set_no_change_tcb_state @@ -609,7 +586,7 @@ lemma (in delete_one) cancelIPC_ReplyCap_corres: qed lemma (in delete_one) cancel_ipc_corres: - "corres dc (einvs and tcb_at t) (invs' and tcb_at' t) + "corres dc (einvs and tcb_at t) invs' (cancel_ipc t) (cancelIPC t)" apply (simp add: cancel_ipc_def cancelIPC_def Let_def) apply (rule corres_guard_imp) @@ -639,7 +616,7 @@ lemma (in delete_one) cancel_ipc_corres: apply (rule hoare_strengthen_post) apply (rule gts_sp'[where P="\"]) apply (clarsimp elim!: pred_tcb'_weakenE) - apply simp + apply fastforce apply simp done @@ -663,24 +640,20 @@ lemma setEndpoint_utr[wp]: declare cart_singleton_empty [simp] declare cart_singleton_empty2[simp] -crunch ksQ[wp]: setNotification "\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*) +crunches setNotification + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_bitmaps[wp]: valid_bitmaps + (wp: valid_bitmaps_lift) + lemma cancelSignal_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. \ Invariants_H.valid_queues s; st_tcb_at' (Not \ runnable') t s \ - \ \x. t \ set (ksReadyQueues s x)" - 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\" @@ -691,9 +664,9 @@ lemma cancelSignal_invs': show ?thesis 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 setNotification_ksQ] sts_valid_queues + hoare_vcg_all_lift setThreadState_ct_not_inQ NTFNSN - hoare_vcg_all_lift setNotification_ksQ + hoare_vcg_all_lift | simp add: valid_tcb_state'_def list_case_If split del: if_split)+ prefer 2 apply assumption @@ -701,8 +674,6 @@ lemma cancelSignal_invs': apply (rule get_ntfn_sp') apply (rename_tac rv s) apply (clarsimp simp: pred_tcb_at') - apply (frule NIQ) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) apply (rule conjI) apply (clarsimp simp: valid_ntfn'_def) apply (case_tac "ntfnObj rv", simp_all add: isWaitingNtfn_def) @@ -742,9 +713,10 @@ lemma cancelSignal_invs': 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 r") + 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) @@ -802,23 +774,25 @@ lemma setEndpoint_ct_not_inQ[wp]: done lemma setEndpoint_ksDomScheduleIdx[wp]: - "\\s. P (ksDomScheduleIdx s)\ setEndpoint ptr ep \\_ s. P (ksDomScheduleIdx s)\" + "setEndpoint ptr ep \\s. P (ksDomScheduleIdx s)\" apply (simp add: setEndpoint_def setObject_def split_def) apply (wp updateObject_default_inv | simp)+ done + end +crunches 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 NIQ: "\s. \ Invariants_H.valid_queues s; st_tcb_at' (Not \ runnable') t s \ - \ \x. t \ set (ksReadyQueues s x)" - 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 EPSCHN: "\eeptr ep'. \\s. sch_act_not (ksCurThread s) s\ setEndpoint eeptr ep' \\_ s. sch_act_not (ksCurThread s) s\" @@ -843,8 +817,8 @@ proof - 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] - sts_valid_queues setThreadState_ct_not_inQ EPSCHN - hoare_vcg_all_lift setNotification_ksQ + setThreadState_ct_not_inQ EPSCHN + hoare_vcg_all_lift | simp add: valid_tcb_state'_def split del: if_split | wpc)+ prefer 2 @@ -852,14 +826,14 @@ proof - 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 (frule NIQ) - apply (erule pred_tcb'_weakenE, fastforce) apply (clarsimp, rule conjI) apply (auto simp: pred_tcb_at'_def obj_at'_def)[1] apply (rule conjI) @@ -1040,37 +1014,12 @@ crunch ksCurDomain[wp]: cancelSignal "\s. P (ksCurDomain s)" 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 tcbSchedEnqueue_not_st: - "(\tcb st qd. P (tcb\tcbState := st, tcbQueued := qd\) \ P tcb) - \ \obj_at' P t'\ tcbSchedEnqueue t \\_. obj_at' P t'\" -apply (simp add: tcbSchedEnqueue_def unless_def) -apply (wp threadGet_wp | simp)+ -apply (clarsimp simp: obj_at'_def) -apply (case_tac obja) -apply fastforce -done - -(* FIXME move *) -lemma setThreadState_not_st: - "(\tcb st qd. P (tcb\tcbState := st, tcbQueued := qd\) \ P tcb) - \ \obj_at' P t'\ setThreadState st t \\_. obj_at' P t'\" -apply (simp add: setThreadState_def rescheduleRequired_def) -apply (wp hoare_vcg_conj_lift tcbSchedEnqueue_not_st - | wpc - | rule hoare_drop_imps - | simp)+ -apply (clarsimp simp: obj_at'_def) -apply (case_tac obj) -apply fastforce -done + 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: @@ -1083,15 +1032,6 @@ lemma setBoundNotification_not_ntfn: | simp)+ done -(* FIXME move *) -lemma setThreadState_tcb_in_cur_domain'[wp]: - "\tcb_in_cur_domain' t'\ setThreadState st t \\_. tcb_in_cur_domain' t'\" -apply (simp add: tcb_in_cur_domain'_def) -apply (rule hoare_pre) -apply wps -apply (wp setThreadState_not_st | simp)+ -done - 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) @@ -1100,22 +1040,24 @@ lemma setBoundNotification_tcb_in_cur_domain'[wp]: apply (wp setBoundNotification_not_ntfn | simp)+ done -lemma cancelSignal_tcb_obj_at': - "(\tcb st qd. P (tcb\tcbState := st, tcbQueued := qd\) \ P tcb) - \ \obj_at' P t'\ cancelSignal t word \\_. obj_at' P t'\" -apply (simp add: cancelSignal_def setNotification_def) -apply (wp setThreadState_not_st getNotification_wp | wpc | simp)+ -done +lemma setThreadState_tcbDomain_obj_at'[wp]: + "setThreadState ts t \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding setThreadState_def + by wpsimp + +crunches 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 (simp add: cancelIPC_def Let_def) -apply (wp hoare_vcg_conj_lift - setThreadState_not_st delete_one_tcbDomain_obj_at' cancelSignal_tcb_obj_at' - | wpc - | rule hoare_drop_imps - | simp add: getThreadReplySlot_def o_def if_fun_split)+ -done + 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': "\tcb_in_cur_domain' t'\ cancelIPC t \\_. tcb_in_cur_domain' t'\" @@ -1218,191 +1160,61 @@ lemma setNotification_weak_sch_act_wf[wp]: lemmas ipccancel_weak_sch_act_wfs = weak_sch_act_wf_lift[OF _ setCTE_pred_tcb_at'] -lemma tcbSchedDequeue_corres': - "corres dc (is_etcb_at t) (tcb_at' t and valid_inQ_queues) (tcb_sched_action (tcb_sched_dequeue) t) (tcbSchedDequeue t)" - apply (simp only: tcbSchedDequeue_def tcb_sched_action_def) - apply (rule corres_symb_exec_r[OF _ _ threadGet_inv, where Q'="\rv. tcb_at' t and valid_inQ_queues and obj_at' (\obj. tcbQueued obj = rv) t"]) - defer - apply (wp threadGet_obj_at', simp, simp) - apply (wp, simp) - apply (case_tac queued) - defer - apply (simp add: unless_def when_def) - apply (rule corres_no_failI) - apply (wp) - apply (clarsimp simp: in_monad ethread_get_def get_etcb_def set_tcb_queue_def is_etcb_at_def state_relation_def gets_the_def gets_def get_def return_def bind_def assert_opt_def get_tcb_queue_def modify_def put_def) - apply (subgoal_tac "t \ set (ready_queues a (tcb_domain y) (tcb_priority y))") - prefer 2 - apply (force simp: tcb_sched_dequeue_def valid_inQ_queues_def - ready_queues_relation_def obj_at'_def inQ_def projectKO_eq project_inject) - apply (simp add: ready_queues_relation_def) - apply (simp add: unless_def when_def) - apply (rule corres_guard_imp) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres, simp add: etcb_relation_def) - apply (simp split del: if_split) - apply (rule corres_split_eqr) - apply (rule ethreadget_corres, simp add: etcb_relation_def) - apply (rule corres_split_eqr[OF getQueue_corres]) - apply (simp split del: if_split) - apply (subst bind_return_unit, rule corres_split[where r'=dc]) - apply (simp add: tcb_sched_dequeue_def) - apply (rule setQueue_corres) - apply (rule corres_split_noop_rhs) - apply (clarsimp, rule removeFromBitmap_corres_noop) - apply (simp add: dc_def[symmetric]) - apply (rule threadSet_corres_noop, simp_all add: tcb_relation_def exst_same_def)[1] - apply (wp | simp)+ - done - -lemma setQueue_valid_inQ_queues: - "\valid_inQ_queues - and (\s. \t \ set ts. obj_at' (inQ d p) t s) - and K (distinct ts)\ - setQueue d p ts - \\_. valid_inQ_queues\" - apply (simp add: setQueue_def valid_inQ_queues_def) - apply wp - apply clarsimp - done - -lemma threadSet_valid_inQ_queues: - "\valid_inQ_queues and (\s. \d p. (\tcb. (inQ d p tcb) \ \(inQ d p (f tcb))) - \ obj_at' (\tcb. (inQ d p tcb) \ \(inQ d p (f tcb))) t s - \ t \ set (ksReadyQueues s (d, p)))\ - threadSet f t - \\rv. valid_inQ_queues\" - apply (simp add: threadSet_def) - apply wp - apply (simp add: valid_inQ_queues_def pred_tcb_at'_def) - apply (wp setObject_queues_unchanged_tcb - hoare_Ball_helper - hoare_vcg_all_lift - setObject_tcb_strongest)[1] - apply (wp getObject_tcb_wp) - apply (clarsimp simp: valid_inQ_queues_def pred_tcb_at'_def) - apply (clarsimp simp: obj_at'_def projectKOs) - apply (fastforce) - done - -(* reorder the threadSet before the setQueue, useful for lemmas that don't refer to bitmap *) -lemma setQueue_after_addToBitmap: - "(setQueue d p q >>= (\rv. (when P (addToBitmap d p)) >>= (\rv. threadSet f t))) = - (when P (addToBitmap d p) >>= (\rv. (threadSet f t) >>= (\rv. setQueue d p q)))" - 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 (simp add: threadSet_def getObject_def setObject_def - loadObject_default_def bitmap_fun_defs - split_def projectKO_def2 alignCheck_assert - magnitudeCheck_assert updateObject_default_def) - apply (intro oblivious_bind, simp_all) - apply (clarsimp simp: bind_assoc) - done - -lemma tcbSchedEnqueue_valid_inQ_queues[wp]: - "\valid_inQ_queues\ tcbSchedEnqueue t \\_. valid_inQ_queues\" - apply (simp add: tcbSchedEnqueue_def setQueue_after_addToBitmap) - apply (rule hoare_pre) - apply (rule_tac B="\rv. valid_inQ_queues and obj_at' (\obj. tcbQueued obj = rv) t" - in hoare_seq_ext) - apply (rename_tac queued) - apply (case_tac queued, simp_all add: unless_def)[1] - apply (wp setQueue_valid_inQ_queues threadSet_valid_inQ_queues threadGet_wp - hoare_vcg_const_Ball_lift - | simp add: inQ_def bitmap_fun_defs - | fastforce simp: valid_inQ_queues_def inQ_def obj_at'_def)+ - done - - (* prevents wp from splitting on the when; stronger technique than hoare_when_weak_wp - FIXME: possible to replace with hoare_when_weak_wp? - *) -definition - "removeFromBitmap_conceal d p q t \ when (null [x\q . x \ t]) (removeFromBitmap d p)" - -lemma removeFromBitmap_conceal_valid_inQ_queues[wp]: - "\ valid_inQ_queues \ removeFromBitmap_conceal d p q t \ \_. valid_inQ_queues \" - unfolding valid_inQ_queues_def removeFromBitmap_conceal_def - by (wp|clarsimp simp: bitmap_fun_defs)+ - -lemma rescheduleRequired_valid_inQ_queues[wp]: - "\valid_inQ_queues\ rescheduleRequired \\_. valid_inQ_queues\" - apply (simp add: rescheduleRequired_def) - apply wpsimp - done - -lemma sts_valid_inQ_queues[wp]: - "\valid_inQ_queues\ setThreadState st t \\rv. valid_inQ_queues\" - apply (simp add: setThreadState_def) - apply (wp threadSet_valid_inQ_queues [THEN hoare_strengthen_post]) - apply (clarsimp simp: sch_act_simple_def Invariants_H.valid_queues_def inQ_def)+ - done - lemma updateObject_ep_inv: "\P\ updateObject (obj::endpoint) ko p q n \\rv. P\" by simp (rule updateObject_default_inv) -lemma sbn_valid_inQ_queues[wp]: - "\valid_inQ_queues\ setBoundNotification ntfn t \\rv. valid_inQ_queues\" - apply (simp add: setBoundNotification_def) - apply (wp threadSet_valid_inQ_queues [THEN hoare_strengthen_post]) - apply (clarsimp simp: sch_act_simple_def Invariants_H.valid_queues_def inQ_def)+ +lemma asUser_tcbQueued_inv[wp]: + "\obj_at' (\tcb. P (tcbQueued tcb)) t'\ asUser t m \\_. obj_at' (\tcb. P (tcbQueued tcb)) t'\" + 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 setEndpoint_valid_inQ_queues[wp]: - "\valid_inQ_queues\ setEndpoint ptr ep \\rv. valid_inQ_queues\" - apply (unfold setEndpoint_def) - apply (rule setObject_ep_pre) - apply (simp add: valid_inQ_queues_def) - apply (wp hoare_Ball_helper hoare_vcg_all_lift setObject_queues_unchanged[OF updateObject_ep_inv]) - apply simp - done +crunches asUser + for valid_sched_pointers[wp]: valid_sched_pointers + (wp: crunch_wps) -lemma set_ntfn_valid_inQ_queues[wp]: - "\valid_inQ_queues\ setNotification ptr ntfn \\rv. valid_inQ_queues\" - apply (unfold setNotification_def) - apply (rule setObject_ntfn_pre) - apply (simp add: valid_inQ_queues_def) - apply (wp hoare_Ball_helper hoare_vcg_all_lift) - apply (clarsimp simp: updateObject_default_def in_monad) - apply (wp updateObject_default_inv | simp)+ - done +crunches set_thread_state + for in_correct_ready_q[wp]: in_correct_ready_q + (wp: crunch_wps ignore_del: set_thread_state_ext) -crunch valid_inQ_queues[wp]: cancelSignal valid_inQ_queues - (simp: updateObject_tcb_inv crunch_simps wp: crunch_wps) +crunches set_thread_state_ext + for ready_qs_distinct[wp]: ready_qs_distinct + (wp: crunch_wps ignore_del: set_thread_state_ext) -lemma (in delete_one_conc_pre) cancelIPC_valid_inQ_queues[wp]: - "\valid_inQ_queues\ cancelIPC t \\_. valid_inQ_queues\" - apply (simp add: cancelIPC_def Let_def getThreadReplySlot_def) - apply (wp hoare_drop_imps delete_one_inQ_queues threadSet_valid_inQ_queues | wpc | simp add:if_apply_def2 Fun.comp_def)+ - apply (clarsimp simp: valid_inQ_queues_def inQ_def)+ - done +lemma set_thread_state_ready_qs_distinct[wp]: + "set_thread_state ref ts \ready_qs_distinct\" + unfolding set_thread_state_def + apply (wpsimp wp: set_object_wp) + by (clarsimp simp: ready_qs_distinct_def) -lemma valid_queues_inQ_queues: - "Invariants_H.valid_queues s \ valid_inQ_queues s" - by (force simp: Invariants_H.valid_queues_def valid_inQ_queues_def obj_at'_def - valid_queues_no_bitmap_def) +lemma as_user_ready_qs_distinct[wp]: + "as_user tptr f \ready_qs_distinct\" + unfolding as_user_def + apply (wpsimp wp: set_object_wp) + by (clarsimp simp: ready_qs_distinct_def) -lemma asUser_tcbQueued_inv[wp]: - "\obj_at' (\tcb. P (tcbQueued tcb)) t'\ asUser t m \\_. obj_at' (\tcb. P (tcbQueued tcb)) t'\" - 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 do_extended_op_pspace_aligned[wp]: + "do_extended_op f \pspace_aligned\" + by (wpsimp simp: do_extended_op_def) -lemma asUser_valid_inQ_queues[wp]: - "\valid_inQ_queues\ asUser t f \\rv. valid_inQ_queues\" - unfolding valid_inQ_queues_def Ball_def - apply (wpsimp wp: hoare_vcg_all_lift) - defer - apply (wp asUser_ksQ) - apply assumption - apply (simp add: inQ_def[abs_def] obj_at'_conj) - apply (rule hoare_convert_imp) - apply (wp asUser_ksQ) - apply wp - done +lemma do_extended_op_pspace_distinct[wp]: + "do_extended_op f \pspace_distinct\" + by (wpsimp simp: do_extended_op_def) + +context begin interpretation Arch . (* FIXME: arch_split *) + +crunches arch_post_cap_deletion + for pspace_aligned[wp]: pspace_aligned + and pspace_distinct[wp]: pspace_distinct + (wp: crunch_wps simp: crunch_simps) + +end + +crunches cancel_ipc + for pspace_aligned[wp]: pspace_aligned + and pspace_distinct[wp]: pspace_distinct + (wp: crunch_wps simp: crunch_simps) lemma (in delete_one) suspend_corres: "corres dc (einvs and tcb_at t) (invs' and tcb_at' t) @@ -1425,19 +1237,19 @@ lemma (in delete_one) suspend_corres: apply (rule corres_return_trivial) apply (rule corres_split_nor[OF setThreadState_corres]) apply simp - apply (rule tcbSchedDequeue_corres') + apply (rule tcbSchedDequeue_corres, simp) apply wpsimp - apply wp - apply wpsimp - apply (wpsimp simp: update_restart_pc_def updateRestartPC_def)+ - apply (rule hoare_post_imp[where Q = "\rv s. tcb_at t s \ is_etcb_at t s"]) - apply simp - apply (wp | simp)+ - apply (rule hoare_post_imp[where Q = "\rv s. tcb_at' t s \ valid_inQ_queues s"]) - apply (wpsimp simp: valid_queues_inQ_queues) - apply wp+ - apply (force simp: valid_sched_def tcb_at_is_etcb_at) - apply (clarsimp simp add: invs'_def valid_state'_def valid_queues_inQ_queues) + 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 + apply simp done lemma no_fail_switchFpuOwner[wp]: @@ -1489,22 +1301,6 @@ lemma (in delete_one_conc_pre) cancelIPC_it[wp]: apply (wp hoare_drop_imps delete_one_it | wpc | simp add:if_apply_def2 Fun.comp_def)+ done -crunch ksQ: threadGet "\s. P (ksReadyQueues s p)" - -lemma tcbSchedDequeue_notksQ: - "\\s. t' \ set(ksReadyQueues s p)\ - tcbSchedDequeue t - \\_ s. t' \ set(ksReadyQueues s p)\" - 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+ - apply clarsimp - apply (rule_tac Q="\_ s. t' \ set(ksReadyQueues s p)" in hoare_post_imp) - apply (wp | clarsimp)+ - done - lemma rescheduleRequired_oa_queued: "\ (\s. P (obj_at' (\tcb. Q (tcbQueued tcb) (tcbDomain tcb) (tcbPriority tcb)) t' s)) and sch_act_simple\ rescheduleRequired @@ -1554,198 +1350,9 @@ lemma setBoundNotification_oa_queued: by (simp add: not_obj_at' comp_def, wp hoare_convert_imp pos) qed -lemma tcbSchedDequeue_ksQ_distinct[wp]: - "\\s. distinct (ksReadyQueues s p)\ - tcbSchedDequeue t - \\_ s. distinct (ksReadyQueues s p)\" - 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+ - apply (rule_tac Q="\_ s. distinct (ksReadyQueues s p)" in hoare_post_imp) - apply (clarsimp | wp)+ - done - -lemma sts_valid_queues_partial: - "\Invariants_H.valid_queues and sch_act_simple\ - setThreadState st t - \\_ s. \t' d p. - (t' \ set(ksReadyQueues s (d, p)) \ - (obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t' s - \ (t' \ t \ st_tcb_at' runnable' t' s))) - \ distinct (ksReadyQueues s (d, p))\" - (is "\_\ _ \\_ s. \t' d p. ?OA t' d p s \ ?DISTINCT d p s \") - apply (rule_tac Q="\_ s. (\t' d p. ?OA t' d p s) \ (\d p. ?DISTINCT d p s)" - in hoare_post_imp) - apply (clarsimp) - apply (rule hoare_conjI) - apply (rule_tac Q="\s. \t' d p. - ((t'\set(ksReadyQueues s (d, p)) - \ \ (sch_act_simple s)) - \ (obj_at'(\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t' s - \ st_tcb_at' runnable' t' s))" in hoare_pre_imp) - apply (fastforce simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def - pred_tcb_at'_def obj_at'_def inQ_def) - apply (rule hoare_vcg_all_lift)+ - apply (rule hoare_convert_imp) - including classic_wp_pre - apply (wp sts_ksQ setThreadState_oa_queued hoare_impI sts_pred_tcb_neq' - | clarsimp)+ - apply (rule_tac Q="\s. \d p. ?DISTINCT d p s \ sch_act_simple s" in hoare_pre_imp) - apply (clarsimp simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def) - apply (wp hoare_vcg_all_lift sts_ksQ) - apply (clarsimp) - done - -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 Q="(\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) - done - -lemma sts_invs_minor'_no_valid_queues: - "\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 \ obj_at' tcbQueued t s \ st_tcb_at' runnable' t s) - and sch_act_simple - and invs'\ - setThreadState st t - \\_ s. (\t' d p. - (t' \ set(ksReadyQueues s (d, p)) \ - (obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t' s - \ (t' \ t \ st_tcb_at' runnable' t' s))) - \ distinct (ksReadyQueues s (d, p)) \ (maxDomain < d \ maxPriority < p \ ksReadyQueues s (d, p) = [])) \ - valid_bitmapQ s \ - bitmapQ_no_L2_orphans s \ - bitmapQ_no_L1_orphans 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_ioports' s \ - valid_machine_state' s \ - irqs_masked' s \ - valid_queues' s \ - ct_not_inQ s \ - ct_idle_or_in_cur_domain' s \ - pspace_domain_valid s \ - ksCurDomain s \ maxDomain \ - valid_dom_schedule' s \ - untyped_ranges_zero' s \ - cur_tcb' s \ - tcb_at' t s\" - apply (simp add: invs'_def valid_state'_def valid_queues_def) - apply (wp sts_valid_queues_partial sts_ksQ - setThreadState_oa_queued sts_st_tcb_at'_cases - irqs_masked_lift - valid_irq_node_lift - setThreadState_ct_not_inQ - sts_valid_bitmapQ_sch_act_simple - sts_valid_bitmapQ_no_L2_orphans_sch_act_simple - sts_valid_bitmapQ_no_L1_orphans_sch_act_simple - hoare_vcg_conj_lift hoare_vcg_imp_lift hoare_vcg_all_lift)+ - apply (clarsimp simp: disj_imp) - apply (intro conjI) - apply (clarsimp simp: valid_queues_def) - apply (rule conjI, clarsimp) - apply (drule valid_queues_no_bitmap_objD, assumption) - apply (clarsimp simp: inQ_def comp_def) - apply (rule conjI) - apply (erule obj_at'_weaken) - apply (simp add: inQ_def) - apply (clarsimp simp: st_tcb_at'_def) - apply (erule obj_at'_weaken) - apply (simp add: inQ_def) - apply (simp add: valid_queues_no_bitmap_def) - apply clarsimp - apply (clarsimp simp: st_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 (fastforce simp: valid_tcb_state'_def - split: Structures_H.thread_state.splits) - apply (clarsimp dest!: st_tcb_at_state_refs_ofD' - elim!: rsubst[where P=sym_refs] - intro!: ext) - apply (fastforce simp: valid_queues_def inQ_def pred_tcb_at' pred_tcb_at'_def - elim!: st_tcb_ex_cap'' obj_at'_weakenE)+ - done - -crunch ct_idle_or_in_cur_domain'[wp]: tcbSchedDequeue ct_idle_or_in_cur_domain' - -lemma tcbSchedDequeue_invs'_no_valid_queues: - "\\s. (\t' d p. - (t' \ set(ksReadyQueues s (d, p)) \ - (obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t' s - \ (t' \ t \ st_tcb_at' runnable' t' s))) - \ distinct (ksReadyQueues s (d, p)) \ (maxDomain < d \ maxPriority < p \ ksReadyQueues s (d, p) = [])) \ - valid_bitmapQ s \ - bitmapQ_no_L2_orphans s \ - bitmapQ_no_L1_orphans 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_ioports' s \ - valid_machine_state' s \ - irqs_masked' s \ - valid_queues' s \ - ct_not_inQ s \ - ct_idle_or_in_cur_domain' s \ - pspace_domain_valid s \ - ksCurDomain s \ maxDomain \ - valid_dom_schedule' s \ - untyped_ranges_zero' s \ - cur_tcb' s \ - tcb_at' t s\ - tcbSchedDequeue t - \\_. invs' \" - apply (simp add: invs'_def valid_state'_def) - apply (wp tcbSchedDequeue_valid_queues_weak valid_irq_handlers_lift - valid_irq_node_lift valid_irq_handlers_lift' - tcbSchedDequeue_irq_states irqs_masked_lift cur_tcb_lift - untyped_ranges_zero_lift - | clarsimp simp add: cteCaps_of_def valid_queues_def o_def)+ - apply (rule conjI) - apply (fastforce simp: obj_at'_def inQ_def st_tcb_at'_def valid_queues_no_bitmap_except_def) - apply (rule conjI, clarsimp simp: correct_queue_def) - apply (fastforce simp: valid_pspace'_def intro: obj_at'_conjI - elim: valid_objs'_maxDomain valid_objs'_maxPriority) - done - -lemmas sts_tcbSchedDequeue_invs' = - sts_invs_minor'_no_valid_queues - tcbSchedDequeue_invs'_no_valid_queues +crunches 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\" @@ -1757,11 +1364,14 @@ lemma (in delete_one_conc) suspend_invs'[wp]: "\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 (wp sts_tcbSchedDequeue_invs') - apply (simp add: updateRestartPC_def | strengthen no_refs_simple_strg')+ - prefer 2 - apply (wpsimp wp: hoare_drop_imps hoare_vcg_imp_lift' - | strengthen no_refs_simple_strg')+ + 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]: @@ -1805,109 +1415,6 @@ lemma (in delete_one_conc_pre) suspend_st_tcb_at': lemmas (in delete_one_conc_pre) suspend_makes_simple' = suspend_st_tcb_at' [where P=simple', simplified] -lemma valid_queues_not_runnable'_not_ksQ: - assumes "Invariants_H.valid_queues s" and "st_tcb_at' (Not \ runnable') t s" - shows "\d p. t \ set (ksReadyQueues s (d, p))" - using assms - apply - - apply (clarsimp simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def pred_tcb_at'_def) - apply (erule_tac x=d in allE) - apply (erule_tac x=p in allE) - apply (clarsimp) - apply (drule(1) bspec) - apply (clarsimp simp: obj_at'_def) - done - -declare valid_queues_not_runnable'_not_ksQ[OF ByAssum, simp] - -lemma cancelSignal_queues[wp]: - "\Invariants_H.valid_queues and st_tcb_at' (Not \ runnable') t\ - cancelSignal t ae \\_. Invariants_H.valid_queues \" - apply (simp add: cancelSignal_def) - apply (wp sts_valid_queues) - apply (rule_tac Q="\_ s. \p. t \ set (ksReadyQueues s p)" in hoare_post_imp, simp) - apply (wp hoare_vcg_all_lift) - apply (wpc) - apply (wp)+ - apply (rule_tac Q="\_ s. Invariants_H.valid_queues s \ (\p. t \ set (ksReadyQueues s p))" in hoare_post_imp) - apply (clarsimp) - apply (wp) - apply (clarsimp) - done - -lemma (in delete_one_conc_pre) cancelIPC_queues[wp]: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - cancelIPC t \\rv. Invariants_H.valid_queues\" - apply (simp add: cancelIPC_def Let_def getThreadReplySlot_def - cong: Structures_H.thread_state.case_cong list.case_cong) - apply (rule hoare_seq_ext [OF _ gts_sp']) - apply (rule hoare_pre) - apply (wpc - | wp hoare_vcg_conj_lift delete_one_queues threadSet_valid_queues - threadSet_valid_objs' sts_valid_queues setEndpoint_ksQ - hoare_vcg_all_lift threadSet_sch_act threadSet_weak_sch_act_wf - | simp add: o_def if_apply_def2 inQ_def - | rule hoare_drop_imps - | clarsimp simp: valid_tcb'_def tcb_cte_cases_def - elim!: pred_tcb'_weakenE)+ - apply (fastforce dest: valid_queues_not_runnable'_not_ksQ elim: pred_tcb'_weakenE) - done - -(* FIXME: move to Schedule_R *) -lemma tcbSchedDequeue_nonq[wp]: - "\Invariants_H.valid_queues and tcb_at' t and K (t = t')\ - tcbSchedDequeue t \\_ s. \d p. t' \ set (ksReadyQueues s (d, p))\" - apply (rule hoare_gen_asm) - apply (simp add: tcbSchedDequeue_def) - apply (wp threadGet_wp|simp)+ - apply (fastforce simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def obj_at'_def projectKOs inQ_def) - done - -lemma sts_ksQ_oaQ: - "\Invariants_H.valid_queues\ - setThreadState st t - \\_ s. t \ set (ksReadyQueues s (d, p)) \ - obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t s\" - (is "\_\ _ \\_. ?POST\") - proof - - have RR: "\sch_act_simple and ?POST\ rescheduleRequired \\_. ?POST\" - apply (simp add: rescheduleRequired_def) - apply (wp) - apply (clarsimp) - apply (rule_tac - Q="(\s. action = ResumeCurrentThread \ action = ChooseNewThread) and ?POST" - in hoare_pre_imp, assumption) - apply (case_tac action) - apply (clarsimp)+ - apply (wp) - apply (clarsimp simp: sch_act_simple_def) - done - show ?thesis - apply (simp add: setThreadState_def) - apply (wp RR) - apply (rule_tac Q="\_. ?POST" in hoare_post_imp) - apply (clarsimp simp add: sch_act_simple_def) - apply (wp hoare_convert_imp) - apply (clarsimp simp: Invariants_H.valid_queues_def valid_queues_no_bitmap_def) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (fastforce dest: bspec elim!: obj_at'_weakenE simp: inQ_def) - done - qed - -lemma (in delete_one_conc_pre) suspend_nonq: - "\Invariants_H.valid_queues and valid_objs' and tcb_at' t - and (\s. weak_sch_act_wf (ksSchedulerAction s) s) - and (\s. t \ ksIdleThread s) and K (t = t')\ - suspend t - \\rv s. \d p. t' \ set (ksReadyQueues s (d, p))\" - apply (rule hoare_gen_asm) - apply (simp add: suspend_def) - unfolding updateRestartPC_def - apply (wp hoare_allI tcbSchedDequeue_t_notksQ sts_ksQ_oaQ) - apply wpsimp+ - done - lemma suspend_makes_inactive: "\K (t = t')\ suspend t \\rv. st_tcb_at' ((=) Inactive) t'\" apply (cases "t = t'", simp_all) @@ -1918,31 +1425,21 @@ lemma suspend_makes_inactive: declare threadSet_sch_act_sane [wp] declare sts_sch_act_sane [wp] -lemma tcbSchedEnqueue_ksQset_weak: - "\\s. t' \ set (ksReadyQueues s p)\ - tcbSchedEnqueue t - \\_ s. t' \ set (ksReadyQueues s p)\" (is "\?PRE\ _ \_\") - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wp hoare_vcg_conj_lift hoare_vcg_imp_lift hoare_vcg_if_lift) - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, ((wp | clarsimp)+))+ - done - 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 tcbSchedEnqueue_ct', wp, simp) + by (rule hoare_weaken_pre, wps, wp, simp) lemma sts_sch_act_not_ct[wp]: "\\s. sch_act_not (ksCurThread s) s\ setThreadState st t \\_ s. sch_act_not (ksCurThread s) s\" - by (rule hoare_weaken_pre, wps tcbSchedEnqueue_ct', wp, simp) + by (rule hoare_weaken_pre, wps, wp, simp) text \Cancelling all IPC in an endpoint or notification object\ lemma ep_cancel_corres_helper: - "corres dc ((\s. \t \ set list. tcb_at t s) and valid_etcbs) - ((\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') + "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 @@ -1951,28 +1448,36 @@ lemma ep_cancel_corres_helper: 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 Q'="\s. \t \ set list. tcb_at' t s" in corres_cross_add_guard) + apply (fastforce elim: tcb_at_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 (rule corres_guard_imp [OF setThreadState_corres]) - apply simp - apply (simp add: valid_tcb_state_def) - apply simp - apply (wp sts_valid_queues)+ - apply (force simp: tcb_at_is_etcb_at) - apply (fastforce elim: obj_at'_weakenE) - apply ((wp hoare_vcg_const_Ball_lift | simp)+)[1] - apply (rule hoare_pre) - apply (wp hoare_vcg_const_Ball_lift - weak_sch_act_wf_lift_linear sts_st_tcb' setThreadState_not_st - sts_valid_queues tcbSchedEnqueue_not_st - | simp)+ - apply (auto elim: obj_at'_weakenE simp: valid_tcb_state'_def) + 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 +crunches 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 ep_cancel_corres: "corres dc (invs and valid_sched and ep_at ep) (invs' and ep_at' ep) (cancel_all_ipc ep) (cancelAllIPC ep)" @@ -1980,10 +1485,10 @@ proof - have P: "\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_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 - \ Invariants_H.valid_queues s \ valid_queues' s \ valid_objs' 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; @@ -2005,22 +1510,24 @@ proof - 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 R="\_ s. \x\set list. tcb_at' x s \ valid_objs' s" + apply (rule_tac R="\_ 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 (rule hoare_name_pre_state) - apply ((wp hoare_vcg_const_Ball_lift mapM_x_wp' - sts_valid_queues setThreadState_not_st sts_st_tcb' tcbSchedEnqueue_not_st - | clarsimp - | fastforce elim: obj_at'_weakenE simp: valid_tcb_state'_def)+)[2] - apply (rule hoare_name_pre_state) + 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 elim!: valid_objs_valid_tcbE))+ + | (clarsimp simp: valid_ep'_def) + | (drule (1) bspec, clarsimp simp: valid_pspace'_def valid_tcb'_def valid_ep'_def + | strengthen valid_objs'_valid_tcbs'))+ + apply fastforce done show ?thesis 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 @@ -2048,6 +1555,8 @@ lemma cancelAllSignals_corres: "corres dc (invs and valid_sched and ntfn_at ntfn) (invs' and ntfn_at' ntfn) (cancel_all_signals ntfn) (cancelAllSignals ntfn)" apply (simp add: cancel_all_signals_def cancelAllSignals_def) + 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+ @@ -2058,22 +1567,27 @@ lemma cancelAllSignals_corres: 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 setThreadState_not_st + weak_sch_act_wf_lift_linear set_thread_state_runnable_weak_valid_sched_action | simp)+ apply (rename_tac list) - apply (rule_tac R="\_ s. (\x\set list. tcb_at' x s) \ valid_objs' s" + apply (rule_tac R="\_ 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_queues setThreadState_not_st - simp: valid_tcb_state'_def) - 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')+ + 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 invs_psp_aligned + invs_distinct valid_queues_ready_qs_distinct + | erule obj_at_valid_objsE | drule ko_at_valid_objs')+ done lemma ep'_Idle_case_helper: @@ -2126,9 +1640,8 @@ lemma cancel_all_invs'_helper: apply clarsimp apply (rule hoare_pre) apply (wp valid_irq_node_lift valid_irq_handlers_lift'' irqs_masked_lift valid_ioports_lift'' - hoare_vcg_const_Ball_lift untyped_ranges_zero_lift - sts_valid_queues sts_st_tcb' setThreadState_not_st - | simp add: cteCaps_of_def o_def)+ + hoare_vcg_const_Ball_lift untyped_ranges_zero_lift sts_st_tcb' + | simp add: cteCaps_of_def o_def)+ apply (unfold fun_upd_apply Invariants_H.tcb_st_refs_of'_simps) apply clarsimp apply (intro conjI) @@ -2136,7 +1649,7 @@ lemma cancel_all_invs'_helper: elim!: rsubst[where P=sym_refs] dest!: set_mono_suffix intro!: ext - | (drule (1) bspec, clarsimp simp: valid_pspace'_def valid_tcb'_def elim!: valid_objs_valid_tcbE))+ + | (drule (1) bspec, clarsimp simp: valid_pspace'_def valid_tcb'_def))+ done lemma ep_q_refs_max: @@ -2152,22 +1665,10 @@ lemma ep_q_refs_max: | case_tac ntfnptr)+ done -crunch ct' [wp]: setEndpoint "\s. P (ksCurThread s)" - (wp: setObject_ep_ct) - -crunch ct' [wp]: setNotification "\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 add: invs'_update_cnt | wpc)+ - apply (clarsimp simp: invs'_def valid_state'_def) done lemma invs_rct_ct_activatable': @@ -2294,6 +1795,7 @@ lemma rescheduleRequired_all_invs_but_ct_not_inQ: lemma cancelAllIPC_invs'[wp]: "\invs'\ cancelAllIPC ep_ptr \\rv. invs'\" apply (simp add: cancelAllIPC_def ep'_Idle_case_helper cong del: if_cong) + apply (rule hoare_seq_ext[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' @@ -2322,6 +1824,7 @@ lemma cancelAllIPC_invs'[wp]: lemma cancelAllSignals_invs'[wp]: "\invs'\ cancelAllSignals ntfn \\rv. invs'\" apply (simp add: cancelAllSignals_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) apply (case_tac "ntfnObj ntfna", simp_all) apply (wp, simp) @@ -2356,12 +1859,14 @@ crunch valid_objs'[wp]: tcbSchedEnqueue valid_objs' (simp: unless_def valid_tcb'_def tcb_cte_cases_def) lemma cancelAllIPC_valid_objs'[wp]: - "\valid_objs'\ cancelAllIPC ep \\rv. valid_objs'\" + "\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 hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ep_sp']) apply (rule hoare_pre) apply (wp set_ep_valid_objs' setSchedulerAction_valid_objs') - apply (rule_tac Q="\rv s. valid_objs' s \ (\x\set (epQueue ep). tcb_at' x s)" + 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) @@ -2378,8 +1883,9 @@ lemma cancelAllIPC_valid_objs'[wp]: done lemma cancelAllSignals_valid_objs'[wp]: - "\valid_objs'\ cancelAllSignals ntfn \\rv. valid_objs'\" + "\valid_objs' and pspace_aligned' and pspace_distinct'\ cancelAllSignals ntfn \\rv. valid_objs'\" apply (simp add: cancelAllSignals_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) apply (case_tac "ntfnObj ntfna", simp_all) apply (wp, simp) @@ -2432,19 +1938,17 @@ 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\" - apply (simp add: setThreadState_def setQueue_def - rescheduleRequired_def tcbSchedEnqueue_def - unless_def bitmap_fun_defs - cong: scheduler_action.case_cong cong del: if_cong - | wp | wpcw)+ - done + 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 unless_def) + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_def) apply (wp | simp add: setQueue_def bitmap_fun_defs)+ done @@ -2478,19 +1982,41 @@ lemma setObject_ko_wp_at': objBits_def[symmetric] ps_clear_upd in_magnitude_check v projectKOs) -lemma rescheduleRequired_unlive: - "\\s. ko_wp_at' (Not \ live') p s \ ksSchedulerAction s \ SwitchToThread p\ - rescheduleRequired +lemma threadSet_unlive_other: + "\ko_wp_at' (Not \ live') p and K (p \ t)\ + threadSet f t \\rv. ko_wp_at' (Not \ live') p\" - apply (simp add: rescheduleRequired_def) - apply (wp | simp | wpc)+ - apply (simp add: tcbSchedEnqueue_def unless_def - threadSet_def setQueue_def threadGet_def) - apply (wp setObject_ko_wp_at getObject_tcb_wp - | simp add: objBits_simps' bitmap_fun_defs split del: if_split)+ - apply (clarsimp simp: o_def) - apply (drule obj_at_ko_at') - apply clarsimp + by (clarsimp simp: threadSet_def valid_def getObject_def projectKOs + setObject_def in_monad loadObject_default_def + ko_wp_at'_def split_def in_magnitude_check + objBits_simps' updateObject_default_def + ps_clear_upd) + +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 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 + +lemma rescheduleRequired_unlive[wp]: + "\\s. ko_wp_at' (Not \ live') p s \ ksSchedulerAction s \ SwitchToThread p\ + rescheduleRequired + \\_. ko_wp_at' (Not \ live') p\" + supply comp_apply[simp del] + unfolding rescheduleRequired_def + apply (wpsimp wp: tcbSchedEnqueue_unlive_other) done lemmas setEndpoint_ko_wp_at' @@ -2500,6 +2026,7 @@ lemma cancelAllIPC_unlive: "\valid_objs' and (\s. sch_act_wf (ksSchedulerAction s) s)\ cancelAllIPC ep \\rv. ko_wp_at' (Not \ live') ep\" apply (simp add: cancelAllIPC_def ep'_Idle_case_helper) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ep_sp']) apply (rule hoare_pre) apply (wp cancelAll_unlive_helper setEndpoint_ko_wp_at' @@ -2519,6 +2046,7 @@ lemma cancelAllSignals_unlive: \ obj_at' (\ko. ntfnBoundTCB ko = None) ntfnptr s\ cancelAllSignals ntfnptr \\rv. ko_wp_at' (Not \ live') ntfnptr\" apply (simp add: cancelAllSignals_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) apply (rule hoare_seq_ext [OF _ get_ntfn_sp']) apply (case_tac "ntfnObj ntfn", simp_all add: setNotification_def) apply wp @@ -2584,25 +2112,22 @@ lemma cancelBadgedSends_filterM_helper': apply (rule hoare_pre) 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' sts_valid_queues setThreadState_not_st valid_ioports_lift'' - tcbSchedEnqueue_not_st + sts_st_tcb' valid_ioports_lift'' 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 + apply (clarsimp simp: valid_pspace'_def cong: conj_cong) apply (intro conjI) - apply (clarsimp simp: valid_pspace'_def valid_tcb'_def elim!: valid_objs_valid_tcbE dest!: st_tcb_ex_cap'') - apply (fastforce dest!: 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) - apply (fastforce elim!: obj_atE' - simp: state_refs_of'_def projectKOs tcb_bound_refs'_def + by (fastforce elim!: obj_atE' + simp: state_refs_of'_def projectKOs tcb_bound_refs'_def subsetD symreftype_inverse' - split: if_split_asm)+ - done + split: if_split_asm)+ lemmas cancelBadgedSends_filterM_helper = spec [where x=Nil, OF cancelBadgedSends_filterM_helper', simplified] @@ -2612,7 +2137,8 @@ lemma cancelBadgedSends_invs[wp]: shows "\invs'\ cancelBadgedSends epptr badge \\rv. invs'\" apply (simp add: cancelBadgedSends_def) - apply (rule hoare_seq_ext [OF _ get_ep_sp']) + apply (rule hoare_seq_ext[OF _ stateAssert_sp]) + apply (rule hoare_seq_ext [OF _ get_ep_sp'], rename_tac ep) apply (case_tac ep, simp_all) apply ((wp | simp)+)[2] apply (subst bind_assoc [where g="\_. rescheduleRequired", @@ -2645,10 +2171,21 @@ lemma cancelBadgedSends_invs[wp]: crunch state_refs_of[wp]: tcb_sched_action "\s. P (state_refs_of s)" (ignore_del: tcb_sched_action) +lemma setEndpoint_valid_tcbs'[wp]: + "setEndpoint ePtr val \valid_tcbs'\" + unfolding setEndpoint_def + supply projectKOs[simp] + apply (wpsimp wp: setObject_valid_tcbs'[where P=\]) + apply (clarsimp simp: updateObject_default_def monad_simps) + apply fastforce + done + lemma cancelBadgedSends_corres: "corres dc (invs and valid_sched and ep_at epptr) (invs' and ep_at' epptr) (cancel_badged_sends epptr bdg) (cancelBadgedSends epptr bdg)" 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 Q'=invs']) @@ -2660,9 +2197,13 @@ lemma cancelBadgedSends_corres: apply (simp add: ep_relation_def) apply (rule corres_split_eqr[OF _ _ _ hoare_post_add[where R="\_. valid_objs'"]]) apply (rule_tac S="(=)" - and Q="\xs s. (\x \ set xs. (epptr, TCBBlockedSend) \ state_refs_of s x) \ distinct xs \ valid_etcbs s" - and Q'="\xs s. (\x \ set xs. tcb_at' x s) \ weak_sch_act_wf (ksSchedulerAction s) s \ Invariants_H.valid_queues s \ valid_queues' s \ valid_objs' s" - in corres_mapM_list_all2[where r'="(=)"], + 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) @@ -2672,59 +2213,61 @@ lemma cancelBadgedSends_corres: 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]) + apply (rule corres_split[OF tcbSchedEnqueue_corres], simp) apply (rule corres_trivial) apply simp apply wp+ - apply simp - apply (wp sts_valid_queues gts_st_tcb_at)+ + 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: is_tcb_def) - apply simp + 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_queues + 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 (wp gts_st_tcb_at hoare_vcg_imp_lift mapM_wp' - sts_st_tcb' sts_valid_queues - set_thread_state_runnable_weak_valid_sched_action - | clarsimp simp: valid_tcb_state'_def)+ - apply (wp hoare_vcg_const_Ball_lift weak_sch_act_wf_lift_linear set_ep_valid_objs' - | simp)+ + 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 (clarsimp simp: st_tcb_at_refs_of_rev) + apply (rule conjI, fastforce) + apply clarsimp 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 (drule ko_at_valid_objs', clarsimp) apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ep'_def invs_weak_sch_act_wf - invs'_def valid_state'_def) + apply (fastforce simp: valid_obj'_def valid_ep'_def invs_weak_sch_act_wf + invs'_def valid_state'_def) done +crunches 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 (simp add: threadGet_def| wp getObject_tcb_wp)+ - apply (rule hoare_strengthen_post, rule hoare_post_taut) - apply (fastforce simp: obj_at'_def projectKOs) - apply (rule hoare_post_taut) - apply wp+ - done - -crunch unqueued: prepareThreadDelete "obj_at' (\a. \ tcbQueued a) t" -crunch inactive: prepareThreadDelete "st_tcb_at' ((=) Inactive) t'" -crunch nonq: prepareThreadDelete " \s. \d p. t' \ set (ksReadyQueues s (d, p))" + unfolding suspend_def + by (wpsimp simp: comp_def wp: tcbSchedDequeue_not_tcbQueued) + +crunches prepareThreadDelete + for unqueued: "obj_at' (\a. \ tcbQueued a) t" + and inactive: "st_tcb_at' ((=) Inactive) t'" end end diff --git a/proof/refine/X64/Ipc_R.thy b/proof/refine/X64/Ipc_R.thy index ff1801b7bf..e7a0cd3f5b 100644 --- a/proof/refine/X64/Ipc_R.thy +++ b/proof/refine/X64/Ipc_R.thy @@ -13,9 +13,10 @@ context begin interpretation Arch . (*FIXME: arch_split*) lemmas lookup_slot_wrapper_defs'[simp] = lookupSourceSlot_def lookupTargetSlot_def lookupPivotSlot_def -lemma getMessageInfo_corres: "corres ((=) \ message_info_map) - (tcb_at t) (tcb_at' t) - (get_message_info t) (getMessageInfo t)" +lemma getMessageInfo_corres: + "corres ((=) \ message_info_map) + (tcb_at t and pspace_aligned and pspace_distinct) \ + (get_message_info t) (getMessageInfo t)" apply (rule corres_guard_imp) apply (unfold get_message_info_def getMessageInfo_def fun_app_def) apply (simp add: X64_H.msgInfoRegister_def @@ -763,14 +764,6 @@ lemma tcts_sch_act[wp]: \\rv s. sch_act_wf (ksSchedulerAction s) s\" by (wp sch_act_wf_lift tcb_in_cur_domain'_lift transferCapsToSlots_pres1) -lemma tcts_vq[wp]: - "\Invariants_H.valid_queues\ transferCapsToSlots ep buffer n caps slots mi \\rv. Invariants_H.valid_queues\" - by (wp valid_queues_lift transferCapsToSlots_pres1) - -lemma tcts_vq'[wp]: - "\valid_queues'\ transferCapsToSlots ep buffer n caps slots mi \\rv. valid_queues'\" - by (wp valid_queues_lift' transferCapsToSlots_pres1) - crunch state_refs_of' [wp]: setExtraBadge "\s. P (state_refs_of' s)" lemma tcts_state_refs_of'[wp]: @@ -1010,6 +1003,11 @@ crunch ksDomScheduleIdx[wp]: setExtraBadge "\s. P (ksDomScheduleIdx s)" crunch ksDomSchedule[wp]: transferCapsToSlots "\s. P (ksDomSchedule s)" crunch ksDomScheduleIdx[wp]: transferCapsToSlots "\s. P (ksDomScheduleIdx s)" +crunches transferCapsToSlots + 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) lemma transferCapsToSlots_invs[wp]: "\\s. invs' s \ distinct slots @@ -1263,9 +1261,6 @@ crunch aligned'[wp]: setMessageInfo pspace_aligned' crunch distinct'[wp]: setMessageInfo pspace_distinct' (wp: crunch_wps simp: crunch_simps) -crunch valid_objs'[wp]: storeWordUser valid_objs' -crunch valid_pspace'[wp]: storeWordUser valid_pspace' - lemma set_mrs_valid_objs' [wp]: "\valid_objs'\ setMRs t a msgs \\rv. valid_objs'\" apply (simp add: setMRs_def zipWithM_x_mapM split_def) @@ -1275,18 +1270,12 @@ lemma set_mrs_valid_objs' [wp]: crunch valid_objs'[wp]: copyMRs valid_objs' (wp: crunch_wps simp: crunch_simps) -crunch valid_queues'[wp]: asUser "Invariants_H.valid_queues'" - (simp: crunch_simps wp: hoare_drop_imps) - - lemma setMRs_invs_bits[wp]: "\valid_pspace'\ setMRs t buf mrs \\rv. valid_pspace'\" "\\s. sch_act_wf (ksSchedulerAction s) s\ setMRs t buf mrs \\rv s. sch_act_wf (ksSchedulerAction s) s\" "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ setMRs t buf mrs \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" - "\Invariants_H.valid_queues\ setMRs t buf mrs \\rv. Invariants_H.valid_queues\" - "\valid_queues'\ setMRs t buf mrs \\rv. valid_queues'\" "\\s. P (state_refs_of' s)\ setMRs t buf mrs \\rv s. P (state_refs_of' s)\" @@ -1303,8 +1292,6 @@ lemma copyMRs_invs_bits[wp]: "\valid_pspace'\ copyMRs s sb r rb n \\rv. valid_pspace'\" "\\s. sch_act_wf (ksSchedulerAction s) s\ copyMRs s sb r rb n \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\Invariants_H.valid_queues\ copyMRs s sb r rb n \\rv. Invariants_H.valid_queues\" - "\valid_queues'\ copyMRs s sb r rb n \\rv. valid_queues'\" "\\s. P (state_refs_of' s)\ copyMRs s sb r rb n \\rv s. P (state_refs_of' s)\" @@ -1562,17 +1549,17 @@ lemma msgFromLookupFailure_map[simp]: by (cases lf, simp_all add: lookup_failure_map_def msgFromLookupFailure_def) lemma asUser_getRestartPC_corres: - "corres (=) (tcb_at t) (tcb_at' t) - (as_user t getRestartPC) (asUser t getRestartPC)" + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ + (as_user t getRestartPC) (asUser t getRestartPC)" apply (rule asUser_corres') apply (rule corres_Id, simp, simp) apply (rule no_fail_getRestartPC) done lemma asUser_mapM_getRegister_corres: - "corres (=) (tcb_at t) (tcb_at' t) - (as_user t (mapM getRegister regs)) - (asUser t (mapM getRegister regs))" + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ + (as_user t (mapM getRegister regs)) + (asUser t (mapM getRegister regs))" apply (rule asUser_corres') apply (rule corres_Id [OF refl refl]) apply (rule no_fail_mapM) @@ -1580,9 +1567,9 @@ lemma asUser_mapM_getRegister_corres: done lemma makeArchFaultMessage_corres: - "corres (=) (tcb_at t) (tcb_at' t) - (make_arch_fault_msg f t) - (makeArchFaultMessage (arch_fault_map f) t)" + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ + (make_arch_fault_msg f t) + (makeArchFaultMessage (arch_fault_map f) t)" apply (cases f, clarsimp simp: makeArchFaultMessage_def split: arch_fault.split) apply (rule corres_guard_imp) apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) @@ -1591,9 +1578,9 @@ lemma makeArchFaultMessage_corres: done lemma makeFaultMessage_corres: - "corres (=) (tcb_at t) (tcb_at' t) - (make_fault_msg ft t) - (makeFaultMessage (fault_map ft) t)" + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ + (make_fault_msg ft t) + (makeFaultMessage (fault_map ft) t)" apply (cases ft, simp_all add: makeFaultMessage_def split del: if_split) apply (rule corres_guard_imp) apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) @@ -1629,18 +1616,18 @@ lemmas threadget_fault_corres = lemma doFaultTransfer_corres: "corres dc (obj_at (\ko. \tcb ft. ko = TCB tcb \ tcb_fault tcb = Some ft) sender - and tcb_at receiver and case_option \ in_user_frame recv_buf) - (tcb_at' sender and tcb_at' receiver and - case_option \ valid_ipc_buffer_ptr' recv_buf) + and tcb_at receiver and case_option \ in_user_frame recv_buf + and pspace_aligned and pspace_distinct) + (case_option \ valid_ipc_buffer_ptr' recv_buf) (do_fault_transfer badge sender receiver recv_buf) (doFaultTransfer badge sender receiver recv_buf)" apply (clarsimp simp: do_fault_transfer_def doFaultTransfer_def split_def X64_H.badgeRegister_def badge_register_def) apply (rule_tac Q="\fault. K (\f. fault = Some f) and tcb_at sender and tcb_at receiver and - case_option \ in_user_frame recv_buf" - and Q'="\fault'. tcb_at' sender and tcb_at' receiver and - case_option \ valid_ipc_buffer_ptr' recv_buf" + case_option \ in_user_frame recv_buf and + pspace_aligned and pspace_distinct" + and Q'="\fault'. case_option \ valid_ipc_buffer_ptr' recv_buf" in corres_underlying_split) apply (rule corres_guard_imp) apply (rule threadget_fault_corres) @@ -1769,17 +1756,10 @@ crunch ifunsafe[wp]: doIPCTransfer "if_unsafe_then_cap'" crunch iflive[wp]: doIPCTransfer "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 vp[wp]: doIPCTransfer "valid_pspace'" (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' wp: transferCapsToSlots_vp simp:ball_conj_distrib ) crunch sch_act_wf[wp]: doIPCTransfer "\s. sch_act_wf (ksSchedulerAction s) s" (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch vq[wp]: doIPCTransfer "Invariants_H.valid_queues" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch vq'[wp]: doIPCTransfer "valid_queues'" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) crunch state_refs_of[wp]: doIPCTransfer "\s. P (state_refs_of' s)" (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) crunch ct[wp]: doIPCTransfer "cur_tcb'" @@ -1810,7 +1790,7 @@ lemma lec_valid_cap' [wp]: apply (rule lookupExtraCaps_srcs) apply wp apply (clarsimp simp: cte_wp_at_ctes_of) - apply (fastforce elim: ctes_of_valid') + apply fastforce apply simp done @@ -1869,7 +1849,7 @@ lemma sanitise_register_corres: sanitiseOrFlags_def sanitiseAndFlags_def) lemma handle_fault_reply_registers_corres: - "corres (=) (tcb_at t) (tcb_at' t) + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ (do t' \ arch_get_sanitise_register_info t; y \ as_user t (zipWithM_x @@ -1897,7 +1877,7 @@ lemma handle_fault_reply_registers_corres: lemma handleFaultReply_corres: "ft' = fault_map ft \ - corres (=) (tcb_at t) (tcb_at' t) + 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) @@ -1940,18 +1920,6 @@ lemma getThreadCallerSlot_inv: "\P\ getThreadCallerSlot t \\_. P\" by (simp add: getThreadCallerSlot_def, wp) -lemma deleteCallerCap_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - deleteCallerCap t - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - apply (simp add: deleteCallerCap_def getSlotCap_def getThreadCallerSlot_def locateSlot_conv) - apply (wp getThreadCallerSlot_inv cteDeleteOne_ct_not_ksQ getCTE_wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - done - -crunch tcb_at'[wp]: unbindNotification "tcb_at' x" - lemma finaliseCapTrue_standin_tcb_at' [wp]: "\tcb_at' x\ finaliseCapTrue_standin cap v2 \\_. tcb_at' x\" apply (simp add: finaliseCapTrue_standin_def Let_def) @@ -2108,39 +2076,11 @@ lemma cteDeleteOne_weak_sch_act[wp]: crunch weak_sch_act_wf[wp]: emptySlot "\s. weak_sch_act_wf (ksSchedulerAction s) s" crunch pred_tcb_at'[wp]: handleFaultReply "pred_tcb_at' proj P t" -crunch valid_queues[wp]: handleFaultReply "Invariants_H.valid_queues" -crunch valid_queues'[wp]: handleFaultReply "valid_queues'" crunch tcb_in_cur_domain'[wp]: handleFaultReply "tcb_in_cur_domain' t" crunch sch_act_wf[wp]: unbindNotification "\s. sch_act_wf (ksSchedulerAction s) s" (wp: sbn_sch_act') -crunch valid_queues'[wp]: cteDeleteOne valid_queues' - (simp: crunch_simps unless_def inQ_def - wp: crunch_wps sts_st_tcb' getObject_inv loadObject_default_inv - threadSet_valid_queues' rescheduleRequired_valid_queues'_weak) - -lemma cancelSignal_valid_queues'[wp]: - "\valid_queues'\ cancelSignal t ntfn \\rv. valid_queues'\" - apply (simp add: cancelSignal_def) - apply (rule hoare_pre) - apply (wp getNotification_wp| wpc | simp)+ - done - -lemma cancelIPC_valid_queues'[wp]: - "\valid_queues' and (\s. sch_act_wf (ksSchedulerAction s) s) \ cancelIPC t \\rv. valid_queues'\" - apply (simp add: cancelIPC_def Let_def getThreadReplySlot_def locateSlot_conv liftM_def) - apply (rule hoare_seq_ext[OF _ gts_sp']) - apply (case_tac state, simp_all) defer 2 - apply (rule hoare_pre) - apply ((wp getEndpoint_wp getCTE_wp | wpc | simp)+)[8] - apply (wp cteDeleteOne_valid_queues') - apply (rule_tac Q="\_. valid_queues' and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp) - apply (clarsimp simp: capHasProperty_def cte_wp_at_ctes_of) - apply (wp threadSet_valid_queues' threadSet_sch_act| simp)+ - apply (clarsimp simp: inQ_def) - done - crunch valid_objs'[wp]: handleFaultReply valid_objs' lemma cte_wp_at_is_reply_cap_toI: @@ -2148,6 +2088,17 @@ lemma cte_wp_at_is_reply_cap_toI: \ cte_wp_at (is_reply_cap_to t) ptr s" by (fastforce simp: cte_wp_at_reply_cap_to_ex_rights) +crunches handle_fault_reply + for pspace_aligned[wp]: pspace_aligned + and pspace_distinct[wp]: pspace_distinct + +crunches cteDeleteOne, doIPCTransfer, handleFaultReply + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + and pspace_aligned'[wp]: pspace_aligned' + and pspace_distinct'[wp]: pspace_distinct' + (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) + lemma doReplyTransfer_corres: "corres dc (einvs and tcb_at receiver and tcb_at sender @@ -2159,7 +2110,7 @@ lemma doReplyTransfer_corres: 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)+) + apply (rule getThreadState_corres, (fastforce simp add: st_tcb_at_tcb_at)+) apply (rule_tac F = "awaiting_reply state" in corres_req) apply (clarsimp simp add: st_tcb_at_def obj_at_def is_tcb) apply (fastforce simp: invs_def valid_state_def intro: has_reply_cap_cte_wpD @@ -2193,8 +2144,12 @@ lemma doReplyTransfer_corres: apply (rule corres_split[OF setThreadState_corres]) apply simp apply (rule possibleSwitchTo_corres) - apply (wp set_thread_state_runnable_valid_sched set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' sts_st_tcb' sts_valid_queues sts_valid_objs' delete_one_tcbDomain_obj_at' - | simp add: valid_tcb_state'_def)+ + 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]) @@ -2203,12 +2158,16 @@ lemma doReplyTransfer_corres: apply (fastforce) apply (clarsimp simp:is_cap_simps) apply (wp weak_valid_sched_action_lift)+ - apply (rule_tac Q="\_. valid_queues' and valid_objs' and cur_tcb' and tcb_at' receiver and (\s. sch_act_wf (ksSchedulerAction s) s)" in hoare_post_imp, simp add: sch_act_wf_weak) + 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) + apply (clarsimp simp: invs_psp_aligned invs_distinct) apply (rule conjI, erule invs_valid_objs) apply (rule conjI, clarsimp)+ apply (rule conjI) @@ -2232,10 +2191,13 @@ lemma doReplyTransfer_corres: 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 P="valid_sched and cur_tcb and tcb_at receiver" + apply (rule_tac P="valid_sched and cur_tcb and tcb_at receiver + and pspace_aligned and pspace_distinct" and P'="tcb_at' receiver and cur_tcb' - and (\s. weak_sch_act_wf (ksSchedulerAction s) s) - and Invariants_H.valid_queues and valid_queues' and valid_objs'" + and (\s. weak_sch_act_wf (ksSchedulerAction s) s) + and valid_objs' + and sym_heap_sched_pointers and valid_sched_pointers + and pspace_aligned' and pspace_distinct'" in corres_inst) apply (case_tac rvb, simp_all)[1] apply (rule corres_guard_imp) @@ -2243,25 +2205,27 @@ lemma doReplyTransfer_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_queues | simp | force simp: valid_sched_def valid_sched_action_def valid_tcb_state'_def)+ + apply (wp hoare_weak_lift_imp hoare_weak_lift_imp_conj + set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' + sts_st_tcb' sts_valid_objs' + | simp + | force simp: valid_sched_def valid_sched_action_def + valid_tcb_state'_def)+ apply (rule corres_guard_imp) apply (rule setThreadState_corres) apply clarsimp+ apply (wp threadSet_cur weak_sch_act_wf_lift_linear threadSet_pred_tcb_no_state - thread_set_not_state_valid_sched threadSet_valid_queues threadSet_valid_queues' + 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 (wp threadSet_cur weak_sch_act_wf_lift_linear threadSet_pred_tcb_no_state - thread_set_not_state_valid_sched threadSet_valid_queues threadSet_valid_queues' - | simp add: runnable_def inQ_def valid_tcb'_def)+ - apply (rule_tac Q="\_. valid_sched and cur_tcb and tcb_at sender and tcb_at receiver and valid_objs and pspace_aligned" + 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) + apply fastforce apply (rule_tac Q="\_. tcb_at' sender and tcb_at' receiver and invs'" in hoare_strengthen_post [rotated]) apply (solves\auto simp: invs'_def valid_state'_def\) @@ -2472,7 +2436,7 @@ proof - apply (rule setEndpoint_corres) apply (simp add: ep_relation_def) apply wp+ - apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def) + apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def invs_psp_aligned invs_distinct) apply clarsimp \ \concludes IdleEP if bl branch\ apply (simp add: ep_relation_def) @@ -2482,7 +2446,7 @@ proof - apply (rule setEndpoint_corres) apply (simp add: ep_relation_def) apply wp+ - apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def) + apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def invs_psp_aligned invs_distinct) apply clarsimp \ \concludes SendEP if bl branch\ apply (simp add: ep_relation_def) @@ -2521,10 +2485,12 @@ proof - 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 setThreadState_valid_queues' sts_valid_queues sts_weak_sch_act_wf + 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) + 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) @@ -2589,11 +2555,13 @@ proof - 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 setThreadState_valid_queues' sts_valid_queues sts_weak_sch_act_wf + 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)+)[1] + | 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) @@ -2619,8 +2587,6 @@ proof - done qed -crunch typ_at'[wp]: setMessageInfo "\s. P (typ_at' T p s)" - lemmas setMessageInfo_typ_ats[wp] = typ_at_lifts [OF setMessageInfo_typ_at'] (* Annotation added by Simon Winwood (Thu Jul 1 20:54:41 2010) using taint-mode *) @@ -2629,15 +2595,10 @@ declare tl_drop_1[simp] crunch cur[wp]: cancel_ipc "cur_tcb" (wp: crunch_wps simp: crunch_simps) -crunch valid_objs'[wp]: asUser "valid_objs'" - lemma valid_sched_weak_strg: "valid_sched s \ weak_valid_sched_action s" by (simp add: valid_sched_def valid_sched_action_def) -crunch weak_valid_sched_action[wp]: as_user weak_valid_sched_action - (wp: weak_valid_sched_action_lift) - lemma sendSignal_corres: "corres dc (einvs and ntfn_at ep) (invs' and ntfn_at' ep) (send_signal ep bg) (sendSignal ep bg)" @@ -2674,14 +2635,15 @@ lemma sendSignal_corres: apply (rule possibleSwitchTo_corres) apply wp apply (wp set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' - sts_valid_queues sts_st_tcb' hoare_disjI2 + 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 (clarsimp simp: invs'_def valid_state'_def sch_act_wf_weak - valid_tcb_state'_def) + 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)+ @@ -2707,23 +2669,23 @@ lemma sendSignal_corres: apply (rule corres_split[OF asUser_setRegister_corres]) apply (rule possibleSwitchTo_corres) apply ((wp | simp)+)[1] - apply (rule_tac Q="\_. Invariants_H.valid_queues and valid_queues' and - (\s. sch_act_wf (ksSchedulerAction s) s) and + apply (rule_tac Q="\_. (\s. sch_act_wf (ksSchedulerAction s) s) and cur_tcb' and - st_tcb_at' runnable' (hd list) and valid_objs'" + 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_queues setThreadState_valid_queues' - setThreadState_st_tcb + 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 (clarsimp 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 (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) @@ -2741,16 +2703,14 @@ lemma sendSignal_corres: apply (wp cur_tcb_lift | 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_queues setThreadState_valid_queues' - setThreadState_st_tcb - | 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 (clarsimp 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 (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] @@ -2781,38 +2741,6 @@ lemma possibleSwitchTo_sch_act[wp]: apply (auto simp: obj_at'_def projectKOs tcb_in_cur_domain'_def) done -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\" - apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs) - apply (wp hoare_drop_imps | wpc | simp)+ - apply (auto simp: valid_tcb'_def weak_sch_act_wf_def - dest: pred_tcb_at' - elim!: valid_objs_valid_tcbE) - done - -lemma possibleSwitchTo_ksQ': - "\(\s. t' \ set (ksReadyQueues s p) \ sch_act_not t' s) and K(t' \ t)\ - possibleSwitchTo t - \\_ s. t' \ set (ksReadyQueues s p)\" - apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs) - apply (wp hoare_weak_lift_imp rescheduleRequired_ksQ' tcbSchedEnqueue_ksQ threadGet_wp - | wpc - | simp split del: if_split)+ - apply (auto simp: obj_at'_def) - done - -lemma possibleSwitchTo_valid_queues'[wp]: - "\valid_queues' and (\s. sch_act_wf (ksSchedulerAction s) s) - and st_tcb_at' runnable' t\ - possibleSwitchTo t - \\rv. valid_queues'\" - apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs) - apply (wp hoare_weak_lift_imp threadGet_wp | wpc | simp)+ - apply (auto simp: obj_at'_def) - done - crunches possibleSwitchTo for st_refs_of'[wp]: "\s. P (state_refs_of' s)" and cap_to'[wp]: "ex_nonz_cap_to' p" @@ -2821,15 +2749,15 @@ crunches possibleSwitchTo (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'\" + "\if_live_then_nonz_cap' and ex_nonz_cap_to' t and (\s. sch_act_wf (ksSchedulerAction s) s) + and pspace_aligned' and pspace_distinct'\ + possibleSwitchTo t + \\_. if_live_then_nonz_cap'\" apply (simp add: possibleSwitchTo_def curDomain_def) apply (wp | wpc | simp)+ apply (simp only: imp_conv_disj, wp hoare_vcg_all_lift hoare_vcg_disj_lift) apply (wp threadGet_wp)+ - apply (auto simp: obj_at'_def projectKOs) + apply (auto simp: obj_at'_def) done crunches possibleSwitchTo @@ -2857,10 +2785,6 @@ crunches sendSignal, setBoundNotification rule: irqs_masked_lift) end -lemma sts_running_valid_queues: - "runnable' st \ \ Invariants_H.valid_queues \ setThreadState st t \\_. Invariants_H.valid_queues \" - by (wp sts_valid_queues, clarsimp) - 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) @@ -2873,24 +2797,21 @@ lemma setThreadState_nonqueued_state_update: \ st \ {Inactive, Running, Restart, IdleThreadState} \ (st \ Inactive \ ex_nonz_cap_to' t s) \ (t = ksIdleThread s \ idle' st) - - \ (\ runnable' st \ sch_act_simple s) - \ (\ runnable' st \ (\p. t \ set (ksReadyQueues s p)))\ - setThreadState st t \\rv. invs'\" + \ (\ 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 - sts_valid_queues - setThreadState_ct_not_inQ) + 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 (drule simple_st_tcb_at_state_refs_ofD') apply (drule bound_tcb_at_state_refs_ofD') - apply (rule conjI, fastforce) - 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 (rule conjI) + apply clarsimp + apply (erule delta_sym_refs) + apply (fastforce split: if_split_asm) + apply (fastforce simp: symreftype_inverse' tcb_bound_refs'_def split: if_split_asm) + apply fastforce done lemma cteDeleteOne_reply_cap_to'[wp]: @@ -2958,16 +2879,14 @@ lemma cancelAllIPC_not_rct[wp]: \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" apply (simp add: cancelAllIPC_def) apply (wp | wpc)+ + apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) + apply simp + apply (rule mapM_x_wp_inv) + apply (wp)+ apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) apply simp apply (rule mapM_x_wp_inv) - apply (wp)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wp)+ - apply (wp hoare_vcg_all_lift hoare_drop_imp) - apply (simp_all) + apply (wpsimp wp: hoare_vcg_all_lift hoare_drop_imp)+ done lemma cancelAllSignals_not_rct[wp]: @@ -2976,12 +2895,10 @@ lemma cancelAllSignals_not_rct[wp]: \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" apply (simp add: cancelAllSignals_def) apply (wp | wpc)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wp)+ - apply (wp hoare_vcg_all_lift hoare_drop_imp) - apply (simp_all) + 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 not_rct[wp]: finaliseCapTrue_standin "\s. ksSchedulerAction s \ ResumeCurrentThread" @@ -3065,7 +2982,6 @@ lemma sai_invs'[wp]: 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 - sts_valid_queues [where st="Structures_H.thread_state.Running", simplified] set_ntfn_valid_objs' cur_tcb_lift sts_st_tcb' hoare_convert_imp [OF setNotification_nosch] | simp split del: if_split)+ @@ -3152,6 +3068,8 @@ lemma replyFromKernel_corres: apply (rule setMessageInfo_corres) apply (wp hoare_case_option_wp hoare_valid_ipc_buffer_ptr_typ_at' | clarsimp)+ + apply fastforce + apply fastforce done lemma rfk_invs': @@ -3164,8 +3082,7 @@ lemma rfk_invs': crunch nosch[wp]: replyFromKernel "\s. P (ksSchedulerAction s)" lemma completeSignal_corres: - "corres dc (ntfn_at ntfnptr and tcb_at tcb and pspace_aligned and valid_objs - \ \and obj_at (\ko. ko = Notification ntfn \ Ipc_A.isActive ntfn) ntfnptr\) + "corres dc (ntfn_at ntfnptr and tcb_at tcb and pspace_aligned and pspace_distinct and valid_objs) (ntfn_at' ntfnptr and tcb_at' tcb and valid_pspace' and obj_at' isActive ntfnptr) (complete_signal ntfnptr tcb) (completeSignal ntfnptr tcb)" apply (simp add: complete_signal_def completeSignal_def) @@ -3189,10 +3106,9 @@ lemma completeSignal_corres: lemma doNBRecvFailedTransfer_corres: - "corres dc (tcb_at thread) - (tcb_at' thread) - (do_nbrecv_failed_transfer thread) - (doNBRecvFailedTransfer thread)" + "corres dc (tcb_at thread and pspace_aligned and pspace_distinct) \ + (do_nbrecv_failed_transfer thread) + (doNBRecvFailedTransfer thread)" unfolding do_nbrecv_failed_transfer_def doNBRecvFailedTransfer_def by (simp add: badgeRegister_def badge_register_def, rule asUser_setRegister_corres) @@ -3279,11 +3195,11 @@ lemma receiveIPC_corres: 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 Invariants_H.valid_queues - and valid_queues' and valid_pspace' and valid_objs' - and (\s. weak_sch_act_wf (ksSchedulerAction s) s)" + 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]) @@ -3292,17 +3208,18 @@ lemma receiveIPC_corres: apply (rule corres_split[OF setThreadState_corres]) apply simp apply (rule possibleSwitchTo_corres) - apply (wp sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action - | simp)+ - apply (wp sts_st_tcb_at'_cases sts_valid_queues setThreadState_valid_queues' - setThreadState_st_tcb + 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 (clarsimp simp: st_tcb_at_tcb_at st_tcb_def2 valid_sched_def - valid_sched_action_def) + 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" - in hoare_post_imp, erule sch_act_wf_weak) + 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 @@ -3325,13 +3242,13 @@ lemma receiveIPC_corres: apply wp+ apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, simp) apply simp - apply (clarsimp simp: valid_tcb_state_def) + apply (fastforce simp: valid_tcb_state_def) apply (clarsimp simp add: valid_tcb_state'_def) apply (wp get_simple_ko_wp[where f=Notification] getNotification_wp gbn_wp gbn_wp' hoare_vcg_all_lift hoare_vcg_imp_lift hoare_vcg_if_lift | wpc | simp add: ep_at_def2[symmetric, simplified] | clarsimp)+ apply (clarsimp simp: valid_cap_def invs_psp_aligned invs_valid_objs pred_tcb_at_def - valid_obj_def valid_tcb_def valid_bound_ntfn_def + valid_obj_def valid_tcb_def valid_bound_ntfn_def invs_distinct dest!: invs_valid_objs elim!: obj_at_valid_objsE split: option.splits) @@ -3368,7 +3285,7 @@ lemma receiveSignal_corres: apply (rule setNotification_corres) apply (simp add: ntfn_relation_def) apply wp+ - apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, simp+) + apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, fastforce+) \ \WaitingNtfn\ apply (simp add: ntfn_relation_def) apply (rule corres_guard_imp) @@ -3379,7 +3296,7 @@ lemma receiveSignal_corres: apply (simp add: ntfn_relation_def) apply wp+ apply (rule corres_guard_imp) - apply (rule doNBRecvFailedTransfer_corres, simp+) + apply (rule doNBRecvFailedTransfer_corres, fastforce+) \ \ActiveNtfn\ apply (simp add: ntfn_relation_def) apply (rule corres_guard_imp) @@ -3449,10 +3366,9 @@ lemma sendFaultIPC_corres: | 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 (simp add: valid_cap_def) - apply (clarsimp simp: valid_cap'_def inQ_def) - apply auto[1] - apply (clarsimp simp: lookup_failure_map_def) + apply (fastforce simp: valid_cap_def) + apply (fastforce simp: valid_cap'_def inQ_def) + apply (fastforce simp: lookup_failure_map_def) apply wp+ apply (fastforce elim: st_tcb_at_tcb_at) apply fastforce @@ -3467,14 +3383,14 @@ lemma gets_the_noop_corres: done lemma handleDoubleFault_corres: - "corres dc (tcb_at thread) + "corres dc (tcb_at thread and pspace_aligned and pspace_distinct) (tcb_at' thread and (\s. weak_sch_act_wf (ksSchedulerAction s) s)) (handle_double_fault thread f ft) (handleDoubleFault thread f' ft')" apply (simp add: handle_double_fault_def handleDoubleFault_def) apply (rule corres_guard_imp) apply (subst bind_return [symmetric], - rule corres_underlying_split [OF setThreadState_corres]) + rule corres_split [OF setThreadState_corres]) apply simp apply (rule corres_noop2) apply (simp add: exs_valid_def return_def) @@ -3498,10 +3414,6 @@ crunch typ_at'[wp]: receiveSignal "\s. P (typ_at' T p s)" lemmas receiveAIPC_typ_ats[wp] = typ_at_lifts [OF receiveSignal_typ_at'] -declare cart_singleton_empty[simp] - -declare cart_singleton_empty2[simp] - crunch aligned'[wp]: setupCallerCap "pspace_aligned'" (wp: crunch_wps) crunch distinct'[wp]: setupCallerCap "pspace_distinct'" @@ -3519,34 +3431,6 @@ lemma setupCallerCap_state_refs_of[wp]: apply (simp add: fun_upd_def cong: if_cong) done -crunch sch_act_wf: setupCallerCap - "\s. sch_act_wf (ksSchedulerAction s) s" - (wp: crunch_wps ssa_sch_act sts_sch_act rule: sch_act_wf_lift) - -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 vq[wp]: cteInsert "Invariants_H.valid_queues" - (wp: crunch_wps) - -crunch vq[wp]: getThreadCallerSlot "Invariants_H.valid_queues" - (wp: crunch_wps) - -crunch vq[wp]: getThreadReplySlot "Invariants_H.valid_queues" - (wp: crunch_wps) - -lemma setupCallerCap_vq[wp]: - "\Invariants_H.valid_queues and (\s. \p. send \ set (ksReadyQueues s p))\ - setupCallerCap send recv grant \\_. Invariants_H.valid_queues\" - apply (simp add: setupCallerCap_def) - apply (wp crunch_wps sts_valid_queues) - apply (fastforce simp: valid_queues_def obj_at'_def inQ_def) - done - -crunch vq'[wp]: setupCallerCap "valid_queues'" - (wp: crunch_wps) - 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)" @@ -3590,7 +3474,7 @@ lemma setupCallerCap_vp[wp]: declare haskell_assert_inv[wp del] lemma setupCallerCap_iflive[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' sender\ + "\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 @@ -3602,7 +3486,7 @@ lemma setupCallerCap_iflive[wp]: lemma setupCallerCap_ifunsafe[wp]: "\if_unsafe_then_cap' and valid_objs' and - ex_nonz_cap_to' rcvr and tcb_at' rcvr\ + 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 @@ -3624,13 +3508,11 @@ lemma setupCallerCap_global_refs'[wp]: \\rv. valid_global_refs'\" unfolding setupCallerCap_def getThreadCallerSlot_def getThreadReplySlot_def locateSlot_conv - apply (wp getSlotCap_cte_wp_at - | simp add: o_def unique_master_reply_cap' - | strengthen eq_imp_strg - | wp (once) getCTE_wp | clarsimp simp: cte_wp_at_ctes_of)+ - (* at setThreadState *) - apply (rule_tac Q="\_. valid_global_refs'" in hoare_post_imp, wpsimp+) - done + 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 valid_arch'[wp]: setupCallerCap "valid_arch_state'" (wp: hoare_drop_imps) @@ -3820,12 +3702,21 @@ crunches possibleSwitchTo and ioports'[wp]: valid_ioports' (wp: valid_ioports_lift' possibleSwitchTo_ctes_of crunch_wps ignore: constOnFailure) +crunches asUser + for valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift wp: crunch_wps) + +crunches setupCallerCap, possibleSwitchTo, doIPCTransfer + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + and valid_bitmaps[wp]: valid_bitmaps + (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) + (* t = ksCurThread s *) lemma ri_invs' [wp]: "\invs' and sch_act_not t and ct_in_state' simple' and st_tcb_at' simple' t - and (\s. \p. t \ set (ksReadyQueues s p)) and ex_nonz_cap_to' t and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s)\ receiveIPC t cap isBlocking @@ -3843,7 +3734,7 @@ lemma ri_invs' [wp]: 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 - sts_valid_queues setThreadState_ct_not_inQ + 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) @@ -3870,7 +3761,7 @@ lemma ri_invs' [wp]: 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 - sts_valid_queues setThreadState_ct_not_inQ + 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) @@ -3894,9 +3785,8 @@ lemma ri_invs' [wp]: 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' sts_valid_queues - setThreadState_ct_not_inQ possibleSwitchTo_valid_queues - possibleSwitchTo_valid_queues' + 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 @@ -3914,8 +3804,6 @@ lemma ri_invs' [wp]: st_tcb_at_refs_of_rev' conj_ac split del: if_split cong: if_cong) - apply (frule_tac t=sender in valid_queues_not_runnable'_not_ksQ) - apply (erule pred_tcb'_weakenE, clarsimp) apply (subgoal_tac "sch_act_not sender s") prefer 2 apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) @@ -3949,7 +3837,6 @@ lemma ri_invs' [wp]: lemma rai_invs'[wp]: "\invs' and sch_act_not t and st_tcb_at' simple' t - and (\s. \p. t \ set (ksReadyQueues s p)) and ex_nonz_cap_to' t and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s) and (\s. \ntfnptr. isNotificationCap cap @@ -3966,7 +3853,7 @@ lemma rai_invs'[wp]: apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) apply (wp valid_irq_node_lift sts_sch_act' typ_at_lifts - sts_valid_queues setThreadState_ct_not_inQ + setThreadState_ct_not_inQ asUser_urz | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def | wpc)+ apply (clarsimp simp: pred_tcb_at' valid_tcb_state'_def) @@ -3984,7 +3871,7 @@ lemma rai_invs'[wp]: apply (clarsimp split: if_split_asm) apply (fastforce simp: tcb_bound_refs'_def symreftype_inverse' split: if_split_asm) - apply (clarsimp dest!: global'_no_ex_cap) + 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) @@ -4004,7 +3891,7 @@ lemma rai_invs'[wp]: apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) apply (wp hoare_vcg_const_Ball_lift valid_irq_node_lift sts_sch_act' - sts_valid_queues setThreadState_ct_not_inQ typ_at_lifts + setThreadState_ct_not_inQ typ_at_lifts asUser_urz | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def | wpc)+ apply (clarsimp simp: valid_tcb_state'_def) @@ -4032,7 +3919,7 @@ lemma rai_invs'[wp]: 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 (clarsimp dest!: global'_no_ex_cap) + apply (fastforce dest!: global'_no_ex_cap) done lemma getCTE_cap_to_refs[wp]: @@ -4064,7 +3951,6 @@ lemma cteInsert_invs_bits[wp]: "\\s. sch_act_wf (ksSchedulerAction s) s\ cteInsert a b c \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\Invariants_H.valid_queues\ cteInsert a b c \\rv. Invariants_H.valid_queues\" "\cur_tcb'\ cteInsert a b c \\rv. cur_tcb'\" "\\s. P (state_refs_of' s)\ cteInsert a b c @@ -4089,9 +3975,12 @@ crunch irqs_masked'[wp]: possibleSwitchTo "irqs_masked'" crunch urz[wp]: possibleSwitchTo "untyped_ranges_zero'" (simp: crunch_simps unless_def wp: crunch_wps) +crunches possibleSwitchTo + for pspace_aligned'[wp]: pspace_aligned' + and pspace_distinct'[wp]: pspace_distinct' + lemma si_invs'[wp]: "\invs' and st_tcb_at' simple' t - and (\s. \p. t \ set (ksReadyQueues s p)) and sch_act_not t and ex_nonz_cap_to' ep and ex_nonz_cap_to' t\ sendIPC bl call ba cg cgr t ep @@ -4110,8 +3999,8 @@ lemma si_invs'[wp]: 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 sts_valid_queues setThreadState_ct_not_inQ - possibleSwitchTo_ksQ' possibleSwitchTo_ct_not_inQ hoare_vcg_all_lift sts_ksQ' + 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"] @@ -4165,8 +4054,7 @@ lemma si_invs'[wp]: 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' sts_valid_queues - setThreadState_ct_not_inQ) + 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") @@ -4185,8 +4073,7 @@ lemma si_invs'[wp]: 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' - sts_valid_queues setThreadState_ct_not_inQ) + 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) @@ -4213,19 +4100,15 @@ lemma si_invs'[wp]: lemma sfi_invs_plus': "\invs' and st_tcb_at' simple' t and sch_act_not t - and (\s. \p. t \ set (ksReadyQueues s p)) and ex_nonz_cap_to' t\ - sendFaultIPC t f - \\rv. invs'\, \\rv. invs' and st_tcb_at' simple' t - and (\s. \p. t \ set (ksReadyQueues s p)) - and sch_act_not t and (\s. ksIdleThread s \ t)\" + sendFaultIPC t f + \\_. invs'\, \\_. invs' and st_tcb_at' simple' t and sch_act_not t and (\s. ksIdleThread s \ t)\" apply (simp add: sendFaultIPC_def) apply (wp threadSet_invs_trivial threadSet_pred_tcb_no_state threadSet_cap_to' | wpc | simp)+ apply (rule_tac Q'="\rv s. invs' s \ sch_act_not t s \ st_tcb_at' simple' t s - \ (\p. t \ set (ksReadyQueues s p)) \ ex_nonz_cap_to' t s \ t \ ksIdleThread s \ (\r\zobj_refs' rv. ex_nonz_cap_to' r s)" @@ -4237,12 +4120,16 @@ lemma sfi_invs_plus': apply (subst(asm) global'_no_ex_cap, auto) done +crunches send_fault_ipc + for pspace_aligned[wp]: pspace_aligned + and psapce_distinct[wp]: pspace_distinct + (simp: crunch_simps wp: crunch_wps) + lemma handleFault_corres: "fr f f' \ corres dc (einvs and st_tcb_at active thread and ex_nonz_cap_to thread and (%_. valid_fault f)) (invs' and sch_act_not thread - and (\s. \p. thread \ set(ksReadyQueues s p)) 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) @@ -4270,17 +4157,13 @@ lemma sts_invs_minor'': \ (st \ Inactive \ \ idle' st \ st' \ Inactive \ \ idle' st')) t and (\s. t = ksIdleThread s \ idle' st) - and (\s. (\p. t \ set (ksReadyQueues s p)) \ runnable' st) - and (\s. runnable' st \ obj_at' tcbQueued t s - \ st_tcb_at' runnable' t s) 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' sts_valid_queues - setThreadState_ct_not_inQ) + apply (wp valid_irq_node_lift sts_sch_act' setThreadState_ct_not_inQ) apply clarsimp apply (rule conjI) apply fastforce @@ -4295,12 +4178,11 @@ lemma sts_invs_minor'': apply (clarsimp dest!: st_tcb_at_state_refs_ofD' elim!: rsubst[where P=sym_refs] intro!: ext) - apply (clarsimp elim!: st_tcb_ex_cap'') + apply (fastforce elim!: st_tcb_ex_cap'') done lemma hf_invs' [wp]: "\invs' and sch_act_not t - and (\s. \p. t \ set(ksReadyQueues s p)) and st_tcb_at' simple' t and ex_nonz_cap_to' t and (\s. t \ ksIdleThread s)\ handleFault t f \\r. invs'\" diff --git a/proof/refine/X64/KHeap_R.thy b/proof/refine/X64/KHeap_R.thy index 199dd740ef..e8e5790784 100644 --- a/proof/refine/X64/KHeap_R.thy +++ b/proof/refine/X64/KHeap_R.thy @@ -14,8 +14,46 @@ lemma lookupAround2_known1: "m x = Some y \ fst (lookupAround2 x m) = Some (x, y)" by (fastforce simp: lookupAround2_char1) +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 + context begin interpretation Arch . (*FIXME: arch_split*) +lemma setObject_modify_variable_size: + fixes v :: "'a :: pspace_storable" shows + "\obj_at' (P :: 'a \ bool) p s; updateObject v = updateObject_default v; + (1 :: machine_word) < 2 ^ objBits v; obj_at' (\obj. objBits v = objBits obj) p s\ + \ setObject p v s = modify (ksPSpace_update (\ps. ps (p \ injectKO v))) s" + supply projectKOs[simp] + apply (clarsimp simp: setObject_def split_def exec_gets obj_at'_def lookupAround2_known1 + assert_opt_def updateObject_default_def bind_assoc) + apply (simp add: projectKO_def alignCheck_assert) + apply (simp add: project_inject objBits_def) + apply (clarsimp simp only: koTypeOf_injectKO) + apply (frule in_magnitude_check[where s'=s]) + apply blast + apply fastforce + apply (simp add: magnitudeCheck_assert in_monad bind_def gets_def oassert_opt_def + get_def return_def) + apply (simp add: simpler_modify_def) + done + +lemma setObject_modify: + fixes v :: "'a :: pspace_storable" shows + "\obj_at' (P :: 'a \ bool) p s; updateObject v = updateObject_default v; + (1 :: machine_word) < 2 ^ objBits v; \ko. P ko \ objBits ko = objBits v \ + \ setObject p v s = modify (ksPSpace_update (\ps. ps (p \ injectKO v))) s" + apply (rule setObject_modify_variable_size) + apply fastforce + apply fastforce + apply fastforce + unfolding obj_at'_def + by fastforce + lemma obj_at_getObject: assumes R: "\a b p q n ko s obj::'a::pspace_storable. @@ -100,9 +138,223 @@ lemmas typ_at_to_obj_at_arches lemmas page_table_at_obj_at' = page_table_at'_def[unfolded typ_at_to_obj_at_arches] +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 projectKOs) + apply (erule (1) pspace_dom_relatedE) + by (clarsimp simp: obj_relation_cuts_def2 obj_at_def cte_relation_def + other_obj_relation_def pte_relation_def is_tcb_def pde_relation_def + pdpte_relation_def pml4e_relation_def + split: Structures_A.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) + +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 simp flip: shiftl_t2n') + 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_shiftl_self, simp) + + \\TCB\ + apply (clarsimp simp: tcbBlockSizeBits_def elim!: is_aligned_weaken) + + \\PTE\ + apply (clarsimp simp: archObjSize_def table_size_def ptTranslationBits_def) + apply (rule is_aligned_add) + apply (erule is_aligned_weaken) + apply simp + apply (simp add: word_size_bits_def) + apply (rule is_aligned_shift) + + \\PDE\ + apply (clarsimp simp: archObjSize_def table_size_def ptTranslationBits_def) + apply (rule is_aligned_add) + apply (erule is_aligned_weaken) + apply simp + apply (simp add: word_size_bits_def) + apply (rule is_aligned_shift) + + \\PDPTE\ + apply (clarsimp simp: archObjSize_def table_size_def ptTranslationBits_def) + apply (rule is_aligned_add) + apply (erule is_aligned_weaken) + apply simp + apply (simp add: word_size_bits_def) + apply (rule is_aligned_shift) + + \\PML4E\ + apply (clarsimp simp: archObjSize_def table_size_def ptTranslationBits_def) + apply (rule is_aligned_add) + apply (erule is_aligned_weaken) + apply simp + apply (simp add: word_size_bits_def) + apply (rule is_aligned_shift) + + \\DataPage\ + apply (rule is_aligned_add) + apply (erule is_aligned_weaken) + apply (rule pbfs_atleast_pageBits) + apply (rule is_aligned_mult_triv2) + + \\other_obj_relation\ + apply (simp add: other_obj_relation_def) + apply (clarsimp simp: tcbBlockSizeBits_def epSizeBits_def ntfnSizeBits_def + split: kernel_object.splits Structures_A.kernel_object.splits) + apply (fastforce simp: archObjSize_def split: arch_kernel_object.splits arch_kernel_obj.splits) + done + +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 bit_simps 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 simp flip: shiftl_t2n') + 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=tcbBlockSizeBits in exI) + apply (simp add: tcbBlockSizeBits_def) + apply (rule_tac x=word_size_bits in exI, simp add: bit_simps is_aligned_shift mask_def, word_bitwise) + apply (rule_tac x=word_size_bits in exI, simp add: bit_simps is_aligned_shift mask_def, word_bitwise) + apply (rule_tac x=word_size_bits in exI, simp add: bit_simps is_aligned_shift mask_def, word_bitwise) + apply (rule_tac x=word_size_bits in exI, simp add: bit_simps is_aligned_shift mask_def, word_bitwise) + apply (rule_tac x=pageBits in exI) + apply (simp add: is_aligned_mult_triv2 pbfs_atleast_pageBits) + apply (simp add: mask_def shiftl_t2n mult_ac pbfs_less_wb') + apply (erule word_less_power_trans2, rule pbfs_atleast_pageBits) + 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 bit_simps cte_level_bits_def + pbfs_atleast_pageBits[simplified bit_simps]) + prefer 5 + apply (cases ko; simp add: other_obj_relation_def objBits_defs split: kernel_object.splits) + apply (rename_tac ako, case_tac ako; clarsimp simp: archObjSize_def)+ + done + +lemmas is_aligned_add_step_le' = is_aligned_add_step_le[simplified mask_2pm1 add_diff_eq] + +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 (rule ps_clearI, assumption) + apply (case_tac ko'; simp add: objBits_simps objBits_defs pageBits_def) + apply (simp add: archObjSize_def pageBits_def split: arch_kernel_object.splits) + 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=cte_level_bits in is_aligned_add_step_le'; assumption?) + apply (rule is_aligned_add; (rule is_aligned_mult_triv2)?) + apply (erule is_aligned_weaken, simp add: cte_level_bits_def) + apply (rule is_aligned_add; (rule is_aligned_mult_triv2)?) + apply (erule is_aligned_weaken, simp add: cte_level_bits_def) + apply (simp add: cte_level_bits_def cteSizeBits_def) + apply (clarsimp simp: pte_relation_def objBits_simps archObjSize_def) + apply (rule_tac n=word_size_bits in is_aligned_add_step_le'; simp add: word_size_bits_def) + apply (clarsimp simp: pde_relation_def objBits_simps archObjSize_def) + apply (rule_tac n=word_size_bits in is_aligned_add_step_le'; simp add: word_size_bits_def) + apply (clarsimp simp: pdpte_relation_def objBits_simps archObjSize_def) + apply (rule_tac n=word_size_bits in is_aligned_add_step_le'; simp add: word_size_bits_def) + apply (clarsimp simp: pml4e_relation_def objBits_simps archObjSize_def) + apply (rule_tac n=word_size_bits in is_aligned_add_step_le'; simp add: word_size_bits_def) + 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: other_obj_relation_def) + apply (rename_tac ako, case_tac ako; simp add: is_other_obj_relation_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) + done + +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 project_inject pspace_distinct'_def pspace_aligned'_def projectKOs) + apply (drule bspec, erule domI)+ + apply (clarsimp simp: bit_simps objBits_simps' word_bits_def + split: kernel_object.splits arch_kernel_object.splits) + 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 projectKOs) + 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 corres_get_tcb: - "corres (tcb_relation \ the) (tcb_at t) (tcb_at' t) (gets (get_tcb t)) (getObject t)" + "corres (tcb_relation \ the) (tcb_at t and pspace_aligned and pspace_distinct) \ + (gets (get_tcb t)) (getObject t)" + apply (rule corres_cross_over_guard[where Q="tcb_at' t"]) + apply (fastforce simp: tcb_at_cross state_relation_def) apply (rule corres_no_failI) apply wp apply (clarsimp simp add: gets_def get_def return_def bind_def get_tcb_def) @@ -118,8 +370,7 @@ lemma corres_get_tcb: apply (drule bspec) apply clarsimp apply blast - apply (clarsimp simp add: other_obj_relation_def - lookupAround2_known1) + apply (clarsimp simp: tcb_relation_cut_def lookupAround2_known1) done lemma lookupAround2_same1[simp]: @@ -394,6 +645,40 @@ lemma setObject_tcb_strongest: ps_clear_upd) done +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 projectKOs + typeError_def opt_map_def opt_pred_def projectKO_opts_defs + split: if_split_asm + Structures_H.kernel_object.split_asm + +lemma setObject_endpoint_tcbs_of'[wp]: + "setObject c (endpoint :: endpoint) \\s. P' (tcbs_of' s)\" + by setObject_easy_cases + +lemma setObject_notification_tcbs_of'[wp]: + "setObject c (notification :: notification) \\s. P' (tcbs_of' s)\" + by setObject_easy_cases + +lemma setObject_cte_tcbSchedNexts_of[wp]: + "setObject c (cte :: cte) \\s. P' (tcbSchedNexts_of s)\" + by setObject_easy_cases + +lemma setObject_cte_tcbSchedPrevs_of[wp]: + "setObject c (cte :: cte) \\s. P' (tcbSchedPrevs_of s)\" + by setObject_easy_cases + +lemma setObject_cte_tcbQueued[wp]: + "setObject c (cte :: cte) \\s. P' (tcbQueued |< tcbs_of' s)\" + supply inQ_def[simp] + by setObject_easy_cases + +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 getObject_obj_at': assumes x: "\q n ko. loadObject p q n ko = (loadObject_default p q n ko :: ('a :: pspace_storable) kernel)" @@ -921,7 +1206,7 @@ lemma obj_relation_cut_same_type: \ (\sz sz'. a_type ko = AArch (ADeviceData sz) \ a_type ko' = AArch (ADeviceData sz'))" apply (rule ccontr) apply (simp add: obj_relation_cuts_def2 a_type_def) - by (auto simp: other_obj_relation_def cte_relation_def + by (auto simp: other_obj_relation_def cte_relation_def tcb_relation_cut_def pte_relation_def pde_relation_def pdpte_relation_def pml4e_relation_def split: Structures_A.kernel_object.split_asm if_split_asm @@ -939,6 +1224,16 @@ 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\ + \ tcbs_of' (s'\ksPSpace := (ksPSpace s')(ptr \ ko)\) = tcbs_of' s'" + by (fastforce simp: typ_at'_def ko_wp_at'_def opt_map_def projectKO_opts_defs + split: kernel_object.splits) + +lemma typ_at'_koTypeOf: + "ko_at' ob' ptr b \ typ_at' (koTypeOf (injectKO ob')) ptr b" + by (auto simp: typ_at'_def ko_wp_at'_def obj_at'_def project_inject projectKOs) + lemma setObject_other_corres: fixes ob' :: "'a :: pspace_storable" assumes x: "updateObject ob' = updateObject_default ob'" @@ -968,7 +1263,7 @@ lemma setObject_other_corres: 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 (extract_conjunct \match conclusion in "ghost_relation _ _ _" \ -\) apply (clarsimp simp add: ghost_relation_def) apply (erule_tac x=ptr in allE)+ apply (clarsimp simp: obj_at_def a_type_def @@ -978,6 +1273,14 @@ lemma setObject_other_corres: apply (simp only: pspace_relation_def pspace_dom_update dom_fun_upd2 simp_thms) apply (elim conjE) apply (frule bspec, erule domI) + apply (prop_tac "typ_at' (koTypeOf (injectKO ob')) ptr b") + subgoal + by (clarsimp simp: typ_at'_def ko_wp_at'_def obj_at'_def projectKO_opts_defs + 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 clarsimp apply (rule conjI) apply (rule ballI, drule(1) bspec) apply (drule domD) @@ -986,28 +1289,30 @@ lemma setObject_other_corres: apply clarsimp apply (frule_tac ko'=ko and x'=ptr in obj_relation_cut_same_type, (fastforce simp add: is_other_obj_relation_type t)+) - apply (erule disjE) - apply (simp add: is_other_obj_relation_type t) - apply (erule disjE) - apply (insert t, - clarsimp simp: is_other_obj_relation_type_CapTable a_type_def) - apply (erule disjE) - apply (insert t, clarsimp simp: is_other_obj_relation_type_UserData a_type_def) - apply (insert t, clarsimp simp: is_other_obj_relation_type_DeviceData a_type_def) - 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) - by (clarsimp simp: is_other_obj_relation_type t exst_same_def - split: Structures_A.kernel_object.splits Structures_H.kernel_object.splits - X64_A.arch_kernel_obj.splits)+ + apply (insert t) + apply ((erule disjE + | 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 @@ -1100,13 +1405,14 @@ lemma typ_at'_valid_obj'_lift: 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, + 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 valid_bound_ntfn'_def - split: option.splits, - wpsimp) + simp add: valid_tcb'_def valid_tcb_state'_def split_def none_top_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) @@ -1389,32 +1695,6 @@ lemma set_ep_bitmapQ_no_L2_orphans[wp]: apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp add: bitmapQ_def)+ done -lemma set_ep_valid_queues[wp]: - "\Invariants_H.valid_queues\ setEndpoint epptr ep \\rv. Invariants_H.valid_queues\" - apply (simp add: Invariants_H.valid_queues_def) - apply (wp hoare_vcg_conj_lift) - apply (simp add: setEndpoint_def valid_queues_no_bitmap_def) - apply (wp hoare_Ball_helper hoare_vcg_all_lift) - apply (rule obj_at_setObject2) - apply (clarsimp simp: updateObject_default_def in_monad) - apply (wp updateObject_default_inv set_ep_valid_bitmapQ[unfolded setEndpoint_def] - | simp add: valid_queues_no_bitmap_def)+ - done - -lemma set_ep_valid_queues'[wp]: - "\valid_queues'\ setEndpoint epptr ep \\rv. valid_queues'\" - apply (unfold setEndpoint_def) - apply (simp only: valid_queues'_def imp_conv_disj - obj_at'_real_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - apply (rule setObject_ko_wp_at) - apply simp - apply (simp add: objBits_simps') - apply simp - apply (wp updateObject_default_inv | simp)+ - apply (clarsimp simp: projectKOs ko_wp_at'_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\" @@ -1614,34 +1894,6 @@ lemma set_ntfn_bitmapQ_no_L2_orphans[wp]: apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp)+ done -lemma set_ntfn_valid_queues[wp]: - "\Invariants_H.valid_queues\ setNotification p ntfn \\rv. Invariants_H.valid_queues\" - apply (simp add: Invariants_H.valid_queues_def) - apply (rule hoare_pre) - apply (wp hoare_vcg_conj_lift) - apply (simp add: setNotification_def valid_queues_no_bitmap_def) - apply (wp hoare_Ball_helper hoare_vcg_all_lift) - apply (rule obj_at_setObject2) - apply (clarsimp simp: updateObject_default_def in_monad) - apply (wp updateObject_default_inv set_ep_valid_bitmapQ[unfolded setEndpoint_def] - | simp add: valid_queues_no_bitmap_def)+ - done - -lemma set_ntfn_valid_queues'[wp]: - "\valid_queues'\ setNotification p ntfn \\rv. valid_queues'\" - apply (unfold setNotification_def) - apply (rule setObject_ntfn_pre) - apply (simp only: valid_queues'_def imp_conv_disj - obj_at'_real_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - apply (rule setObject_ko_wp_at) - apply simp - apply (simp add: objBits_simps') - apply simp - apply (wp updateObject_default_inv | simp)+ - apply (clarsimp simp: projectKOs ko_wp_at'_def) - 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)))\ @@ -2052,6 +2304,21 @@ lemma setNotification_ct_idle_or_in_cur_domain'[wp]: crunch gsUntypedZeroRanges[wp]: setNotification "\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)\" + assumes nexts: "\P. f \\s. P (tcbSchedNexts_of s)\" + shows "f \sym_heap_sched_pointers\" + by (rule_tac f=tcbSchedPrevs_of in hoare_lift_Pf2; wpsimp wp: assms) + +crunches setNotification + for tcbSchedNexts_of[wp]: "\s. P (tcbSchedNexts_of s)" + and tcbSchedPrevs_of[wp]: "\s. P (tcbSchedPrevs_of s)" + and valid_sched_pointers[wp]: valid_sched_pointers + and ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" + and ksReadyQueuesL1Bitmap[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" + and ksReadyQueuesL2Bitmap[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" + (simp: updateObject_default_def) + lemma set_ntfn_minor_invs': "\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)) @@ -2061,9 +2328,10 @@ lemma set_ntfn_minor_invs': and (\s. ptr \ ksIdleThread s) \ setNotification ptr val \\rv. invs'\" - apply (clarsimp simp add: invs'_def valid_state'_def cteCaps_of_def) - apply (wp irqs_masked_lift valid_irq_node_lift untyped_ranges_zero_lift, - simp_all add: o_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')+ @@ -2149,21 +2417,17 @@ crunch typ_at'[wp]: doMachineOp "\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'\" + "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 - valid_pspace'_def valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs - | wp cur_tcb_lift sch_act_wf_lift tcb_in_cur_domain'_lift - | fastforce elim: state_refs_of'_pspaceI)+ + | wp + | fastforce elim: state_refs_of'_pspaceI)+ crunch obj_at'[wp]: doMachineOp "\s. P (obj_at' P' p s)" @@ -2193,5 +2457,15 @@ lemma obj_at'_is_canonical: apply (clarsimp simp: obj_at'_def pspace_canonical'_def projectKOs) by (drule_tac x=t in bspec) clarsimp+ +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 aligned'_distinct'_ko_at'I = aligned_distinct_obj_atI' + end end diff --git a/proof/refine/X64/Refine.thy b/proof/refine/X64/Refine.thy index 530bbac778..9b579df531 100644 --- a/proof/refine/X64/Refine.thy +++ b/proof/refine/X64/Refine.thy @@ -80,7 +80,7 @@ lemma typ_at_UserDataI: apply (drule (1) bspec) apply clarsimp apply (subst mask_lower_twice [where n = pageBits, OF pbfs_atleast_pageBits, symmetric]) - apply (clarsimp simp: obj_relation_cuts_def2 pte_relation_def + apply (clarsimp simp: obj_relation_cuts_def2 pte_relation_def tcb_relation_cut_def cte_relation_def other_obj_relation_def pde_relation_def pdpte_relation_def pml4e_relation_def split: Structures_A.kernel_object.split_asm @@ -111,7 +111,7 @@ lemma typ_at_DeviceDataI: apply (drule (1) bspec) apply clarsimp apply (subst mask_lower_twice [where n = pageBits, OF pbfs_atleast_pageBits, symmetric]) - apply (clarsimp simp: obj_relation_cuts_def2 pte_relation_def + apply (clarsimp simp: obj_relation_cuts_def2 pte_relation_def tcb_relation_cut_def cte_relation_def other_obj_relation_def pde_relation_def pdpte_relation_def pml4e_relation_def split: Structures_A.kernel_object.split_asm @@ -558,7 +558,7 @@ lemma kernel_corres': apply simp apply (rule handleInterrupt_corres[simplified dc_def]) apply simp - apply (wp hoare_drop_imps hoare_vcg_all_lift)[1] + 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' \ @@ -635,7 +635,7 @@ lemma entry_corres: apply (rule corres_split[OF getCurThread_corres]) apply (rule corres_split) apply simp - apply (rule threadset_corresT) + 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) @@ -647,7 +647,7 @@ lemma entry_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, simp add: invs_def cur_tcb_def) + 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' @@ -655,8 +655,8 @@ lemma entry_corres: 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) + | (wps, wp threadSet_st_tcb_at2))+ + apply (fastforce simp: invs_def cur_tcb_def) apply (clarsimp simp: ct_in_state'_def) done diff --git a/proof/refine/X64/Retype_R.thy b/proof/refine/X64/Retype_R.thy index b63669123a..1e87a9df47 100644 --- a/proof/refine/X64/Retype_R.thy +++ b/proof/refine/X64/Retype_R.thy @@ -315,7 +315,7 @@ lemma state_relation_null_filterE: null_filter (caps_of_state t) = null_filter (caps_of_state s); null_filter' (ctes_of t') = null_filter' (ctes_of s'); pspace_relation (kheap t) (ksPSpace t'); - ekheap_relation (ekheap t) (ksPSpace 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'; @@ -1003,7 +1003,7 @@ lemma retype_ekheap_relation: apply (intro impI conjI) apply clarsimp apply (drule_tac x=a in bspec,force) - apply (clarsimp simp add: other_obj_relation_def split: if_split_asm) + 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 X64_H.object_type.splits @@ -1193,6 +1193,149 @@ lemma update_gs_simps[simp]: gsUserPages_update (\ups x. if x \ ptrs then Some X64HugePage else ups x)" by (simp_all add: update_gs_def) +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 - + 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_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 "\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 (fastforce simp: ptr_add_def p_assoc_help) + done +qed + +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 + "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 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_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 + "tcbSchedNexts_of + (s'\ksPSpace := foldr (\addr. data_map_insert addr ko) (new_cap_addrs m ptr ko) (ksPSpace s')\) + = tcbSchedNexts_of s'" +proof - + 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 + 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 + 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 ksReadyQueues_update_gs[simp]: + "ksReadyQueues (update_gs tp us addrs s) = ksReadyQueues s" + by (simp add: update_gs_def + split: aobject_type.splits Structures_A.apiobject_type.splits) + lemma retype_state_relation: notes data_map_insert_def[simp del] assumes sr: "(s, s') \ state_relation" @@ -1221,7 +1364,7 @@ lemma retype_state_relation: \ state_relation" (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) + 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 ko] num_r]) @@ -1410,6 +1553,16 @@ lemma retype_state_relation: else cns x" in exI, simp) apply (rule_tac x=id in exI, simp)+ done + + have rdyqrel: "ready_queues_relation s s'" + using sr by (simp add: state_relation_def) + + thus "ready_queues_relation_2 (ready_queues s) (ksReadyQueues s') + (?ps' |> tcb_of' |> tcbSchedNext) (?ps' |> tcb_of' |> tcbSchedPrev) + (\d p. inQ d p |< (?ps' |> tcb_of'))" + using retype_ready_queues_relation[OF _ vs' pn' ko cover num_r] + by (clarsimp simp: ready_queues_relation_def Let_def) + qed lemma new_cap_addrs_fold': @@ -2432,7 +2585,6 @@ qed lemma other_objs_default_relation: "\ case ty of Structures_A.EndpointObject \ ko = injectKO (makeObject :: endpoint) | Structures_A.NotificationObject \ ko = injectKO (makeObject :: Structures_H.notification) - | Structures_A.TCBObject \ ko = injectKO (makeObject :: tcb) | _ \ False \ \ obj_relation_retype (default_object ty dev n) ko" apply (rule obj_relation_retype_other_obj) @@ -2453,6 +2605,13 @@ lemma other_objs_default_relation: split: Structures_A.apiobject_type.split_asm) done +lemma tcb_relation_retype: + "obj_relation_retype (default_object Structures_A.TCBObject dev n) (KOTCB makeObject)" + by (clarsimp simp: default_object_def obj_relation_retype_def tcb_relation_def default_tcb_def + makeObject_tcb makeObject_cte new_context_def newContext_def + fault_rel_optionation_def initContext_def default_arch_tcb_def newArchTCB_def + arch_tcb_relation_def objBits_simps' tcb_relation_cut_def) + lemma captable_relation_retype: "n < word_bits \ obj_relation_retype (default_object Structures_A.CapTableObject dev n) (KOCTE makeObject)" @@ -2595,6 +2754,7 @@ lemma ksMachineState_update_gs[simp]: "ksMachineState (update_gs tp us addrs s) = ksMachineState s" by (simp add: update_gs_def split: aobject_type.splits Structures_A.apiobject_type.splits) + lemma update_gs_ksMachineState_update_swap: "update_gs tp us addrs (ksMachineState_update f s) = ksMachineState_update f (update_gs tp us addrs s)" @@ -3230,10 +3390,10 @@ proof (intro conjI impI) apply (rule_tac ptr="x + xa" in cte_wp_at_tcbI', assumption+) apply fastforce apply simp - apply (rename_tac thread_state mcp priority bool option nat cptr vptr bound user_context) - apply (case_tac thread_state, simp_all add: valid_tcb_state'_def - valid_bound_ntfn'_def obj_at_disj' - split: option.splits)[2] + 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' none_top_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)]) @@ -3960,16 +4120,6 @@ lemma sch_act_wf_lift_asm: apply auto done -lemma valid_queues_lift_asm': - assumes tat: "\d p t. \\s. \ obj_at' (inQ d p) t s \ Q d p s\ f \\_ s. \ obj_at' (inQ d p) t s\" - and prq: "\P. \\s. P (ksReadyQueues s)\ f \\_ s. P (ksReadyQueues s)\" - shows "\\s. valid_queues' s \ (\d p. Q d p s)\ f \\_. valid_queues'\" - apply (simp only: valid_queues'_def imp_conv_disj) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift - tat prq) - apply simp - done - lemma createObjects'_ct[wp]: "\\s. P (ksCurThread s)\ createObjects' p n v us \\rv s. P (ksCurThread s)\" by (rule createObjects_pspace_only, simp) @@ -4368,35 +4518,157 @@ crunch ksMachine[wp]: createObjects "\s. P (ksMachineState s)" crunch cur_domain[wp]: createObjects "\s. P (ksCurDomain s)" (simp: unless_def) -lemma createNewCaps_valid_queues': - "\valid_queues' and pspace_no_overlap' ptr sz - 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_queues'\" - apply (wp valid_queues_lift_asm' [OF createNewCaps_obj_at2]) - apply (clarsimp simp: projectKOs) - apply (simp add: makeObjectKO_def - split: object_type.split_asm - apiobject_type.split_asm) - apply (clarsimp simp: inQ_def) - apply (auto simp: makeObject_tcb - split: object_type.splits apiobject_type.splits) +lemma createObjects_valid_bitmaps: + "createObjects' ptr n val gbits \valid_bitmaps\" + apply (clarsimp simp: createObjects'_def alignError_def split_def) + apply (wp case_option_wp[where P="\_. P" and P'=P for P, simplified] assert_inv + | clarsimp simp del: fun_upd_apply)+ + apply (clarsimp simp: valid_bitmaps_def valid_bitmapQ_def bitmapQ_def bitmapQ_no_L2_orphans_def + bitmapQ_no_L1_orphans_def) done -lemma createNewCaps_valid_queues: - "\valid_queues and pspace_no_overlap' ptr sz - 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_queues\" - apply (rule hoare_gen_asm) - apply (wpsimp wp: valid_queues_lift_asm createNewCaps_obj_at2[where sz=sz]) - apply (clarsimp simp: projectKO_opts_defs) - apply (simp add: inQ_def) - apply (wpsimp wp: createNewCaps_pred_tcb_at'[where sz=sz])+ +lemma valid_bitmaps_gsCNodes_update[simp]: + "valid_bitmaps (gsCNodes_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) + +lemma valid_bitmaps_gsUserPages_update[simp]: + "valid_bitmaps (gsUserPages_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) + +crunches curDomain, copyGlobalMappings + for valid_bitmaps[wp]: valid_bitmaps + and sched_pointers[wp]: "\s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)" + and valid_sched_pointers[wp]: valid_sched_pointers + (wp: crunch_wps valid_bitmaps_lift) + +lemma createNewCaps_valid_bitmaps: + "\\s. valid_pspace' s \ pspace_no_overlap' ptr sz s \ valid_bitmaps s\ + createNewCaps ty ptr n us dev + \\_. valid_bitmaps\" + unfolding createNewCaps_def + apply (clarsimp simp: X64_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 (wpsimp wp: createObjects_valid_bitmaps) + by (wpsimp wp: createObjects_valid_bitmaps[simplified o_def] mapM_x_wp + | simp add: makeObject_tcb objBits_def createObjects_def + | intro conjI impI)+ + +lemma createObjects_sched_queues: + "\\s. n \ 0 + \ range_cover ptr sz (objBitsKO val + gbits) n + \ P (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ (case val of KOTCB tcb \ tcbSchedNext tcb = None \ tcbSchedPrev tcb = None + | _ \ True) + \ pspace_aligned' s \ pspace_distinct' s + \ pspace_no_overlap' ptr sz s\ + createObjects' ptr n val gbits + \\_ s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of 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 \\_ s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" + proof - + have shiftr_not_zero:" 1 \ ((of_nat n)::machine_word) << gbits" + using range_cover_not_zero_shift[OF not_0 cover,where gbits = gbits] + by (simp add:word_le_sub1) + show ?thesis + supply projectKOs[simp] + apply (clarsimp simp: createObjects'_def unless_def alignError_def split_def) + apply (wp | clarsimp simp del: fun_upd_apply)+ + 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 (clarsimp simp: foldr_upd_app_if) + apply (rule_tac a="tcbSchedNexts_of s" and b="tcbSchedPrevs_of s" + in rsubst2[rotated, OF sym sym, where P=P]) + apply (rule ext) + apply (clarsimp simp: opt_map_def) + apply (frule (3) retype_ksPSpace_None[simplified mult.commute]) + apply (fastforce intro: cover) + apply fastforce + apply (clarsimp split: kernel_object.splits option.splits) + apply (rule ext) + apply (clarsimp simp: opt_map_def) + apply (frule (3) retype_ksPSpace_None[simplified mult.commute]) + apply (fastforce intro: cover) + apply fastforce + apply (clarsimp split: kernel_object.splits option.splits) + apply simp + done + qed + qed +qed + +lemma createNewCaps_sched_queues: + assumes cover: "range_cover ptr sz (APIType_capBits ty us) n" + assumes not_0: "n \ 0" + shows + "\\s. valid_pspace' s \ pspace_no_overlap' ptr sz s + \ P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\ + createNewCaps ty ptr n us dev + \\_ s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" + unfolding createNewCaps_def + apply (clarsimp simp: X64_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) + apply (wpsimp wp: mapM_x_wp' createObjects_sched_queues + simp: curDomain_def) + by (wpsimp wp: mapM_x_wp' createObjects_sched_queues[simplified o_def] + threadSet_sched_pointers + | simp add: objBitsKO_def APIType_capBits_def valid_pspace'_def makeObject_tcb + objBits_def archObjSize_def createObjects_def + bit_simps + | intro conjI impI)+ + +lemma createObjects_valid_sched_pointers: + "\\s. valid_sched_pointers s + \ (case val of KOTCB tcb \ tcbSchedNext tcb = None \ tcbSchedPrev tcb = None + | _ \ True)\ + createObjects' ptr n val gbits + \\_. valid_sched_pointers\" + supply projectKOs[simp] + apply (clarsimp simp: createObjects'_def unless_def alignError_def split_def) + apply (wp case_option_wp[where P="\_. P" and P'=P for P, simplified] assert_inv + | clarsimp simp del: fun_upd_apply)+ + apply (clarsimp simp: valid_sched_pointers_def foldr_upd_app_if opt_pred_def opt_map_def comp_def) + apply (cases "tcb_of' val"; clarsimp) done +lemma createNewCaps_valid_sched_pointers: + "\\s. valid_pspace' s \ pspace_no_overlap' ptr sz s \ valid_sched_pointers s\ + createNewCaps ty ptr n us dev + \\_. valid_sched_pointers\" + unfolding createNewCaps_def + apply (clarsimp simp: X64_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 (wpsimp wp: createObjects_valid_sched_pointers) + by (wpsimp wp: createObjects_valid_sched_pointers[simplified o_def] mapM_x_wp + threadSet_valid_sched_pointers + | simp add: makeObject_tcb objBits_def createObjects_def + | intro conjI impI)+ + lemma mapM_x_threadSet_valid_pspace: "\valid_pspace' and K (curdom \ maxDomain)\ mapM_x (threadSet (tcbDomain_update (\_. curdom))) addrs \\y. valid_pspace'\" @@ -4783,12 +5055,13 @@ proof (rule hoare_gen_asm, elim conjE) createNewCaps_valid_arch_state valid_irq_node_lift_asm [unfolded pred_conj_def, OF _ createNewCaps_obj_at'] createNewCaps_irq_handlers' createNewCaps_vms createNewCaps_ioports' - createNewCaps_valid_queues - createNewCaps_valid_queues' createNewCaps_pred_tcb_at' cnc_ct_not_inQ createNewCaps_ct_idle_or_in_cur_domain' createNewCaps_sch_act_wf createNewCaps_urz[where sz=sz] + createNewCaps_sched_queues[OF cover not_0] + createNewCaps_valid_sched_pointers + createNewCaps_valid_bitmaps | simp)+ using not_0 apply (clarsimp simp: valid_pspace'_def) @@ -4861,35 +5134,6 @@ lemma createObjects_sch: apply (wp sch_act_wf_lift_asm createObjects_pred_tcb_at' createObjects_orig_obj_at3 | force)+ done -lemma createObjects_queues: - "\\s. valid_queues 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. valid_queues\" - apply (wpsimp wp: valid_queues_lift_asm [unfolded pred_conj_def, OF createObjects_orig_obj_at3] - createObjects_pred_tcb_at' [unfolded pred_conj_def]) - apply fastforce - apply wp+ - apply fastforce - done - -lemma createObjects_queues': - assumes no_tcb: "\t. projectKO_opt val \ Some (t::tcb)" - shows - "\\s. valid_queues' 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. valid_queues'\" - apply (simp add: createObjects_def) - apply (wp valid_queues_lift_asm') - apply (wp createObjects_orig_obj_at2') - apply clarsimp - apply assumption - apply wp - apply (clarsimp simp: no_tcb split: option.splits) - apply fastforce - done - lemma createObjects_no_cte_ifunsafe': assumes no_cte: "\c. projectKO_opt val \ Some (c::cte)" assumes no_tcb: "\t. projectKO_opt val \ Some (t::tcb)" @@ -5155,43 +5399,53 @@ proof - apply (simp)+ done show ?thesis - 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 createObjects_queues) - 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' - createObjects_queues' [OF no_tcb] createObjects_no_cte_ioports - 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' - createObjects_queues' [OF no_tcb] assms - createObjects_pspace_domain_valid co_ct_not_inQ - createObjects_ct_idle_or_in_cur_domain' createObjects_no_cte_ioports - 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 (clarsimp simp: invs'_def no_tcb valid_state'_def no_cte split: option.splits) - 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' assms) + apply (rule hoare_vcg_conj_lift) + apply (simp add: createObjects_def) + apply (wp createObjects_idle') + apply (wp irqs_masked_lift createObjects_no_cte_valid_global + createObjects_valid_arch createObjects_irq_state + createObjects_no_cte_irq_handlers createObjects_no_cte_ioports assms + | 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] + createObjects_sched_queues + | 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: @@ -5227,7 +5481,7 @@ lemma gcd_corres: "corres (=) \ \ (gets cur_domain) curDomain" 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. 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 @@ -5238,7 +5492,7 @@ lemma retype_region2_extra_ext_mapM_x_corres: 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. tcb_at' t s" + and P'="\s. \t \ set addrs. obj_at' (Not \ tcbQueued) t s" in corres_mapM_x) apply simp apply (rule corres_guard_imp) @@ -5246,8 +5500,10 @@ lemma retype_region2_extra_ext_mapM_x_corres: apply (case_tac tcb') apply simp apply fastforce - 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 @@ -5280,10 +5536,11 @@ lemma retype_region2_obj_at: apply (auto simp: obj_at_def default_object_def is_tcb_def) done -lemma createObjects_tcb_at': +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\ - createObjects ptr n (KOTCB makeObject) 0 \\ptrs s. \addr\set ptrs. tcb_at' addr 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 @@ -5391,8 +5648,9 @@ lemma corres_retype_region_createNewCaps: apply (rule corres_retype[where 'a = tcb], simp_all add: obj_bits_api_def objBits_simps' pageBits_def APIType_map2_def makeObjectKO_def - other_objs_default_relation)[1] + tcb_relation_retype)[1] apply (fastforce simp: range_cover_def) + apply (simp add: tcb_relation_retype) apply (rule corres_split_nor) apply (simp add: APIType_map2_def) apply (rule retype_region2_extra_ext_mapM_x_corres) @@ -5402,7 +5660,7 @@ lemma corres_retype_region_createNewCaps: apply wp apply wp apply ((wp retype_region2_obj_at | simp add: APIType_map2_def)+)[1] - apply ((wp createObjects_tcb_at'[where sz=sz] + apply ((wp createObjects_Not_tcbQueued[where sz=sz] | simp add: APIType_map2_def objBits_simps' obj_bits_api_def)+)[1] apply simp apply simp diff --git a/proof/refine/X64/Schedule_R.thy b/proof/refine/X64/Schedule_R.thy index 4d6bf37acf..06186ff96d 100644 --- a/proof/refine/X64/Schedule_R.thy +++ b/proof/refine/X64/Schedule_R.thy @@ -15,11 +15,6 @@ declare hoare_weak_lift_imp[wp_split del] (* Levity: added (20090713 10:04:12) *) declare sts_rel_idle [simp] -lemma invs_no_cicd'_queues: - "invs_no_cicd' s \ valid_queues s" - unfolding invs_no_cicd'_def - by simp - 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)" @@ -86,227 +81,231 @@ lemma schedule_choose_new_thread_sched_act_rct[wp]: unfolding schedule_choose_new_thread_def by wp +\ \This proof shares many similarities with the proof of @{thm tcbSchedEnqueue_corres}\ lemma tcbSchedAppend_corres: - notes trans_state_update'[symmetric, simp del] - shows - "corres dc (is_etcb_at t) (tcb_at' t and Invariants_H.valid_queues and valid_queues') (tcb_sched_action (tcb_sched_append) t) (tcbSchedAppend t)" - apply (simp only: tcbSchedAppend_def tcb_sched_action_def) - apply (rule corres_symb_exec_r [OF _ _ threadGet_inv, 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, simp) - apply (rule no_fail_pre, wp, simp) - apply (case_tac queued) - apply (simp add: unless_def when_def) - apply (rule corres_no_failI) - apply wp+ - apply (clarsimp simp: in_monad ethread_get_def gets_the_def bind_assoc - assert_opt_def exec_gets is_etcb_at_def get_etcb_def get_tcb_queue_def - set_tcb_queue_def simpler_modify_def) - - apply (subgoal_tac "tcb_sched_append t (ready_queues a (tcb_domain y) (tcb_priority y)) - = (ready_queues a (tcb_domain y) (tcb_priority y))") - apply (simp add: state_relation_def ready_queues_relation_def) - apply (clarsimp simp: tcb_sched_append_def state_relation_def - valid_queues'_def ready_queues_relation_def - ekheap_relation_def etcb_relation_def - obj_at'_def inQ_def projectKO_eq project_inject) - apply (drule_tac x=t in bspec,clarsimp) + "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_append tcb_ptr) (tcbSchedAppend tcbPtr)" + supply if_split[split del] + heap_path_append[simp del] fun_upd_apply[simp del] distinct_append[simp del] + supply projectKOs[simp] + 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_append_def get_tcb_queue_def + tcbSchedAppend_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]; 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) + 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 (clarsimp simp: unless_def when_def cong: if_cong) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres) - apply (simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres) - apply (simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply simp - apply (rule getQueue_corres) - apply (rule corres_split_noop_rhs2) - apply (simp add: tcb_sched_append_def) - apply (intro conjI impI) - apply (rule corres_guard_imp) - apply (rule setQueue_corres) - prefer 3 - apply (rule_tac P=\ and Q="K (t \ set queuea)" in corres_assume_pre) - apply simp - apply simp - apply simp - apply (rule corres_split_noop_rhs2) - apply (rule addToBitmap_if_null_noop_corres) - apply (rule threadSet_corres_noop, simp_all add: tcb_relation_def exst_same_def)[1] - apply wp+ - apply (wp getObject_tcb_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) + apply (rule corres_symb_exec_r[OF _ threadGet_sp]; (solves wpsimp)?) + apply (rule corres_symb_exec_r[OF _ threadGet_sp]; (solves wpsimp)?) + apply (rule corres_symb_exec_r[OF _ gets_sp]; (solves wpsimp)?) + + \ \break off the addToBitmap\ + apply (rule corres_add_noop_lhs) + apply (rule corres_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) + + apply (rule corres_from_valid_det) + apply (fastforce intro: det_wp_modify det_wp_pre simp: set_tcb_queue_def) + apply (wpsimp simp: tcbQueueAppend_def wp: hoare_vcg_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'_tcbQueueEnd_ksReadyQueues simp: obj_at'_def) + + apply (rename_tac s rv t) + apply (clarsimp simp: state_relation_def) + apply (intro hoare_vcg_conj_lift_pre_fix; + (solves \frule singleton_eqD, frule set_tcb_queue_projs_inv, wpsimp simp: swp_def\)?) + + \ \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 simp: setQueue_def tcbQueueAppend_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) + 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 obj_at'_tcbQueueEnd_ksReadyQueues) + apply fast + apply fast + apply fastforce + apply fastforce + apply (cut_tac xs="ready_queues s d p" in heap_path_head') + apply (force dest!: spec simp: list_queue_relation_def) + 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) + apply (metis inQ_def option.simps(5) tcb_of'_TCB) + apply (intro conjI impI; clarsimp) + + \ \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 (tcbQueueEnd (ksReadyQueues s' (tcb_domain etcb, tcb_priority etcb))) + \ set (ready_queues s d p)") + apply (erule orthD2) + apply (drule_tac x="tcb_domain etcb" in spec) + apply (drule_tac x="tcb_priority etcb" in spec) + apply clarsimp + apply (drule_tac x="the (tcbQueueEnd (ksReadyQueues s' (tcb_domain etcb, tcb_priority etcb)))" + in spec) + subgoal by (auto simp: in_opt_pred opt_map_red) + 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"; + clarsimp 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 split: if_splits) + apply (case_tac "t = the (tcbQueueEnd (ksReadyQueues s' (tcb_domain etcb, tcb_priority etcb)))") + apply (clarsimp simp: inQ_def opt_pred_def fun_upd_apply) + 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 tcb \ p = tcb_priority tcb\ + 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) + apply (frule valid_tcbs'_maxPriority[where t=tcbPtr], simp add: obj_at'_def) + 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) + apply (intro conjI; clarsimp) + + \ \the ready queue was originally empty\ + apply (force simp: inQ_def in_opt_pred fun_upd_apply opt_map_def obj_at'_def + queue_end_valid_def prev_queue_head_def + split: if_splits option.splits) + + \ \the ready queue was not originally empty\ + apply (drule (2) heap_ls_append[where new=tcbPtr]) + apply (rule conjI) + apply (clarsimp simp: fun_upd_apply queue_end_valid_def opt_map_def split: if_splits) + apply (rule conjI) + apply (clarsimp simp: fun_upd_apply queue_end_valid_def) + apply (rule conjI) + apply (subst opt_map_upd_triv) + apply (clarsimp simp: opt_map_def fun_upd_apply queue_end_valid_def split: if_splits) + apply (clarsimp simp: prev_queue_head_def fun_upd_apply split: if_splits) + by (clarsimp simp: inQ_def in_opt_pred fun_upd_apply queue_end_valid_def split: if_splits) + +lemma tcbQueueAppend_valid_objs'[wp]: + "\\s. valid_objs' s \ tcb_at' tcbPtr s \ (\end. tcbQueueEnd queue = Some end \ tcb_at' end s)\ + tcbQueueAppend queue tcbPtr + \\_. valid_objs'\" + unfolding tcbQueueAppend_def + apply (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') + apply (clarsimp simp: tcbQueueEmpty_def valid_bound_tcb'_def split: option.splits) + done + +lemma tcbSchedAppend_valid_objs'[wp]: + "\valid_objs' and pspace_aligned' and pspace_distinct'\ + tcbSchedAppend tcbPtr + \\_. valid_objs'\" + apply (clarsimp simp: tcbSchedAppend_def setQueue_def) + apply (wpsimp wp: threadSet_valid_objs' threadGet_wp hoare_vcg_all_lift) + apply (normalise_obj_at', rename_tac tcb "end") + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply clarsimp + apply (frule tcbQueueHead_iff_tcbQueueEnd) + apply (force dest!: obj_at'_tcbQueueEnd_ksReadyQueues simp: tcbQueueEmpty_def obj_at'_def) done - -crunches tcbSchedEnqueue, tcbSchedAppend, tcbSchedDequeue - for valid_pspace'[wp]: valid_pspace' - and valid_arch_state'[wp]: valid_arch_state' - (simp: unless_def) - crunches tcbSchedAppend, tcbSchedDequeue for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" (wp: threadSet_pred_tcb_no_state simp: unless_def tcb_to_itcb'_def) crunch state_refs_of'[wp]: setQueue "\s. P (state_refs_of' s)" -lemma removeFromBitmap_valid_queues_no_bitmap_except[wp]: -" \ valid_queues_no_bitmap_except t \ - removeFromBitmap d p - \\_. valid_queues_no_bitmap_except t \" - unfolding bitmapQ_defs valid_queues_no_bitmap_except_def - by (wp| clarsimp simp: bitmap_fun_defs)+ - -lemma removeFromBitmap_bitmapQ: - "\ \s. True \ removeFromBitmap d p \\_ s. \ bitmapQ d p s \" - unfolding bitmapQ_defs bitmap_fun_defs - by (wp| clarsimp simp: bitmap_fun_defs)+ - -lemma removeFromBitmap_valid_bitmapQ[wp]: -" \ valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - (\s. ksReadyQueues s (d,p) = []) \ - removeFromBitmap d p - \\_. valid_bitmapQ \" -proof - - have "\ valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - (\s. ksReadyQueues s (d,p) = []) \ - removeFromBitmap d p - \\_. valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - (\s. \ bitmapQ d p s \ ksReadyQueues s (d,p) = []) \" - by (rule hoare_pre) - (wp removeFromBitmap_valid_queues_no_bitmap_except removeFromBitmap_valid_bitmapQ_except - removeFromBitmap_bitmapQ, simp) - thus ?thesis - by - (erule hoare_strengthen_post; fastforce elim: valid_bitmap_valid_bitmapQ_exceptE) -qed - -(* this should be the actual weakest precondition to establish valid_queues - under tagging a thread as not queued *) -lemma threadSet_valid_queues_dequeue_wp: - "\ valid_queues_no_bitmap_except t and - valid_bitmapQ and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - (\s. \d p. t \ set (ksReadyQueues s (d,p))) \ - threadSet (tcbQueued_update (\_. False)) t - \\rv. valid_queues \" - unfolding threadSet_def - apply (rule hoare_seq_ext[OF _ getObject_tcb_sp]) - apply (rule hoare_pre) - apply (simp add: valid_queues_def valid_queues_no_bitmap_except_def valid_queues_no_bitmap_def) - apply (wp setObject_queues_unchanged_tcb hoare_Ball_helper hoare_vcg_all_lift - setObject_tcb_strongest) - apply (clarsimp simp: valid_queues_no_bitmap_except_def obj_at'_def valid_queues_no_bitmap_def) - done - (* FIXME move *) lemmas obj_at'_conjI = obj_at_conj' -lemma setQueue_valid_queues_no_bitmap_except_dequeue_wp: - "\d p ts t. - \ \s. valid_queues_no_bitmap_except t s \ - (\t' \ set ts. obj_at' (inQ d p and runnable' \ tcbState) t' s) \ - t \ set ts \ distinct ts \ p \ maxPriority \ d \ maxDomain \ - setQueue d p ts - \\rv. valid_queues_no_bitmap_except t \" - unfolding setQueue_def valid_queues_no_bitmap_except_def null_def - by wp force - -definition (* if t is in a queue, it should be tagged with right priority and domain *) - "correct_queue t s \ \d p. t \ set(ksReadyQueues s (d, p)) \ - (obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t s)" - -lemma valid_queues_no_bitmap_correct_queueI[intro]: - "valid_queues_no_bitmap s \ correct_queue t s" - unfolding correct_queue_def valid_queues_no_bitmap_def - by (fastforce simp: obj_at'_def inQ_def) - - -lemma tcbSchedDequeue_valid_queues_weak: - "\ valid_queues_no_bitmap_except t and valid_bitmapQ and - bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans and - correct_queue t and - obj_at' (\tcb. tcbDomain tcb \ maxDomain \ tcbPriority tcb \ maxPriority) t \ - tcbSchedDequeue t - \\_. Invariants_H.valid_queues\" -proof - - show ?thesis - unfolding tcbSchedDequeue_def null_def valid_queues_def - apply wp (* stops on threadSet *) - apply (rule hoare_post_eq[OF _ threadSet_valid_queues_dequeue_wp], - simp add: valid_queues_def) - apply (wp hoare_vcg_if_lift hoare_vcg_conj_lift hoare_vcg_imp_lift)+ - apply (wp hoare_vcg_imp_lift setQueue_valid_queues_no_bitmap_except_dequeue_wp - setQueue_valid_bitmapQ threadGet_const_tcb_at hoare_vcg_if_lift)+ - (* wp done *) - apply (normalise_obj_at') - apply (clarsimp simp: correct_queue_def) - apply (normalise_obj_at') - apply (fastforce simp add: valid_queues_no_bitmap_except_def valid_queues_no_bitmap_def elim: obj_at'_weaken)+ - done -qed - -lemma tcbSchedDequeue_valid_queues: - "\Invariants_H.valid_queues - and obj_at' (\tcb. tcbDomain tcb \ maxDomain) t - and obj_at' (\tcb. tcbPriority tcb \ maxPriority) t\ - tcbSchedDequeue t - \\_. Invariants_H.valid_queues\" - apply (rule hoare_pre, rule tcbSchedDequeue_valid_queues_weak) - apply (fastforce simp: valid_queues_def valid_queues_no_bitmap_def obj_at'_def inQ_def) - done - -lemma tcbSchedAppend_valid_queues'[wp]: - (* most of this is identical to tcbSchedEnqueue_valid_queues' in TcbAcc_R *) - "\valid_queues' and tcb_at' t\ tcbSchedAppend t \\_. valid_queues'\" - apply (simp add: tcbSchedAppend_def) - apply (rule hoare_pre) - apply (rule_tac B="\rv. valid_queues' and obj_at' (\obj. tcbQueued obj = rv) t" - in hoare_seq_ext) - 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_def)+ - apply (clarsimp simp: obj_at'_def inQ_def projectKOs valid_queues'_def) - apply (wp getObject_tcb_wp | simp add: threadGet_def)+ - apply (clarsimp simp: obj_at'_def) - done - -lemma threadSet_valid_queues'_dequeue: (* threadSet_valid_queues' is too weak for dequeue *) - "\\s. (\d p t'. obj_at' (inQ d p) t' s \ t' \ t \ t' \ set (ksReadyQueues s (d, p))) \ - obj_at' (inQ d p) t s \ - threadSet (tcbQueued_update (\_. False)) t - \\rv. valid_queues' \" - unfolding valid_queues'_def - apply (rule hoare_pre) - apply (wp hoare_vcg_all_lift) - apply (simp only: imp_conv_disj not_obj_at') - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - apply (simp add: not_obj_at') - apply (clarsimp simp: typ_at_tcb') - apply normalise_obj_at' - apply (fastforce elim: obj_at'_weaken simp: inQ_def) - done - lemma setQueue_ksReadyQueues_lift: "\ \s. P (s\ksReadyQueues := (ksReadyQueues s)((d, p) := ts)\) ts \ setQueue d p ts @@ -314,116 +313,42 @@ lemma setQueue_ksReadyQueues_lift: unfolding setQueue_def by (wp, clarsimp simp: fun_upd_def cong: if_cong) -lemma tcbSchedDequeue_valid_queues'[wp]: - "\valid_queues' and tcb_at' t\ - tcbSchedDequeue t \\_. valid_queues'\" - unfolding tcbSchedDequeue_def - apply (rule_tac B="\rv. valid_queues' and obj_at' (\obj. tcbQueued obj = rv) t" - in hoare_seq_ext) - prefer 2 - apply (wp threadGet_const_tcb_at) - apply (fastforce simp: obj_at'_def) - apply clarsimp - apply (rename_tac queued) - apply (case_tac queued, simp_all) - apply wp - apply (rule_tac d=tdom and p=prio in threadSet_valid_queues'_dequeue) - apply (rule hoare_pre_post, assumption) - apply (wp | clarsimp simp: bitmap_fun_defs)+ - apply (wp hoare_vcg_all_lift setQueue_ksReadyQueues_lift) - apply clarsimp - apply (wp threadGet_obj_at' threadGet_const_tcb_at)+ - apply clarsimp - apply (rule context_conjI, clarsimp simp: obj_at'_def) - apply (clarsimp simp: valid_queues'_def obj_at'_def projectKOs inQ_def|wp)+ - done - -crunch tcb_at'[wp]: tcbSchedEnqueue "tcb_at' t" - (simp: unless_def) -crunch tcb_at'[wp]: tcbSchedAppend "tcb_at' t" - (simp: unless_def) -crunch tcb_at'[wp]: tcbSchedDequeue "tcb_at' t" - -crunch state_refs_of'[wp]: tcbSchedEnqueue "\s. P (state_refs_of' s)" - (wp: refl simp: crunch_simps unless_def) -crunch state_refs_of'[wp]: tcbSchedAppend "\s. P (state_refs_of' s)" - (wp: refl simp: crunch_simps unless_def) -crunch state_refs_of'[wp]: tcbSchedDequeue "\s. P (state_refs_of' s)" - (wp: refl simp: crunch_simps) - -crunch cap_to'[wp]: tcbSchedEnqueue "ex_nonz_cap_to' p" - (simp: unless_def) -crunch cap_to'[wp]: tcbSchedAppend "ex_nonz_cap_to' p" - (simp: unless_def) -crunch cap_to'[wp]: tcbSchedDequeue "ex_nonz_cap_to' p" +crunches tcbSchedAppend, tcbSchedDequeue, tcbSchedEnqueue + for tcb_at'[wp]: "tcb_at' t" + and cap_to'[wp]: "ex_nonz_cap_to' p" + and ifunsafe'[wp]: if_unsafe_then_cap' + (wp: crunch_wps simp: crunch_simps) lemma tcbSchedAppend_iflive'[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' tcb\ - tcbSchedAppend tcb \\_. if_live_then_nonz_cap'\" - apply (simp add: tcbSchedAppend_def unless_def) - apply (wp threadSet_iflive' hoare_drop_imps | simp add: crunch_simps)+ + "\if_live_then_nonz_cap' and pspace_aligned' and pspace_distinct'\ + tcbSchedAppend tcbPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbSchedAppend_def + supply projectKOs[simp] + apply (wpsimp wp: tcbQueueAppend_if_live_then_nonz_cap' threadGet_wp simp: bitmap_fun_defs) + apply (frule_tac p=tcbPtr in if_live_then_nonz_capE') + apply (fastforce simp: ko_wp_at'_def st_tcb_at'_def obj_at'_def runnable_eq_active') + apply (clarsimp simp: tcbQueueEmpty_def) + apply (erule if_live_then_nonz_capE') + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (fastforce dest!: obj_at'_tcbQueueEnd_ksReadyQueues + simp: ko_wp_at'_def inQ_def obj_at'_def tcbQueueEmpty_def) done lemma tcbSchedDequeue_iflive'[wp]: - "\if_live_then_nonz_cap'\ tcbSchedDequeue tcb \\_. if_live_then_nonz_cap'\" + "\if_live_then_nonz_cap' and valid_objs' and sym_heap_sched_pointers\ + tcbSchedDequeue tcbPtr + \\_. if_live_then_nonz_cap'\" apply (simp add: tcbSchedDequeue_def) - apply (wp threadSet_iflive' hoare_when_weak_wp | simp add: crunch_simps)+ - apply ((wp | clarsimp simp: bitmap_fun_defs)+)[1] (* deal with removeFromBitmap *) - apply (wp threadSet_iflive' hoare_when_weak_wp | simp add: crunch_simps)+ - apply (rule_tac Q="\rv. \" in hoare_post_imp, fastforce) - apply (wp | simp add: crunch_simps)+ + apply (wpsimp wp: tcbQueueRemove_if_live_then_nonz_cap' threadGet_wp) + apply (fastforce elim: if_live_then_nonz_capE' simp: obj_at'_def ko_wp_at'_def projectKOs) done -crunch ifunsafe'[wp]: tcbSchedAppend if_unsafe_then_cap' - (simp: unless_def) -crunch ifunsafe'[wp]: tcbSchedDequeue if_unsafe_then_cap' - crunch idle'[wp]: tcbSchedAppend valid_idle' (simp: crunch_simps unless_def) -crunch global_refs'[wp]: tcbSchedEnqueue valid_global_refs' - (wp: threadSet_global_refs simp: unless_def) -crunch global_refs'[wp]: tcbSchedAppend valid_global_refs' - (wp: threadSet_global_refs simp: unless_def) -crunch global_refs'[wp]: tcbSchedDequeue valid_global_refs' - (wp: threadSet_global_refs) - -crunch irq_node'[wp]: tcbSchedEnqueue "\s. P (irq_node' s)" - (simp: unless_def) -crunch irq_node'[wp]: tcbSchedAppend "\s. P (irq_node' s)" - (simp: unless_def) -crunch irq_node'[wp]: tcbSchedDequeue "\s. P (irq_node' s)" - -crunch typ_at'[wp]: tcbSchedEnqueue "\s. P (typ_at' T p s)" - (simp: unless_def) -crunch typ_at'[wp]: tcbSchedAppend "\s. P (typ_at' T p s)" - (simp: unless_def) -crunch typ_at'[wp]: tcbSchedDequeue "\s. P (typ_at' T p s)" - -crunch ctes_of[wp]: tcbSchedEnqueue "\s. P (ctes_of s)" - (simp: unless_def) -crunch ctes_of[wp]: tcbSchedAppend "\s. P (ctes_of s)" - (simp: unless_def) -crunch ctes_of[wp]: tcbSchedDequeue "\s. P (ctes_of s)" - -crunch ksInterrupt[wp]: tcbSchedEnqueue "\s. P (ksInterruptState s)" - (simp: unless_def) -crunch ksInterrupt[wp]: tcbSchedAppend "\s. P (ksInterruptState s)" - (simp: unless_def) -crunch ksInterrupt[wp]: tcbSchedDequeue "\s. P (ksInterruptState s)" - -crunch irq_states[wp]: tcbSchedEnqueue valid_irq_states' - (simp: unless_def) -crunch irq_states[wp]: tcbSchedAppend valid_irq_states' - (simp: unless_def) -crunch irq_states[wp]: tcbSchedDequeue valid_irq_states' - -crunch ct'[wp]: tcbSchedEnqueue "\s. P (ksCurThread s)" - (simp: unless_def) -crunch ct'[wp]: tcbSchedAppend "\s. P (ksCurThread s)" - (simp: unless_def) -crunch ct'[wp]: tcbSchedDequeue "\s. P (ksCurThread s)" - lemma tcbSchedEnqueue_vms'[wp]: "\valid_machine_state'\ tcbSchedEnqueue t \\_. valid_machine_state'\" apply (simp add: valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def) @@ -452,57 +377,117 @@ lemma ct_idle_or_in_cur_domain'_lift2: apply simp+ done +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'\" + supply projectKOs[simp] + apply (wpsimp wp: setObject_tcb_mdb' getTCB_wp simp: threadSet_def obj_at'_def) + apply fastforce + done + +lemma tcbSchedNext_update_valid_mdb'[wp]: + "\valid_mdb' and tcb_at' tcbPtr\ threadSet (tcbSchedNext_update f) tcbPtr \\_. valid_mdb'\" + apply (wpsimp wp: threadSet_mdb') + apply (fastforce simp: obj_at'_def valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) + done + +lemma tcbSchedPrev_update_valid_mdb'[wp]: + "\valid_mdb' and tcb_at' tcbPtr\ threadSet (tcbSchedPrev_update f) tcbPtr \\_. valid_mdb'\" + apply (wpsimp wp: threadSet_mdb') + apply (fastforce simp: obj_at'_def valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) + done + +lemma tcbQueueRemove_valid_mdb': + "\\s. valid_mdb' s \ valid_objs' s\ tcbQueueRemove q tcbPtr \\_. valid_mdb'\" + unfolding tcbQueueRemove_def + apply (wpsimp wp: getTCB_wp) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (fastforce simp: valid_tcb'_def obj_at'_def) + done + +lemma tcbQueuePrepend_valid_mdb': + "\valid_mdb' and tcb_at' tcbPtr + and (\s. \ tcbQueueEmpty queue \ tcb_at' (the (tcbQueueHead queue)) s)\ + tcbQueuePrepend queue tcbPtr + \\_. valid_mdb'\" + unfolding tcbQueuePrepend_def + by (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') + +lemma tcbQueueAppend_valid_mdb': + "\\s. valid_mdb' s \ tcb_at' tcbPtr s + \ (\ tcbQueueEmpty queue \ tcb_at' (the (tcbQueueEnd queue)) s)\ + tcbQueueAppend queue tcbPtr + \\_. valid_mdb'\" + unfolding tcbQueueAppend_def + by (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') + +lemma tcbQueued_update_valid_mdb'[wp]: + "\valid_mdb' and tcb_at' tcbPtr\ threadSet (tcbQueued_update f) tcbPtr \\_. valid_mdb'\" + apply (wpsimp wp: threadSet_mdb') + apply (fastforce simp: obj_at'_def valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) + done + +lemma valid_mdb'_ksReadyQueuesL1Bitmap_update[simp]: + "valid_mdb' (ksReadyQueuesL1Bitmap_update f s) = valid_mdb' s" + by (simp add: valid_mdb'_def) + +lemma valid_mdb'_ksReadyQueuesL2Bitmap_update[simp]: + "valid_mdb' (ksReadyQueuesL2Bitmap_update f s) = valid_mdb' s" + by (simp add: valid_mdb'_def) + +lemma tcbSchedEnqueue_valid_mdb'[wp]: + "\valid_mdb' and valid_objs' and pspace_aligned' and pspace_distinct'\ + tcbSchedEnqueue tcbPtr + \\_. valid_mdb'\" + apply (clarsimp simp: tcbSchedEnqueue_def setQueue_def) + apply (wpsimp wp: tcbQueuePrepend_valid_mdb' threadGet_wp simp: bitmap_fun_defs) + apply normalise_obj_at' + apply (fastforce dest!: obj_at'_tcbQueueHead_ksReadyQueues + simp: ready_queue_relation_def ksReadyQueues_asrt_def obj_at'_def) + done + +crunches tcbSchedEnqueue + for cur_tcb'[wp]: cur_tcb' + (wp: threadSet_cur) + lemma tcbSchedEnqueue_invs'[wp]: - "\invs' - and st_tcb_at' runnable' t - and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ - tcbSchedEnqueue t + "\invs' and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ + tcbSchedEnqueue t \\_. invs'\" - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp tcbSchedEnqueue_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 valid_ioports_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 tcbSchedEnqueue_ct_not_inQ valid_ioports_lift' + simp: cteCaps_of_def o_def) done -crunch ksMachine[wp]: tcbSchedAppend "\s. P (ksMachineState s)" - (simp: unless_def) - lemma tcbSchedAppend_vms'[wp]: "\valid_machine_state'\ tcbSchedAppend t \\_. valid_machine_state'\" apply (simp add: valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift tcbSchedAppend_ksMachine) + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) done -crunch pspace_domain_valid[wp]: tcbSchedAppend "pspace_domain_valid" - (simp: unless_def) - -crunch ksCurDomain[wp]: tcbSchedAppend "\s. P (ksCurDomain s)" -(simp: unless_def) +lemma tcbQueueAppend_tcbPriority_obj_at'[wp]: + "tcbQueueAppend queue tptr \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + unfolding tcbQueueAppend_def + apply (wpsimp wp: threadSet_wp) + by (auto simp: obj_at'_def objBits_simps ps_clear_def projectKOs split: if_splits) -crunch ksIdleThread[wp]: tcbSchedAppend "\s. P (ksIdleThread s)" -(simp: unless_def) - -crunch ksDomSchedule[wp]: tcbSchedAppend "\s. P (ksDomSchedule s)" -(simp: unless_def) +lemma tcbQueueAppend_tcbDomain_obj_at'[wp]: + "tcbQueueAppend queue tptr \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding tcbQueueAppend_def + apply (wpsimp wp: threadSet_wp) + by (auto simp: obj_at'_def objBits_simps ps_clear_def projectKOs split: if_splits) lemma tcbSchedAppend_tcbDomain[wp]: - "\ obj_at' (\tcb. P (tcbDomain tcb)) t' \ - tcbSchedAppend t - \ \_. obj_at' (\tcb. P (tcbDomain tcb)) t' \" + "tcbSchedAppend t \obj_at' (\tcb. P (tcbDomain tcb)) t'\" apply (clarsimp simp: tcbSchedAppend_def) - apply (wpsimp simp: unless_def)+ - done + by wpsimp lemma tcbSchedAppend_tcbPriority[wp]: - "\ obj_at' (\tcb. P (tcbPriority tcb)) t' \ - tcbSchedAppend t - \ \_. obj_at' (\tcb. P (tcbPriority tcb)) t' \" + "tcbSchedAppend t \obj_at' (\tcb. P (tcbPriority tcb)) t'\" apply (clarsimp simp: tcbSchedAppend_def) - apply (wpsimp simp: unless_def)+ - done + by wpsimp lemma tcbSchedAppend_tcb_in_cur_domain'[wp]: "\tcb_in_cur_domain' t'\ tcbSchedAppend t \\_. tcb_in_cur_domain' t' \" @@ -510,36 +495,66 @@ lemma tcbSchedAppend_tcb_in_cur_domain'[wp]: apply wp+ done -crunch ksDomScheduleIdx[wp]: tcbSchedAppend "\s. P (ksDomScheduleIdx s)" - (simp: unless_def) - crunches tcbSchedAppend, tcbSchedDequeue - for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" - and arch'[wp]: "\s. P (ksArchState s)" + for arch'[wp]: "\s. P (ksArchState s)" and ioports'[wp]: valid_ioports' (simp: unless_def wp: valid_ioports_lift'') lemma tcbSchedAppend_sch_act_wf[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ tcbSchedAppend thread - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - apply (simp add:tcbSchedAppend_def bitmap_fun_defs) - apply (wp unless_wp setQueue_sch_act threadGet_wp|simp)+ - apply (fastforce simp:typ_at'_def obj_at'_def) + "tcbSchedAppend thread \\s. sch_act_wf (ksSchedulerAction s) s\" + by (wpsimp wp: sch_act_wf_lift) + +lemma tcbSchedAppend_valid_bitmapQ[wp]: + "\valid_bitmaps\ tcbSchedAppend tcbPtr \\_. valid_bitmapQ\" + supply if_split[split del] + unfolding tcbSchedAppend_def + apply (wpsimp simp: tcbQueueAppend_def + wp: setQueue_valid_bitmapQ' addToBitmap_valid_bitmapQ_except addToBitmap_bitmapQ + threadGet_wp hoare_vcg_if_lift2) + apply (clarsimp simp: ksReadyQueues_asrt_def split: if_splits) + apply normalise_obj_at' + apply (force dest: tcbQueueHead_iff_tcbQueueEnd + simp: valid_bitmaps_def valid_bitmapQ_def tcbQueueEmpty_def) + done + +lemma tcbSchedAppend_valid_mdb'[wp]: + "\valid_mdb' and valid_tcbs' and pspace_aligned' and pspace_distinct'\ + tcbSchedAppend tcbPtr + \\_. valid_mdb'\" + supply projectKOs[simp] + apply (clarsimp simp: tcbSchedAppend_def setQueue_def) + apply (wpsimp wp: tcbQueueAppend_valid_mdb' threadGet_wp simp: bitmap_fun_defs) + apply (fastforce dest: obj_at'_tcbQueueEnd_ksReadyQueues + simp: ready_queue_relation_def ksReadyQueues_asrt_def obj_at'_def) + done + +lemma tcbSchedAppend_valid_bitmaps[wp]: + "tcbSchedAppend tcbPtr \valid_bitmaps\" + unfolding valid_bitmaps_def + apply wpsimp + apply (clarsimp simp: valid_bitmaps_def) done lemma tcbSchedAppend_invs'[wp]: - "\invs' - and st_tcb_at' runnable' t - and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ - tcbSchedAppend t + "\invs' and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ + tcbSchedAppend t \\_. invs'\" - apply (simp add: invs'_def valid_state'_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: @@ -562,70 +577,98 @@ 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) -crunch ksMachine[wp]: tcbSchedDequeue "\s. P (ksMachineState s)" - (simp: unless_def) - lemma tcbSchedDequeue_vms'[wp]: "\valid_machine_state'\ tcbSchedDequeue t \\_. valid_machine_state'\" apply (simp add: valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift tcbSchedDequeue_ksMachine) + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) done -crunch pspace_domain_valid[wp]: tcbSchedDequeue "pspace_domain_valid" - -crunch ksCurDomain[wp]: tcbSchedDequeue "\s. P (ksCurDomain s)" -(simp: unless_def) - -crunch ksIdleThread[wp]: tcbSchedDequeue "\s. P (ksIdleThread s)" -(simp: unless_def) - -crunch ksDomSchedule[wp]: tcbSchedDequeue "\s. P (ksDomSchedule s)" -(simp: unless_def) - lemma tcbSchedDequeue_tcb_in_cur_domain'[wp]: "\tcb_in_cur_domain' t'\ tcbSchedDequeue t \\_. tcb_in_cur_domain' t' \" apply (rule tcb_in_cur_domain'_lift) apply wp - apply (clarsimp simp: tcbSchedDequeue_def) - apply (wp hoare_when_weak_wp | simp)+ + apply (clarsimp simp: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wpsimp wp: hoare_when_weak_wp getObject_tcb_wp threadGet_wp) done -lemma tcbSchedDequeue_tcbDomain[wp]: - "\ obj_at' (\tcb. P (tcbDomain tcb)) t' \ - tcbSchedDequeue t - \ \_. obj_at' (\tcb. P (tcbDomain tcb)) t' \" - apply (clarsimp simp: tcbSchedDequeue_def) - apply (wp hoare_when_weak_wp | simp)+ - done - -lemma tcbSchedDequeue_tcbPriority[wp]: - "\ obj_at' (\tcb. P (tcbPriority tcb)) t' \ - tcbSchedDequeue t - \ \_. obj_at' (\tcb. P (tcbPriority tcb)) t' \" - apply (clarsimp simp: tcbSchedDequeue_def) - apply (wp hoare_when_weak_wp | simp)+ +lemma tcbSchedDequeue_valid_mdb'[wp]: + "\valid_mdb' and valid_objs'\ tcbSchedDequeue tcbPtr \\_. valid_mdb'\" + unfolding tcbSchedDequeue_def + apply (wpsimp simp: bitmap_fun_defs setQueue_def wp: threadSet_mdb' tcbQueueRemove_valid_mdb') + apply (rule_tac Q="\_. tcb_at' tcbPtr" in hoare_post_imp) + apply (fastforce simp: tcb_cte_cases_def cteSizeBits_def) + apply (wpsimp wp: threadGet_wp)+ + apply (fastforce simp: obj_at'_def) done -crunch ksDomScheduleIdx[wp]: tcbSchedDequeue "\s. P (ksDomScheduleIdx s)" - (simp: unless_def) - lemma tcbSchedDequeue_invs'[wp]: - "\invs' and tcb_at' t\ - tcbSchedDequeue t - \\_. invs'\" - unfolding invs'_def valid_state'_def - apply (rule hoare_pre) - 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 - tcbSchedDequeue_valid_queues - untyped_ranges_zero_lift - | simp add: cteCaps_of_def o_def)+ - apply (fastforce elim: valid_objs'_maxDomain valid_objs'_maxPriority simp: valid_pspace'_def)+ + "tcbSchedDequeue t \invs'\" + 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: + "\(s, s') \ state_relation; pspace_aligned s; pspace_distinct s; valid_queues s\ + \ ready_qs_runnable s'" + supply projectKOs[simp] + apply (clarsimp simp: ready_qs_runnable_def) + apply normalise_obj_at' + apply (frule state_relation_ready_queues_relation) + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def + list_queue_relation_def) + apply (drule_tac x="tcbDomain ko" in spec) + apply (drule_tac x="tcbPriority ko" in spec) + apply (clarsimp simp: valid_queues_def) + apply (drule_tac x="tcbDomain ko" in spec) + apply (drule_tac x="tcbPriority ko" in spec) + apply clarsimp + apply (drule_tac x=t in bspec) + apply (fastforce simp: inQ_def in_opt_pred obj_at'_def opt_map_red) + apply (fastforce dest: st_tcb_at_runnable_cross simp: obj_at'_def st_tcb_at'_def) + done + +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_queues)?, (frule invs_psp_aligned)?, (frule invs_distinct)?, + fastforce dest: ready_qs_runnable_cross + +defs idleThreadNotQueued_def: + "idleThreadNotQueued s \ obj_at' (Not \ tcbQueued) (ksIdleThread s) s" + +lemma idle_thread_not_queued: + "\valid_idle s; valid_queues s; valid_etcbs s\ + \ \ (\d p. idle_thread s \ set (ready_queues s d p))" + apply (clarsimp simp: valid_queues_def) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply clarsimp + apply (drule_tac x="idle_thread s" in bspec) + apply fastforce + apply (clarsimp simp: valid_idle_def pred_tcb_at_def obj_at_def valid_etcbs_def) done +lemma valid_idle_tcb_at: + "valid_idle s \ tcb_at (idle_thread s) s" + by (clarsimp simp: valid_idle_def pred_tcb_at_def obj_at_def is_tcb_def) + lemma setCurThread_corres: - "corres dc \ \ (modify (cur_thread_update (\_. t))) (setCurThread t)" - apply (unfold setCurThread_def) + "corres dc (valid_idle and valid_queues and valid_etcbs and pspace_aligned and pspace_distinct) \ + (modify (cur_thread_update (\_. t))) (setCurThread t)" + supply projectKOs[simp] + 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 opt_pred_def opt_map_def) apply (rule corres_modify) apply (simp add: state_relation_def swp_def) done @@ -664,47 +707,62 @@ lemma arch_switch_thread_ksQ[wp]: apply (wp) done -crunch valid_queues[wp]: "Arch.switchToThread" "Invariants_H.valid_queues" -(wp: crunch_wps simp: crunch_simps) +crunches storeWordUser, setVMRoot, asUser, storeWordUser, Arch.switchToThread + for ksIdleThread[wp]: "\s. P (ksIdleThread s)" + and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_objs'[wp]: valid_objs' + (wp: crunch_wps threadSet_sched_pointers simp: crunch_simps) + +crunches arch_switch_to_thread, arch_switch_to_idle_thread + for pspace_aligned[wp]: pspace_aligned + and pspace_distinct[wp]: pspace_distinct + and ready_qs_distinct[wp]: ready_qs_distinct + (wp: ready_qs_distinct_lift simp: crunch_simps) + +crunches arch_switch_to_thread, arch_switch_to_idle_thread + for valid_idle[wp]: "\s::det_ext state. valid_idle s" + +lemma valid_queues_in_correct_ready_q[elim!]: + "valid_queues s \ in_correct_ready_q s" + by (clarsimp simp: valid_queues_def in_correct_ready_q_def) + +lemma valid_queues_ready_qs_distinct[elim!]: + "valid_queues s \ ready_qs_distinct s" + by (clarsimp simp: valid_queues_def ready_qs_distinct_def) 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_vs_lookup and valid_global_objs and unique_table_refs o caps_of_state - and st_tcb_at runnable t and valid_etcbs) - (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_pspace' and valid_arch_state') (switch_to_thread t) (switchToThread t)" - (is "corres _ ?PA ?PH _ _") - -proof - - have mainpart: "corres dc (?PA) (?PH) - (do y \ arch_switch_to_thread t; - y \ (tcb_sched_action tcb_sched_dequeue t); - modify (cur_thread_update (\_. t)) - od) - (do y \ Arch.switchToThread t; - y \ tcbSchedDequeue t; - setCurThread 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) + apply add_ready_qs_runnable + apply (simp add: switch_to_thread_def Thread_H.switchToThread_def) + apply (rule corres_symb_exec_l[OF _ _ get_sp]; (solves wpsimp)?) + apply (rule corres_symb_exec_l[OF _ _ assert_sp]; (solves wpsimp)?) + 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_stateAssert_ignore) + apply (fastforce dest!: state_relation_ready_queues_relation intro: ksReadyQueues_asrt_cross) + apply (rule corres_stateAssert_add_assertion[rotated]) + apply fastforce apply (rule corres_guard_imp) apply (rule corres_split[OF arch_switchToThread_corres]) apply (rule corres_split[OF tcbSchedDequeue_corres setCurThread_corres]) - apply (wp|clarsimp simp: tcb_at_is_etcb_at st_tcb_at_tcb_at)+ - done - - show ?thesis - apply - - apply (simp add: switch_to_thread_def Thread_H.switchToThread_def) - apply (rule corres_symb_exec_l [where Q = "\ s rv. (?PA and (=) rv) s", - OF corres_symb_exec_l [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 @@ -720,15 +778,21 @@ lemma arch_switchToIdleThread_corres: done lemma switchToIdleThread_corres: - "corres dc invs invs_no_cicd' switch_to_idle_thread switchToIdleThread" + "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 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_trivial, rule corres_modify) - apply (simp add: state_relation_def cdt_relation_def) - apply (wp+, simp+) + 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) @@ -763,11 +827,9 @@ proof - 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 Invariants_H.valid_queues_def - sch_act_wf ct_in_state'_def state_refs_of'_def - ps_clear_def valid_irq_node'_def valid_queues'_def ct_not_inQ_ct - ct_idle_or_in_cur_domain'_def - bitmapQ_defs valid_queues_no_bitmap_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 @@ -781,101 +843,20 @@ lemma setCurThread_invs: by (rule hoare_pre, rule setCurThread_invs_no_cicd') (simp add: invs'_to_invs_no_cicd'_def) -lemma valid_queues_not_runnable_not_queued: - fixes s - assumes vq: "Invariants_H.valid_queues 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 - - with vq have "st_tcb_at' runnable' t s" - unfolding Invariants_H.valid_queues_def valid_queues_no_bitmap_def - apply - - apply clarsimp - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp simp add: st_tcb_at'_def) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE) - apply (clarsimp) - done - - with st show False - apply - - apply (drule(1) pred_tcb_at_conj') - apply (clarsimp) - done -qed - -(* - * The idle thread is not part of any ready queues. - *) -lemma idle'_not_tcbQueued': - assumes vq: "Invariants_H.valid_queues 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 vq' show ?thesis - by (rule valid_queues_not_runnable_not_queued) - qed - lemma setCurThread_invs_no_cicd'_idle_thread: - "\invs_no_cicd' and (\s. t = ksIdleThread s) \ 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 - have idle'_activatable': "\ s t. st_tcb_at' idle' t s \ st_tcb_at' activatable' t s" - apply (clarsimp simp: st_tcb_at'_def o_def obj_at'_def) + "\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 st_tcb_at'_def + idleThreadNotQueued_def projectKOs) done - show ?thesis - apply (simp add: setCurThread_def) - apply wp - apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def) - apply (frule (2) idle'_not_tcbQueued'[simplified o_def]) - apply (clarsimp simp add: ct_not_inQ_ct idle'_activatable' - 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_queues_no_bitmap_def valid_queues'_def - pred_tcb_at'_def - cong: option.case_cong) - apply (clarsimp simp: obj_at'_def projectKOs idle_tcb'_def) - done -qed lemma setCurThread_invs_idle_thread: "\invs' and (\s. t = ksIdleThread s) \ setCurThread t \\rv. invs'\" @@ -910,13 +891,13 @@ lemma Arch_switchToThread_tcb_in_cur_domain'[wp]: done lemma tcbSchedDequeue_not_tcbQueued: - "\ tcb_at' t \ tcbSchedDequeue t \ \_. obj_at' (\x. \ tcbQueued x) t \" + "\\\ tcbSchedDequeue t \\_. obj_at' (\x. \ tcbQueued x) t\" apply (simp add: tcbSchedDequeue_def) apply (wp|clarsimp)+ apply (rule_tac Q="\queued. obj_at' (\x. tcbQueued x = queued) t" in hoare_post_imp) - apply (clarsimp simp: obj_at'_def) - apply (wp threadGet_obj_at') - apply (simp) + apply (clarsimp simp: obj_at'_def) + apply (wpsimp wp: threadGet_wp)+ + apply (clarsimp simp: obj_at'_def) done lemma Arch_switchToThread_obj_at[wp]: @@ -938,10 +919,6 @@ crunch valid_irq_states'[wp]: asUser "valid_irq_states'" crunch valid_machine_state'[wp]: asUser "valid_machine_state'" (wp: crunch_wps simp: crunch_simps) -crunch valid_queues'[wp]: asUser "valid_queues'" -(wp: crunch_wps simp: crunch_simps) - - lemma asUser_valid_irq_node'[wp]: "\\s. valid_irq_node' (irq_node' s) s\ asUser t (setRegister f r) \\_ s. valid_irq_node' (irq_node' s) s\" @@ -1012,22 +989,17 @@ lemma Arch_switchToThread_invs_no_cicd': by (wp|rule setVMRoot_invs_no_cicd')+ lemma tcbSchedDequeue_invs_no_cicd'[wp]: - "\invs_no_cicd' and tcb_at' t\ - tcbSchedDequeue t - \\_. invs_no_cicd'\" - unfolding all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def + "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 - tcbSchedDequeue_valid_queues_weak untyped_ranges_zero_lift | simp add: cteCaps_of_def o_def)+ apply clarsimp - apply (fastforce simp: valid_pspace'_def valid_queues_def - elim: valid_objs'_maxDomain valid_objs'_maxPriority intro: obj_at'_conjI) done lemma switchToThread_invs_no_cicd': - "\invs_no_cicd' and st_tcb_at' runnable' t and tcb_in_cur_domain' t \ ThreadDecls_H.switchToThread t \\rv. invs' \" + "\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') @@ -1035,7 +1007,7 @@ lemma switchToThread_invs_no_cicd': done lemma switchToThread_invs[wp]: - "\invs' and st_tcb_at' runnable' t and tcb_in_cur_domain' t \ switchToThread t \\rv. invs' \" + "\invs' and tcb_in_cur_domain' t \ switchToThread t \\rv. invs' \" apply (simp add: Thread_H.switchToThread_def ) apply (wp threadSet_timeslice_invs setCurThread_invs Arch_switchToThread_invs dmo_invs' @@ -1110,61 +1082,6 @@ lemma obj_tcb_at': "obj_at' (\tcb::tcb. P tcb) t s \ tcb_at' t s" by (clarsimp simp: obj_at'_def) -lemma invs'_not_runnable_not_queued: - fixes s - assumes inv: "invs' s" - and st: "st_tcb_at' (Not \ runnable') t s" - shows "obj_at' (Not \ tcbQueued) t s" - apply (insert assms) - apply (rule valid_queues_not_runnable_not_queued) - apply (clarsimp simp add: invs'_def valid_state'_def)+ - done - -lemma valid_queues_not_tcbQueued_not_ksQ: - fixes s - assumes vq: "Invariants_H.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" - unfolding Invariants_H.valid_queues_def valid_queues_no_bitmap_def - apply clarify - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp) - apply (drule(1) bspec) - apply (erule obj_at'_weakenE) - apply (simp) - done - 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 valid_state'_def) - apply (drule(1) valid_queues_not_tcbQueued_not_ksQ) - apply (clarsimp) - done - -lemma ct_not_ksQ: - "\ invs' s; ksSchedulerAction s = ResumeCurrentThread \ - \ \p. ksCurThread s \ set (ksReadyQueues s p)" - apply (clarsimp simp: invs'_def valid_state'_def ct_not_inQ_def) - apply (frule(1) valid_queues_not_tcbQueued_not_ksQ) - apply (fastforce) - done - lemma setThreadState_rct: "\\s. (runnable' st \ ksCurThread s \ t) \ ksSchedulerAction s = ResumeCurrentThread\ @@ -1236,21 +1153,24 @@ lemma bitmapQ_from_bitmap_lookup: done lemma lookupBitmapPriority_obj_at': - "\ksReadyQueuesL1Bitmap s (ksCurDomain s) \ 0; valid_queues_no_bitmap s; valid_bitmapQ s; - bitmapQ_no_L1_orphans s\ - \ obj_at' (inQ (ksCurDomain s) (lookupBitmapPriority (ksCurDomain s) s) and runnable' \ tcbState) - (hd (ksReadyQueues s (ksCurDomain s, lookupBitmapPriority (ksCurDomain s) s))) s" + "\ksReadyQueuesL1Bitmap s d \ 0; valid_bitmapQ s; bitmapQ_no_L1_orphans s; + ksReadyQueues_asrt s; ready_qs_runnable s; pspace_aligned' s; pspace_distinct' s\ + \ obj_at' (inQ d (lookupBitmapPriority d s) and runnable' \ tcbState) + (the (tcbQueueHead (ksReadyQueues s (d, lookupBitmapPriority d s)))) s" apply (drule (2) bitmapQ_from_bitmap_lookup) apply (simp add: valid_bitmapQ_bitmapQ_simp) - apply (case_tac "ksReadyQueues s (ksCurDomain s, lookupBitmapPriority (ksCurDomain s) s)", simp) - apply (clarsimp, rename_tac t ts) - apply (drule cons_set_intro) - apply (drule (2) valid_queues_no_bitmap_objD) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def tcbQueueEmpty_def) + apply (drule_tac x=d in spec) + apply (drule_tac x="lookupBitmapPriority d s" in spec) + apply clarsimp + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (fastforce simp: obj_at'_and ready_qs_runnable_def obj_at'_def st_tcb_at'_def inQ_def + tcbQueueEmpty_def) done lemma bitmapL1_zero_ksReadyQueues: "\ valid_bitmapQ s ; bitmapQ_no_L1_orphans s \ - \ (ksReadyQueuesL1Bitmap s d = 0) = (\p. ksReadyQueues s (d,p) = [])" + \ (ksReadyQueuesL1Bitmap s d = 0) = (\p. tcbQueueEmpty (ksReadyQueues s (d, p)))" apply (cases "ksReadyQueuesL1Bitmap s d = 0") apply (force simp add: bitmapQ_def valid_bitmapQ_def) apply (fastforce dest: bitmapQ_from_bitmap_lookup simp: valid_bitmapQ_bitmapQ_simp) @@ -1321,7 +1241,7 @@ lemma bitmapL1_highest_lookup: done lemma bitmapQ_ksReadyQueuesI: - "\ bitmapQ d p s ; valid_bitmapQ s \ \ ksReadyQueues s (d, p) \ []" + "\ bitmapQ d p s ; valid_bitmapQ s \ \ \ tcbQueueEmpty (ksReadyQueues s (d, p))" unfolding valid_bitmapQ_def by simp lemma getReadyQueuesL2Bitmap_inv[wp]: @@ -1330,24 +1250,22 @@ lemma getReadyQueuesL2Bitmap_inv[wp]: lemma switchToThread_lookupBitmapPriority_wp: "\\s. invs_no_cicd' s \ bitmapQ (ksCurDomain s) (lookupBitmapPriority (ksCurDomain s) s) s \ - t = hd (ksReadyQueues s (ksCurDomain s, lookupBitmapPriority (ksCurDomain 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 ; 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 elim: obj_at'_weaken simp: inQ_def tcb_in_cur_domain'_def st_tcb_at'_def) - done - thus ?thesis - by (wp switchToThread_invs_no_cicd') (fastforce dest: invs_no_cicd'_queues) -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_no_cicd': "\invs_no_cicd'\ switchToIdleThread \\rv. invs'\" @@ -1446,8 +1364,9 @@ 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 st_tcb_at runnable t and valid_etcbs) - (valid_arch_state' and valid_pspace' and Invariants_H.valid_queues + and st_tcb_at runnable t and valid_etcbs + and valid_queues and valid_idle) + (valid_arch_state' and valid_pspace' and sym_heap_sched_pointers and st_tcb_at' runnable' t and cur_tcb') (guarded_switch_to t) (switchToThread t)" apply (simp add: guarded_switch_to_def) @@ -1457,8 +1376,8 @@ lemma guarded_switch_to_corres: 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)+ - done + apply (force simp: st_tcb_at_tcb_at)+ + done abbreviation "enumPrio \ [0.e.maxPriority]" @@ -1493,7 +1412,7 @@ lemma curDomain_corres: "corres (=) \ \ (gets cur_domain) (curDomain)" lemma curDomain_corres': "corres (=) \ (\s. ksCurDomain s \ maxDomain) - (gets cur_domain) (if 1 < numDomains then curDomain else return 0)" + (gets cur_domain) (if Suc 0 < numDomains then curDomain else return 0)" apply (case_tac "1 < numDomains"; simp) apply (rule corres_guard_imp[OF curDomain_corres]; solves simp) (* if we have only one domain, then we are in it *) @@ -1503,27 +1422,32 @@ lemma curDomain_corres': lemma lookupBitmapPriority_Max_eqI: "\ valid_bitmapQ s ; bitmapQ_no_L1_orphans s ; ksReadyQueuesL1Bitmap s d \ 0 \ - \ lookupBitmapPriority d s = (Max {prio. ksReadyQueues s (d, prio) \ []})" + \ lookupBitmapPriority d s = (Max {prio. \ tcbQueueEmpty (ksReadyQueues s (d, prio))})" apply (rule Max_eqI[simplified eq_commute]; simp) apply (fastforce simp: bitmapL1_highest_lookup valid_bitmapQ_bitmapQ_simp) apply (metis valid_bitmapQ_bitmapQ_simp bitmapQ_from_bitmap_lookup) done lemma corres_gets_queues_getReadyQueuesL1Bitmap: - "corres (\qs l1. ((l1 = 0) = (\p. qs p = []))) \ valid_queues + "corres (\qs l1. (l1 = 0) = (\p. qs p = [])) \ valid_bitmaps (gets (\s. ready_queues s d)) (getReadyQueuesL1Bitmap d)" - unfolding state_relation_def valid_queues_def getReadyQueuesL1Bitmap_def - by (clarsimp simp: bitmapL1_zero_ksReadyQueues ready_queues_relation_def) + unfolding state_relation_def valid_bitmaps_def getReadyQueuesL1Bitmap_def + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def) + apply (drule_tac x=d in spec) + apply (fastforce simp: bitmapL1_zero_ksReadyQueues list_queue_relation_def tcbQueueEmpty_def) + done lemma guarded_switch_to_chooseThread_fragment_corres: "corres dc (P and st_tcb_at runnable t and invs and valid_sched) - (P' and st_tcb_at' runnable' t and invs_no_cicd') - (guarded_switch_to t) - (do runnable \ isRunnable t; - y \ assert runnable; - ThreadDecls_H.switchToThread t - od)" + (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) @@ -1538,35 +1462,50 @@ lemma guarded_switch_to_chooseThread_fragment_corres: 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' + \ Max {prio. ready_queues s d prio \ []} + = Max {prio. \ tcbQueueEmpty (ksReadyQueues s' (d, prio))}" + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def + list_queue_relation_def tcbQueueEmpty_def) + apply (rule Max_eq_if) + apply fastforce + apply fastforce + apply (fastforce dest: heap_path_head) + apply clarsimp + apply (drule_tac x=d in spec) + apply (drule_tac x=b in spec) + apply force + done + lemma bitmap_lookup_queue_is_max_non_empty: - "\ valid_queues s'; (s, s') \ state_relation; invs s; + "\ 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 all_invs_but_ct_idle_or_in_cur_domain'_def 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 \ - \ 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 (simp add: valid_queues_no_bitmap_def) - apply (erule_tac x="ksCurDomain s" in allE) - apply (erule_tac x="lookupBitmapPriority (ksCurDomain s) s" in allE) - apply (clarsimp simp: st_tcb_at'_def) - apply (erule obj_at'_weaken) - apply simp - 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 \" @@ -1578,52 +1517,72 @@ lemma invs_no_cicd_ksCurDomain_maxDomain': "invs_no_cicd' s \ ksCurDomain s \ maxDomain" unfolding invs_no_cicd'_def by simp +crunches curDomain + for valid_bitmaps[wp]: valid_bitmaps + lemma chooseThread_corres: - "corres dc (invs and valid_sched) (invs_no_cicd') - choose_thread chooseThread" (is "corres _ ?PREI ?PREH _ _") + "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 - unfolding choose_thread_def chooseThread_def - 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 \ 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 dest!: invs_no_cicd'_queues simp: bitmap_lookup_queue_is_max_non_empty) - 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 (clarsimp simp: if_apply_def2) - apply (wp hoare_vcg_conj_lift hoare_vcg_imp_lift ksReadyQueuesL1Bitmap_return_wp) - apply (wpsimp wp: curDomain_or_return_0 simp: curDomain_def)+ - apply (fastforce simp: invs_no_cicd'_def) - apply (clarsimp simp: valid_sched_def DetSchedInvs_AI.valid_queues_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 (simp add: invs_no_cicd_ksCurDomain_maxDomain') - apply (clarsimp dest!: invs_no_cicd'_queues) - apply (fastforce intro: ksReadyQueuesL1Bitmap_st_tcb_at') - done + 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 (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 = @@ -1712,7 +1671,7 @@ lemma isHighestPrio_corres: assumes "d' = d" assumes "p' = p" shows - "corres ((=)) \ valid_queues + "corres ((=)) \ valid_bitmaps (gets (is_highest_prio d p)) (isHighestPrio d' p')" using assms @@ -1722,18 +1681,16 @@ lemma isHighestPrio_corres: apply (rule corres_split[OF corres_gets_queues_getReadyQueuesL1Bitmap]) apply (rule corres_if_r'[where P'="\_. True",rotated]) apply (rule_tac corres_symb_exec_r) - apply (rule_tac - P="\s. q = ready_queues s d - " and - P'="\s. valid_queues s \ - l1 = ksReadyQueuesL1Bitmap s d \ - l1 \ 0 \ hprio = lookupBitmapPriority d s" and - F="hprio = Max {prio. q prio \ []}" in corres_req) - apply (elim conjE) - apply (clarsimp simp: valid_queues_def) - apply (subst lookupBitmapPriority_Max_eqI; blast?) - apply (fastforce simp: ready_queues_relation_def dest!: state_relationD) - apply fastforce + apply (rule_tac P="\s. q = ready_queues s d" + and P'="\s. valid_bitmaps s \ l1 = ksReadyQueuesL1Bitmap s d \ + l1 \ 0 \ hprio = lookupBitmapPriority d s" + and F="hprio = Max {prio. q prio \ []}" in corres_req) + apply (elim conjE) + apply (clarsimp simp: valid_bitmaps_def) + apply (subst lookupBitmapPriority_Max_eqI; blast?) + apply (fastforce dest: state_relation_ready_queues_relation Max_prio_helper[where d=d] + simp: tcbQueueEmpty_def) + apply fastforce apply (wpsimp simp: if_apply_def2 wp: hoare_drop_imps ksReadyQueuesL1Bitmap_return_wp)+ done @@ -1745,9 +1702,8 @@ crunch inv[wp]: schedule_switch_thread_fastfail P crunch inv[wp]: scheduleSwitchThreadFastfail P lemma setSchedulerAction_invs': (* not in wp set, clobbered by ssa_wp *) - "\\s. invs' s \ setSchedulerAction ChooseNewThread \\_. invs' \" + "setSchedulerAction ChooseNewThread \invs' \" by (wpsimp simp: invs'_def cur_tcb'_def valid_state'_def valid_irq_node'_def ct_not_inQ_def - valid_queues_def valid_queues_no_bitmap_def valid_queues'_def ct_idle_or_in_cur_domain'_def) lemma scheduleChooseNewThread_corres: @@ -1779,6 +1735,51 @@ lemma ethread_get_when_corres: 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 + +crunches 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) + +crunches reschedule_required + for in_correct_ready_q[wp]: in_correct_ready_q + and ready_qs_distinct[wp]: ready_qs_distinct + (wp: crunch_wps ignore_del: reschedule_required) + +lemma tcbSchedEnqueue_valid_pspace'[wp]: + "tcbSchedEnqueue tcbPtr \valid_pspace'\" + unfolding valid_pspace'_def + by wpsimp + 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] @@ -1807,7 +1808,7 @@ lemma schedule_corres: apply (rule corres_split[OF thread_get_isRunnable_corres]) apply (rule corres_split) apply (rule corres_when, simp) - apply (rule tcbSchedEnqueue_corres) + 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)+ @@ -1816,7 +1817,7 @@ lemma schedule_corres: rename_tac was_running wasRunning) apply (rule corres_split) apply (rule corres_when, simp) - apply (rule tcbSchedEnqueue_corres) + 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) @@ -1832,7 +1833,7 @@ lemma schedule_corres: 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]) + apply (rule corres_split[OF tcbSchedEnqueue_corres], simp) apply (simp, fold dc_def) apply (rule corres_split) apply (rule setSchedulerAction_corres; simp) @@ -1846,7 +1847,7 @@ lemma schedule_corres: 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]) + apply (rule corres_split[OF tcbSchedAppend_corres], simp) apply (simp, fold dc_def) apply (rule corres_split) apply (rule setSchedulerAction_corres; simp) @@ -1878,7 +1879,8 @@ lemma schedule_corres: 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)+ + del: gets_wp + | strengthen valid_objs'_valid_tcbs')+ apply (clarsimp simp: conj_ac if_apply_def2 cong: imp_cong conj_cong del: hoare_gets) apply (wp gets_wp)+ @@ -1901,18 +1903,17 @@ lemma schedule_corres: 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 (clarsimp simp add: pred_tcb_at_def obj_at_def is_tcb valid_idle_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)+ - apply (simp add: valid_sched_def valid_blocked_def valid_blocked_except_def) done (* haskell final subgoal *) - apply (clarsimp simp: if_apply_def2 invs'_def valid_state'_def + 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 @@ -1926,11 +1927,8 @@ proof - apply (simp add: setSchedulerAction_def) apply wp apply (clarsimp simp add: invs'_def valid_state'_def cur_tcb'_def - Invariants_H.valid_queues_def - state_refs_of'_def ps_clear_def - valid_irq_node'_def valid_queues'_def - tcb_in_cur_domain'_def ct_idle_or_in_cur_domain'_def - bitmapQ_defs valid_queues_no_bitmap_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 @@ -1965,13 +1963,10 @@ lemma getDomainTime_wp[wp]: "\\s. P (ksDomainTime s) s \ by wp lemma switchToThread_ct_not_queued_2: - "\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 (simp add: X64_H.switchToThread_def setCurThread_def) - apply (wp tcbSchedDequeue_not_tcbQueued | simp )+ - done + "\invs_no_cicd' and tcb_at' t\ switchToThread t \\_ s. obj_at' (Not \ tcbQueued) (ksCurThread s) s\" + unfolding Thread_H.switchToThread_def + by (wpsimp simp: X64_H.switchToThread_def setCurThread_def + wp: hoare_drop_imp tcbSchedDequeue_not_tcbQueued) lemma setCurThread_obj_at': "\ obj_at' P t \ setCurThread t \\rv s. obj_at' P (ksCurThread s) s \" @@ -1984,11 +1979,12 @@ proof - qed lemma switchToIdleThread_ct_not_queued_no_cicd': - "\ invs_no_cicd' \ switchToIdleThread \\rv s. obj_at' (Not \ tcbQueued) (ksCurThread s) s \" + "\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 (rule idle'_not_tcbQueued') - apply (simp add: invs_no_cicd'_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]: @@ -2005,7 +2001,7 @@ lemma switchToThread_tcb_in_cur_domain': ThreadDecls_H.switchToThread thread \\y s. tcb_in_cur_domain' (ksCurThread s) s\" apply (simp add: Thread_H.switchToThread_def setCurThread_def) - apply (wpsimp wp: tcbSchedDequeue_not_tcbQueued) + apply (wpsimp wp: tcbSchedDequeue_not_tcbQueued hoare_drop_imps) done lemma chooseThread_invs_no_cicd'_posts: (* generic version *) @@ -2027,11 +2023,14 @@ proof - by (simp add: all_invs_but_ct_idle_or_in_cur_domain'_def maxDomain_def) show ?thesis - unfolding chooseThread_def Let_def curDomain_def + apply (clarsimp simp: chooseThread_def Let_def curDomain_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp])+ apply (simp only: return_bind, simp) - apply (rule hoare_seq_ext[where B="\rv s. invs_no_cicd' s \ rv = ksCurDomain s"]) + apply (rule hoare_seq_ext[where B="\rv s. invs_no_cicd' s \ rv = ksCurDomain s + \ ksReadyQueues_asrt s \ ready_qs_runnable s"]) apply (rule_tac B="\rv s. invs_no_cicd' s \ curdom = ksCurDomain s \ - rv = ksReadyQueuesL1Bitmap s curdom" in hoare_seq_ext) + rv = ksReadyQueuesL1Bitmap s curdom \ + ksReadyQueues_asrt s \ ready_qs_runnable s" in hoare_seq_ext) apply (rename_tac l1) apply (case_tac "l1 = 0") (* switch to idle thread *) @@ -2045,12 +2044,10 @@ proof - 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 - apply (clarsimp dest!: invs_no_cicd'_queues - simp: valid_queues_def lookupBitmapPriority_def[symmetric]) - 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 (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 @@ -2089,11 +2086,14 @@ proof - (* FIXME this is almost identical to the chooseThread_invs_no_cicd'_posts proof, can generalise? *) show ?thesis - unfolding chooseThread_def Let_def curDomain_def + apply (clarsimp simp: chooseThread_def Let_def curDomain_def) + apply (rule hoare_seq_ext[OF _ stateAssert_sp])+ apply (simp only: return_bind, simp) - apply (rule hoare_seq_ext[where B="\rv s. invs_no_cicd' s \ rv = ksCurDomain s"]) + apply (rule hoare_seq_ext[where B="\rv s. invs_no_cicd' s \ rv = ksCurDomain s + \ ksReadyQueues_asrt s \ ready_qs_runnable s"]) apply (rule_tac B="\rv s. invs_no_cicd' s \ curdom = ksCurDomain s \ - rv = ksReadyQueuesL1Bitmap s curdom" in hoare_seq_ext) + rv = ksReadyQueuesL1Bitmap s curdom \ + ksReadyQueues_asrt s \ ready_qs_runnable s" in hoare_seq_ext) apply (rename_tac l1) apply (case_tac "l1 = 0") (* switch to idle thread *) @@ -2101,7 +2101,10 @@ proof - (* we have a thread to switch to *) apply (clarsimp simp: bitmap_fun_defs) apply (wp assert_inv) - apply (clarsimp dest!: invs_no_cicd'_queues simp: valid_queues_def) + 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 @@ -2250,11 +2253,18 @@ lemma sbn_sch_act_sane: done lemma possibleSwitchTo_corres: - "corres dc (valid_etcbs and weak_valid_sched_action and cur_tcb and st_tcb_at runnable t) - (Invariants_H.valid_queues and valid_queues' and - (\s. weak_sch_act_wf (ksSchedulerAction s) s) and cur_tcb' and tcb_at' t and st_tcb_at' runnable' t and valid_objs') - (possible_switch_to t) - (possibleSwitchTo t)" + "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) + apply (rule_tac Q'="tcb_at' t" in corres_cross_add_guard) + apply (fastforce dest!: st_tcb_at_tcb_at elim!: tcb_at_cross) supply ethread_get_wp[wp del] apply (simp add: possible_switch_to_def possibleSwitchTo_def cong: if_cong) apply (rule corres_guard_imp) @@ -2264,12 +2274,12 @@ lemma possibleSwitchTo_corres: apply (clarsimp simp: etcb_relation_def) apply (rule corres_split[OF getSchedulerAction_corres]) apply (rule corres_if, simp) - apply (rule tcbSchedEnqueue_corres) + 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) - apply (wp rescheduleRequired_valid_queues'_weak)+ + 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])+ @@ -2278,7 +2288,7 @@ lemma possibleSwitchTo_corres: apply (fastforce simp: valid_sched_def invs_def valid_state_def cur_tcb_def valid_sched_action_def weak_valid_sched_action_def tcb_at_is_etcb_at[OF st_tcb_at_tcb_at[rotated]]) - apply (simp add: tcb_at_is_etcb_at) + apply fastforce done end diff --git a/proof/refine/X64/StateRelation.thy b/proof/refine/X64/StateRelation.thy index 88f7b61666..1df131c221 100644 --- a/proof/refine/X64/StateRelation.thy +++ b/proof/refine/X64/StateRelation.thy @@ -200,17 +200,24 @@ where \ tcb_bound_notification tcb = tcbBoundNotification tcb' \ tcb_mcpriority tcb = tcbMCP tcb'" + +\ \ + A pair of objects @{term "(obj, obj')"} should satisfy the following relation when, under further + mild assumptions, a @{term corres_underlying} lemma for @{term "set_object obj"} + and @{term "setObject obj'"} can be stated: see setObject_other_corres in KHeap_R. + + TCBs do not satisfy this relation because the tcbSchedPrev and tcbSchedNext fields of a TCB are + used to model the ready queues, and so an update to such a field would correspond to an update + to a ready queue (see ready_queues_relation below).\ definition other_obj_relation :: "Structures_A.kernel_object \ Structures_H.kernel_object \ bool" where "other_obj_relation obj obj' \ - (case (obj, obj') of - (TCB tcb, KOTCB tcb') \ tcb_relation tcb tcb' - | (Endpoint ep, KOEndpoint ep') \ ep_relation ep ep' + case (obj, obj') of + (Endpoint ep, KOEndpoint ep') \ ep_relation ep ep' | (Notification ntfn, KONotification ntfn') \ ntfn_relation ntfn ntfn' - | (ArchObj (X64_A.ASIDPool pool), KOArch (KOASIDPool pool')) - \ asid_pool_relation pool pool' - | _ \ False)" + | (ArchObj (X64_A.ASIDPool pool), KOArch (KOASIDPool pool')) \ asid_pool_relation pool pool' + | _ \ False" primrec pml4e_relation' :: "X64_A.pml4e \ X64_H.pml4e \ bool" @@ -290,6 +297,12 @@ where | "aobj_relation_cuts (PageMapL4 pm) x = (\y. (x + (ucast y << word_size_bits), pml4e_relation y)) ` UNIV" +definition tcb_relation_cut :: "Structures_A.kernel_object \ kernel_object \ bool" where + "tcb_relation_cut obj obj' \ + case (obj, obj') of + (TCB t, KOTCB t') \ tcb_relation t t' + | _ \ False" + primrec obj_relation_cuts :: "Structures_A.kernel_object \ machine_word \ obj_relation_cuts" where @@ -297,17 +310,17 @@ where (if well_formed_cnode_n sz cs then {(cte_map (x, y), cte_relation y) | y. y \ dom cs} else {(x, \\)})" -| "obj_relation_cuts (TCB tcb) x = {(x, other_obj_relation)}" +| "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 (ArchObj ao) x = aobj_relation_cuts ao x" - lemma obj_relation_cuts_def2: "obj_relation_cuts ko x = (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, \\)} + | TCB tcb \ {(x, tcb_relation_cut)} | ArchObj (PageTable pt) \ (\y. (x + (ucast y << word_size_bits), pte_relation y)) ` (UNIV :: 9 word set) | ArchObj (PageDirectory pd) \ (\y. (x + (ucast y << word_size_bits), pde_relation y)) @@ -326,6 +339,7 @@ lemma obj_relation_cuts_def3: "obj_relation_cuts ko x = (case (a_type ko) of ACapTable n \ {(cte_map (x, y), cte_relation y) | y. length y = n} + | ATCB \ {(x, tcb_relation_cut)} | AArch APageTable \ (\y. (x + (ucast y << word_size_bits), pte_relation y)) ` (UNIV :: 9 word set) | AArch APageDirectory \ (\y. (x + (ucast y << word_size_bits), pde_relation y)) @@ -345,22 +359,27 @@ lemma obj_relation_cuts_def3: done definition - "is_other_obj_relation_type tp \ - case tp of - ACapTable n \ False - | AArch APageTable \ False - | AArch APageDirectory \ False - | AArch APDPointerTable \ False - | AArch APageMapL4 \ False - | AArch (AUserData _) \ False - | AArch (ADeviceData _) \ False - | AGarbage _ \ False - | _ \ True" + "is_other_obj_relation_type tp \ + case tp of + ACapTable n \ False + | ATCB \ False + | AArch APageTable \ False + | AArch APageDirectory \ False + | AArch APDPointerTable \ False + | AArch APageMapL4 \ False + | AArch (AUserData _) \ False + | AArch (ADeviceData _) \ False + | AGarbage _ \ False + | _ \ True" 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_TCB: + "\ is_other_obj_relation_type ATCB" + by (simp add: is_other_obj_relation_type_def) + lemma is_other_obj_relation_type_UserData: "\ is_other_obj_relation_type (AArch (AUserData sz))" unfolding is_other_obj_relation_type_def by simp @@ -408,11 +427,55 @@ where "sched_act_relation choose_new_thread a' = (a' = ChooseNewThread)" | "sched_act_relation (switch_thread x) a' = (a' = SwitchToThread x)" -definition - ready_queues_relation :: "(Deterministic_A.domain \ Structures_A.priority \ Deterministic_A.ready_queue) - \ (domain \ priority \ KernelStateData_H.ready_queue) \ bool" -where - "ready_queues_relation qs qs' \ \d p. (qs d p = qs' (d, p))" +definition queue_end_valid :: "obj_ref list \ tcb_queue \ bool" where + "queue_end_valid ts q \ + (ts = [] \ tcbQueueEnd q = None) \ (ts \ [] \ tcbQueueEnd q = Some (last ts))" + +definition prev_queue_head :: "tcb_queue \ (obj_ref \ 'a) \ bool" where + "prev_queue_head q prevs \ \head. tcbQueueHead q = Some head \ prevs head = None" + +lemma prev_queue_head_heap_upd: + "\prev_queue_head q prevs; Some r \ tcbQueueHead q\ \ prev_queue_head q (prevs(r := x))" + by (clarsimp simp: prev_queue_head_def) + +definition list_queue_relation :: + "obj_ref list \ tcb_queue \ (obj_ref \ obj_ref) \ (obj_ref \ obj_ref) \ bool" + where + "list_queue_relation ts q nexts prevs \ + heap_ls nexts (tcbQueueHead q) ts \ queue_end_valid ts q \ prev_queue_head q prevs" + +lemma list_queue_relation_nil: + "list_queue_relation ts q nexts prevs \ ts = [] \ tcbQueueEmpty q" + by (fastforce dest: heap_path_head simp: tcbQueueEmpty_def list_queue_relation_def) + +definition ready_queue_relation :: + "Deterministic_A.domain \ Structures_A.priority + \ Deterministic_A.ready_queue \ ready_queue + \ (obj_ref \ obj_ref) \ (obj_ref \ obj_ref) + \ (obj_ref \ bool) \ bool" + where + "ready_queue_relation d p q q' nexts prevs flag \ + list_queue_relation q q' nexts prevs + \ (\t. flag t \ t \ set q) + \ (d > maxDomain \ p > maxPriority \ tcbQueueEmpty q')" + +definition ready_queues_relation_2 :: + "(Deterministic_A.domain \ Structures_A.priority \ Deterministic_A.ready_queue) + \ (domain \ priority \ ready_queue) + \ (obj_ref \ obj_ref) \ (obj_ref \ obj_ref) + \ (domain \ priority \ obj_ref \ bool) \ bool" + where + "ready_queues_relation_2 qs qs' nexts prevs inQs \ + \d p. let q = qs d p; q' = qs' (d, p); flag = inQs d p in + ready_queue_relation d p q q' nexts prevs flag" + +abbreviation ready_queues_relation :: "det_state \ kernel_state \ bool" where + "ready_queues_relation s s' \ + ready_queues_relation_2 + (ready_queues s) (ksReadyQueues s') (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + (\d p. inQ d p |< tcbs_of' s')" + +lemmas ready_queues_relation_def = ready_queues_relation_2_def definition ghost_relation :: "Structures_A.kheap \ (machine_word \ vmpage_size) \ (machine_word \ nat) \ bool" @@ -507,6 +570,8 @@ lemma obj_relation_cutsE: \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; + \tcb tcb'. \ y = x; ko = TCB tcb; ko' = KOTCB tcb'; tcb_relation tcb tcb' \ + \ R; \pt (z :: 9 word) pte'. \ ko = ArchObj (PageTable pt); y = x + (ucast z << word_size_bits); ko' = KOArch (KOPTE pte'); pte_relation' (pt z) pte' \ \ R; @@ -524,8 +589,8 @@ lemma obj_relation_cutsE: \ y = x; other_obj_relation ko ko'; is_other_obj_relation_type (a_type ko) \ \ R \ \ R" apply (simp add: obj_relation_cuts_def2 is_other_obj_relation_type_def - a_type_def - split: Structures_A.kernel_object.split_asm if_split_asm + a_type_def tcb_relation_cut_def + split: Structures_A.kernel_object.split_asm if_split_asm kernel_object.split_asm X64_A.arch_kernel_obj.split_asm) apply ((clarsimp split: if_splits, force simp: cte_relation_def pte_relation_def pde_relation_def @@ -606,7 +671,7 @@ where pspace_relation (kheap s) (ksPSpace s') \ ekheap_relation (ekheap s) (ksPSpace s') \ sched_act_relation (scheduler_action s) (ksSchedulerAction s') - \ ready_queues_relation (ready_queues s) (ksReadyQueues s') + \ ready_queues_relation s 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') @@ -628,6 +693,10 @@ lemma curthread_relation: "(a, b) \ state_relation \ ksCurThread b = cur_thread a" by (simp add: state_relation_def) +lemma curdomain_relation[elim!]: + "(s, s') \ state_relation \ cur_domain s = ksCurDomain s'" + by (clarsimp simp: state_relation_def) + lemma state_relation_pspace_relation[elim!]: "(s,s') \ state_relation \ pspace_relation (kheap s) (ksPSpace s')" by (simp add: state_relation_def) @@ -636,12 +705,24 @@ 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')" + by (clarsimp simp: state_relation_def) + +lemma state_relation_ready_queues_relation[elim!]: + "(s, s') \ state_relation \ ready_queues_relation s s'" + by (simp add: state_relation_def) + +lemma state_relation_idle_thread[elim!]: + "(s, s') \ state_relation \ idle_thread s = ksIdleThread s'" + by (clarsimp simp: state_relation_def) + lemma state_relationD: assumes sr: "(s, s') \ state_relation" shows "pspace_relation (kheap s) (ksPSpace s') \ ekheap_relation (ekheap s) (ksPSpace s') \ sched_act_relation (scheduler_action s) (ksSchedulerAction s') \ - ready_queues_relation (ready_queues s) (ksReadyQueues s') \ + ready_queues_relation s 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') \ @@ -663,7 +744,7 @@ lemma state_relationE [elim?]: and rl: "\pspace_relation (kheap s) (ksPSpace s'); ekheap_relation (ekheap s) (ksPSpace s'); sched_act_relation (scheduler_action s) (ksSchedulerAction s'); - ready_queues_relation (ready_queues s) (ksReadyQueues s'); + ready_queues_relation s 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'); diff --git a/proof/refine/X64/Syscall_R.thy b/proof/refine/X64/Syscall_R.thy index 98ef62652a..a6e8133c98 100644 --- a/proof/refine/X64/Syscall_R.thy +++ b/proof/refine/X64/Syscall_R.thy @@ -350,16 +350,14 @@ lemma threadSet_tcbDomain_update_sch_act_wf[wp]: lemma setDomain_corres: "corres dc - (valid_etcbs and valid_sched and tcb_at tptr) - (invs' and sch_act_simple - and tcb_at' tptr and (\s. new_dom \ maxDomain)) - (set_domain tptr new_dom) - (setDomain tptr new_dom)" + (valid_etcbs and valid_sched and pspace_aligned and pspace_distinct and tcb_at tptr) + (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 corres_guard_imp) apply (rule corres_split[OF getCurThread_corres]) - apply (rule corres_split[OF tcbSchedDequeue_corres]) + apply (rule corres_split[OF tcbSchedDequeue_corres], simp) apply (rule corres_split) apply (rule ethread_set_corres; simp) apply (clarsimp simp: etcb_relation_def) @@ -368,26 +366,38 @@ lemma setDomain_corres: apply (rule corres_split) apply clarsimp apply (rule corres_when[OF refl]) - apply (rule tcbSchedEnqueue_corres) + apply (rule tcbSchedEnqueue_corres, simp) apply (rule corres_when[OF refl]) apply (rule rescheduleRequired_corres) - apply ((wp hoare_drop_imps hoare_vcg_conj_lift | clarsimp| assumption)+)[5] - apply clarsimp - apply (rule_tac Q="\_. valid_objs' and valid_queues' and valid_queues and - (\s. sch_act_wf (ksSchedulerAction s) s) and tcb_at' tptr" - in hoare_strengthen_post[rotated]) - apply (auto simp: invs'_def valid_state'_def sch_act_wf_weak st_tcb_at'_def o_def)[1] - apply (wp threadSet_valid_objs' threadSet_valid_queues'_no_state - threadSet_valid_queues_no_state - threadSet_pred_tcb_no_state | simp)+ - apply (rule_tac Q = "\r s. invs' s \ (\p. tptr \ set (ksReadyQueues s p)) \ 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) - apply (drule(1) bspec) - apply (clarsimp simp:tcb_cte_cases_def) + 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 Tcb_R.tcbSchedDequeue_not_in_queue)+ + apply (wp hoare_vcg_all_lift tcbSchedDequeue_not_queued)+ apply clarsimp apply (frule tcb_at_is_etcb_at) apply simp+ @@ -395,7 +405,6 @@ lemma setDomain_corres: simp: valid_sched_def valid_sched_action_def) done - lemma performInvocation_corres: "\ inv_relation i i'; call \ block \ \ corres (dc \ (=)) @@ -457,7 +466,7 @@ lemma performInvocation_corres: apply (rule corres_split[OF setDomain_corres]) apply (rule corres_trivial, simp) apply (wp)+ - apply (clarsimp+)[2] + apply (fastforce+)[2] \ \CNodes\ apply clarsimp apply (rule corres_guard_imp) @@ -766,90 +775,71 @@ 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 - \\rv. invs'\" + doReplyTransfer t' t slot grant + \\_. invs'\" apply (simp add: doReplyTransfer_def liftM_def) apply (rule hoare_seq_ext [OF _ gts_sp']) apply (rule hoare_seq_ext [OF _ assert_sp]) apply (rule hoare_seq_ext [OF _ getCTE_sp]) apply (wp, wpc) - apply (wp) + apply wp apply (wp (once) sts_invs_minor'') - apply (simp) + apply simp apply (wp (once) sts_st_tcb') - apply (wp)[1] - apply (rule_tac Q="\rv s. invs' s - \ t \ ksIdleThread s - \ st_tcb_at' awaiting_reply' t s" + 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 (frule_tac t=t in invs'_not_runnable_not_queued) - apply (erule pred_tcb'_weakenE, case_tac st, clarsimp+) + apply clarsimp apply (rule conjI, erule pred_tcb'_weakenE, case_tac st, clarsimp+) - apply (rule conjI, rule impI, erule pred_tcb'_weakenE, case_tac st) - apply (clarsimp | drule(1) obj_at_conj')+ 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 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 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]) + 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 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="\rv s. invs' s \ sch_act_simple s - \ st_tcb_at' awaiting_reply' t s - \ t \ ksIdleThread s" - in hoare_post_imp) - apply (clarsimp) - apply (frule_tac t=t in invs'_not_runnable_not_queued) - apply (erule pred_tcb'_weakenE, case_tac st, clarsimp+) + 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 (rule conjI, rule impI, erule pred_tcb'_weakenE, case_tac st) - apply (clarsimp | drule(1) obj_at_conj')+ 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 clarsimp apply (erule_tac P="\st. awaiting_reply' st \ activatable' st" - in pred_tcb'_weakenE) + 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 clarsimp apply (rule conjI) - apply (clarsimp simp: invs'_def valid_state'_def valid_idle'_def) - apply (rule conjI) - apply clarsimp - apply (clarsimp simp: obj_at'_def idle_tcb'_def pred_tcb_at'_def) + 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 (rule conjI) apply (clarsimp simp : invs'_def valid_state'_def valid_idle'_def pred_tcb_at'_def obj_at'_def idle_tcb'_def) - apply (rule conjI) - apply clarsimp - apply (frule invs'_not_runnable_not_queued) - apply (erule pred_tcb'_weakenE, clarsimp) - apply (frule (1) not_tcbQueued_not_ksQ) - apply simp - apply clarsimp 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) @@ -859,35 +849,9 @@ lemma ct_active_runnable' [simp]: "ct_active' s \ ct_in_state' runnable' s" by (fastforce simp: ct_in_state'_def elim!: pred_tcb'_weakenE) -lemma valid_irq_node_tcbSchedEnqueue[wp]: - "\\s. valid_irq_node' (irq_node' s) s \ tcbSchedEnqueue ptr - \\rv s'. valid_irq_node' (irq_node' s') s'\" - apply (rule hoare_pre) - apply (simp add:valid_irq_node'_def ) - apply (wp unless_wp hoare_vcg_all_lift | wps)+ - apply (simp add:tcbSchedEnqueue_def) - apply (wp unless_wp| simp)+ - apply (simp add:valid_irq_node'_def) - done - -lemma rescheduleRequired_valid_queues_but_ct_domain: - "\\s. Invariants_H.valid_queues s \ valid_objs' s - \ (\x. ksSchedulerAction s = SwitchToThread x \ st_tcb_at' runnable' x s) \ - rescheduleRequired - \\_. Invariants_H.valid_queues\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp)+ - done - -lemma rescheduleRequired_valid_queues'_but_ct_domain: - "\\s. valid_queues' s - \ (\x. ksSchedulerAction s = SwitchToThread x \ st_tcb_at' runnable' x s) - \ - rescheduleRequired - \\_. valid_queues'\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp | fastforce simp: valid_queues'_def)+ - done +crunches tcbSchedEnqueue + for valid_irq_node[wp]: "\s. valid_irq_node' (irq_node' s) s" + (rule: valid_irq_node_lift) lemma tcbSchedEnqueue_valid_action: "\\s. \x. ksSchedulerAction s = SwitchToThread x \ st_tcb_at' runnable' x s\ @@ -898,9 +862,10 @@ lemma tcbSchedEnqueue_valid_action: done abbreviation (input) "all_invs_but_sch_extra \ - \s. valid_pspace' s \ Invariants_H.valid_queues s \ + \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 \ @@ -913,35 +878,27 @@ abbreviation (input) "all_invs_but_sch_extra \ valid_machine_state' s \ cur_tcb' s \ untyped_ranges_zero' s \ - valid_queues' s \ pspace_domain_valid 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'\" + "\all_invs_but_sch_extra\ rescheduleRequired \\_. invs'\" apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp add:rescheduleRequired_ct_not_inQ - rescheduleRequired_sch_act' - rescheduleRequired_valid_queues_but_ct_domain - rescheduleRequired_valid_queues'_but_ct_domain - valid_irq_node_lift valid_irq_handlers_lift'' valid_ioports_lift'' - irqs_masked_lift cur_tcb_lift) + 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 (\s. (\p. t \ set (ksReadyQueues s p))) and - all_invs_but_sch_extra and sch_act_simple and + 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 (wp threadSet_valid_pspace'T_P[where P = False and Q = \ and Q' = \]) - apply (simp add:tcb_cte_cases_def)+ + 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'=\] @@ -954,18 +911,14 @@ lemma threadSet_all_invs_but_sch_extra: valid_ioports_lift'' threadSet_ctes_ofT threadSet_not_inQ - threadSet_valid_queues'_no_state threadSet_tcbDomain_update_ct_idle_or_in_cur_domain' - threadSet_valid_queues threadSet_valid_dom_schedule' threadSet_iflive'T threadSet_ifunsafe'T - untyped_ranges_zero_lift + untyped_ranges_zero_lift threadSet_sched_pointers threadSet_valid_sched_pointers | simp add:tcb_cte_cases_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+ + apply (fastforce simp: sch_act_simple_def o_def cteCaps_of_def) done lemma threadSet_not_curthread_ct_domain: @@ -988,9 +941,7 @@ lemma setDomain_invs': \ (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 (erule st_tcb_ex_cap'') apply simp - apply (case_tac st,simp_all)[1] apply (rule hoare_strengthen_post[OF hoare_vcg_conj_lift]) apply (rule threadSet_all_invs_but_sch_extra) prefer 2 @@ -1008,17 +959,14 @@ lemma setDomain_invs': done lemma performInv_invs'[wp]: - "\invs' and sch_act_simple - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p)) - and ct_active' and valid_invocation' i\ - RetypeDecls_H.performInvocation block call i \\rv. invs'\" + "\invs' and sch_act_simple and ct_active' and valid_invocation' i\ + RetypeDecls_H.performInvocation block call i + \\_. invs'\" unfolding performInvocation_def apply (cases i) - apply ((clarsimp simp: simple_sane_strg sch_act_simple_def - ct_not_ksQ sch_act_sane_def - | wp tcbinv_invs' arch_performInvocation_invs' - setDomain_invs' - | rule conjI | erule active_ex_cap')+) + 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]: @@ -1182,7 +1130,10 @@ done lemmas set_thread_state_active_valid_sched = set_thread_state_runnable_valid_sched[simplified runnable_eq_active] -(*FIXME: move to Nondet_VCG.valid_validE_R *) +crunches reply_from_kernel + for pspace_aligned[wp]: pspace_aligned + and pspace_distinct[wp]: pspace_distinct + lemma handleInvocation_corres: "c \ b \ corres (dc \ dc) @@ -1229,13 +1180,14 @@ lemma handleInvocation_corres: apply simp apply (simp add: when_def) apply (rule conjI, rule impI) - apply (rule reply_from_kernel_tcb_at) - apply (rule impI, wp+) - apply simp+ - apply (wp hoare_drop_imps)+ - apply simp - apply wp - apply simp + apply (wp reply_from_kernel_tcb_at) + apply wpsimp + apply wp+ + apply simp + apply (strengthen invs_psp_aligned invs_distinct) + apply (simp cong: conj_cong) + apply (simp cong: rev_conj_cong) + apply (wpsimp wp: hoare_drop_imps)+ 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" @@ -1250,7 +1202,6 @@ lemma handleInvocation_corres: and (\s. ksSchedulerAction s = ResumeCurrentThread)" in hoare_post_imp) apply (clarsimp simp: ct_in_state'_def) - apply (frule(1) ct_not_ksQ) apply (clarsimp) apply (wp setThreadState_nonqueued_state_update setThreadState_st_tcb setThreadState_rct)[1] @@ -1261,14 +1212,14 @@ lemma handleInvocation_corres: apply (clarsimp simp: tcb_at_invs invs_valid_objs valid_tcb_state_def ct_in_state_def simple_from_active invs_mdb) - apply (clarsimp simp: msg_max_length_def word_bits_def) + apply (clarsimp simp: msg_max_length_def word_bits_def schact_is_rct_def + invs_psp_aligned invs_distinct) apply (erule st_tcb_ex_cap, clarsimp+) apply fastforce 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(1) valid_queues_not_tcbQueued_not_ksQ) 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) @@ -1278,7 +1229,7 @@ lemma handleInvocation_corres: lemma ts_Restart_case_helper': "(case ts of Structures_H.Restart \ A | _ \ B) - = (if ts = Structures_H.Restart then A else B)" + = (if ts = Structures_H.Restart then A else B)" by (cases ts, simp_all) lemma gts_imp': @@ -1328,11 +1279,8 @@ lemma hinv_invs'[wp]: and st_tcb_at' active' thread" in hoare_post_imp) apply (clarsimp simp: ct_in_state'_def) - apply (frule(1) ct_not_ksQ) - apply (clarsimp) apply (wp sts_invs_minor' setThreadState_st_tcb setThreadState_rct | simp)+ apply (clarsimp) - apply (frule(1) ct_not_ksQ) apply (fastforce simp add: tcb_at_invs' ct_in_state'_def simple_sane_strg sch_act_simple_def @@ -1476,7 +1424,6 @@ lemma handleRecv_isBlocking_corres': and (\s. ex_nonz_cap_to (cur_thread s) s)) (invs' and ct_in_state' simple' and sch_act_sane - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p)) and (\s. ex_nonz_cap_to' (ksCurThread s) s)) (handle_recv isBlocking) (handleRecv isBlocking)" (is "corres dc (?pre1) (?pre2) (handle_recv _) (handleRecv _)") @@ -1539,8 +1486,7 @@ lemma handleRecv_isBlocking_corres': lemma handleRecv_isBlocking_corres: "corres dc (einvs and ct_active) - (invs' and ct_active' and sch_act_sane and - (\s. \p. ksCurThread s \ set (ksReadyQueues s p))) + (invs' and ct_active' and sch_act_sane) (handle_recv isBlocking) (handleRecv isBlocking)" apply (rule corres_guard_imp) apply (rule handleRecv_isBlocking_corres') @@ -1555,42 +1501,27 @@ lemma lookupCap_refs[wp]: "\invs'\ lookupCap t ref \\rv s. \r\zobj_refs' rv. ex_nonz_cap_to' r s\,-" by (simp add: lookupCap_def split_def | wp | simp add: o_def)+ -lemma deleteCallerCap_ksQ_ct': - "\invs' and ct_in_state' simple' and sch_act_sane and - (\s. ksCurThread s \ set (ksReadyQueues s p) \ thread = ksCurThread s)\ - deleteCallerCap thread - \\rv s. thread \ set (ksReadyQueues s p)\" - apply (rule_tac Q="\rv s. thread = ksCurThread s \ ksCurThread s \ set (ksReadyQueues s p)" - in hoare_strengthen_post) - apply (wp deleteCallerCap_ct_not_ksQ) - apply auto - done - lemma hw_invs'[wp]: "\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) - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p))\ + 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 - deleteCallerCap_ksQ_ct' hoare_lift_Pf2[OF deleteCallerCap_simple deleteCallerCap_ct'] | wpc | simp)+)[1] apply simp apply (wp deleteCallerCap_nonz_cap hoare_vcg_all_lift - deleteCallerCap_ksQ_ct' 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 - \ (\p. ksCurThread s \ set (ksReadyQueues s p)) \ thread = ksCurThread s \ ct_in_state' simple' s \ ex_nonz_cap_to' thread s @@ -1614,34 +1545,45 @@ lemma setSchedulerAction_obj_at'[wp]: by (wp, clarsimp elim!: obj_at'_pspaceI) lemma handleYield_corres: - "corres dc einvs (invs' and ct_active' and (\s. ksSchedulerAction s = ResumeCurrentThread)) handle_yield handleYield" + "corres dc + (einvs and ct_active) + (invs' and (\s. ksSchedulerAction s = ResumeCurrentThread)) + handle_yield handleYield" apply (clarsimp simp: handle_yield_def handleYield_def) apply (rule corres_guard_imp) apply (rule corres_split[OF getCurThread_corres]) apply simp - apply (rule corres_split[OF tcbSchedDequeue_corres]) - apply (rule corres_split[OF tcbSchedAppend_corres]) + apply (rule corres_split[OF tcbSchedDequeue_corres], simp) + apply (rule corres_split[OF tcbSchedAppend_corres], simp) apply (rule rescheduleRequired_corres) - apply (wp weak_sch_act_wf_lift_linear tcbSchedDequeue_valid_queues | simp add: )+ - apply (simp add: invs_def valid_sched_def valid_sched_action_def - cur_tcb_def tcb_at_is_etcb_at) - apply clarsimp - apply (frule ct_active_runnable') - apply (clarsimp 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) - apply (erule(1) valid_objs_valid_tcbE[OF valid_pspace_valid_objs']) - apply (simp add:valid_tcb'_def) + 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 (fastforce simp: invs_def valid_sched_def valid_sched_action_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 hy_invs': "\invs' and ct_active'\ handleYield \\r. invs' and ct_active'\" apply (simp add: handleYield_def) - apply (wp ct_in_state_thread_state_lift' - rescheduleRequired_all_invs_but_ct_not_inQ - tcbSchedAppend_invs_but_ct_not_inQ' | simp)+ - apply (clarsimp simp add: 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 - ) + 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 @@ -1836,7 +1778,7 @@ 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 haskell_assert_wp doReplyTransfer_sane getCTE_wp'| wpc)+ + apply (wp doReplyTransfer_sane getCTE_wp'| wpc)+ apply (clarsimp simp: cte_wp_at_ctes_of) done @@ -1852,75 +1794,6 @@ lemma handleReply_nonz_cap_to_ct: crunch ksQ[wp]: handleFaultReply "\s. P (ksReadyQueues s p)" -lemma doReplyTransfer_ct_not_ksQ: - "\ invs' and sch_act_simple - and tcb_at' thread and tcb_at' word - and ct_in_state' simple' - and (\s. ksCurThread s \ word) - and (\s. \p. ksCurThread s \ set(ksReadyQueues s p))\ - doReplyTransfer thread word callerSlot g - \\rv s. \p. ksCurThread s \ set(ksReadyQueues s p)\" -proof - - have astct: "\t p. - \(\s. ksCurThread s \ set(ksReadyQueues s p) \ sch_act_sane s) - and (\s. ksCurThread s \ t)\ - possibleSwitchTo t \\rv s. ksCurThread s \ set(ksReadyQueues s p)\" - apply (rule hoare_weaken_pre) - apply (wps possibleSwitchTo_ct') - apply (wp possibleSwitchTo_ksQ') - apply (clarsimp simp: sch_act_sane_def) - done - have stsct: "\t st p. - \(\s. ksCurThread s \ set(ksReadyQueues s p)) and sch_act_simple\ - setThreadState st t - \\rv s. ksCurThread s \ set(ksReadyQueues s p)\" - apply (rule hoare_weaken_pre) - apply (wps setThreadState_ct') - apply (wp hoare_vcg_all_lift sts_ksQ) - apply (clarsimp) - done - show ?thesis - apply (simp add: doReplyTransfer_def) - apply (wp, wpc) - apply (wp astct stsct hoare_vcg_all_lift - cteDeleteOne_ct_not_ksQ hoare_drop_imp - hoare_lift_Pf2 [OF cteDeleteOne_sch_act_not cteDeleteOne_ct'] - hoare_lift_Pf2 [OF doIPCTransfer_pred_tcb_at' doIPCTransfer_ct'] - hoare_lift_Pf2 [OF doIPCTransfer_ksQ doIPCTransfer_ct'] - hoare_lift_Pf2 [OF threadSet_ksQ threadSet_ct] - hoare_lift_Pf2 [OF handleFaultReply_ksQ handleFaultReply_ct'] - | simp add: ct_in_state'_def)+ - apply (fastforce simp: sch_act_simple_def sch_act_sane_def ct_in_state'_def)+ - done -qed - -lemma handleReply_ct_not_ksQ: - "\invs' and sch_act_simple - and ct_in_state' simple' - and (\s. \p. ksCurThread s \ set (ksReadyQueues s p))\ - handleReply - \\rv s. \p. ksCurThread s \ set (ksReadyQueues s p)\" - apply (simp add: handleReply_def del: split_paired_All) - apply (subst haskell_assert_def) - apply (wp | wpc)+ - apply (wp doReplyTransfer_ct_not_ksQ getThreadCallerSlot_inv)+ - apply (rule_tac Q="\cap. - (\s. \p. ksCurThread s \ set(ksReadyQueues s p)) - and invs' - and sch_act_simple - and (\s. thread = ksCurThread s) - and tcb_at' thread - and ct_in_state' simple' - and cte_wp_at' (\c. cteCap c = cap) callerSlot" - in hoare_post_imp) - apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def - cte_wp_at_ctes_of valid_cap'_def - dest!: ctes_of_valid') - apply (wp getSlotCap_cte_wp_at getThreadCallerSlot_inv)+ - apply (clarsimp) - done - -crunch valid_etcbs[wp]: possible_switch_to "valid_etcbs" crunch valid_etcbs[wp]: handle_recv "valid_etcbs" (wp: crunch_wps simp: crunch_simps) @@ -1933,11 +1806,10 @@ lemma handleReply_handleRecv_corres: 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 handleReply_ct_not_ksQ handle_reply_valid_sched)+ + 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 (frule(1) ct_not_ksQ) apply (fastforce elim: pred_tcb'_weakenE) done @@ -1945,7 +1817,6 @@ lemma handleHypervisorFault_corres: "corres dc (einvs and st_tcb_at active thread and ex_nonz_cap_to thread and (%_. valid_fault f)) (invs' and sch_act_not thread - and (\s. \p. thread \ set(ksReadyQueues s p)) and st_tcb_at' simple' thread and ex_nonz_cap_to' thread) (handle_hypervisor_fault w fault) (handleHypervisorFault w fault)" apply (cases fault; clarsimp simp add: handleHypervisorFault_def returnOk_def2) @@ -1961,14 +1832,13 @@ lemma handleEvent_corres: (is "?handleEvent_corres") proof - have hw: - "\isBlocking. corres dc (einvs and ct_running and (\s. scheduler_action s = resume_cur_thread)) + "\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 - dest!: ct_not_ksQ)+ + elim!: st_tcb_weakenE pred_tcb'_weakenE)+ done show ?thesis apply (case_tac event) @@ -1983,7 +1853,7 @@ proof - corres_guard_imp[OF handleCall_corres] corres_guard_imp[OF handleYield_corres] active_from_running active_from_running' - simp: simple_sane_strg)[8] + 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) @@ -1994,7 +1864,6 @@ proof - simp: ct_in_state_def) apply wp apply (clarsimp) - apply (frule(1) ct_not_ksQ) apply (auto simp: ct_in_state'_def sch_act_simple_def sch_act_sane_def elim: pred_tcb'_weakenE st_tcb_ex_cap'')[1] @@ -2007,12 +1876,11 @@ proof - simp: ct_in_state_def valid_fault_def) apply wp apply clarsimp - apply (frule(1) ct_not_ksQ) 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="\rv. einvs" + 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) @@ -2022,7 +1890,6 @@ proof - apply (rule handleInterrupt_corres) apply (wp hoare_vcg_all_lift doMachineOp_getActiveIRQ_IRQ_active' - | simp | simp add: imp_conjR | wp (once) hoare_drop_imps)+ apply (simp add: invs'_def valid_state'_def) apply (rule_tac corres_underlying_split) @@ -2039,7 +1906,6 @@ proof - apply (fastforce elim!: st_tcb_ex_cap st_tcb_weakenE simp: ct_in_state_def) apply wp apply (clarsimp) - apply (frule(1) ct_not_ksQ) 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) @@ -2051,7 +1917,6 @@ proof - simp: ct_in_state_def) apply wp apply (clarsimp) - apply (frule(1) ct_not_ksQ) apply (auto simp: ct_in_state'_def sch_act_simple_def sch_act_sane_def elim: pred_tcb'_weakenE st_tcb_ex_cap'')[1] @@ -2139,10 +2004,8 @@ proof - apply (rename_tac syscall) apply (case_tac syscall, (wp handleReply_sane handleReply_nonz_cap_to_ct handleReply_ksCurThread - handleReply_ct_not_ksQ | clarsimp simp: active_from_running' simple_from_running' simple_sane_strg simp del: split_paired_All | rule conjI active_ex_cap' - | drule ct_not_ksQ[rotated] | strengthen nidle)+) apply (rule hoare_strengthen_post, rule hoare_weaken_pre, @@ -2154,7 +2017,6 @@ proof - | 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' - | drule ct_not_ksQ[rotated] | wpc | wp (once) hoare_drop_imps)+ done qed diff --git a/proof/refine/X64/TcbAcc_R.thy b/proof/refine/X64/TcbAcc_R.thy index d34682ed73..53f21c2a29 100644 --- a/proof/refine/X64/TcbAcc_R.thy +++ b/proof/refine/X64/TcbAcc_R.thy @@ -58,10 +58,8 @@ lemma getHighestPrio_inv[wp]: unfolding bitmap_fun_defs by simp lemma valid_bitmapQ_bitmapQ_simp: - "\ valid_bitmapQ s \ \ - bitmapQ d p s = (ksReadyQueues s (d, p) \ [])" - unfolding valid_bitmapQ_def - by simp + "valid_bitmapQ s \ bitmapQ d p s = (\ tcbQueueEmpty (ksReadyQueues s (d, p)))" + by (simp add: valid_bitmapQ_def) lemma prioToL1Index_l1IndexToPrio_or_id: "\ unat (w'::priority) < 2 ^ wordRadix ; w < 2^(size w' - wordRadix) \ @@ -84,35 +82,18 @@ 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 :: "machine_word \ 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 and runnable' \ tcbState) t s) - \ distinct (ksReadyQueues s (d, p)) - \ (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 - 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 objBits_simps) - 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 - X64_A.arch_kernel_obj.split_asm)+ - apply fastforce - done + 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" @@ -128,39 +109,13 @@ lemma st_tcb_at_runnable_coerce_concrete: 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 projectKOs) - apply (drule(1) pspace_relation_absD) - apply (clarsimp simp: is_tcb other_obj_relation_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 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" +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) done -lemma valid_objs'_maxDomain: - "\s t. \ valid_objs' s; tcb_at' t s \ \ obj_at' (\tcb. tcbDomain tcb \ maxDomain) t s" - apply (erule (1) valid_objs_valid_tcbE) - apply (clarsimp simp: valid_tcb'_def) - done - -lemma valid_objs'_maxPriority: - "\s t. \ valid_objs' s; tcb_at' t s \ \ obj_at' (\tcb. tcbPriority tcb \ maxPriority) t s" - apply (erule (1) valid_objs_valid_tcbE) - apply (clarsimp simp: valid_tcb'_def) - done - lemma doMachineOp_irq_states': assumes masks: "\P. \\s. P (irq_masks s)\ f \\_ s. P (irq_masks s)\" shows "\valid_irq_states'\ doMachineOp f \\rv. valid_irq_states'\" @@ -257,67 +212,217 @@ lemma updateObject_tcb_inv: "\P\ updateObject (obj::tcb) ko p q n \\rv. P\" by simp (rule updateObject_default_inv) +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': + 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" + using assms + 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) + done + +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 + 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 objBits_simps') + done + +definition valid_tcbs' :: "kernel_state \ bool" where + "valid_tcbs' s' \ \ptr tcb. ksPSpace s' ptr = Some (KOTCB tcb) \ valid_tcb' tcb s'" + +lemma valid_objs'_valid_tcbs'[elim!]: + "valid_objs' s \ valid_tcbs' s" + by (auto simp: valid_objs'_def valid_tcbs'_def valid_obj'_def split: kernel_object.splits) + +lemma invs'_valid_tcbs'[elim!]: + "invs' s \ valid_tcbs' s" + by (fastforce del: valid_objs'_valid_tcbs' intro: valid_objs'_valid_tcbs') + +lemma valid_tcbs'_maxDomain: + "\s t. \ valid_tcbs' s; tcb_at' t s \ \ obj_at' (\tcb. tcbDomain tcb \ maxDomain) t s" + by (clarsimp simp: valid_tcbs'_def obj_at'_def valid_tcb'_def projectKOs) + +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" + by (clarsimp simp: valid_tcbs'_def obj_at'_def valid_tcb'_def projectKOs) + +lemmas valid_objs'_maxPriority = valid_tcbs'_maxPriority[OF valid_objs'_valid_tcbs'] + +lemma valid_tcbs'_obj_at': + assumes "valid_tcbs' 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" + using assms + apply (clarsimp simp add: valid_tcbs'_def ran_def typ_at'_def projectKOs + ko_wp_at'_def valid_obj'_def valid_tcb'_def obj_at'_def) + done + +lemma update_valid_tcb'[simp]: + "\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" + "\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_valid_tcbs'[simp]: + "\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 setObject_update_TCB_corres': - assumes tcbs: "tcb_relation tcb tcb' \ tcb_relation tcbu tcbu'" - assumes tables: "\(getF, v) \ ran tcb_cap_cases. getF tcbu = getF tcb" - assumes tables': "\(getF, v) \ ran tcb_cte_cases. getF tcbu' = getF tcb'" + 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" + assumes tables': "\(getF, v) \ ran tcb_cte_cases. getF new_tcb' = getF tcb'" + assumes sched_pointers: "tcbSchedPrev new_tcb' = tcbSchedPrev tcb'" + "tcbSchedNext new_tcb' = tcbSchedNext tcb'" + assumes flag: "tcbQueued new_tcb' = tcbQueued tcb'" assumes r: "r () ()" - assumes exst: "exst_same tcb' tcbu'" - 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' \ exst_same tcb' tcbu'" 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 exst) - 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) + apply (clarsimp simp: projectKOs tcb_relation_cut_def exst) + 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 + split: option.splits) + apply (metis (no_types, lifting) tcb_of'_TCB) + 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 () (); exst_same tcb' tcbu'\ - \ 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 fastforce - apply (clarsimp simp: getObject_def in_monad split_def obj_at'_def - loadObject_default_def projectKOs objBits_simps' - in_magnitude_check) + 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: - "corres tcb_relation (tcb_at t) (tcb_at' t) + "corres tcb_relation (tcb_at t and pspace_aligned and pspace_distinct) \ (gets_the (get_tcb t)) (getObject t)" + 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 (rule corres_gets_the) apply (rule corres_get_tcb) apply (simp add: tcb_at_def) - apply assumption + apply simp done 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)" + 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 @@ -339,7 +444,8 @@ lemma ball_tcb_cte_casesI: 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. P (Thread a b c d e f g h i j k l m n p q) \ \ \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: @@ -348,18 +454,23 @@ 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" + 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) - (tcb_at' t) - (thread_set f t) (threadSet f' t)" + 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 (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+ @@ -372,26 +483,19 @@ 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 - X64_A.arch_kernel_obj.split_asm)+ - done +lemmas pspace_relation_tcb_at = tcb_at'_cross 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" + 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) - (return v) (threadSet fn t)" + 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) @@ -407,19 +511,15 @@ proof - defer apply (subst bind_return [symmetric], rule corres_underlying_split [OF threadset_corresT]) - apply (simp add: x) - apply simp - apply (rule y) + 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 wp+ - apply simp - apply (erule pspace_relation_tcb_at[rotated]) - apply clarsimp - apply simp - apply simp + apply wpsimp+ done qed @@ -433,14 +533,20 @@ 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'\" + 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 P (tcb_at' t and P') - m (threadSet fn t >>= (\rv. m'))" + 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)+ @@ -674,16 +780,23 @@ lemma threadSet_valid_pspace'T_P: assumes v: "\tcb. (P \ Q' (tcbBoundNotification tcb)) \ (\s. valid_bound_ntfn' (tcbBoundNotification tcb) s \ valid_bound_ntfn' (tcbBoundNotification (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)\ - threadSet F t - \\rv. valid_pspace'\" + "\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 + \\_. valid_pspace'\" apply (simp add: valid_pspace'_def threadSet_def) apply (rule hoare_pre, wp setObject_tcb_valid_objs getObject_tcb_wp) @@ -691,7 +804,7 @@ lemma threadSet_valid_pspace'T_P: 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 v w') + split_paired_Ball y u w v w' p n) done lemmas threadSet_valid_pspace'T = @@ -765,6 +878,10 @@ lemma threadSet_iflive'T: \ tcbState (F tcb) \ Inactive \ tcbState (F tcb) \ IdleThreadState \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) + \ ((\tcb. tcbSchedNext tcb = None \ tcbSchedNext (F tcb) \ None + \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) + \ ((\tcb. tcbSchedPrev tcb = None \ tcbSchedPrev (F tcb) \ None + \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) \ ((\tcb. \ tcbQueued tcb \ tcbQueued (F tcb) \ ko_at' tcb t s) \ ex_nonz_cap_to' t s)\ threadSet F t @@ -772,8 +889,7 @@ lemma threadSet_iflive'T: apply (simp add: threadSet_def) apply (wp setObject_tcb_iflive' getObject_tcb_wp) apply (clarsimp simp: obj_at'_def projectKOs) - apply (subst conj_assoc[symmetric], subst imp_disjL[symmetric]) - apply (subst conj_assoc[symmetric], subst imp_disjL[symmetric]) + apply (subst conj_assoc[symmetric], subst imp_disjL[symmetric])+ apply (rule conjI) apply (rule impI, clarsimp) apply (erule if_live_then_nonz_capE') @@ -819,6 +935,12 @@ lemmas threadSet_ctes_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) + \ 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 objBits_simps') + lemma threadSet_idle'T: assumes x: "\tcb. \(getF, setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" shows @@ -857,30 +979,6 @@ lemma set_tcb_bitmapQ_no_L2_orphans[wp]: apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp add: bitmapQ_def)+ done -lemma threadSet_valid_queues_no_bitmap: - "\ valid_queues_no_bitmap and - (\s. \d p. (\tcb. (inQ d p tcb \ runnable' (tcbState tcb)) \ - \(inQ d p (f tcb) \ runnable' (tcbState (f tcb)))) - \ obj_at' (\tcb. (inQ d p tcb \ runnable' (tcbState tcb)) \ - \(inQ d p (f tcb) \ runnable' (tcbState (f tcb)))) t s - \ t \ set (ksReadyQueues s (d, p)) - )\ - threadSet f t - \\rv. valid_queues_no_bitmap \" - apply (simp add: threadSet_def) - apply wp - apply (simp add: Invariants_H.valid_queues_no_bitmap_def' pred_tcb_at'_def) - - apply (wp setObject_queues_unchanged_tcb - hoare_Ball_helper - hoare_vcg_all_lift - setObject_tcb_strongest)[1] - apply (wp getObject_tcb_wp) - apply (clarsimp simp: valid_queues_no_bitmap_def' pred_tcb_at'_def) - apply (clarsimp simp: obj_at'_def projectKOs) - apply (fastforce) - done - lemma threadSet_valid_bitmapQ[wp]: "\ valid_bitmapQ \ threadSet f t \ \rv. valid_bitmapQ \" unfolding bitmapQ_defs threadSet_def @@ -899,73 +997,6 @@ lemma threadSet_valid_bitmapQ_no_L2_orphans[wp]: by (clarsimp simp: setObject_def split_def) (wp | simp add: updateObject_default_def)+ -lemma threadSet_valid_queues: - "\Invariants_H.valid_queues and - (\s. \d p. (\tcb. (inQ d p tcb \ runnable' (tcbState tcb)) \ - \(inQ d p (f tcb) \ runnable' (tcbState (f tcb)))) - \ obj_at' (\tcb. (inQ d p tcb \ runnable' (tcbState tcb)) \ - \(inQ d p (f tcb) \ runnable' (tcbState (f tcb)))) t s - \ t \ set (ksReadyQueues s (d, p)) - )\ - threadSet f t - \\rv. Invariants_H.valid_queues\" - unfolding valid_queues_def - by (wp threadSet_valid_queues_no_bitmap;simp) - -definition - addToQs :: "(Structures_H.tcb \ Structures_H.tcb) - \ machine_word \ (domain \ priority \ machine_word list) - \ (domain \ priority \ machine_word list)" -where - "addToQs F t \ \qs (qdom, prio). if (\ko. \ inQ qdom prio (F ko)) - then t # qs (qdom, prio) - else qs (qdom, prio)" - -lemma addToQs_set_def: - "(t' \ set (addToQs F t qs (qdom, prio))) = (t' \ set (qs (qdom, prio)) - \ (t' = t \ (\ko. \ inQ qdom prio (F ko))))" - by (auto simp add: addToQs_def) - -lemma threadSet_valid_queues_addToQs: - "\\s. (\ko qdom prio. ko_at' ko t s \ inQ qdom prio (F ko) \ \ inQ qdom prio ko - \ t \ set (ksReadyQueues s (qdom, prio))) - \ valid_queues' (ksReadyQueues_update (addToQs F t) s)\ - threadSet F t - \\rv. 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_set_def - split del: if_split cong: if_cong) - apply (fastforce simp: projectKOs split: if_split_asm) - done - -lemma threadSet_valid_queues_Qf: - "\\s. (\ko qdom prio. ko_at' ko t s \ inQ qdom prio (F ko) \ \ inQ qdom prio ko - \ t \ set (ksReadyQueues s (qdom, prio))) - \ valid_queues' (ksReadyQueues_update Qf s) - \ (\prio. set (Qf (ksReadyQueues s) prio) - \ set (addToQs F t (ksReadyQueues s) prio))\ - threadSet F t - \\rv. valid_queues'\" - apply (wp threadSet_valid_queues_addToQs) - apply (clarsimp simp: valid_queues'_def subset_iff) - done - -lemma addToQs_subset: - "set (qs p) \ set (addToQs F t qs p)" -by (clarsimp simp: addToQs_def split_def) - -lemmas threadSet_valid_queues' - = threadSet_valid_queues_Qf - [where Qf=id, simplified ksReadyQueues_update_id - id_apply addToQs_subset simp_thms] - lemma threadSet_cur: "\\s. cur_tcb' s\ threadSet f t \\rv s. cur_tcb' s\" apply (simp add: threadSet_def cur_tcb'_def) @@ -981,7 +1012,7 @@ lemma modifyReadyQueuesL1Bitmap_obj_at[wp]: crunches setThreadState, setBoundNotification for valid_arch' [wp]: valid_arch_state' - (simp: unless_def crunch_simps) + (simp: unless_def crunch_simps wp: crunch_wps) crunch ksInterrupt'[wp]: threadSet "\s. P (ksInterruptState s)" (wp: setObject_ksInterrupt updateObject_default_inv) @@ -1237,57 +1268,103 @@ lemma threadSet_valid_dom_schedule': unfolding threadSet_def by (wp setObject_ksDomSchedule_inv hoare_Ball_helper) +lemma threadSet_wp: + "\\s. \tcb. ko_at' tcb t s \ P (s\ksPSpace := (ksPSpace s)(t \ injectKO (f tcb))\)\ + threadSet f t + \\_. P\" + unfolding threadSet_def setObject_def + apply (wpsimp wp: getObject_tcb_wp simp: updateObject_default_def) + apply (auto simp: obj_at'_def split: if_splits) + apply (erule rsubst[where P=P]) + apply (clarsimp simp: fun_upd_def) + apply (prop_tac "\ptr. psMap (ksPSpace s) ptr = ksPSpace s ptr") + apply fastforce + apply metis + done + +lemma threadSet_sched_pointers: + "\\tcb. tcbSchedNext (F tcb) = tcbSchedNext tcb; \tcb. tcbSchedPrev (F tcb) = tcbSchedPrev tcb\ + \ threadSet F tcbPtr \\s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + apply (erule rsubst2[where P=P]) + apply (fastforce simp: opt_map_def obj_at'_def projectKOs) + apply (fastforce simp: opt_map_def obj_at'_def projectKOs) + done + +lemma threadSet_valid_sched_pointers: + "\\tcb. tcbSchedNext (F tcb) = tcbSchedNext tcb; \tcb. tcbSchedPrev (F tcb) = tcbSchedPrev tcb; + \tcb. tcbQueued (F tcb) = tcbQueued tcb\ + \ threadSet F tcbPtr \valid_sched_pointers\" + unfolding valid_sched_pointers_def + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + by (fastforce simp: opt_pred_def opt_map_def obj_at'_def projectKOs split: option.splits if_splits) + +lemma threadSet_tcbSchedNexts_of: + "(\tcb. tcbSchedNext (F tcb) = tcbSchedNext tcb) \ + threadSet F t \\s. P (tcbSchedNexts_of s)\" + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + apply (erule rsubst[where P=P]) + apply (fastforce simp: opt_map_def obj_at'_def projectKOs) + done + +lemma threadSet_tcbSchedPrevs_of: + "(\tcb. tcbSchedPrev (F tcb) = tcbSchedPrev tcb) \ + threadSet F t \\s. P (tcbSchedPrevs_of s)\" + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + apply (erule rsubst[where P=P]) + apply (fastforce simp: opt_map_def obj_at'_def projectKOs) + done + +lemma threadSet_tcbQueued: + "(\tcb. tcbQueued (F tcb) = tcbQueued tcb) \ + threadSet F t \\s. P (tcbQueued |< tcbs_of' s)\" + apply (wpsimp wp: threadSet_wp getObject_tcb_wp) + apply (erule rsubst[where P=P]) + apply (fastforce simp: opt_pred_def opt_map_def obj_at'_def projectKOs) + done + +crunches threadSet + for ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" + and ksReadyQueuesL1Bitmap[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" + and ksReadyQueuesL2Bitmap[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" + lemma threadSet_invs_trivialT: - assumes x: "\tcb. \(getF,setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" - assumes z: "\tcb. tcbState (F tcb) = tcbState tcb \ tcbDomain (F tcb) = tcbDomain tcb" - assumes w: "\tcb. is_aligned (tcbIPCBuffer tcb) msg_align_bits \ is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits" - assumes a: "\tcb. tcbBoundNotification (F tcb) = tcbBoundNotification tcb" - assumes w: "\tcb. is_aligned (tcbIPCBuffer tcb) msg_align_bits \ is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits" - 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" - shows - "\\s. invs' s \ - 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. \ tcbQueued tcb \ tcbQueued (F tcb)) \ ex_nonz_cap_to' t s \ t \ ksCurThread s) \ - (\tcb. tcbQueued (F tcb) \ ksSchedulerAction s = ResumeCurrentThread \ tcbQueued tcb \ t \ ksCurThread s)\ - threadSet F t - \\rv. invs'\" -proof - - from z have domains: "\tcb. tcbDomain (F tcb) = tcbDomain tcb" by blast - note threadSet_sch_actT_P[where P=False, simplified] - have y: "\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 valid_state'_def split del: if_split) - apply (rule hoare_pre) - apply (wp x w v u b - threadSet_valid_pspace'T - threadSet_sch_actT_P[where P=False, simplified] - threadSet_valid_queues - 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'' valid_ioports_lift'' - threadSet_ctes_ofT - threadSet_not_inQ - threadSet_ct_idle_or_in_cur_domain' - threadSet_valid_dom_schedule' - threadSet_valid_queues' - threadSet_cur - untyped_ranges_zero_lift - |clarsimp simp: y z a domains cteCaps_of_def |rule refl)+ - apply (clarsimp simp: obj_at'_def projectKOs pred_tcb_at'_def) - apply (clarsimp simp: cur_tcb'_def valid_irq_node'_def valid_queues'_def o_def) - by (fastforce simp: domains ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def z a) -qed + assumes + "\tcb. \(getF,setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" + "\tcb. tcbState (F tcb) = tcbState tcb" + "\tcb. is_aligned (tcbIPCBuffer tcb) msg_align_bits + \ is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits" + "\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. tcbMCP tcb \ maxPriority \ tcbMCP (F tcb) \ maxPriority" + shows "threadSet F t \invs'\" + apply (simp add: invs'_def valid_state'_def split del: if_split) + apply (wp threadSet_valid_pspace'T + threadSet_sch_actT_P[where P=False, simplified] + 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'' valid_ioports_lift'' + threadSet_ctes_ofT + threadSet_not_inQ + threadSet_ct_idle_or_in_cur_domain' + threadSet_valid_dom_schedule' + threadSet_cur + untyped_ranges_zero_lift + sym_heap_sched_pointers_lift threadSet_valid_sched_pointers + threadSet_tcbQueued + threadSet_tcbSchedPrevs_of threadSet_tcbSchedNexts_of valid_bitmaps_lift + | clarsimp simp: assms cteCaps_of_def | rule refl)+ + apply (clarsimp simp: o_def) + by (auto simp: assms obj_at'_def) lemmas threadSet_invs_trivial = threadSet_invs_trivialT [OF all_tcbI all_tcbI all_tcbI all_tcbI, OF ball_tcb_cte_casesI] @@ -1327,10 +1404,73 @@ lemma threadSet_valid_objs': apply (clarsimp elim!: obj_at'_weakenE) done +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'] + +lemma setObject_valid_tcbs': + assumes preserve_valid_tcb': "\s s' ko ko' x n tcb tcb'. + \ (ko', s') \ fst (updateObject val ko ptr x n s); P s; + lookupAround2 ptr (ksPSpace s) = (Some (x, ko), n); + projectKO_opt ko = Some tcb; projectKO_opt ko' = Some tcb'; + valid_tcb' tcb s \ \ valid_tcb' tcb' s" + shows "\valid_tcbs' and P\ setObject ptr val \\rv. valid_tcbs'\" + unfolding valid_tcbs'_def + apply (clarsimp simp: valid_def) + apply (rename_tac s s' ptr' tcb) + apply (prop_tac "\tcb'. valid_tcb' tcb s \ valid_tcb' tcb s'") + apply clarsimp + apply (erule (1) use_valid[OF _ setObject_valid_tcb']) + apply (drule spec, erule mp) + apply (clarsimp simp: setObject_def in_monad split_def lookupAround2_char1) + apply (rename_tac s ptr' new_tcb' ptr'' old_tcb_ko' s' f) + apply (case_tac "ptr'' = ptr'"; clarsimp) + apply (prop_tac "\old_tcb' :: tcb. projectKO_opt old_tcb_ko' = Some old_tcb'") + apply (frule updateObject_type) + apply (case_tac old_tcb_ko'; clarsimp simp: project_inject) + apply (erule exE) + apply (rule preserve_valid_tcb', assumption+) + apply (simp add: prod_eqI lookupAround2_char1) + apply force + apply (clarsimp simp: project_inject) + apply (clarsimp simp: project_inject) + done + +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 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 + \\_. valid_tcb' tcb\" + apply (simp add: threadSet_def) + apply (wpsimp wp: setObject_valid_tcb') + done + +lemma threadSet_valid_tcbs': + "\valid_tcbs' and (\s. \tcb. valid_tcb' tcb s \ valid_tcb' (f tcb) s)\ + threadSet f t + \\_. valid_tcbs'\" + apply (simp add: threadSet_def) + apply (rule hoare_seq_ext[OF _ getObject_tcb_sp]) + apply (wpsimp wp: setObject_tcb_valid_tcbs') + 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 objBits_simps') + done + lemma asUser_corres': assumes y: "corres_underlying Id False True r \ \ f g" - shows "corres r (tcb_at t) - (tcb_at' t) + shows "corres r (tcb_at t and pspace_aligned and pspace_distinct) \ (as_user t f) (asUser t g)" proof - note arch_tcb_context_get_def[simp] @@ -1338,7 +1478,7 @@ lemma asUser_corres': note arch_tcb_context_set_def[simp] note atcbContextSet_def[simp] have L1: "corres (\tcb con. (arch_tcb_context_get o tcb_arch) tcb = con) - (tcb_at t) (tcb_at' t) + (tcb_at t and pspace_aligned and pspace_distinct) \ (gets_the (get_tcb t)) (threadGet (atcbContextGet o tcbArch) t)" apply (rule corres_guard_imp) apply (rule corres_gets_the) @@ -1364,6 +1504,8 @@ lemma asUser_corres': using y by (fastforce simp: corres_underlying_def select_f_def split_def Id_def) show ?thesis + apply (rule corres_cross_over_guard[where Q="tcb_at' t"]) + apply (fastforce elim: tcb_at_cross) apply (simp add: as_user_def asUser_def) apply (rule corres_guard_imp) apply (rule_tac r'="\tcb con. (arch_tcb_context_get o tcb_arch) tcb = con" @@ -1387,7 +1529,7 @@ qed lemma asUser_corres: assumes y: "corres_underlying Id False True r \ \ f g" - shows "corres r (tcb_at t and invs) (tcb_at' t and invs') (as_user t f) (asUser t g)" + shows "corres r (tcb_at t and invs) invs' (as_user t f) (asUser t g)" apply (rule corres_guard_imp) apply (rule asUser_corres' [OF y]) apply (simp add: invs_def valid_state_def valid_pspace_def) @@ -1415,17 +1557,15 @@ proof - qed lemma asUser_getRegister_corres: - "corres (=) (tcb_at t) (tcb_at' t) - (as_user t (getRegister r)) (asUser t (getRegister r))" + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ + (as_user t (getRegister r)) (asUser t (getRegister r))" apply (rule asUser_corres') apply (clarsimp simp: getRegister_def) done lemma user_getreg_inv'[wp]: "\P\ asUser t (getRegister r) \\x. P\" - apply (rule asUser_inv) - apply (simp_all add: getRegister_def) - done + by (wp asUser_inv) lemma asUser_typ_at' [wp]: "\\s. P (typ_at' T p s)\ asUser t' f \\rv s. P (typ_at' T p s)\" @@ -1437,7 +1577,6 @@ lemma asUser_invs[wp]: "\invs' and tcb_at' t\ asUser t m \\rv. invs'\" apply (simp add: asUser_def split_def) apply (wp hoare_drop_imps | simp)+ - apply (wp threadSet_invs_trivial hoare_drop_imps | simp)+ done @@ -1465,14 +1604,6 @@ lemma asUser_valid_pspace'[wp]: apply (wp threadSet_valid_pspace' hoare_drop_imps | simp)+ done -lemma asUser_valid_queues[wp]: - "\Invariants_H.valid_queues\ asUser t m \\rv. Invariants_H.valid_queues\" - apply (simp add: asUser_def split_def) - apply (wp hoare_drop_imps | simp)+ - - apply (wp threadSet_valid_queues hoare_drop_imps | simp)+ - done - lemma asUser_ifunsafe'[wp]: "\if_unsafe_then_cap'\ asUser t m \\rv. if_unsafe_then_cap'\" apply (simp add: asUser_def split_def) @@ -1564,8 +1695,8 @@ lemma no_fail_asUser [wp]: done lemma asUser_setRegister_corres: - "corres dc (tcb_at t) - (tcb_at' t) + "corres dc (tcb_at t and pspace_aligned and pspace_distinct) + \ (as_user t (setRegister r v)) (asUser t (setRegister r v))" apply (simp add: setRegister_def) @@ -1574,7 +1705,7 @@ lemma asUser_setRegister_corres: done lemma getThreadState_corres: - "corres thread_state_relation (tcb_at t) (tcb_at' t) + "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) @@ -1605,7 +1736,7 @@ lemma gts_inv'[wp]: "\P\ getThreadState t \\rv. by (simp add: getThreadState_def) wp lemma getBoundNotification_corres: - "corres (=) (tcb_at t) (tcb_at' t) + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ (get_bound_notification t) (getBoundNotification t)" apply (simp add: get_bound_notification_def getBoundNotification_def) apply (rule threadGet_corres) @@ -1750,19 +1881,22 @@ lemma ethreadget_corres: apply (simp add: x) done -lemma setQueue_corres: - "corres dc \ \ (set_tcb_queue d p q) (setQueue d p q)" - apply (rule corres_no_failI) - apply wp - apply (clarsimp simp: setQueue_def in_monad set_tcb_queue_def return_def simpler_modify_def) - apply (fastforce simp: state_relation_def ready_queues_relation_def) - done - - -lemma getQueue_corres: "corres (=) \ \ (get_tcb_queue qdom prio) (getQueue qdom prio)" - apply (clarsimp simp add: getQueue_def state_relation_def ready_queues_relation_def get_tcb_queue_def gets_def) - apply (fold gets_def) - apply simp +lemma getQueue_corres: + "corres (\ls q. (ls = [] \ tcbQueueEmpty q) \ (ls \ [] \ tcbQueueHead q = Some (hd ls)) + \ queue_end_valid ls q) + \ \ (get_tcb_queue qdom prio) (getQueue qdom prio)" + apply (clarsimp simp: get_tcb_queue_def getQueue_def tcbQueueEmpty_def) + apply (rule corres_bind_return2) + apply (rule corres_symb_exec_l[OF _ _ gets_sp]) + apply (rule corres_symb_exec_r[OF _ gets_sp]) + apply clarsimp + apply (drule state_relation_ready_queues_relation) + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def + list_queue_relation_def) + apply (drule_tac x=qdom in spec) + apply (drule_tac x=prio in spec) + apply (fastforce dest: heap_path_head) + apply wpsimp+ done lemma no_fail_return: @@ -1777,8 +1911,8 @@ lemma addToBitmap_noop_corres: (wp | simp add: state_relation_def | rule no_fail_pre)+ lemma addToBitmap_if_null_noop_corres: (* used this way in Haskell code *) - "corres dc \ \ (return ()) (if null queue then addToBitmap d p else return ())" - by (cases "null queue", simp_all add: addToBitmap_noop_corres) + "corres dc \ \ (return ()) (if tcbQueueEmpty queue then addToBitmap d p else return ())" + by (cases "tcbQueueHead queue", simp_all add: addToBitmap_noop_corres) lemma removeFromBitmap_corres_noop: "corres dc \ \ (return ()) (removeFromBitmap tdom prioa)" @@ -1795,54 +1929,701 @@ crunch typ_at'[wp]: removeFromBitmap "\s. P (typ_at' T p s)" 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 ekheap_relation_tcb_domain_priority: + "\ekheap_relation (ekheap s) (ksPSpace s'); ekheap s t = Some (tcb); + ksPSpace s' t = Some (KOTCB tcb')\ + \ 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 (clarsimp simp: other_obj_relation_def etcb_relation_def) + done + +lemma no_fail_thread_get[wp]: + "no_fail (tcb_at tcb_ptr) (thread_get f tcb_ptr)" + unfolding thread_get_def + apply wpsimp + apply (clarsimp simp: tcb_at_def) + done + +lemma pspace_relation_tcb_relation: + "\pspace_relation (kheap s) (ksPSpace s'); kheap s ptr = Some (TCB tcb); + ksPSpace s' ptr = Some (KOTCB tcb')\ + \ 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 + +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) + +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 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 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 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) + +crunches 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) + +crunches 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 + +crunches 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) + +crunches 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 pspace_canonical'[wp]: pspace_canonical' + 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 pspace_in_kernel_mappings'[wp]: pspace_in_kernel_mappings' + and ksIdleThread[wp]: "\s. P (ksIdleThread s)" + (wp: crunch_wps threadSet_state_refs_of'[where f'=id and g'=id] + 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 ready_queue_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: 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 + +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\ + isRunnable tcb_ptr + \\rv s. \tcb'. ko_at' tcb' tcb_ptr s + \ (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_def) + apply (fastforce simp: obj_at'_def split: Structures_H.thread_state.splits) + done + +crunch (no_fail) no_fail[wp]: isRunnable + +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) + +crunches 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 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 in_set_ready_queues_inQ_eq: + "ready_queues_relation s s' \ t \ set (ready_queues s d p) \ (inQ d p |< tcbs_of' s') t" + by (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def) + +lemma in_ready_q_tcbQueued_eq: + "ready_queues_relation s s' + \ (\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_queues_relation_def ready_queue_relation_def Let_def inQ_def + opt_pred_def + split: option.splits) + done + lemma tcbSchedEnqueue_corres: - "corres dc (is_etcb_at t) (tcb_at' t and Invariants_H.valid_queues and valid_queues') - (tcb_sched_action (tcb_sched_enqueue) t) (tcbSchedEnqueue t)" -proof - - have ready_queues_helper: - "\t tcb a b. \ ekheap a t = Some tcb; obj_at' tcbQueued t b ; valid_queues' b ; - ekheap_relation (ekheap a) (ksPSpace b) \ - \ t \ set (ksReadyQueues b (tcb_domain tcb, tcb_priority tcb))" - unfolding valid_queues'_def - by (fastforce dest: ekheap_relation_absD simp: obj_at'_def inQ_def etcb_relation_def projectKO_eq projectKO_tcb) - - show ?thesis unfolding tcbSchedEnqueue_def tcb_sched_action_def - apply (rule corres_symb_exec_r [OF _ _ threadGet_inv, - 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 (rule no_fail_pre, wp, blast) - apply (case_tac queued; simp_all) - apply (rule corres_no_failI; simp add: no_fail_return) - apply (clarsimp simp: in_monad ethread_get_def gets_the_def bind_assoc - assert_opt_def exec_gets is_etcb_at_def get_etcb_def get_tcb_queue_def - set_tcb_queue_def simpler_modify_def ready_queues_relation_def - state_relation_def tcb_sched_enqueue_def) - apply (rule ready_queues_helper; auto) - apply (clarsimp simp: when_def) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres) - apply (simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres) - apply (simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply simp - apply (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 - apply (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 exst_same_def) - apply (wp getObject_tcb_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 + "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)?) + + \ \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) + + 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) + apply (metis inQ_def option.simps(5) tcb_of'_TCB projectKO_eq) + 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 fun_upd_apply projectKOs + 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 projectKOs) + 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 + 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 fun_upd_apply split: if_splits) + apply (clarsimp simp: fun_upd_apply 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 projectKOs + split: if_splits option.splits) definition weak_sch_act_wf :: "scheduler_action \ kernel_state \ bool" @@ -1869,7 +2650,11 @@ lemma getSchedulerAction_corres: done lemma rescheduleRequired_corres: - "corres dc (weak_valid_sched_action and valid_etcbs) (Invariants_H.valid_queues and valid_queues' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)) + "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' + and pspace_aligned' and pspace_distinct') (reschedule_required) rescheduleRequired" apply (simp add: rescheduleRequired_def reschedule_required_def) apply (rule corres_guard_imp) @@ -1880,7 +2665,7 @@ lemma rescheduleRequired_corres: apply (case_tac action) apply simp apply simp - apply (rule tcbSchedEnqueue_corres) + apply (rule tcbSchedEnqueue_corres, simp) apply simp apply (rule setSchedulerAction_corres) apply simp @@ -1956,20 +2741,13 @@ lemmas addToBitmap_weak_sch_act_wf[wp] = weak_sch_act_wf_lift[OF addToBitmap_nosch] crunch st_tcb_at'[wp]: removeFromBitmap "st_tcb_at' P t" -crunch pred_tcb_at'[wp]: removeFromBitmap "pred_tcb_at' proj P t" +crunch pred_tcb_at'[wp]: removeFromBitmap "\s. Q (pred_tcb_at' proj P t s)" -crunch not_st_tcb_at'[wp]: removeFromBitmap "\s. \ (st_tcb_at' P' t) s" -crunch not_pred_tcb_at'[wp]: removeFromBitmap "\s. \ (pred_tcb_at' proj P' t) s" +crunch pred_tcb_at'[wp]: addToBitmap "\s. Q (pred_tcb_at' proj P t s)" -crunch st_tcb_at'[wp]: addToBitmap "st_tcb_at' P' t" -crunch pred_tcb_at'[wp]: addToBitmap "pred_tcb_at' proj P' t" +crunch obj_at'[wp]: removeFromBitmap "\s. Q (obj_at' P t s)" -crunch not_st_tcb_at'[wp]: addToBitmap "\s. \ (st_tcb_at' P' t) s" -crunch not_pred_tcb_at'[wp]: addToBitmap "\s. \ (pred_tcb_at' proj P' t) s" - -crunch obj_at'[wp]: removeFromBitmap "obj_at' P t" - -crunch obj_at'[wp]: addToBitmap "obj_at' P t" +crunch obj_at'[wp]: addToBitmap "\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\" @@ -1986,9 +2764,11 @@ lemma addToBitmap_tcb_in_cur_domain'[wp]: done lemma tcbSchedDequeue_weak_sch_act_wf[wp]: - "\ \s. weak_sch_act_wf (ksSchedulerAction s) s \ tcbSchedDequeue a \ \_ s. weak_sch_act_wf (ksSchedulerAction s) s \" - apply (simp add: tcbSchedDequeue_def) - apply (wp threadSet_weak_sch_act_wf removeFromBitmap_weak_sch_act_wf | simp add: crunch_simps)+ + "tcbSchedDequeue tcbPtr \\s. weak_sch_act_wf (ksSchedulerAction s) s\" + apply (simp add: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wp threadSet_weak_sch_act_wf getObject_tcb_wp removeFromBitmap_weak_sch_act_wf + | simp add: crunch_simps threadGet_def)+ + apply (clarsimp simp: obj_at'_def) done lemma dequeue_nothing_eq[simp]: @@ -2004,44 +2784,343 @@ lemma gets_the_exec: "f s \ None \ (do x \ ge return_def assert_opt_def) done -lemma tcbSchedDequeue_corres: - "corres dc (is_etcb_at t) (tcb_at' t and Invariants_H.valid_queues) - (tcb_sched_action tcb_sched_dequeue t) (tcbSchedDequeue t)" - apply (simp only: tcbSchedDequeue_def tcb_sched_action_def) - apply (rule corres_symb_exec_r[OF _ _ threadGet_inv, where Q'="\rv. tcb_at' t and Invariants_H.valid_queues and obj_at' (\obj. tcbQueued obj = rv) t"]) - defer - apply (wp threadGet_obj_at', simp, simp) - apply (rule no_fail_pre, wp, simp) - apply (case_tac queued) - defer - apply (simp add: when_def) - apply (rule corres_no_failI) - apply (wp) - apply (clarsimp simp: in_monad ethread_get_def set_tcb_queue_def is_etcb_at_def state_relation_def) - apply (subgoal_tac "t \ set (ready_queues a (tcb_domain y) (tcb_priority y))") - prefer 2 - subgoal by (force simp: tcb_sched_dequeue_def Invariants_H.valid_queues_def valid_queues_no_bitmap_def - ready_queues_relation_def obj_at'_def inQ_def projectKO_eq project_inject) - apply (subst gets_the_exec) - apply (simp add: get_etcb_def) - apply (subst gets_the_exec) - apply (simp add: get_etcb_def) - apply (simp add: exec_gets simpler_modify_def get_etcb_def ready_queues_relation_def cong: if_cong get_tcb_queue_def) - apply (simp add: when_def) - apply (rule corres_guard_imp) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres, simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply (rule ethreadget_corres, simp add: etcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply (simp, rule getQueue_corres) - apply (rule corres_split_noop_rhs2) - apply (simp add: tcb_sched_dequeue_def) - apply (rule setQueue_corres) - apply (rule corres_split_noop_rhs) - apply (clarsimp, rule removeFromBitmap_corres_noop) - apply (rule threadSet_corres_noop; simp_all add: tcb_relation_def exst_same_def) - apply (wp | simp)+ +lemma tcbQueueRemove_no_fail: + "no_fail (\s. tcb_at' tcbPtr s + \ (\ts. list_queue_relation ts queue (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ tcbPtr \ set ts) + \ sym_heap_sched_pointers s \ valid_objs' s) + (tcbQueueRemove queue tcbPtr)" + unfolding tcbQueueRemove_def + apply (wpsimp wp: getObject_tcb_wp) + apply normalise_obj_at' + apply (frule (1) ko_at_valid_objs') + apply (fastforce simp: projectKOs) + apply (clarsimp simp: list_queue_relation_def) + apply (prop_tac "tcbQueueHead queue \ Some tcbPtr \ tcbSchedPrevs_of s tcbPtr \ None") + apply (rule impI) + apply (frule not_head_prev_not_None[where p=tcbPtr]) + apply (fastforce simp: inQ_def opt_pred_def opt_map_def obj_at'_def) + apply (fastforce dest: heap_path_head) + apply fastforce + apply (fastforce simp: opt_map_def obj_at'_def valid_tcb'_def valid_bound_tcb'_def) + by (fastforce dest!: not_last_next_not_None[where p=tcbPtr] + simp: queue_end_valid_def opt_map_def obj_at'_def valid_obj'_def valid_tcb'_def + projectKOs) + +crunch (no_fail) no_fail[wp]: removeFromBitmap + +crunches removeFromBitmap + for ready_queues_relation[wp]: "ready_queues_relation s" + and list_queue_relation[wp]: + "\s'. list_queue_relation ts (P (ksReadyQueues s')) + (tcbSchedNexts_of s') (tcbSchedPrevs_of s')" + (simp: bitmap_fun_defs ready_queues_relation_def) + +\ \ + A direct analogue of tcbQueueRemove, used in tcb_sched_dequeue' below, so that within the proof of + tcbQueueRemove_corres, we may reason in terms of the list operations used within this function + rather than @{term filter}.\ +definition tcb_queue_remove :: "'a \ 'a list \ 'a list" where + "tcb_queue_remove a ls \ + if ls = [a] + then [] + else if a = hd ls + then tl ls + else if a = last ls + then butlast ls + else list_remove ls a" + +definition tcb_sched_dequeue' :: "obj_ref \ unit det_ext_monad" where + "tcb_sched_dequeue' tcb_ptr \ do + d \ ethread_get tcb_domain tcb_ptr; + prio \ ethread_get tcb_priority tcb_ptr; + queue \ get_tcb_queue d prio; + when (tcb_ptr \ set queue) $ set_tcb_queue d prio (tcb_queue_remove tcb_ptr queue) + od" + +lemma filter_tcb_queue_remove: + "\a \ set ls; distinct ls \ \ filter ((\) a) ls = tcb_queue_remove a ls" + apply (clarsimp simp: tcb_queue_remove_def) + apply (intro conjI impI) + apply (fastforce elim: filter_hd_equals_tl) + apply (fastforce elim: filter_last_equals_butlast) + apply (fastforce elim: filter_hd_equals_tl) + apply (frule split_list) + apply (clarsimp simp: list_remove_middle_distinct) + apply (subst filter_True | clarsimp simp: list_remove_none)+ + done + +lemma tcb_sched_dequeue_monadic_rewrite: + "monadic_rewrite False True (is_etcb_at t and (\s. \d p. distinct (ready_queues s d p))) + (tcb_sched_action tcb_sched_dequeue t) (tcb_sched_dequeue' t)" + supply if_split[split del] + apply (clarsimp simp: tcb_sched_dequeue'_def tcb_sched_dequeue_def tcb_sched_action_def + set_tcb_queue_def) + apply (rule monadic_rewrite_bind_tail)+ + apply (clarsimp simp: when_def) + apply (rule monadic_rewrite_if_r) + apply (rule_tac P="\_. distinct queue" in monadic_rewrite_guard_arg_cong) + apply (frule (1) filter_tcb_queue_remove) + apply (metis (mono_tags, lifting) filter_cong) + apply (rule monadic_rewrite_modify_noop) + apply (wpsimp wp: thread_get_wp)+ + apply (clarsimp simp: etcb_at_def split: option.splits) + apply (prop_tac "(\d' p. if d' = tcb_domain x2 \ p = tcb_priority x2 + then filter (\x. x \ t) (ready_queues s (tcb_domain x2) (tcb_priority x2)) + else ready_queues s d' p) + = ready_queues s") + apply (subst filter_True) + apply fastforce + apply (fastforce split: if_splits) + apply fastforce + done + +crunches removeFromBitmap + for ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" + +lemma list_queue_relation_neighbour_in_set: + "\list_queue_relation ls q hp hp'; sym_heap hp hp'; p \ set ls\ + \ \nbr. (hp p = Some nbr \ nbr \ set ls) \ (hp' p = Some nbr \ nbr \ set ls)" + apply (rule heap_ls_neighbour_in_set) + apply (fastforce simp: list_queue_relation_def) + apply fastforce + apply (clarsimp simp: list_queue_relation_def prev_queue_head_def) + apply fastforce + done + +lemma in_queue_not_head_or_not_tail_length_gt_1: + "\tcbPtr \ set ls; tcbQueueHead q \ Some tcbPtr \ tcbQueueEnd q \ Some tcbPtr; + list_queue_relation ls q nexts prevs\ + \ Suc 0 < length ls" + apply (clarsimp simp: list_queue_relation_def) + apply (cases ls; fastforce simp: queue_end_valid_def) + done + +lemma tcbSchedDequeue_corres: + "tcb_ptr = tcbPtr \ + corres dc + (in_correct_ready_q and ready_qs_distinct and valid_etcbs and tcb_at tcb_ptr + and pspace_aligned and pspace_distinct) + (sym_heap_sched_pointers and valid_objs') + (tcb_sched_action tcb_sched_dequeue tcb_ptr) (tcbSchedDequeue tcbPtr)" + supply heap_path_append[simp del] fun_upd_apply[simp del] distinct_append[simp del] + list_remove_append[simp del] projectKOs[simp] + apply (rule_tac Q'="tcb_at' tcbPtr" in corres_cross_add_guard) + apply (fastforce intro!: tcb_at_cross simp: obj_at_def is_tcb_def) + apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) + apply (fastforce dest: pspace_aligned_cross) + apply (rule_tac Q'=pspace_distinct' in corres_cross_add_guard) + apply (fastforce dest: pspace_distinct_cross) + apply (rule monadic_rewrite_corres_l[where P=P and Q=P for P, simplified]) + apply (rule monadic_rewrite_guard_imp[OF tcb_sched_dequeue_monadic_rewrite]) + apply (fastforce dest: tcb_at_is_etcb_at simp: in_correct_ready_q_def ready_qs_distinct_def) + apply (clarsimp simp: tcb_sched_dequeue'_def get_tcb_queue_def tcbSchedDequeue_def getQueue_def + unless_def when_def) + apply (rule corres_symb_exec_l[OF _ _ ethread_get_sp]; wpsimp?) + apply (rename_tac dom) + apply (rule corres_symb_exec_l[OF _ _ ethread_get_sp]; wpsimp?) + apply (rename_tac prio) + 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 _ threadGet_sp]; (solves wpsimp)?) + apply (rule corres_if_strong'; fastforce?) + apply (frule state_relation_ready_queues_relation) + apply (frule in_ready_q_tcbQueued_eq[where t=tcbPtr]) + apply (fastforce 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) + apply (rule corres_symb_exec_r[OF _ threadGet_sp]; wpsimp?) + apply (rule corres_symb_exec_r[OF _ threadGet_sp]; wpsimp?) + apply (rule corres_symb_exec_r[OF _ gets_sp]; wpsimp?) + apply (rule corres_from_valid_det) + apply (fastforce intro: det_wp_modify det_wp_pre simp: set_tcb_queue_def) + apply (wpsimp wp: tcbQueueRemove_no_fail) + apply (fastforce dest: state_relation_ready_queues_relation + simp: ex_abs_underlying_def ready_queues_relation_def ready_queue_relation_def + Let_def inQ_def opt_pred_def opt_map_def obj_at'_def) + apply (clarsimp simp: state_relation_def) + apply (intro hoare_vcg_conj_lift_pre_fix; + (solves \frule singleton_eqD, frule set_tcb_queue_projs_inv, wpsimp simp: swp_def\)?) + + \ \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 tcbQueueRemove_def + split_del: if_split) + apply (frule (1) tcb_at_is_etcb_at) + apply (clarsimp simp: obj_at_def is_etcb_at_def etcb_at_def) + apply normalise_obj_at' + 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) + + apply (case_tac "d \ tcb_domain etcb \ p \ tcb_priority etcb") + apply clarsimp + apply (cut_tac p=tcbPtr and ls="ready_queues s (tcb_domain etcb) (tcb_priority etcb)" + in list_queue_relation_neighbour_in_set) + apply (fastforce dest!: spec) + apply fastforce + apply fastforce + apply (cut_tac xs="ready_queues s d p" in heap_path_head') + apply (force dest!: spec simp: ready_queues_relation_def Let_def list_queue_relation_def) + 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 (cut_tac ts="ready_queues s d p" in list_queue_relation_nil) + apply fast + apply (clarsimp simp: tcbQueueEmpty_def) + apply (prop_tac "Some tcbPtr \ tcbQueueHead (ksReadyQueues s' (d, p))") + apply (metis hd_in_set not_emptyI option.sel option.simps(2)) + apply (prop_tac "tcbPtr \ set (ready_queues s d p)") + apply blast + apply (clarsimp simp: list_queue_relation_def) + apply (intro conjI; clarsimp) + + \ \the ready queue is the singleton consisting of tcbPtr\ + apply (intro conjI) + apply (force intro!: heap_path_heap_upd_not_in simp: fun_upd_apply) + apply (clarsimp simp: queue_end_valid_def fun_upd_apply) + apply (force simp: prev_queue_head_heap_upd fun_upd_apply) + apply (clarsimp simp: inQ_def in_opt_pred fun_upd_apply) + apply (clarsimp simp: fun_upd_apply) + apply (clarsimp simp: fun_upd_apply) + + apply (clarsimp simp: etcb_at_def obj_at'_def) + apply (intro conjI; clarsimp) + + \ \tcbPtr is the head of the ready queue\ + apply (intro conjI) + apply (intro heap_path_heap_upd_not_in) + apply (force simp: fun_upd_apply) + apply (force simp: not_emptyI opt_map_red) + apply assumption + apply (clarsimp simp: queue_end_valid_def fun_upd_apply) + apply (clarsimp simp: prev_queue_head_def fun_upd_apply) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + apply (clarsimp simp: fun_upd_apply) + apply (clarsimp simp: fun_upd_apply) + apply (intro conjI; clarsimp) + + \ \tcbPtr is the end of the ready queue\ + apply (intro conjI) + apply (intro heap_path_heap_upd_not_in) + apply (simp add: fun_upd_apply split: if_splits) + apply (force simp: not_emptyI opt_map_red) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + apply (clarsimp simp: queue_end_valid_def fun_upd_apply) + apply (force simp: prev_queue_head_def fun_upd_apply opt_map_red opt_map_upd_triv) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + apply (clarsimp simp: fun_upd_apply) + apply (clarsimp simp: fun_upd_apply) + + \ \tcbPtr is in the middle of the ready queue\ + apply (intro conjI) + apply (intro heap_path_heap_upd_not_in) + apply (simp add: fun_upd_apply) + apply (force simp: not_emptyI opt_map_red) + apply (force simp: not_emptyI opt_map_red) + apply fastforce + apply (clarsimp simp: opt_map_red opt_map_upd_triv) + apply (intro prev_queue_head_heap_upd) + apply (force dest!: spec) + apply (metis hd_in_set not_emptyI option.sel option.simps(2)) + apply fastforce + subgoal + by (clarsimp simp: inQ_def opt_map_def opt_pred_def fun_upd_apply + split: if_splits option.splits) + + \ \d = tcb_domain tcb \ p = tcb_priority tcb\ + apply clarsimp + apply (drule_tac x="tcb_domain etcb" in spec) + apply (drule_tac x="tcb_priority etcb" in spec) + apply (clarsimp simp: list_queue_relation_def) + apply (frule heap_path_head') + apply (frule heap_ls_distinct) + apply (intro conjI; clarsimp simp: tcbQueueEmpty_def) + + \ \the ready queue is the singleton consisting of tcbPtr\ + apply (intro conjI) + apply (simp add: fun_upd_apply tcb_queue_remove_def queue_end_valid_def heap_ls_unique + heap_path_last_end) + apply (simp add: fun_upd_apply tcb_queue_remove_def queue_end_valid_def heap_ls_unique + heap_path_last_end) + apply (simp add: fun_upd_apply prev_queue_head_def) + apply (case_tac "ready_queues s (tcb_domain etcb) (tcb_priority etcb)"; + clarsimp simp: tcb_queue_remove_def inQ_def opt_pred_def fun_upd_apply) + apply (intro conjI; clarsimp) + + \ \tcbPtr is the head of the ready queue\ + apply (frule set_list_mem_nonempty) + apply (frule in_queue_not_head_or_not_tail_length_gt_1) + apply fastforce + apply (fastforce simp: list_queue_relation_def) + apply (frule list_not_head) + apply (clarsimp simp: tcb_queue_remove_def) + apply (frule length_tail_nonempty) + apply (frule (2) heap_ls_next_of_hd) + apply (clarsimp simp: obj_at'_def) + apply (intro conjI impI allI) + apply (drule (1) heap_ls_remove_head_not_singleton) + apply (clarsimp simp: opt_map_red opt_map_upd_triv fun_upd_apply) + apply (clarsimp simp: queue_end_valid_def fun_upd_apply last_tl) + apply (clarsimp simp: prev_queue_head_def fun_upd_apply) + apply (case_tac "ready_queues s (tcb_domain etcb) (tcb_priority etcb)"; + clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + apply (intro conjI; clarsimp) + + \ \tcbPtr is the end of the ready queue\ + apply (frule set_list_mem_nonempty) + apply (frule in_queue_not_head_or_not_tail_length_gt_1) + apply fast + apply (force dest!: spec simp: list_queue_relation_def) + apply (clarsimp simp: queue_end_valid_def) + apply (frule list_not_last) + apply (clarsimp simp: tcb_queue_remove_def) + apply (frule length_gt_1_imp_butlast_nonempty) + apply (frule (3) heap_ls_prev_of_last) + apply (clarsimp simp: obj_at'_def) + apply (intro conjI impI; clarsimp?) + apply (drule (1) heap_ls_remove_last_not_singleton) + apply (force elim!: rsubst3[where P=heap_ls] simp: opt_map_def fun_upd_apply) + apply (clarsimp simp: opt_map_def fun_upd_apply) + apply (clarsimp simp: prev_queue_head_def fun_upd_apply opt_map_def) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply split: option.splits) + apply (meson distinct_in_butlast_not_last in_set_butlastD last_in_set not_last_in_set_butlast) + + \ \tcbPtr is in the middle of the ready queue\ + apply (clarsimp simp: obj_at'_def) + apply (frule set_list_mem_nonempty) + apply (frule split_list) + apply clarsimp + apply (rename_tac xs ys) + apply (prop_tac "xs \ [] \ ys \ []", fastforce simp: queue_end_valid_def) + apply clarsimp + apply (frule (2) ptr_in_middle_prev_next) + apply fastforce + apply (clarsimp simp: tcb_queue_remove_def) + apply (prop_tac "tcbPtr \ last xs") + apply (clarsimp simp: distinct_append) + apply (prop_tac "tcbPtr \ hd ys") + apply (fastforce dest: hd_in_set simp: distinct_append) + apply (prop_tac "last xs \ hd ys") + apply (metis distinct_decompose2 hd_Cons_tl last_in_set) + apply (prop_tac "list_remove (xs @ tcbPtr # ys) tcbPtr = xs @ ys") + apply (simp add: list_remove_middle_distinct) + apply (intro conjI impI allI; (solves \clarsimp simp: distinct_append\)?) + apply (fastforce elim!: rsubst3[where P=heap_ls] + dest!: heap_ls_remove_middle hd_in_set last_in_set + simp: distinct_append not_emptyI opt_map_def fun_upd_apply) + apply (clarsimp simp: queue_end_valid_def fun_upd_apply) + apply (case_tac xs; + fastforce simp: prev_queue_head_def opt_map_def fun_upd_apply distinct_append) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def fun_upd_apply distinct_append + split: option.splits) done lemma thread_get_test: "do cur_ts \ get_thread_state cur; g (test cur_ts) od = @@ -2049,7 +3128,9 @@ lemma thread_get_test: "do cur_ts \ get_thread_state cur; g (test cur apply (simp add: get_thread_state_def thread_get_def) done -lemma thread_get_isRunnable_corres: "corres (=) (tcb_at t) (tcb_at' t) (thread_get (\tcb. runnable (tcb_state tcb)) t) (isRunnable t)" +lemma thread_get_isRunnable_corres: + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ + (thread_get (\tcb. runnable (tcb_state tcb)) t) (isRunnable t)" apply (simp add: isRunnable_def getThreadState_def threadGet_def thread_get_def) apply (fold liftM_def) @@ -2063,8 +3144,8 @@ lemma thread_get_isRunnable_corres: "corres (=) (tcb_at t) (tcb_at' t) (thread_g lemma setThreadState_corres: "thread_state_relation ts ts' \ corres dc - (tcb_at t) - (tcb_at' t) + (tcb_at t and pspace_aligned and pspace_distinct) + \ (set_thread_state t ts) (setThreadState ts' t)" (is "?tsr \ corres dc ?Pre ?Pre' ?sts ?sts'") apply (simp add: set_thread_state_def setThreadState_def) @@ -2088,8 +3169,8 @@ lemma setThreadState_corres: lemma setBoundNotification_corres: "corres dc - (tcb_at t) - (tcb_at' t) + (tcb_at t and pspace_aligned and pspace_distinct) + \ (set_bound_notification t ntfn) (setBoundNotification ntfn t)" apply (simp add: set_bound_notification_def setBoundNotification_def) apply (subst thread_set_def[simplified, symmetric]) @@ -2098,31 +3179,85 @@ lemma setBoundNotification_corres: crunches rescheduleRequired, tcbSchedDequeue, setThreadState, setBoundNotification for tcb'[wp]: "tcb_at' addr" - (simp: unless_def) + +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 + +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 + +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) + +crunches addToBitmap + for valid_objs'[wp]: valid_objs' + (simp: unless_def crunch_simps wp: crunch_wps) + +lemma tcbSchedEnqueue_valid_objs'[wp]: + "\valid_objs' and pspace_aligned' and pspace_distinct'\ + tcbSchedEnqueue tcbPtr + \\_. valid_objs'\" + 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 crunches rescheduleRequired, removeFromBitmap for valid_objs'[wp]: valid_objs' (simp: crunch_simps) -lemma tcbSchedDequeue_valid_objs' [wp]: "\ valid_objs' \ tcbSchedDequeue t \\_. valid_objs' \" - unfolding tcbSchedDequeue_def - apply (wp threadSet_valid_objs') - apply (clarsimp simp add: valid_tcb'_def tcb_cte_cases_def) - apply wp - apply (simp add: if_apply_def2) - apply (wp hoare_drop_imps) - apply (wp | simp cong: if_cong add: valid_tcb'_def tcb_cte_cases_def if_apply_def2)+ +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] + +lemma tcbQueueRemove_valid_objs'[wp]: + "tcbQueueRemove queue tcbPtr \valid_objs'\" + unfolding tcbQueueRemove_def + apply (wpsimp wp: getObject_tcb_wp) + apply normalise_obj_at' + apply (fastforce dest!: tcb_ko_at_valid_objs_valid_tcb' + simp: valid_tcb'_def valid_bound_tcb'_def obj_at'_def) done +lemma tcbSchedDequeue_valid_objs'[wp]: + "tcbSchedDequeue t \valid_objs'\" + unfolding tcbSchedDequeue_def setQueue_def + by (wpsimp wp: threadSet_valid_objs') + lemma sts_valid_objs': - "\valid_objs' and valid_tcb_state' st\ - setThreadState st t - \\rv. valid_objs'\" - apply (simp add: setThreadState_def setQueue_def isRunnable_def isStopped_def) - apply (wp threadSet_valid_objs') - apply (simp add: valid_tcb'_def tcb_cte_cases_def) - apply (wp threadSet_valid_objs' | simp)+ - apply (clarsimp simp: valid_tcb'_def tcb_cte_cases_def) + "\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') + 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': @@ -2165,19 +3300,12 @@ lemma sts'_valid_pspace'_inv[wp]: apply (simp add: tcb_cte_cases_def) done -crunch ct[wp]: setQueue "\s. P (ksCurThread s)" - -crunch cur_domain[wp]: setQueue "\s. P (ksCurDomain s)" - -crunch ct'[wp]: addToBitmap "\s. P (ksCurThread s)" -crunch ct'[wp]: removeFromBitmap "\s. P (ksCurThread s)" - 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 \ @@ -2210,18 +3338,6 @@ lemma setQueue_valid_bitmapQ_except[wp]: unfolding setQueue_def bitmapQ_defs by (wp, clarsimp simp: bitmapQ_def) -lemma setQueue_valid_bitmapQ: (* enqueue only *) - "\ valid_bitmapQ and (\s. (ksReadyQueues s (d, p) = []) = (ts = [])) \ - setQueue d p ts - \\_. valid_bitmapQ \" - unfolding setQueue_def bitmapQ_defs - by (wp, clarsimp simp: bitmapQ_def) - -lemma setQueue_valid_queues': - "\valid_queues' and (\s. \t. obj_at' (inQ d p) t s \ t \ set ts)\ - setQueue d p ts \\_. valid_queues'\" - by (wp | simp add: valid_queues'_def setQueue_def)+ - lemma setQueue_cur: "\\s. cur_tcb' s\ setQueue d p ts \\rv s. cur_tcb' s\" unfolding setQueue_def cur_tcb'_def @@ -2359,9 +3475,17 @@ lemma threadSet_queued_sch_act_wf[wp]: apply (wp tcb_in_cur_domain'_lift | simp add: obj_at'_def)+ done +lemma tcbSchedNext_update_pred_tcb_at'[wp]: + "threadSet (tcbSchedNext_update f) t \\s. P (pred_tcb_at' proj P' t' s)\" + by (wp threadSet_pred_tcb_no_state crunch_wps | clarsimp simp: tcb_to_itcb'_def)+ + +lemma tcbSchedPrev_update_pred_tcb_at'[wp]: + "threadSet (tcbSchedPrev_update f) t \\s. P (pred_tcb_at' proj P' t' s)\" + by (wp threadSet_pred_tcb_no_state crunch_wps | clarsimp simp: tcb_to_itcb'_def)+ + lemma tcbSchedEnqueue_pred_tcb_at'[wp]: "\\s. pred_tcb_at' proj P' t' s \ tcbSchedEnqueue t \\_ s. pred_tcb_at' proj P' t' s\" - apply (simp add: tcbSchedEnqueue_def when_def unless_def) + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def when_def unless_def) apply (wp threadSet_pred_tcb_no_state crunch_wps | clarsimp simp: tcb_to_itcb'_def)+ done @@ -2369,8 +3493,9 @@ lemma tcbSchedDequeue_sch_act_wf[wp]: "\\s. sch_act_wf (ksSchedulerAction s) s\ tcbSchedDequeue t \\_ s. sch_act_wf (ksSchedulerAction s) s\" - unfolding tcbSchedDequeue_def - by (wp setQueue_sch_act | wp sch_act_wf_lift | simp add: if_apply_def2)+ + unfolding tcbSchedDequeue_def tcbQueueRemove_def + by (wp setQueue_sch_act threadSet_tcbDomain_triv hoare_drop_imps + | wp sch_act_wf_lift | simp add: if_apply_def2)+ crunch nosch: tcbSchedDequeue "\s. P (ksSchedulerAction s)" @@ -2466,21 +3591,22 @@ lemma tcbSchedEnqueue_sch_act[wp]: "\\s. sch_act_wf (ksSchedulerAction s) s\ tcbSchedEnqueue t \\_ s. sch_act_wf (ksSchedulerAction s) s\" - by (simp add: tcbSchedEnqueue_def unless_def) - (wp setQueue_sch_act | wp sch_act_wf_lift | clarsimp)+ + by (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_def) + (wp setQueue_sch_act threadSet_tcbDomain_triv | wp sch_act_wf_lift | clarsimp)+ lemma tcbSchedEnqueue_weak_sch_act[wp]: "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ tcbSchedEnqueue t \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: tcbSchedEnqueue_def unless_def) + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_def) apply (wp setQueue_sch_act threadSet_weak_sch_act_wf | clarsimp)+ done -lemma threadGet_wp: "\\s. tcb_at' t s \ (\tcb. ko_at' tcb t s \ P (f tcb) s)\ threadGet f t \P\" +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 + apply (clarsimp simp: obj_at'_def) done lemma threadGet_const: @@ -2526,14 +3652,6 @@ lemma addToBitmap_bitmapQ: by (wpsimp simp: bitmap_fun_defs bitmapQ_def prioToL1Index_bit_set prioL2Index_bit_set simp_del: bit_exp_iff) -lemma addToBitmap_valid_queues_no_bitmap_except: -" \ valid_queues_no_bitmap_except t \ - addToBitmap d p - \\_. valid_queues_no_bitmap_except t \" - unfolding addToBitmap_def modifyReadyQueuesL1Bitmap_def modifyReadyQueuesL2Bitmap_def - getReadyQueuesL1Bitmap_def getReadyQueuesL2Bitmap_def valid_queues_no_bitmap_except_def - by (wp, clarsimp) - crunch norq[wp]: addToBitmap "\s. P (ksReadyQueues s)" (wp: updateObject_cte_inv hoare_drop_imps) crunch norq[wp]: removeFromBitmap "\s. P (ksReadyQueues s)" @@ -2565,9 +3683,8 @@ lemma prioToL1Index_complement_nth_w2p: lemma valid_bitmapQ_exceptE: "\ valid_bitmapQ_except d' p' s ; d \ d' \ p \ p' \ - \ bitmapQ d p s = (ksReadyQueues s (d, p) \ [])" - unfolding valid_bitmapQ_except_def - by blast + \ bitmapQ d p s = (\ tcbQueueEmpty (ksReadyQueues s (d, p)))" + by (fastforce simp: valid_bitmapQ_except_def) lemma invertL1Index_eq_cancelD: "\ invertL1Index i = invertL1Index j ; i < l2BitmapSize ; j < l2BitmapSize \ @@ -2682,22 +3799,15 @@ lemma addToBitmap_valid_bitmapQ_except: done lemma addToBitmap_valid_bitmapQ: -" \ valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and - (\s. ksReadyQueues s (d,p) \ []) \ - addToBitmap d p - \\_. valid_bitmapQ \" -proof - - have "\ valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and - (\s. ksReadyQueues s (d,p) \ []) \ - addToBitmap d p - \\_. valid_bitmapQ_except d p and - bitmapQ_no_L2_orphans and (\s. bitmapQ d p s \ ksReadyQueues s (d,p) \ []) \" - by (wp addToBitmap_valid_queues_no_bitmap_except addToBitmap_valid_bitmapQ_except - addToBitmap_bitmapQ_no_L2_orphans addToBitmap_bitmapQ; simp) - - thus ?thesis - by - (erule hoare_strengthen_post; fastforce elim: valid_bitmap_valid_bitmapQ_exceptE) -qed + "\valid_bitmapQ_except d p and bitmapQ_no_L2_orphans + and (\s. \ tcbQueueEmpty (ksReadyQueues s (d,p)))\ + addToBitmap d p + \\_. valid_bitmapQ\" + (is "\?pre\ _ \_\") + apply (rule_tac Q="\_ s. ?pre s \ bitmapQ d p s" in hoare_strengthen_post) + apply (wpsimp wp: addToBitmap_valid_bitmapQ_except addToBitmap_bitmapQ) + apply (fastforce elim: valid_bitmap_valid_bitmapQ_exceptE) + done 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 \" @@ -2715,12 +3825,6 @@ lemma threadGet_const_tcb_at_imp_lift: apply (clarsimp simp: obj_at'_def) done -lemma valid_queues_no_bitmap_objD: - "\ valid_queues_no_bitmap s; t \ set (ksReadyQueues s (d, p))\ - \ obj_at' (inQ d p and runnable' \ tcbState) t s" - unfolding valid_queues_no_bitmap_def - by metis - lemma setQueue_bitmapQ_no_L1_orphans[wp]: "\ bitmapQ_no_L1_orphans \ setQueue d p ts @@ -2740,126 +3844,6 @@ lemma setQueue_sets_queue[wp]: unfolding setQueue_def by (wp, simp) -lemma tcbSchedEnqueueOrAppend_valid_queues: - (* f is either (t#ts) or (ts @ [t]), so we define its properties generally *) - assumes f_set[simp]: "\ts. t \ set (f ts)" - assumes f_set_insert[simp]: "\ts. set (f ts) = insert t (set ts)" - assumes f_not_empty[simp]: "\ts. f ts \ []" - assumes f_distinct: "\ts. \ distinct ts ; t \ set ts \ \ distinct (f ts)" - shows "\Invariants_H.valid_queues and st_tcb_at' runnable' t and valid_objs' \ - do queued \ threadGet tcbQueued t; - unless queued $ - do tdom \ threadGet tcbDomain t; - prio \ threadGet tcbPriority t; - queue \ getQueue tdom prio; - setQueue tdom prio $ f queue; - when (null queue) $ addToBitmap tdom prio; - threadSet (tcbQueued_update (\_. True)) t - od - od - \\_. Invariants_H.valid_queues\" -proof - - - define could_run where "could_run == - \d p t. obj_at' (\tcb. inQ d p (tcbQueued_update (\_. True) tcb) \ runnable' (tcbState tcb)) t" - - have addToBitmap_could_run: - "\d p. \\s. \d p. t \ set (ksReadyQueues s (d, p)) \ could_run d p t s\ - addToBitmap d p - \\_ s. \d p. t \ set (ksReadyQueues s (d, p)) \ could_run d p t s\" - unfolding bitmap_fun_defs - by (wp, clarsimp simp: could_run_def) - - have setQueue_valid_queues_no_bitmap_except: - "\d p ts. - \ valid_queues_no_bitmap_except t and - (\s. ksReadyQueues s (d, p) = ts \ p \ maxPriority \ d \ maxDomain \ t \ set ts) \ - setQueue d p (f ts) - \\rv. valid_queues_no_bitmap_except t\" - unfolding setQueue_def valid_queues_no_bitmap_except_def null_def - by (wp, auto intro: f_distinct) - - have threadSet_valid_queues_could_run: - "\f. \ valid_queues_no_bitmap_except t and - (\s. \d p. t \ set (ksReadyQueues s (d,p)) \ could_run d p t s) and - valid_bitmapQ and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans \ - threadSet (tcbQueued_update (\_. True)) t - \\rv. Invariants_H.valid_queues \" - unfolding threadSet_def could_run_def - apply (rule hoare_seq_ext[OF _ getObject_tcb_sp]) - apply (rule hoare_pre) - apply (simp add: valid_queues_def valid_queues_no_bitmap_def) - apply (wp setObject_queues_unchanged_tcb hoare_Ball_helper hoare_vcg_all_lift - setObject_tcb_strongest) - apply (clarsimp simp: valid_queues_no_bitmap_except_def obj_at'_def) - done - - have setQueue_could_run: "\d p ts. - \ valid_queues and (\_. t \ set ts) and - (\s. could_run d p t s) \ - setQueue d p ts - \\rv s. (\d p. t \ set (ksReadyQueues s (d, p)) \ could_run d p t s)\" - unfolding setQueue_def valid_queues_def could_run_def - by wp (fastforce dest: valid_queues_no_bitmap_objD simp: obj_at'_def inQ_def) - - note hoare_vcg_if_lift[wp] hoare_vcg_conj_lift[wp] hoare_vcg_const_imp_lift[wp] - - show ?thesis - unfolding tcbSchedEnqueue_def null_def - apply (rule hoare_pre) - apply (rule hoare_seq_ext) - apply (simp add: unless_def) - apply (wp threadSet_valid_queues_could_run) - apply (wp addToBitmap_could_run addToBitmap_valid_bitmapQ - addToBitmap_valid_queues_no_bitmap_except addToBitmap_bitmapQ_no_L2_orphans)+ - apply (wp setQueue_valid_queues_no_bitmap_except setQueue_could_run - setQueue_valid_bitmapQ_except setQueue_sets_queue setQueue_valid_bitmapQ)+ - apply (wp threadGet_const_tcb_at_imp_lift | simp add: if_apply_def2)+ - apply clarsimp - apply (frule pred_tcb_at') - apply (frule (1) valid_objs'_maxDomain) - apply (frule (1) valid_objs'_maxPriority) - apply (clarsimp simp: valid_queues_def st_tcb_at'_def obj_at'_def valid_queues_no_bitmap_exceptI) - apply (fastforce dest!: valid_queues_no_bitmap_objD simp: obj_at'_def inQ_def could_run_def) - done -qed - -lemma tcbSchedEnqueue_valid_queues[wp]: - "\Invariants_H.valid_queues - and st_tcb_at' runnable' t - and valid_objs' \ - tcbSchedEnqueue t - \\_. Invariants_H.valid_queues\" - unfolding tcbSchedEnqueue_def - by (fastforce intro: tcbSchedEnqueueOrAppend_valid_queues) - -lemma tcbSchedAppend_valid_queues[wp]: - "\Invariants_H.valid_queues - and st_tcb_at' runnable' t - and valid_objs' \ - tcbSchedAppend t - \\_. Invariants_H.valid_queues\" - unfolding tcbSchedAppend_def - by (fastforce intro: tcbSchedEnqueueOrAppend_valid_queues) - -lemma rescheduleRequired_valid_queues[wp]: - "\\s. Invariants_H.valid_queues s \ valid_objs' s \ - weak_sch_act_wf (ksSchedulerAction s) s\ - rescheduleRequired - \\_. Invariants_H.valid_queues\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp)+ - apply (fastforce simp: weak_sch_act_wf_def elim: valid_objs'_maxDomain valid_objs'_maxPriority) - done - -lemma rescheduleRequired_valid_queues_sch_act_simple: - "\Invariants_H.valid_queues and sch_act_simple\ - rescheduleRequired - \\_. Invariants_H.valid_queues\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp | fastforce simp: Invariants_H.valid_queues_def sch_act_simple_def)+ - done - lemma rescheduleRequired_valid_bitmapQ_sch_act_simple: "\ valid_bitmapQ and sch_act_simple\ rescheduleRequired @@ -2901,138 +3885,32 @@ lemma rescheduleRequired_bitmapQ_no_L2_orphans_sch_act_simple: lemma sts_valid_bitmapQ_sch_act_simple: "\valid_bitmapQ and sch_act_simple\ - setThreadState st t + setThreadState st t \\_. valid_bitmapQ \" 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 Invariants_H.valid_queues_def inQ_def)+ + 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 + 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 Invariants_H.valid_queues_def inQ_def)+ + 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 + setThreadState st t \\_. bitmapQ_no_L1_orphans \" 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 Invariants_H.valid_queues_def inQ_def)+ - done - -lemma sts_valid_queues: - "\\s. Invariants_H.valid_queues s \ - ((\p. t \ set(ksReadyQueues s p)) \ runnable' st)\ - setThreadState st t \\rv. Invariants_H.valid_queues\" - apply (simp add: setThreadState_def) - apply (wp rescheduleRequired_valid_queues_sch_act_simple - threadSet_valid_queues [THEN hoare_strengthen_post]) - apply (clarsimp simp: sch_act_simple_def Invariants_H.valid_queues_def inQ_def)+ - done - -lemma sbn_valid_queues: - "\\s. Invariants_H.valid_queues s\ - setBoundNotification ntfn t \\rv. Invariants_H.valid_queues\" - apply (simp add: setBoundNotification_def) - apply (wp threadSet_valid_queues [THEN hoare_strengthen_post]) - apply (clarsimp simp: sch_act_simple_def Invariants_H.valid_queues_def inQ_def)+ - done - - - -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]: - "\valid_queues' and st_tcb_at' runnable' t \ - tcbSchedEnqueue t - \\_. valid_queues'\" - apply (simp add: tcbSchedEnqueue_def) - apply (rule hoare_pre) - apply (rule_tac B="\rv. valid_queues' and obj_at' (\obj. tcbQueued obj = rv) t" - in hoare_seq_ext) - 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_def)+ - apply (clarsimp simp: obj_at'_def inQ_def projectKOs valid_queues'_def) - apply (wp getObject_tcb_wp | simp add: threadGet_def)+ - apply (clarsimp simp: obj_at'_def) - done - -lemma rescheduleRequired_valid_queues'_weak[wp]: - "\\s. valid_queues' s \ weak_sch_act_wf (ksSchedulerAction s) s\ - rescheduleRequired - \\_. valid_queues'\" - apply (simp add: rescheduleRequired_def) - apply wpsimp - apply (clarsimp simp: weak_sch_act_wf_def) - done - -lemma rescheduleRequired_valid_queues'_sch_act_simple: - "\valid_queues' and sch_act_simple\ - rescheduleRequired - \\_. valid_queues'\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp | fastforce simp: valid_queues'_def sch_act_simple_def)+ - done - -lemma setThreadState_valid_queues'[wp]: - "\\s. valid_queues' s\ setThreadState st t \\rv. valid_queues'\" - apply (simp add: setThreadState_def) - apply (wp rescheduleRequired_valid_queues'_sch_act_simple) - apply (rule_tac Q="\_. valid_queues'" in hoare_post_imp) - apply (clarsimp simp: sch_act_simple_def) - apply (wp threadSet_valid_queues') - apply (fastforce simp: inQ_def obj_at'_def pred_tcb_at'_def) - 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 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) - done - -lemma setThreadState_valid_objs'[wp]: - "\ valid_tcb_state' st and valid_objs' \ setThreadState st t \ \_. valid_objs' \" - apply (simp add: setThreadState_def) - apply (wp threadSet_valid_objs' | clarsimp simp: valid_tcb'_tcbState_update)+ + apply (clarsimp simp: sch_act_simple_def inQ_def)+ done lemma rescheduleRequired_ksQ: @@ -3060,17 +3938,6 @@ lemma sbn_ksQ: "\\s. P (ksReadyQueues s p)\ setBoundNotification ntfn t \\rv s. P (ksReadyQueues s p)\" by (simp add: setBoundNotification_def, wp) -lemma sts_ksQ: - "\\s. sch_act_simple s \ P (ksReadyQueues s p)\ - setThreadState st t - \\_ s. P (ksReadyQueues s p)\" - apply (simp add: setThreadState_def) - apply (wp rescheduleRequired_ksQ) - apply (rule_tac Q="\_ s. P (ksReadyQueues s p)" in hoare_post_imp) - apply (clarsimp simp: sch_act_simple_def)+ - apply (wp, simp) - done - lemma setQueue_ksQ[wp]: "\\s. P ((ksReadyQueues s)((d, p) := q))\ setQueue d p q @@ -3078,22 +3945,6 @@ lemma setQueue_ksQ[wp]: by (simp add: setQueue_def fun_upd_def[symmetric] | wp)+ -lemma tcbSchedEnqueue_ksQ: - "\\s. t' \ set (ksReadyQueues s p) \ t' \ t \ - tcbSchedEnqueue t \\_ s. t' \ set (ksReadyQueues s p)\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wpsimp wp: hoare_vcg_imp_lift threadGet_wp) - apply (drule obj_at_ko_at') - apply fastforce - done - -lemma rescheduleRequired_ksQ': - "\\s. t \ set (ksReadyQueues s p) \ sch_act_not t s \ - rescheduleRequired \\_ s. t \ set (ksReadyQueues s p)\" - apply (simp add: rescheduleRequired_def) - apply (wpsimp wp: tcbSchedEnqueue_ksQ) - done - lemma threadSet_tcbState_st_tcb_at': "\\s. P st \ threadSet (tcbState_update (\_. st)) t \\_. st_tcb_at' P t\" apply (simp add: threadSet_def pred_tcb_at'_def) @@ -3104,36 +3955,6 @@ lemma isRunnable_const: "\st_tcb_at' runnable' t\ isRunnable t \\runnable _. runnable \" by (rule isRunnable_wp) -lemma sts_ksQ': - "\\s. (runnable' st \ ksCurThread s \ t) \ P (ksReadyQueues s p)\ - setThreadState st t - \\_ s. P (ksReadyQueues s p)\" - apply (simp add: setThreadState_def) - apply (rule hoare_pre_disj') - apply (rule hoare_seq_ext [OF _ - hoare_vcg_conj_lift - [OF threadSet_tcbState_st_tcb_at' [where P=runnable'] - threadSet_ksQ]]) - apply (rule hoare_seq_ext [OF _ - hoare_vcg_conj_lift [OF isRunnable_const isRunnable_inv]]) - apply (clarsimp simp: when_def) - apply (case_tac x) - apply (clarsimp, wp)[1] - apply (clarsimp) - apply (rule hoare_seq_ext [OF _ - hoare_vcg_conj_lift - [OF threadSet_ct threadSet_ksQ]]) - apply (rule hoare_seq_ext [OF _ isRunnable_inv]) - apply (rule hoare_seq_ext [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 valid_ipc_buffer_ptr'D: assumes yv: "y < unat max_ipc_words" and buf: "valid_ipc_buffer_ptr' a s" @@ -3260,14 +4081,16 @@ lemma thread_get_registers: done lemma getMRs_corres: - "corres (=) (tcb_at t) - (tcb_at' t and case_option \ valid_ipc_buffer_ptr' buf) + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) + (case_option \ valid_ipc_buffer_ptr' buf) (get_mrs t buf mi) (getMRs t buf (message_info_map mi))" proof - have S: "get = gets id" by (simp add: gets_def) - have T: "corres (\con regs. regs = map con msg_registers) (tcb_at t) (tcb_at' t) - (thread_get (arch_tcb_get_registers o tcb_arch) t) (asUser t (mapM getRegister X64_H.msgRegisters))" + have T: "corres (\con regs. regs = map con msg_registers) + (tcb_at t and pspace_aligned and pspace_distinct) \ + (thread_get (arch_tcb_get_registers o tcb_arch) t) + (asUser t (mapM getRegister X64_H.msgRegisters))" apply (subst thread_get_registers) apply (rule asUser_corres') apply (subst mapM_gets) @@ -3372,8 +4195,8 @@ lemma UserContext_fold: lemma setMRs_corres: assumes m: "mrs' = mrs" shows - "corres (=) (tcb_at t and case_option \ in_user_frame buf) - (tcb_at' t and case_option \ valid_ipc_buffer_ptr' buf) + "corres (=) (tcb_at t and case_option \ in_user_frame buf and pspace_aligned and pspace_distinct) + (case_option \ valid_ipc_buffer_ptr' buf) (set_mrs t buf mrs) (setMRs t buf mrs')" proof - have setRegister_def2: @@ -3434,9 +4257,9 @@ lemma copyMRs_corres: "corres (=) (tcb_at s and tcb_at r and case_option \ in_user_frame sb and case_option \ in_user_frame rb + and pspace_aligned and pspace_distinct and K (unat n \ msg_max_length)) - (tcb_at' s and tcb_at' r - and case_option \ valid_ipc_buffer_ptr' sb + (case_option \ valid_ipc_buffer_ptr' sb and case_option \ valid_ipc_buffer_ptr' rb) (copy_mrs s sb r rb n) (copyMRs s sb r rb n)" proof - @@ -3447,7 +4270,7 @@ proof - note R=R'[simplified] have as_user_bit: - "\v :: machine_word. corres dc (tcb_at s and tcb_at r) (tcb_at' s and tcb_at' r) + "\v :: machine_word. corres dc (tcb_at s and tcb_at r and pspace_aligned and pspace_distinct) \ (mapM (\ra. do v \ as_user s (getRegister ra); as_user r (setRegister ra v) @@ -3590,9 +4413,8 @@ qed lemmas valid_ipc_buffer_cap_simps = valid_ipc_buffer_cap_def [split_simps cap.split arch_cap.split] lemma lookupIPCBuffer_corres': - "corres (=) (tcb_at t and valid_objs and pspace_aligned) - (tcb_at' t and valid_objs' and pspace_aligned' - and pspace_distinct' and no_0_obj') + "corres (=) (tcb_at t and valid_objs and pspace_aligned and pspace_distinct) + (valid_objs' and pspace_aligned' and pspace_distinct' and no_0_obj') (lookup_ipc_buffer w t) (lookupIPCBuffer w t)" apply (simp add: lookup_ipc_buffer_def X64_H.lookupIPCBuffer_def) apply (rule corres_guard_imp) @@ -3637,9 +4459,8 @@ lemma lookupIPCBuffer_corres': done lemma lookupIPCBuffer_corres: - "corres (=) (tcb_at t and invs) - (tcb_at' t and invs') - (lookup_ipc_buffer w t) (lookupIPCBuffer w t)" + "corres (=) (tcb_at t and invs) invs' + (lookup_ipc_buffer w t) (lookupIPCBuffer w t)" using lookupIPCBuffer_corres' by (rule corres_guard_imp, auto simp: invs'_def valid_state'_def) @@ -3705,7 +4526,7 @@ lemma ct_in_state'_set: crunches setQueue, rescheduleRequired, tcbSchedDequeue for idle'[wp]: "valid_idle'" - (simp: crunch_simps) + (simp: crunch_simps wp: crunch_wps) lemma sts_valid_idle'[wp]: "\valid_idle' and valid_pspace' and @@ -3745,8 +4566,9 @@ lemma gbn_sp': lemma tcbSchedDequeue_tcbState_obj_at'[wp]: "\obj_at' (P \ tcbState) t'\ tcbSchedDequeue t \\rv. obj_at' (P \ tcbState) t'\" - apply (simp add: tcbSchedDequeue_def) - apply (wp | simp add: o_def split del: if_split cong: if_cong)+ + apply (simp add: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wpsimp wp: getObject_tcb_wp simp: o_def threadGet_def) + apply (clarsimp simp: obj_at'_def) done crunch typ_at'[wp]: setQueue "\s. P' (typ_at' P t s)" @@ -3765,10 +4587,14 @@ lemma setQueue_pred_tcb_at[wp]: lemma tcbSchedDequeue_pred_tcb_at'[wp]: "\\s. P' (pred_tcb_at' proj P t' s)\ tcbSchedDequeue t \\_ s. P' (pred_tcb_at' proj P t' s)\" apply (rule_tac P=P' in P_bool_lift) - apply (simp add: tcbSchedDequeue_def) - apply (wp threadSet_pred_tcb_no_state | clarsimp simp: tcb_to_itcb'_def)+ - apply (simp add: tcbSchedDequeue_def) - apply (wp threadSet_pred_tcb_no_state | clarsimp simp: tcb_to_itcb'_def)+ + apply (simp add: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wpsimp wp: threadSet_pred_tcb_no_state getObject_tcb_wp + simp: threadGet_def tcb_to_itcb'_def) + apply (clarsimp simp: obj_at'_def) + apply (simp add: tcbSchedDequeue_def tcbQueueRemove_def) + apply (wpsimp wp: threadSet_pred_tcb_no_state getObject_tcb_wp + simp: threadGet_def tcb_to_itcb'_def) + apply (clarsimp simp: obj_at'_def) done lemma sts_st_tcb': @@ -3865,39 +4691,156 @@ crunch nonz_cap[wp]: addToBitmap "ex_nonz_cap_to' t" crunch iflive'[wp]: removeFromBitmap if_live_then_nonz_cap' crunch nonz_cap[wp]: removeFromBitmap "ex_nonz_cap_to' t" -lemma tcbSchedEnqueue_iflive'[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' tcb\ - tcbSchedEnqueue tcb \\_. if_live_then_nonz_cap'\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wp threadSet_iflive' hoare_drop_imps | simp add: crunch_simps)+ +crunches rescheduleRequired + for cap_to'[wp]: "ex_nonz_cap_to' p" + +lemma tcbQueued_update_tcb_cte_cases: + "(getF, setF) \ ran tcb_cte_cases \ getF (tcbQueued_update f tcb) = getF tcb" + unfolding tcb_cte_cases_def + by (case_tac tcb; fastforce simp: objBits_simps') + +lemma tcbSchedNext_update_tcb_cte_cases: + "(getF, setF) \ ran tcb_cte_cases \ getF (tcbSchedNext_update f tcb) = getF tcb" + unfolding tcb_cte_cases_def + by (case_tac tcb; fastforce simp: objBits_simps') + +lemma tcbSchedPrev_update_tcb_cte_cases: + "(getF, setF) \ ran tcb_cte_cases \ getF (tcbSchedPrev_update f tcb) = getF tcb" + unfolding tcb_cte_cases_def + by (case_tac tcb; fastforce simp: objBits_simps') + +lemma tcbSchedNext_update_ctes_of[wp]: + "threadSet (tcbSchedNext_update f) tptr \\s. P (ctes_of s)\" + by (wpsimp wp: threadSet_ctes_ofT simp: tcbSchedNext_update_tcb_cte_cases) + +lemma tcbSchedPrev_update_ctes_of[wp]: + "threadSet (tcbSchedPrev_update f) tptr \\s. P (ctes_of s)\" + by (wpsimp wp: threadSet_ctes_ofT simp: tcbSchedPrev_update_tcb_cte_cases) + +lemma tcbSchedNext_ex_nonz_cap_to'[wp]: + "threadSet (tcbSchedNext_update f) tptr \ex_nonz_cap_to' p\" + by (wpsimp wp: threadSet_cap_to simp: tcbSchedNext_update_tcb_cte_cases) + +lemma tcbSchedPrev_ex_nonz_cap_to'[wp]: + "threadSet (tcbSchedPrev_update f) tptr \ex_nonz_cap_to' p\" + by (wpsimp wp: threadSet_cap_to simp: tcbSchedPrev_update_tcb_cte_cases) + +lemma tcbSchedNext_update_iflive': + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' t s\ + threadSet (tcbSchedNext_update f) t + \\_. if_live_then_nonz_cap'\" + by (wpsimp wp: threadSet_iflive'T simp: tcbSchedNext_update_tcb_cte_cases) + +lemma tcbSchedPrev_update_iflive': + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' t s\ + threadSet (tcbSchedPrev_update f) t + \\_. if_live_then_nonz_cap'\" + by (wpsimp wp: threadSet_iflive'T simp: tcbSchedPrev_update_tcb_cte_cases) + +lemma tcbQueued_update_iflive'[wp]: + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' t s\ + threadSet (tcbQueued_update f) t + \\_. if_live_then_nonz_cap'\" + by (wpsimp wp: threadSet_iflive'T simp: tcbQueued_update_tcb_cte_cases) + +lemma getTCB_wp: + "\\s. \ko :: tcb. ko_at' ko p s \ Q ko s\ getObject p \Q\" + apply (wpsimp wp: getObject_tcb_wp) + apply (clarsimp simp: obj_at'_def) done -lemma rescheduleRequired_iflive'[wp]: - "\if_live_then_nonz_cap' - and (\s. \t. ksSchedulerAction s = SwitchToThread t - \ st_tcb_at' runnable' t s)\ - rescheduleRequired - \\rv. if_live_then_nonz_cap'\" - apply (simp add: rescheduleRequired_def) - apply (wp | wpc | simp)+ - apply (clarsimp simp: pred_tcb_at'_def obj_at'_real_def) - apply (erule(1) if_live_then_nonz_capD') - apply (fastforce simp: projectKOs) +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 ko_wp_at'_def projectKOs) + done + +lemma tcbQueueRemove_ex_nonz_cap_to'[wp]: + "tcbQueueRemove q tcbPtr \ex_nonz_cap_to' tcbPtr'\" + unfolding tcbQueueRemove_def + by (wpsimp wp: threadSet_cap_to' hoare_drop_imps getTCB_wp) + +(* We could write this one as "\t. tcbQueueHead t \ ..." instead, but we can't do the same in + tcbQueueAppend_if_live_then_nonz_cap', and it's nicer if the two lemmas are symmetric *) +lemma tcbQueuePrepend_if_live_then_nonz_cap': + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' tcbPtr s + \ (\ tcbQueueEmpty q \ ex_nonz_cap_to' (the (tcbQueueHead q)) s)\ + tcbQueuePrepend q tcbPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbQueuePrepend_def + by (wpsimp wp: tcbSchedPrev_update_iflive' tcbSchedNext_update_iflive' + hoare_vcg_if_lift2 hoare_vcg_imp_lift') + +lemma tcbQueueAppend_if_live_then_nonz_cap': + "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' tcbPtr s + \ (\ tcbQueueEmpty q \ ex_nonz_cap_to' (the (tcbQueueEnd q)) s)\ + tcbQueueAppend q tcbPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbQueueAppend_def + by (wpsimp wp: tcbSchedPrev_update_iflive' tcbSchedNext_update_iflive') + +lemma tcbQueueInsert_if_live_then_nonz_cap': + "\if_live_then_nonz_cap' and ex_nonz_cap_to' tcbPtr and valid_objs' and sym_heap_sched_pointers\ + tcbQueueInsert tcbPtr afterPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbQueueInsert_def + supply projectKOs[simp] + apply (wpsimp wp: tcbSchedPrev_update_iflive' tcbSchedNext_update_iflive' getTCB_wp) + apply (intro conjI) + apply (erule if_live_then_nonz_capE') + apply (clarsimp simp: ko_wp_at'_def obj_at'_def) + apply (erule if_live_then_nonz_capE') + apply (frule_tac p'=afterPtr in sym_heapD2) + apply (fastforce simp: opt_map_def obj_at'_def) + apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (clarsimp simp: valid_tcb'_def ko_wp_at'_def obj_at'_def opt_map_def) + done + +lemma tcbSchedEnqueue_iflive'[wp]: + "\if_live_then_nonz_cap' and pspace_aligned' and pspace_distinct'\ + tcbSchedEnqueue tcbPtr + \\_. if_live_then_nonz_cap'\" + unfolding tcbSchedEnqueue_def + supply projectKOs[simp] + apply (wpsimp wp: tcbQueuePrepend_if_live_then_nonz_cap' threadGet_wp) + apply normalise_obj_at' + apply (rename_tac tcb) + apply (frule_tac p=tcbPtr in if_live_then_nonz_capE') + apply (fastforce simp: ko_wp_at'_def obj_at'_def) + apply clarsimp + apply (erule if_live_then_nonz_capE') + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (fastforce dest!: obj_at'_tcbQueueHead_ksReadyQueues + simp: ko_wp_at'_def inQ_def opt_pred_def opt_map_def obj_at'_def + split: option.splits) done +crunches rescheduleRequired + for iflive'[wp]: if_live_then_nonz_cap' + lemma sts_iflive'[wp]: "\\s. if_live_then_nonz_cap' s - \ (st \ Inactive \ \ idle' st \ ex_nonz_cap_to' t s)\ - setThreadState st t + \ (st \ Inactive \ \ idle' st \ ex_nonz_cap_to' t s) + \ pspace_aligned' s \ pspace_distinct' s\ + setThreadState st t \\rv. if_live_then_nonz_cap'\" apply (simp add: setThreadState_def setQueue_def) - apply (rule hoare_pre) - apply (wp | simp)+ - apply (rule_tac Q="\rv. if_live_then_nonz_cap'" in hoare_post_imp) - apply clarsimp - apply (wp threadSet_iflive' | simp)+ - apply auto - done + 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 + done lemma sbn_iflive'[wp]: "\\s. if_live_then_nonz_cap' s @@ -4016,6 +4959,19 @@ lemma setBoundNotification_vms'[wp]: apply (intro hoare_vcg_all_lift hoare_vcg_disj_lift; wp) done +lemma threadSet_ct_not_inQ: + "(\tcb. tcbQueued tcb = tcbQueued (F tcb)) + \ threadSet F tcbPtr \\s. P (ct_not_inQ s)\" + unfolding threadSet_def + supply projectKOs[simp] + apply (wpsimp wp: getTCB_wp simp: setObject_def updateObject_default_def) + apply (erule rsubst[where P=P]) + by (fastforce simp: ct_not_inQ_def obj_at'_def objBits_simps ps_clear_def split: if_splits) + +crunches tcbQueuePrepend, tcbQueueAppend, tcbQueueInsert, tcbQueueRemove, addToBitmap + for ct_not_inQ[wp]: ct_not_inQ + (wp: threadSet_ct_not_inQ crunch_wps) + lemma tcbSchedEnqueue_ct_not_inQ: "\ct_not_inQ and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ tcbSchedEnqueue t \\_. ct_not_inQ\" @@ -4039,12 +4995,7 @@ lemma tcbSchedEnqueue_ct_not_inQ: done show ?thesis apply (simp add: tcbSchedEnqueue_def unless_def null_def) - apply (wp ts sq hoare_convert_imp [OF addToBitmap_nosch addToBitmap_ct'])+ - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, clarsimp) - apply (wp sq hoare_convert_imp [OF setQueue_nosch setQueue_ct])+ - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, clarsimp) - apply wp - apply assumption + apply (wpsimp wp: ts sq hoare_vcg_imp_lift' getTCB_wp simp: threadGet_def)+ done qed @@ -4071,12 +5022,7 @@ lemma tcbSchedAppend_ct_not_inQ: done show ?thesis apply (simp add: tcbSchedAppend_def unless_def null_def) - apply (wp ts sq hoare_convert_imp [OF addToBitmap_nosch addToBitmap_ct'])+ - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, clarsimp) - apply (wp sq hoare_convert_imp [OF setQueue_nosch setQueue_ct])+ - apply (rule_tac Q="\_. ?PRE" in hoare_post_imp, clarsimp) - apply wp - apply assumption + apply (wpsimp wp: ts sq hoare_vcg_imp_lift' getTCB_wp simp: threadGet_def)+ done qed @@ -4092,11 +5038,6 @@ lemma rescheduleRequired_ct_not_inQ: apply (wp setSchedulerAction_direct) done -crunch nosch[wp]: tcbSchedEnqueue "\s. P (ksSchedulerAction s)" - (simp: unless_def) -crunch nosch[wp]: tcbSchedAppend "\s. P (ksSchedulerAction s)" - (simp: unless_def) - lemma rescheduleRequired_sa_cnt[wp]: "\\s. True \ rescheduleRequired \\_ s. ksSchedulerAction s = ChooseNewThread \" unfolding rescheduleRequired_def setSchedulerAction_def @@ -4105,12 +5046,10 @@ lemma rescheduleRequired_sa_cnt[wp]: lemma possibleSwitchTo_ct_not_inQ: "\ct_not_inQ and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ possibleSwitchTo t \\_. ct_not_inQ\" - (is "\?PRE\ _ \_\") apply (simp add: possibleSwitchTo_def curDomain_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) + | (rule hoare_post_imp[OF _ rescheduleRequired_sa_cnt], fastforce))+ done lemma threadSet_tcbState_update_ct_not_inQ[wp]: @@ -4190,29 +5129,6 @@ lemma tcbSchedDequeue_ct_not_inQ[wp]: done qed -lemma tcbSchedEnqueue_not_st: - "(\tcb st qd. P (tcb\tcbState := st, tcbQueued := qd\) \ P tcb) - \ \obj_at' P t'\ tcbSchedEnqueue t \\_. obj_at' P t'\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply (wp threadGet_wp | simp)+ - apply (clarsimp simp: obj_at'_def) - apply (case_tac obja) - apply fastforce - done - -lemma setThreadState_not_st: - "(\tcb st qd. P (tcb\tcbState := st, tcbQueued := qd\) \ P tcb) - \ \obj_at' P t'\ setThreadState st t \\_. obj_at' P t'\" - apply (simp add: setThreadState_def rescheduleRequired_def) - apply (wp hoare_vcg_conj_lift tcbSchedEnqueue_not_st - | wpc - | rule hoare_drop_imps - | simp)+ - apply (clarsimp simp: obj_at'_def) - apply (case_tac obj) - apply fastforce - done - crunch ct_idle_or_in_cur_domain'[wp]: setQueue ct_idle_or_in_cur_domain' (simp: ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) @@ -4241,17 +5157,8 @@ lemma removeFromBitmap_ct_idle_or_in_cur_domain'[wp]: | clarsimp simp: updateObject_default_def in_monad setNotification_def)+ done -lemma tcbSchedEnqueue_ksCurDomain[wp]: - "\ \s. P (ksCurDomain s)\ tcbSchedEnqueue tptr \\_ s. P (ksCurDomain s)\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply wpsimp - done - -lemma tcbSchedEnqueue_ksDomSchedule[wp]: - "\ \s. P (ksDomSchedule s)\ tcbSchedEnqueue tptr \\_ s. P (ksDomSchedule s)\" - apply (simp add: tcbSchedEnqueue_def unless_def) - apply wpsimp - done +crunches tcbQueuePrepend + for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' lemma tcbSchedEnqueue_ct_idle_or_in_cur_domain'[wp]: "\ct_idle_or_in_cur_domain'\ tcbSchedEnqueue tptr \\_. ct_idle_or_in_cur_domain'\" @@ -4331,12 +5238,386 @@ lemma sts_utr[wp]: apply (wp untyped_ranges_zero_lift) done +lemma removeFromBitmap_bitmapQ: + "\\\ removeFromBitmap d p \\_ s. \ bitmapQ d p s \" + unfolding bitmapQ_defs bitmap_fun_defs + by (wpsimp simp: bitmap_fun_defs) + +lemma removeFromBitmap_valid_bitmapQ[wp]: + "\valid_bitmapQ_except d p and bitmapQ_no_L2_orphans and bitmapQ_no_L1_orphans + and (\s. tcbQueueEmpty (ksReadyQueues s (d,p)))\ + removeFromBitmap d p + \\_. valid_bitmapQ\" + (is "\?pre\ _ \_\") + apply (rule_tac Q="\_ s. ?pre s \ \ bitmapQ d p s" in hoare_strengthen_post) + apply (wpsimp wp: removeFromBitmap_valid_bitmapQ_except removeFromBitmap_bitmapQ) + apply (fastforce elim: valid_bitmap_valid_bitmapQ_exceptE) + done + +crunches tcbSchedDequeue + for bitmapQ_no_L1_orphans[wp]: bitmapQ_no_L1_orphans + and bitmapQ_no_L2_orphans[wp]: bitmapQ_no_L2_orphans + (wp: crunch_wps simp: crunch_simps) + +lemma setQueue_nonempty_valid_bitmapQ': + "\\s. valid_bitmapQ s \ \ tcbQueueEmpty (ksReadyQueues s (d, p))\ + setQueue d p queue + \\_ s. \ tcbQueueEmpty queue \ valid_bitmapQ s\" + apply (wpsimp simp: setQueue_def) + apply (fastforce simp: valid_bitmapQ_def bitmapQ_def) + done + +lemma threadSet_valid_bitmapQ_except[wp]: + "threadSet f tcbPtr \valid_bitmapQ_except d p\" + unfolding threadSet_def + apply (wpsimp wp: getTCB_wp simp: setObject_def updateObject_default_def) + apply (clarsimp simp: valid_bitmapQ_except_def bitmapQ_def) + done + +lemma threadSet_bitmapQ: + "threadSet F t \bitmapQ domain priority\" + unfolding threadSet_def + apply (wpsimp wp: getTCB_wp simp: setObject_def updateObject_default_def) + by (clarsimp simp: bitmapQ_def) + +crunches tcbQueueRemove, tcbQueuePrepend, tcbQueueAppend + for valid_bitmapQ_except[wp]: "valid_bitmapQ_except d p" + and valid_bitmapQ[wp]: valid_bitmapQ + and bitmapQ[wp]: "bitmapQ tdom prio" + (wp: crunch_wps) + +lemma tcbQueued_imp_queue_nonempty: + "\list_queue_relation ts (ksReadyQueues s (tcbDomain tcb, tcbPriority tcb)) nexts prevs; + \t. t \ set ts \ (inQ (tcbDomain tcb) (tcbPriority tcb) |< tcbs_of' s) t; + ko_at' tcb tcbPtr s; tcbQueued tcb\ + \ \ tcbQueueEmpty (ksReadyQueues s (tcbDomain tcb, tcbPriority tcb))" + supply projectKOs[simp] + apply (clarsimp simp: list_queue_relation_def tcbQueueEmpty_def) + apply (drule_tac x=tcbPtr in spec) + apply (fastforce dest: heap_path_head simp: inQ_def opt_map_def opt_pred_def obj_at'_def) + done + +lemma tcbSchedDequeue_valid_bitmapQ[wp]: + "\valid_bitmaps\ tcbSchedDequeue tcbPtr \\_. valid_bitmapQ\" + unfolding tcbSchedDequeue_def tcbQueueRemove_def + apply (wpsimp wp: setQueue_nonempty_valid_bitmapQ' hoare_vcg_conj_lift + hoare_vcg_if_lift2 hoare_vcg_const_imp_lift threadGet_wp + | wp (once) hoare_drop_imps)+ + by (fastforce dest!: tcbQueued_imp_queue_nonempty + simp: ready_queue_relation_def ksReadyQueues_asrt_def obj_at'_def) + +lemma tcbSchedDequeue_valid_bitmaps[wp]: + "tcbSchedDequeue tcbPtr \valid_bitmaps\" + by (wpsimp simp: valid_bitmaps_def) + +lemma setQueue_valid_bitmapQ': (* enqueue only *) + "\valid_bitmapQ_except d p and bitmapQ d p and K (\ tcbQueueEmpty q)\ + setQueue d p q + \\_. valid_bitmapQ\" + unfolding setQueue_def bitmapQ_defs + by (wpsimp simp: bitmapQ_def) + +lemma tcbSchedEnqueue_valid_bitmapQ[wp]: + "\valid_bitmaps\ tcbSchedEnqueue tcbPtr \\_. valid_bitmapQ\" + supply if_split[split del] + unfolding tcbSchedEnqueue_def + apply (wpsimp simp: tcbQueuePrepend_def + wp: setQueue_valid_bitmapQ' addToBitmap_valid_bitmapQ_except addToBitmap_bitmapQ + threadGet_wp) + apply (fastforce simp: valid_bitmaps_def valid_bitmapQ_def tcbQueueEmpty_def split: if_splits) + done + +crunches tcbSchedEnqueue, tcbSchedAppend + for bitmapQ_no_L1_orphans[wp]: bitmapQ_no_L1_orphans + and bitmapQ_no_L2_orphans[wp]: bitmapQ_no_L2_orphans + +lemma tcbSchedEnqueue_valid_bitmaps[wp]: + "tcbSchedEnqueue tcbPtr \valid_bitmaps\" + unfolding valid_bitmaps_def + apply wpsimp + apply (clarsimp simp: valid_bitmaps_def) + done + +crunches rescheduleRequired, threadSet, setThreadState + for valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift) + +lemma tcbSchedEnqueue_valid_sched_pointers[wp]: + "tcbSchedEnqueue tcbPtr \valid_sched_pointers\" + supply projectKOs[simp] + apply (clarsimp simp: tcbSchedEnqueue_def getQueue_def unless_def) + \ \we step forwards until we can step over the addToBitmap in order to avoid state blow-up\ + apply (intro hoare_seq_ext[OF _ stateAssert_sp] hoare_seq_ext[OF _ isRunnable_inv] + hoare_seq_ext[OF _ assert_sp] hoare_seq_ext[OF _ threadGet_sp] + hoare_seq_ext[OF _ gets_sp] + | rule hoare_when_cases, fastforce)+ + apply (forward_inv_step wp: hoare_vcg_ex_lift) + supply if_split[split del] + apply (wpsimp wp: getTCB_wp + simp: threadSet_def setObject_def updateObject_default_def tcbQueuePrepend_def + setQueue_def) + apply (clarsimp simp: valid_sched_pointers_def) + apply (intro conjI impI) + apply (fastforce simp: opt_pred_def opt_map_def split: if_splits) + apply normalise_obj_at' + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (clarsimp simp: valid_sched_pointers_def list_queue_relation_def) + apply (case_tac "ts = []", fastforce simp: tcbQueueEmpty_def) + by (intro conjI impI; + force dest!: hd_in_set heap_path_head + simp: inQ_def opt_pred_def opt_map_def obj_at'_def split: if_splits) + +lemma tcbSchedAppend_valid_sched_pointers[wp]: + "tcbSchedAppend tcbPtr \valid_sched_pointers\" + supply projectKOs[simp] + apply (clarsimp simp: tcbSchedAppend_def getQueue_def unless_def) + \ \we step forwards until we can step over the addToBitmap in order to avoid state blow-up\ + apply (intro hoare_seq_ext[OF _ stateAssert_sp] hoare_seq_ext[OF _ isRunnable_inv] + hoare_seq_ext[OF _ assert_sp] hoare_seq_ext[OF _ threadGet_sp] + hoare_seq_ext[OF _ gets_sp] + | rule hoare_when_cases, fastforce)+ + apply (forward_inv_step wp: hoare_vcg_ex_lift) + supply if_split[split del] + apply (wpsimp wp: getTCB_wp + simp: threadSet_def setObject_def updateObject_default_def tcbQueueAppend_def + setQueue_def) + apply (clarsimp simp: valid_sched_pointers_def) + apply (intro conjI impI) + apply (fastforce simp: opt_pred_def opt_map_def split: if_splits) + apply normalise_obj_at' + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + by (intro conjI impI; + clarsimp dest: last_in_set + simp: valid_sched_pointers_def opt_map_def list_queue_relation_def tcbQueueEmpty_def + queue_end_valid_def inQ_def opt_pred_def obj_at'_def + split: if_splits option.splits; + fastforce) + +lemma tcbSchedDequeue_valid_sched_pointers[wp]: + "\valid_sched_pointers and sym_heap_sched_pointers\ + tcbSchedDequeue tcbPtr + \\_. valid_sched_pointers\" + supply if_split[split del] fun_upd_apply[simp del] + supply projectKOs[simp] + apply (clarsimp simp: tcbSchedDequeue_def getQueue_def setQueue_def) + apply (wpsimp wp: threadSet_wp getTCB_wp threadGet_wp simp: tcbQueueRemove_def) + apply normalise_obj_at' + apply (rename_tac tcb) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (clarsimp split: if_splits) + apply (frule (1) list_queue_relation_neighbour_in_set[where p=tcbPtr]) + apply (fastforce simp: inQ_def opt_pred_def opt_map_def obj_at'_def) + apply (clarsimp simp: list_queue_relation_def) + apply (intro conjI impI) + \ \the ready queue is the singleton consisting of tcbPtr\ + apply (clarsimp simp: valid_sched_pointers_def) + apply (case_tac "ptr = tcbPtr") + apply (force dest!: heap_ls_last_None + simp: prev_queue_head_def queue_end_valid_def inQ_def opt_map_def obj_at'_def) + apply (simp add: fun_upd_def opt_pred_def) + \ \tcbPtr is the head of the ready queue\ + subgoal + by (auto dest!: heap_ls_last_None + simp: valid_sched_pointers_def fun_upd_apply prev_queue_head_def + inQ_def opt_pred_def opt_map_def obj_at'_def + split: if_splits option.splits) + \ \tcbPtr is the end of the ready queue\ + subgoal + by (auto dest!: heap_ls_last_None + simp: valid_sched_pointers_def queue_end_valid_def inQ_def opt_pred_def + opt_map_def fun_upd_apply obj_at'_def + split: if_splits option.splits) + \ \tcbPtr is in the middle of the ready queue\ + apply (intro conjI impI allI) + by (clarsimp simp: valid_sched_pointers_def inQ_def opt_pred_def opt_map_def fun_upd_apply obj_at'_def + split: if_splits option.splits; + auto) + +lemma tcbQueueRemove_sym_heap_sched_pointers: + "\\s. sym_heap_sched_pointers s + \ (\ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ tcbPtr \ set ts)\ + tcbQueueRemove q tcbPtr + \\_. sym_heap_sched_pointers\" + supply heap_path_append[simp del] + supply projectKOs[simp] + apply (clarsimp simp: tcbQueueRemove_def) + apply (wpsimp wp: threadSet_wp getTCB_wp) + apply (rename_tac tcb ts) + + \ \tcbPtr is the head of q, which is not a singleton\ + apply (rule conjI) + apply clarsimp + apply (clarsimp simp: list_queue_relation_def Let_def) + apply (prop_tac "tcbSchedNext tcb \ Some tcbPtr") + apply (fastforce dest: heap_ls_no_loops[where p=tcbPtr] simp: opt_map_def obj_at'_def) + apply (fastforce intro: sym_heap_remove_only' + simp: prev_queue_head_def opt_map_red opt_map_upd_triv obj_at'_def) + + \ \tcbPtr is the end of q, which is not a singleton\ + apply (intro impI) + apply (rule conjI) + apply clarsimp + apply (prop_tac "tcbSchedPrev tcb \ Some tcbPtr") + apply (fastforce dest!: heap_ls_prev_no_loops[where p=tcbPtr] + simp: list_queue_relation_def opt_map_def obj_at'_def) + apply (subst fun_upd_swap, fastforce) + apply (fastforce intro: sym_heap_remove_only simp: opt_map_red opt_map_upd_triv obj_at'_def) + + \ \tcbPtr is in the middle of q\ + apply (intro conjI impI allI) + apply (frule (2) list_queue_relation_neighbour_in_set[where p=tcbPtr]) + apply (frule split_list) + apply clarsimp + apply (rename_tac xs ys) + apply (prop_tac "xs \ [] \ ys \ []") + apply (fastforce simp: list_queue_relation_def queue_end_valid_def) + apply (clarsimp simp: list_queue_relation_def) + apply (frule (3) ptr_in_middle_prev_next) + apply (frule heap_ls_distinct) + apply (rename_tac afterPtr beforePtr xs ys) + apply (frule_tac before=beforePtr and middle=tcbPtr and after=afterPtr + in sym_heap_remove_middle_from_chain) + apply (fastforce dest: last_in_set simp: opt_map_def obj_at'_def) + apply (fastforce dest: hd_in_set simp: opt_map_def obj_at'_def) + apply (rule_tac hp="tcbSchedNexts_of s" in sym_heapD2) + apply fastforce + apply (fastforce simp: opt_map_def obj_at'_def) + apply (fastforce simp: opt_map_def obj_at'_def) + apply (fastforce simp: fun_upd_swap opt_map_red opt_map_upd_triv obj_at'_def split: if_splits) + done + +lemma tcbQueuePrepend_sym_heap_sched_pointers: + "\\s. sym_heap_sched_pointers s + \ (\ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ tcbPtr \ set ts) + \ tcbSchedNexts_of s tcbPtr = None \ tcbSchedPrevs_of s tcbPtr = None\ + tcbQueuePrepend q tcbPtr + \\_. sym_heap_sched_pointers\" + supply if_split[split del] + supply projectKOs[simp] + apply (clarsimp simp: tcbQueuePrepend_def) + apply (wpsimp wp: threadSet_wp) + apply (prop_tac "tcbPtr \ the (tcbQueueHead q)") + apply (case_tac "ts = []"; + fastforce dest: heap_path_head simp: list_queue_relation_def tcbQueueEmpty_def) + apply (drule_tac a=tcbPtr and b="the (tcbQueueHead q)" in sym_heap_connect) + apply assumption + apply (clarsimp simp: list_queue_relation_def prev_queue_head_def tcbQueueEmpty_def) + apply (fastforce simp: fun_upd_swap opt_map_red opt_map_upd_triv obj_at'_def tcbQueueEmpty_def) + done + +lemma tcbQueueInsert_sym_heap_sched_pointers: + "\\s. sym_heap_sched_pointers s + \ tcbSchedNexts_of s tcbPtr = None \ tcbSchedPrevs_of s tcbPtr = None\ + tcbQueueInsert tcbPtr afterPtr + \\_. sym_heap_sched_pointers\" + supply projectKOs[simp] + apply (clarsimp simp: tcbQueueInsert_def) + \ \forwards step in order to name beforePtr below\ + apply (rule hoare_seq_ext[OF _ getObject_tcb_sp]) + apply (rule hoare_seq_ext[OF _ assert_sp]) + apply (rule hoare_ex_pre_conj[simplified conj_commute], rename_tac beforePtr) + apply (rule hoare_seq_ext[OF _ assert_sp]) + apply (wpsimp wp: threadSet_wp) + apply normalise_obj_at' + apply (prop_tac "tcbPtr \ afterPtr") + apply (clarsimp simp: list_queue_relation_def opt_map_red obj_at'_def) + apply (prop_tac "tcbPtr \ beforePtr") + apply (fastforce dest: sym_heap_None simp: opt_map_def obj_at'_def split: option.splits) + apply (prop_tac "tcbSchedNexts_of s beforePtr = Some afterPtr") + apply (fastforce intro: sym_heapD2 simp: opt_map_def obj_at'_def) + apply (fastforce dest: sym_heap_insert_into_middle_of_chain + simp: fun_upd_swap opt_map_red opt_map_upd_triv obj_at'_def) + done + +lemma tcbQueueAppend_sym_heap_sched_pointers: + "\\s. sym_heap_sched_pointers s + \ (\ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ tcbPtr \ set ts) + \ tcbSchedNexts_of s tcbPtr = None \ tcbSchedPrevs_of s tcbPtr = None\ + tcbQueueAppend q tcbPtr + \\_. sym_heap_sched_pointers\" + supply if_split[split del] + supply projectKOs[simp] + apply (clarsimp simp: tcbQueueAppend_def) + apply (wpsimp wp: threadSet_wp) + apply (clarsimp simp: tcbQueueEmpty_def list_queue_relation_def queue_end_valid_def obj_at'_def + split: if_splits) + apply fastforce + apply (drule_tac a="last ts" and b=tcbPtr in sym_heap_connect) + apply (fastforce dest: heap_ls_last_None) + apply assumption + apply (simp add: opt_map_red tcbQueueEmpty_def) + apply (subst fun_upd_swap, simp) + apply (fastforce simp: opt_map_red opt_map_upd_triv) + done + +lemma tcbQueued_update_sym_heap_sched_pointers[wp]: + "threadSet (tcbQueued_update f) tcbPtr \sym_heap_sched_pointers\" + by (rule sym_heap_sched_pointers_lift; + wpsimp wp: threadSet_tcbSchedPrevs_of threadSet_tcbSchedNexts_of) + +lemma tcbSchedEnqueue_sym_heap_sched_pointers[wp]: + "\sym_heap_sched_pointers and valid_sched_pointers\ + tcbSchedEnqueue tcbPtr + \\_. sym_heap_sched_pointers\" + unfolding tcbSchedEnqueue_def + supply projectKOs[simp] + apply (wpsimp wp: tcbQueuePrepend_sym_heap_sched_pointers threadGet_wp + simp: addToBitmap_def bitmap_fun_defs) + apply (normalise_obj_at', rename_tac tcb) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (fastforce dest!: spec[where x=tcbPtr] inQ_implies_tcbQueueds_of + simp: valid_sched_pointers_def opt_pred_def opt_map_def obj_at'_def) + done + +lemma tcbSchedAppend_sym_heap_sched_pointers[wp]: + "\sym_heap_sched_pointers and valid_sched_pointers\ + tcbSchedAppend tcbPtr + \\_. sym_heap_sched_pointers\" + unfolding tcbSchedAppend_def + supply projectKOs[simp] + apply (wpsimp wp: tcbQueueAppend_sym_heap_sched_pointers threadGet_wp + simp: addToBitmap_def bitmap_fun_defs) + apply (normalise_obj_at', rename_tac tcb) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (fastforce dest!: spec[where x=tcbPtr] inQ_implies_tcbQueueds_of + simp: valid_sched_pointers_def opt_pred_def opt_map_def obj_at'_def) + done + +lemma tcbSchedDequeue_sym_heap_sched_pointers[wp]: + "\sym_heap_sched_pointers and valid_sched_pointers\ + tcbSchedDequeue tcbPtr + \\_. sym_heap_sched_pointers\" + unfolding tcbSchedDequeue_def + supply projectKOs[simp] + apply (wpsimp wp: tcbQueueRemove_sym_heap_sched_pointers hoare_vcg_if_lift2 threadGet_wp + simp: bitmap_fun_defs) + apply (fastforce simp: ready_queue_relation_def ksReadyQueues_asrt_def inQ_def opt_pred_def + opt_map_def obj_at'_def) + done + +crunches setThreadState + for valid_sched_pointers[wp]: valid_sched_pointers + and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + (simp: crunch_simps wp: crunch_wps threadSet_valid_sched_pointers threadSet_sched_pointers) + 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. (\p. t \ set(ksReadyQueues s p)) \ runnable' st) and (\s. runnable' st \ obj_at' tcbQueued t s \ st_tcb_at' runnable' t s) and sch_act_simple and invs'\ @@ -4345,21 +5626,21 @@ lemma sts_invs_minor': including no_pre apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) - apply (wp sts_valid_queues valid_irq_node_lift irqs_masked_lift - setThreadState_ct_not_inQ + apply (wp valid_irq_node_lift irqs_masked_lift + setThreadState_ct_not_inQ | simp add: cteCaps_of_def o_def)+ apply (clarsimp simp: sch_act_simple_def) apply (intro conjI) - apply clarsimp - defer - apply (clarsimp dest!: st_tcb_at_state_refs_ofD' - elim!: rsubst[where P=sym_refs] - intro!: ext) - apply (clarsimp elim!: st_tcb_ex_cap'') + apply clarsimp + defer + apply (clarsimp dest!: st_tcb_at_state_refs_ofD' + elim!: rsubst[where P=sym_refs] + intro!: ext) + apply (clarsimp elim!: st_tcb_ex_cap'') + apply fastforce + apply fastforce apply (frule tcb_in_valid_state', clarsimp+) - apply (cases st, simp_all add: valid_tcb_state'_def - split: Structures_H.thread_state.split_asm) - done + by (cases st; simp add: valid_tcb_state'_def split: Structures_H.thread_state.split_asm) lemma sts_cap_to'[wp]: "\ex_nonz_cap_to' p\ setThreadState st t \\rv. ex_nonz_cap_to' p\" @@ -4404,12 +5685,59 @@ lemma threadSet_ct_running': apply wp done +lemma tcbQueuePrepend_tcbPriority_obj_at'[wp]: + "tcbQueuePrepend queue tptr \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + unfolding tcbQueuePrepend_def + supply projectKOs[simp] + apply (wpsimp wp: threadSet_wp) + by (auto simp: obj_at'_def objBits_simps ps_clear_def split: if_splits) + +lemma tcbQueuePrepend_tcbDomain_obj_at'[wp]: + "tcbQueuePrepend queue tptr \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding tcbQueuePrepend_def + supply projectKOs[simp] + apply (wpsimp wp: threadSet_wp) + by (auto simp: obj_at'_def objBits_simps ps_clear_def split: if_splits) + +lemma tcbSchedDequeue_tcbPriority[wp]: + "tcbSchedDequeue t \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + unfolding tcbSchedDequeue_def tcbQueueRemove_def + by (wpsimp wp: hoare_when_weak_wp hoare_drop_imps) + +lemma tcbSchedDequeue_tcbDomain[wp]: + "tcbSchedDequeue t \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding tcbSchedDequeue_def tcbQueueRemove_def + by (wpsimp wp: hoare_when_weak_wp hoare_drop_imps) + +lemma tcbSchedEnqueue_tcbPriority_obj_at'[wp]: + "tcbSchedEnqueue tcbPtr \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + unfolding tcbSchedEnqueue_def setQueue_def + by wpsimp + +lemma tcbSchedEnqueue_tcbDomain_obj_at'[wp]: + "tcbSchedEnqueue tcbPtr \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding tcbSchedEnqueue_def setQueue_def + by wpsimp + +crunches rescheduleRequired + for tcbPriority_obj_at'[wp]: "obj_at' (\tcb. P (tcbPriority tcb)) t'" + and tcbDomain_obj_at'[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t'" + +lemma setThreadState_tcbPriority_obj_at'[wp]: + "setThreadState ts tptr \obj_at' (\tcb. P (tcbPriority tcb)) t'\" + unfolding setThreadState_def + supply projectKOs[simp] + apply (wpsimp wp: threadSet_wp) + apply (fastforce simp: obj_at'_def objBits_simps ps_clear_def) + done + lemma setThreadState_tcb_in_cur_domain'[wp]: "\tcb_in_cur_domain' t'\ setThreadState st t \\_. tcb_in_cur_domain' t'\" apply (simp add: tcb_in_cur_domain'_def) apply (rule hoare_pre) apply wps - apply (wp setThreadState_not_st | simp)+ + apply (simp add: setThreadState_def) + apply (wpsimp wp: threadSet_ct_idle_or_in_cur_domain' hoare_drop_imps)+ done lemma asUser_global_refs': "\valid_global_refs'\ asUser t f \\rv. valid_global_refs'\" @@ -4555,10 +5883,13 @@ 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) - (set_eobject ptr etcb) (setObject ptr tcb')" + 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 @@ -4579,21 +5910,35 @@ lemma set_eobject_corres': 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 cte_relation_def tcb_relation_def projectKOs split: if_split_asm)+ + 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: X64_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 pdpte_relation_def pml4e_relation_def is_tcb_def split: if_split_asm)+ - 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 (clarsimp simp: projectKOs) - apply (insert e) - apply (clarsimp simp: other_obj_relation_def etcb_relation_def is_other_obj_relation_type split: Structures_A.kernel_object.splits Structures_H.kernel_object.splits X64_A.arch_kernel_obj.splits) + 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 non_exst_same_def projectKOs split: option.splits) + apply (prop_tac "(tcbSchedPrevs_of s')(ptr := tcbSchedPrev tcb') = tcbSchedPrevs_of s'") + apply (fastforce simp: opt_map_def obj_at'_def non_exst_same_def projectKOs split: option.splits) + apply (clarsimp simp: ready_queue_relation_def opt_map_def opt_pred_def obj_at'_def inQ_def + non_exst_same_def projectKOs + split: option.splits) + apply metis done lemma set_eobject_corres: @@ -4601,9 +5946,13 @@ lemma set_eobject_corres: 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) - (set_eobject add etcbu) (setObject add tcbu')" + 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) @@ -4630,24 +5979,27 @@ lemma set_eobject_corres: 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) - (ethread_set f t) (threadSet f' t)" + 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+ + 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 simp + apply (clarsimp simp: obj_at'_def) done lemmas ethread_set_corres = diff --git a/proof/refine/X64/Tcb_R.thy b/proof/refine/X64/Tcb_R.thy index 9c02ebcce4..9e5297971a 100644 --- a/proof/refine/X64/Tcb_R.thy +++ b/proof/refine/X64/Tcb_R.thy @@ -11,7 +11,7 @@ begin context begin interpretation Arch . (*FIXME: arch_split*) lemma asUser_setNextPC_corres: - "corres dc (tcb_at t and invs) (tcb_at' t and invs') + "corres dc (tcb_at t and invs) invs' (as_user t (setNextPC v)) (asUser t (setNextPC v))" apply (rule asUser_corres) apply (rule corres_Id, simp, simp) @@ -46,15 +46,15 @@ lemma activateThread_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) + apply (fastforce 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)+ - apply (clarsimp simp: ct_in_state_def tcb_at_invs - elim!: st_tcb_weakenE) + apply (fastforce simp: ct_in_state_def tcb_at_invs + elim!: st_tcb_weakenE) apply (clarsimp simp: tcb_at_invs' ct_in_state'_def elim!: pred_tcb'_weakenE) done @@ -197,13 +197,12 @@ lemma setupReplyMaster_weak_sch_act_wf[wp]: apply assumption done -crunches setupReplyMaster - for valid_queues[wp]: "Invariants_H.valid_queues" - and valid_queues'[wp]: "valid_queues'" - (wp: crunch_wps simp: crunch_simps) +crunches setup_reply_master + for pspace_aligned[wp]: pspace_aligned + and pspace_distinct[wp]: pspace_distinct lemma restart_corres: - "corres dc (einvs and tcb_at t) (invs' and tcb_at' t) + "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) @@ -215,16 +214,19 @@ lemma restart_corres: apply (rule corres_split_nor[OF setThreadState_corres]) apply clarsimp apply (rule corres_split[OF tcbSchedEnqueue_corres possibleSwitchTo_corres]) - apply (wp set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' sts_valid_queues sts_st_tcb' - | clarsimp simp: valid_tcb_state'_def)+ - apply (rule_tac Q="\rv. valid_sched and cur_tcb" in hoare_strengthen_post) - apply wp - apply (simp add: valid_sched_def valid_sched_action_def) - apply (rule_tac Q="\rv. invs' and tcb_at' t" in hoare_strengthen_post) - apply wp - apply (clarsimp simp: invs'_def valid_state'_def sch_act_wf_weak valid_pspace'_def) - apply wp+ - apply (simp add: valid_sched_def invs_def tcb_at_is_etcb_at) + 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 (fastforce simp: valid_sched_def invs_def tcb_at_is_etcb_at) apply (clarsimp simp add: invs'_def valid_state'_def sch_act_wf_weak) done @@ -301,29 +303,30 @@ lemma invokeTCB_ReadRegisters_corres: apply (clarsimp simp: invs'_def valid_state'_def dest!: global'_no_ex_cap) done -crunch sch_act_simple [wp]: asUser "sch_act_simple" - (rule: sch_act_simple_lift) - -lemma invs_valid_queues': - "invs' s \ valid_queues' s" - by (clarsimp simp: invs'_def valid_state'_def) - -declare invs_valid_queues'[rule_format, elim!] - lemma einvs_valid_etcbs: "einvs s \ valid_etcbs s" by (clarsimp simp: valid_sched_def) lemma asUser_postModifyRegisters_corres: - "corres dc (tcb_at t) (tcb_at' t and tcb_at' ct) + "corres dc (tcb_at t and pspace_aligned and pspace_distinct) (tcb_at' ct) (arch_post_modify_registers ct t) (asUser t $ postModifyRegisters ct t)" - apply (rule corres_guard_imp) - apply (clarsimp simp: arch_post_modify_registers_def postModifyRegisters_def when_def) - apply safe - apply (rule asUser_setRegister_corres) - apply (subst submonad_asUser.return) - apply (rule corres_stateAssert_assume) - by simp+ + apply (clarsimp simp: arch_post_modify_registers_def postModifyRegisters_def when_def) + apply (rule conjI; clarsimp) + apply (corres corres: asUser_setRegister_corres) + apply (subst submonad_asUser.return) + apply (rule corres_stateAssert_assume; simp) + done + +crunches Tcb_A.restart, IpcCancel_A.suspend + for pspace_aligned[wp]: pspace_aligned + and pspace_distinct[wp]: pspace_distinct + +crunches restart + 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' + (simp: crunch_simps wp: crunch_wps threadSet_sched_pointers threadSet_valid_sched_pointers) lemma invokeTCB_WriteRegisters_corres: "corres (dc \ (=)) (einvs and tcb_at dest and ex_nonz_cap_to dest) @@ -354,20 +357,22 @@ lemma invokeTCB_WriteRegisters_corres: apply simp apply (wp+)[2] apply ((wp hoare_weak_lift_imp restart_invs' - | strengthen valid_sched_weak_strg einvs_valid_etcbs invs_valid_queues' invs_queues - invs_weak_sch_act_wf - | 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] + | 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_post_imp) 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_post_imp) apply (fastforce simp: sch_act_wf_weak invs'_def valid_state'_def dest!: global'_no_ex_cap) apply wpsimp+ + apply fastforce + apply fastforce done -crunch it[wp]: suspend "\s. P (ksIdleThread s)" - lemma tcbSchedDequeue_ResumeCurrentThread_imp_notct[wp]: "\\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ tcbSchedDequeue t @@ -388,6 +393,10 @@ lemma suspend_ResumeCurrentThread_imp_notct[wp]: \\rv s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" by (wpsimp simp: suspend_def) +crunches restart, suspend + for cur_tcb'[wp]: cur_tcb' + (wp: crunch_wps threadSet_cur ignore: threadSet) + 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 @@ -416,6 +425,8 @@ proof - apply simp apply simp apply (simp | wp)+ + apply fastforce + apply simp done have R: "\src src' des des' xs ys. \ src = src'; des = des'; xs = ys \ \ corres dc (tcb_at src and tcb_at des and invs) @@ -438,7 +449,7 @@ proof - apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) apply (rule asUser_setNextPC_corres) apply wp+ - apply simp+ + apply fastforce+ done show ?thesis apply (simp add: invokeTCB_def performTransfer_def) @@ -462,17 +473,20 @@ proof - 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_post_imp) - apply (clarsimp simp: invs_def valid_sched_weak_strg valid_sched_def) - prefer 2 - apply (rule_tac Q="\_. invs' and tcb_at' dest" in hoare_post_imp) - apply (clarsimp simp: invs'_def valid_state'_def invs_weak_sch_act_wf cur_tcb'_def) - apply (wp mapM_x_wp' hoare_weak_lift_imp | simp)+ - 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 ((solves \wpsimp wp: hoare_weak_lift_imp\)+) + apply (rule_tac Q="\_. einvs and tcb_at dest" in hoare_post_imp) + apply (fastforce simp: invs_def valid_sched_weak_strg valid_sched_def) + prefer 2 + 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 flip: cur_tcb'_def)+)[8] + apply ((wp hoare_weak_lift_imp restart_invs' | wpc | + clarsimp simp: if_apply_def2 simp flip: cur_tcb'_def)+)[2] + apply (wp suspend_nonz_cap_to_tcb hoare_weak_lift_imp + | simp add: if_apply_def2 flip: cur_tcb'_def)+ apply (fastforce simp: invs_def valid_state_def valid_pspace_def dest!: idle_no_ex_cap) + apply clarsimp apply (fastforce simp: invs'_def valid_state'_def dest!: global'_no_ex_cap) done qed @@ -515,41 +529,9 @@ lemma copyreg_invs': \\rv. invs'\" by (rule hoare_strengthen_post, rule copyreg_invs'', simp) -lemma threadSet_valid_queues_no_state: - "\Invariants_H.valid_queues and (\s. \p. t \ set (ksReadyQueues s p))\ - threadSet f t \\_. Invariants_H.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 setObject_queues_unchanged_tcb - 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 isRunnable_corres: - "corres (\ts runn. runnable ts = runn) (tcb_at t) (tcb_at' t) - (get_thread_state t) (isRunnable t)" + "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) @@ -570,16 +552,6 @@ lemma tcbSchedDequeue_not_queued: apply (wp tg_sp' [where P=\, simplified] | simp)+ done -lemma tcbSchedDequeue_not_in_queue: - "\p. \Invariants_H.valid_queues and tcb_at' t and valid_objs'\ tcbSchedDequeue t - \\rv s. t \ set (ksReadyQueues s p)\" - apply (rule_tac Q="\rv. Invariants_H.valid_queues and obj_at' (Not \ tcbQueued) t" - in hoare_post_imp) - apply (fastforce simp: valid_queues_def valid_queues_no_bitmap_def obj_at'_def projectKOs inQ_def ) - apply (wp tcbSchedDequeue_not_queued tcbSchedDequeue_valid_queues | - simp add: valid_objs'_maxDomain valid_objs'_maxPriority)+ - done - lemma threadSet_ct_in_state': "(\tcb. tcbState (f tcb) = tcbState tcb) \ \ct_in_state' test\ threadSet f t \\rv. ct_in_state' test\" @@ -621,16 +593,17 @@ lemma tcbSchedDequeue_ct_in_state'[wp]: apply (rule hoare_lift_Pf [where f=ksCurThread]; wp) done -crunch cur[wp]: tcbSchedDequeue cur_tcb' - lemma sp_corres2: - "corres dc (valid_etcbs and weak_valid_sched_action and cur_tcb) - (Invariants_H.valid_queues and valid_queues' and cur_tcb' and tcb_at' t - and (\s. weak_sch_act_wf (ksSchedulerAction s) s) and valid_objs' and (\_. x \ maxPriority)) - (set_priority t x) (setPriority t x)" + "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 and pspace_aligned' and pspace_distinct') + (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]) + 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]) @@ -642,32 +615,35 @@ lemma sp_corres2: 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) - apply clarsimp - apply ((wp hoare_drop_imps hoare_vcg_if_lift hoare_vcg_all_lift - isRunnable_wp threadSet_pred_tcb_no_state threadSet_valid_queues_no_state - threadSet_valid_queues'_no_state threadSet_cur threadSet_valid_objs_tcbPriority_update - threadSet_weak_sch_act_wf threadSet_ct_in_state'[simplified ct_in_state'_def] - | simp add: etcb_relation_def)+)[1] - apply ((wp hoare_vcg_imp_lift' hoare_vcg_if_lift hoare_vcg_all_lift hoare_vcg_disj_lift - tcbSchedDequeue_not_in_queue tcbSchedDequeue_valid_queues - tcbSchedDequeue_ct_in_state'[simplified ct_in_state'_def] - | simp add: etcb_relation_def)+)[2] + 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 (force simp: state_relation_def elim: valid_objs'_maxDomain valid_objs'_maxPriority) + apply clarsimp done -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)" +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 (clarsimp simp: valid_sched_def valid_sched_action_def) - apply (clarsimp simp: invs'_def valid_state'_def sch_act_wf_weak) + apply (fastforce simp: valid_sched_def valid_sched_action_def) + apply (fastforce 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 x) (setMCPriority t x)" +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) @@ -684,26 +660,21 @@ 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) - (tcb_at' t) + 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 - apply (clarsimp simp add: threadset_corresT [OF _ x y e]) + 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] -crunch sch_act[wp]: tcbSchedEnqueue "\s. sch_act_wf (ksSchedulerAction s) s" - (simp: unless_def) - -crunch vq'[wp]: getCurThread valid_queues' - crunch ioports'[wp]: tcbSchedEnqueue valid_ioports' (wp: crunch_wps valid_ioports_lift'' simp: crunch_simps) @@ -711,37 +682,45 @@ lemma tcbSchedDequeue_sch_act_simple[wp]: "tcbSchedDequeue t \sch_act_simple\" by (wpsimp simp: sch_act_simple_def) +lemma tcbSchedNext_update_tcb_cte_cases: + "(a, b) \ ran tcb_cte_cases \ a (tcbPriority_update f tcb) = a tcb" + unfolding tcb_cte_cases_def + by (case_tac tcb; fastforce simp: objBits_simps') + +lemma threadSet_priority_invs': + "\invs' and tcb_at' t and K (p \ maxPriority)\ + threadSet (tcbPriority_update (\_. p)) t + \\_. invs'\" + apply (rule hoare_gen_asm) + apply (simp add: invs'_def valid_state'_def split del: if_split) + apply (wp threadSet_valid_pspace' + threadSet_sch_actT_P[where P=False, simplified] + threadSet_state_refs_of'T[where f'=id] + threadSet_iflive'T + threadSet_ifunsafe'T + threadSet_idle'T + valid_irq_node_lift + valid_irq_handlers_lift'' + valid_ioports_lift' + threadSet_ctes_ofT + threadSet_not_inQ + threadSet_ct_idle_or_in_cur_domain' + threadSet_cur + untyped_ranges_zero_lift + sym_heap_sched_pointers_lift threadSet_valid_sched_pointers + threadSet_tcbSchedPrevs_of threadSet_tcbSchedNexts_of + | clarsimp simp: cteCaps_of_def tcbSchedNext_update_tcb_cte_cases o_def | rule refl)+ + by (auto simp: obj_at'_def) + lemma setP_invs': "\invs' and tcb_at' t and K (p \ maxPriority)\ setPriority t p \\rv. invs'\" - apply (rule hoare_gen_asm) - apply (simp add: setPriority_def) - apply (wp rescheduleRequired_all_invs_but_ct_not_inQ) - apply simp - apply (wp hoare_vcg_conj_lift hoare_vcg_imp_lift') - unfolding st_tcb_at'_def - apply (strengthen not_obj_at'_strengthen, wp) - apply (wp hoare_vcg_imp_lift') - apply (rule_tac Q="\rv s. invs' s" in hoare_post_imp) - apply (clarsimp simp: invs_sch_act_wf' invs'_def invs_queues) - apply (clarsimp simp: valid_state'_def) - apply (wp hoare_drop_imps threadSet_invs_trivial, - simp_all add: inQ_def cong: conj_cong)[1] - apply (wp hoare_drop_imps threadSet_invs_trivial, - simp_all add: inQ_def cong: conj_cong)[1] - apply (wp hoare_drop_imps threadSet_invs_trivial, - simp_all add: inQ_def cong: conj_cong)[1] - apply (rule_tac Q="\_. invs' and obj_at' (Not \ tcbQueued) t - and (\s. \d p. t \ set (ksReadyQueues s (d,p)))" - in hoare_post_imp) - apply (clarsimp simp: obj_at'_def inQ_def) - apply (wp tcbSchedDequeue_not_queued)+ - apply clarsimp - done + unfolding setPriority_def + by (wpsimp wp: rescheduleRequired_invs' threadSet_priority_invs') crunches setPriority, setMCPriority for typ_at'[wp]: "\s. P (typ_at' T p s)" and valid_cap[wp]: "valid_cap' c" - (simp: crunch_simps) + (simp: crunch_simps wp: crunch_wps) lemmas setPriority_typ_ats [wp] = typ_at_lifts [OF setPriority_typ_at'] @@ -1026,11 +1005,6 @@ lemma setMCPriority_valid_objs'[wp]: crunch sch_act_simple[wp]: setMCPriority sch_act_simple (wp: ssa_sch_act_simple crunch_wps rule: sch_act_simple_lift simp: crunch_simps) -(* For some reason, when this was embedded in a larger expression clarsimp wouldn't remove it. Adding it as a simp rule does *) -lemma inQ_tc_corres_helper: - "(\d p. (\tcb. tcbQueued tcb \ tcbPriority tcb = p \ tcbDomain tcb = d \ (tcbQueued tcb \ tcbDomain tcb \ d)) \ a \ set (ksReadyQueues s (d, p))) = True" - by clarsimp - abbreviation "valid_option_prio \ case_option True (\(p, auth). p \ maxPriority)" definition valid_tcb_invocation :: "tcbinvocation \ bool" where @@ -1039,9 +1013,9 @@ definition valid_tcb_invocation :: "tcbinvocation \ bool" where | _ \ True" lemma threadcontrol_corres_helper1: - "\ einvs and simple_sched_action\ - thread_set (tcb_ipc_buffer_update f) a - \\x. weak_valid_sched_action and valid_etcbs\" + "\einvs and simple_sched_action\ + thread_set (tcb_ipc_buffer_update f) a + \\_. weak_valid_sched_action and valid_etcbs\" apply (rule hoare_pre) apply (simp add: thread_set_def) apply (wp set_object_wp) @@ -1054,107 +1028,75 @@ lemma threadcontrol_corres_helper1: apply (clarsimp simp: is_tcb_def) done -lemma threadcontrol_corres_helper2: - "is_aligned a msg_align_bits \ \invs' and tcb_at' t\ - threadSet (tcbIPCBuffer_update (\_. a)) t - \\x s. Invariants_H.valid_queues s \ valid_queues' s \ weak_sch_act_wf (ksSchedulerAction s) s\" - by (wp threadSet_invs_trivial - | strengthen invs_valid_queues' invs_queues invs_weak_sch_act_wf - | clarsimp simp: inQ_def )+ - 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))) - \\x. weak_valid_sched_action and valid_etcbs \" - apply (rule hoare_pre) - apply (wp check_cap_inv | simp add:)+ - by (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) + "\einvs and simple_sched_action\ + check_cap_at cap p (check_cap_at (cap.ThreadCap cap') slot (cap_insert cap p tcb_slot)) + \\_ 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 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))))) - \\x. Invariants_H.valid_queues and valid_queues' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\" - apply (wp - | strengthen invs_valid_queues' invs_queues invs_weak_sch_act_wf - | clarsimp simp: )+ + \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))))) + \\_ s. sym_heap_sched_pointers s \ valid_sched_pointers s \ valid_tcbs' s \ pspace_aligned' s \ + pspace_distinct' s\" + apply (wpsimp wp: + | strengthen invs_sym_heap_sched_pointers invs_valid_sched_pointers + invs_valid_objs' valid_objs'_valid_tcbs' invs_pspace_aligned' + invs_pspace_distinct')+ 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 \ tcbDomain (F tcb) = tcbDomain tcb" - assumes a: "\tcb. tcbBoundNotification (F tcb) = tcbBoundNotification 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_at' t s \ (\tcb. is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits) - \ (\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. \ tcbQueued tcb \ tcbQueued (F tcb)) \ ex_nonz_cap_to' t s \ t \ ksCurThread s) - \ (\tcb. tcbQueued (F tcb) \ ksSchedulerAction s = ResumeCurrentThread \ tcbQueued tcb \ t \ ksCurThread s)\ - threadSet F t - \\rv. invs'\" -proof - - from z have domains: "\tcb. tcbDomain (F tcb) = tcbDomain tcb" by blast - note threadSet_sch_actT_P[where P=False, simplified] - have y: "\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 valid_state'_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_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'' valid_ioports_lift'' - threadSet_ctes_ofT - threadSet_not_inQ - threadSet_ct_idle_or_in_cur_domain' - threadSet_valid_dom_schedule' - threadSet_valid_queues' - threadSet_cur - untyped_ranges_zero_lift - |clarsimp simp: y z a domains cteCaps_of_def |rule refl)+ - apply (clarsimp simp: obj_at'_def projectKOs pred_tcb_at'_def) - apply (clarsimp simp: cur_tcb'_def valid_irq_node'_def valid_queues'_def o_def) - by (fastforce simp: domains ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def z a) -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'' valid_ioports_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\" @@ -1165,10 +1107,6 @@ 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) @@ -1177,6 +1115,14 @@ lemma cteDelete_it [wp]: "\\s. P (ksIdleThread s)\ cteDelete slot e \\_ s. P (ksIdleThread s)\" by (rule cteDelete_preservation) (wp | clarsimp)+ +lemma cteDelete_pspace_aligned'[wp]: + "cteDelete slot e \pspace_aligned'\" + by (rule cteDelete_preservation; wpsimp) + +lemma cteDelete_pspace_distinct'[wp]: + "cteDelete slot e \pspace_distinct'\" + by (rule cteDelete_preservation; wpsimp) + lemmas threadSet_invs_trivial2 = threadSet_invs_trivialT2 [OF all_tcbI all_tcbI all_tcbI all_tcbI, OF ball_tcb_cte_casesI] @@ -1204,6 +1150,43 @@ lemma assertDerived_wp_weak: apply (wpsimp simp: assertDerived_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 + +crunches cap_insert + for in_correct_ready_q[wp]: in_correct_ready_q + and ready_qs_distinct[wp]: ready_qs_distinct + (wp: crunch_wps ready_qs_distinct_lift) + +crunches cap_delete + for pspace_aligned[wp]: pspace_aligned + and pspace_distinct[wp]: pspace_distinct + (ignore_del: preemption_point + wp: crunch_wps + simp: crunch_simps OR_choiceE_def + ignore: wrap_ext_bool OR_choiceE) + +crunches option_update_thread + for aligned[wp]: "pspace_aligned" + and distinct[wp]: "pspace_distinct" + +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'" and y: "newroot_rel f f'" @@ -1246,8 +1229,8 @@ lemma transferCaps_corres: (invokeTCB (tcbinvocation.ThreadControl a sl' b' mcp_auth p_auth e' f' g'))" proof - have P: "\t v. corres dc - (tcb_at t) - (tcb_at' t) + (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 () @@ -1257,8 +1240,8 @@ proof - apply (safe, case_tac tcb', simp add: tcb_relation_def split: option.split) done have R: "\t v. corres dc - (tcb_at t) - (tcb_at' t) + (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)" @@ -1271,7 +1254,7 @@ proof - (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) (tcb_at' t) + 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) @@ -1395,10 +1378,20 @@ proof - apply (rule corres_split[OF getCurThread_corres], clarsimp) apply (rule corres_when[OF refl rescheduleRequired_corres]) apply (wpsimp wp: gct_wp)+ - apply (wp hoare_drop_imp) - apply (rule threadcontrol_corres_helper1[unfolded pred_conj_def]) - apply (wp hoare_drop_imp) - apply (wp threadcontrol_corres_helper2 | wpc | simp)+ + 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)+ + 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 @@ -1410,15 +1403,16 @@ proof - 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_nor) + 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) 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 + apply (wp thread_set_tcb_ipc_buffer_cap_cleared_invs ready_qs_distinct_lift thread_set_cte_wp_at_trivial thread_set_not_state_valid_sched | simp add: ran_tcb_cap_cases)+ apply (wp threadSet_invs_trivial @@ -1427,15 +1421,14 @@ proof - cap_delete_valid_cap cteDelete_deletes cteDelete_invs' | strengthen use_no_cap_to_obj_asid_strg - | clarsimp simp: inQ_def inQ_tc_corres_helper)+ + | 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 (clarsimp simp: cte_map_def tcb_cnode_index_def obj_at'_def objBits_simps projectKOs) 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))" @@ -1511,36 +1504,16 @@ proof - 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 - cap_delete_deletes + check_cap_inv[where P=simple_sched_action] + cap_delete_deletes hoare_drop_imps cap_delete_valid_cap - simp: ran_tcb_cap_cases) + 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_drop_imps) - apply ((wpsimp wp: hoare_vcg_const_imp_lift hoare_vcg_imp_lift' hoare_vcg_all_lift - threadSet_cte_wp_at' threadSet_invs_trivialT2 cteDelete_invs' - simp: tcb_cte_cases_def), (fastforce+)[6]) - apply wpsimp - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - threadSet_invs_trivialT2 threadSet_cte_wp_at' - simp: tcb_cte_cases_def, (fastforce+)[6]) - apply wpsimp - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - rescheduleRequired_invs' threadSet_cte_wp_at' - simp: tcb_cte_cases_def) - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - rescheduleRequired_invs' threadSet_invs_trivialT2 threadSet_cte_wp_at' - simp: tcb_cte_cases_def, (fastforce+)[6]) - apply wpsimp - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - rescheduleRequired_invs' threadSet_invs_trivialT2 threadSet_cte_wp_at' - simp: tcb_cte_cases_def, (fastforce+)[6]) - apply wpsimp - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift - rescheduleRequired_invs' threadSet_cap_to' threadSet_invs_trivialT2 - threadSet_cte_wp_at' hoare_drop_imps - simp: tcb_cte_cases_def) - apply (clarsimp) + 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_lift_R hoare_vcg_all_lift hoare_vcg_const_imp_lift_R hoare_vcg_const_imp_lift threadSet_valid_objs' thread_set_not_state_valid_sched @@ -1553,9 +1526,9 @@ proof - | strengthen tcb_cap_always_valid_strg tcb_at_invs use_no_cap_to_obj_asid_strg - | (erule exE, clarsimp simp: word_bits_def))+) + | (erule exE, clarsimp simp: word_bits_def) | wp (once) hoare_drop_imps)+) apply (strengthen valid_tcb_ipc_buffer_update) - apply (strengthen invs_valid_objs') + 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 @@ -1595,6 +1568,7 @@ proof - 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 + invs_psp_aligned invs_distinct cong: conj_cong imp_cong split: option.split_asm) by (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def objBits_defs @@ -1679,7 +1653,7 @@ lemma setSchedulerAction_invs'[wp]: apply (simp add: setSchedulerAction_def) apply wp apply (clarsimp simp add: invs'_def valid_state'_def valid_irq_node'_def - valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs cur_tcb'_def + valid_queues_def bitmapQ_defs cur_tcb'_def ct_not_inQ_def) apply (simp add: ct_idle_or_in_cur_domain'_def) done @@ -1809,8 +1783,8 @@ lemma invokeTCB_corres: apply (rule TcbAcc_R.rescheduleRequired_corres) apply (rule corres_trivial, simp) apply (wpsimp wp: hoare_drop_imp)+ - apply (clarsimp simp: valid_sched_weak_strg einvs_valid_etcbs) - apply (clarsimp simp: Tcb_R.invs_valid_queues' Invariants_H.invs_queues) + apply (fastforce dest: valid_sched_valid_queues simp: valid_sched_weak_strg einvs_valid_etcbs) + apply fastforce done lemma tcbBoundNotification_caps_safe[simp]: @@ -1825,6 +1799,10 @@ lemma valid_bound_ntfn_lift: apply (wp typ_at_lifts[OF P])+ done +crunches 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 @@ -1837,7 +1815,7 @@ lemma bindNotification_invs': apply (simp add: bindNotification_def invs'_def valid_state'_def) apply (rule hoare_seq_ext[OF _ get_ntfn_sp']) apply (rule hoare_pre) - apply (wp set_ntfn_valid_pspace' sbn_sch_act' sbn_valid_queues valid_irq_node_lift + 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)+ @@ -2008,8 +1986,8 @@ lemma eq_ucast_word8[simp]: done lemma checkPrio_corres: - "corres (ser \ dc) (tcb_at auth) (tcb_at' auth) - (check_prio p auth) (checkPrio p auth)" + "corres (ser \ dc) (tcb_at auth and pspace_aligned and pspace_distinct) \ + (check_prio p auth) (checkPrio p auth)" apply (simp add: check_prio_def checkPrio_def) apply (rule corres_guard_imp) apply (simp add: liftE_bindE) @@ -2031,8 +2009,9 @@ 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 valid_etcbs and (\s. \x \ set extras. s \ (fst x))) - (invs' 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'; @@ -2050,8 +2029,9 @@ lemma decodeSetMCPriority_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 valid_etcbs and (\s. \x \ set extras. s \ (fst x))) - (invs' 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_mcpriority args cap slot extras) (decodeSetMCPriority args cap' extras')" apply (cases args; cases extras; cases extras'; @@ -2065,12 +2045,6 @@ lemma decodeSetMCPriority_corres: apply (wpsimp simp: valid_cap_def valid_cap'_def)+ done -lemma valid_objs'_maxPriority': - "\s t. \ valid_objs' s; tcb_at' t s \ \ obj_at' (\tcb. tcbMCP tcb \ maxPriority) t s" - apply (erule (1) valid_objs_valid_tcbE) - apply (clarsimp simp: valid_tcb'_def) - done - lemma getMCP_sp: "\P\ threadGet tcbMCP t \\rv. mcpriority_tcb_at' (\st. st = rv) t and P\" apply (simp add: threadGet_def) @@ -2164,8 +2138,9 @@ lemma decodeSetSchedParams_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 valid_etcbs and (\s. \x \ set extras. s \ (fst x))) - (invs' 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_sched_params args cap slot extras) (decodeSetSchedParams args cap' extras')" apply (simp add: decode_set_sched_params_def decodeSetSchedParams_def) @@ -2588,10 +2563,9 @@ notes if_cong[cong] shows lemma decodeUnbindNotification_corres: "corres (ser \ tcbinv_relation) - (tcb_at t) - (tcb_at' t) - (decode_unbind_notification (cap.ThreadCap t)) - (decodeUnbindNotification (capability.ThreadCap t))" + (tcb_at t and pspace_aligned and pspace_distinct) \ + (decode_unbind_notification (cap.ThreadCap t)) + (decodeUnbindNotification (capability.ThreadCap t))" apply (simp add: decode_unbind_notification_def decodeUnbindNotification_def) apply (rule corres_guard_imp) apply (rule corres_split_eqrE) @@ -2640,7 +2614,7 @@ lemma decodeTCBInvocation_corres: corres_guard_imp[OF decodeUnbindNotification_corres] corres_guard_imp[OF decodeSetTLSBase_corres], simp_all add: valid_cap_simps valid_cap_simps' invs_def valid_sched_def) - apply (auto simp: list_all2_map1 list_all2_map2 + apply (auto simp: list_all2_map1 list_all2_map2 valid_state_def elim!: list_all2_mono) done diff --git a/proof/refine/X64/Untyped_R.thy b/proof/refine/X64/Untyped_R.thy index 551b5e7c2b..77f9bdb329 100644 --- a/proof/refine/X64/Untyped_R.thy +++ b/proof/refine/X64/Untyped_R.thy @@ -291,9 +291,9 @@ next toInteger_nat fromInteger_nat wordBits_def) apply (simp add: not_le) apply (rule whenE_throwError_corres, simp) - apply (clarsimp simp: fromAPIType_def X64_H.fromAPIType_def) + apply (clarsimp simp: fromAPIType_def) apply (rule whenE_throwError_corres, simp) - apply (clarsimp simp: fromAPIType_def X64_H.fromAPIType_def) + apply (clarsimp simp: fromAPIType_def) apply (rule_tac r' = "\cap cap'. cap_relation cap cap'" in corres_splitEE[OF corres_if]) apply simp @@ -1401,16 +1401,6 @@ crunch nosch[wp]: insertNewCaps "\s. P (ksSchedulerAction s)" crunch exst[wp]: set_cdt "\s. P (exst s)" -(*FIXME: Move to StateRelation*) -lemma state_relation_schact[elim!]: - "(s,s') \ state_relation \ sched_act_relation (scheduler_action s) (ksSchedulerAction s')" - apply (simp add: state_relation_def) - done - -lemma state_relation_queues[elim!]: "(s,s') \ state_relation \ ready_queues_relation (ready_queues s) (ksReadyQueues s')" - apply (simp add: state_relation_def) - done - lemma set_original_symb_exec_l: "corres_underlying {(s, s'). f (kheap s) (exst s) s'} nf 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) @@ -1441,6 +1431,10 @@ lemma updateNewFreeIndex_noop_psp_corres: | simp add: updateTrackedFreeIndex_def getSlotCap_def)+ done +crunches updateMDB, updateNewFreeIndex, setCTE + for rdyq_projs[wp]: + "\s. P (ksReadyQueues s) (tcbSchedNexts_of s) (tcbSchedPrevs_of s) (\d p. inQ d p |< tcbs_of' s)" + lemma insertNewCap_corres: notes if_cong[cong del] if_weak_cong[cong] shows @@ -3718,8 +3712,8 @@ lemma updateFreeIndex_clear_invs': apply (simp add:updateCap_def) apply (wp setCTE_irq_handlers' getCTE_wp) apply (simp add:updateCap_def) - apply (wp irqs_masked_lift valid_queues_lift' cur_tcb_lift ct_idle_or_in_cur_domain'_lift - hoare_vcg_disj_lift untyped_ranges_zero_lift getCTE_wp setCTE_ioports' + apply (wp irqs_masked_lift cur_tcb_lift ct_idle_or_in_cur_domain'_lift setCTE_ioports' + hoare_vcg_disj_lift untyped_ranges_zero_lift getCTE_wp valid_bitmaps_lift | wp (once) hoare_use_eq[where f="gsUntypedZeroRanges"] | simp add: getSlotCap_def | simp add: cte_wp_at_ctes_of)+ @@ -4305,14 +4299,12 @@ context begin interpretation Arch . (*FIXME: arch_split*) lemma resetUntypedCap_corres: "untypinv_relation ui ui' \ corres (dc \ dc) - (invs 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) @@ -5155,7 +5147,7 @@ lemma inv_untyped_corres': apply (clarsimp simp only: pred_conj_def invs ui) apply (strengthen vui) apply (cut_tac vui invs invs') - apply (clarsimp simp: cte_wp_at_caps_of_state valid_sched_etcbs) + 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 @@ -5169,12 +5161,6 @@ crunch pred_tcb_at'[wp]: insertNewCap "pred_tcb_at' proj P t" crunch pred_tcb_at'[wp]: doMachineOp "pred_tcb_at' proj P t" (wp: crunch_wps) - -crunch irq_node[wp]: set_thread_state "\s. P (interrupt_irq_node s)" -crunch ctes_of [wp]: setQueue "\s. P (ctes_of s)" -crunch cte_wp_at [wp]: setQueue "cte_wp_at' P p" - (simp: cte_wp_at_ctes_of) - lemma sts_valid_untyped_inv': "\valid_untyped_inv' ui\ setThreadState st t \\rv. valid_untyped_inv' ui\" apply (cases ui, simp add: ex_cte_cap_to'_def) @@ -5211,11 +5197,8 @@ crunch norqL1[wp]: insertNewCap "\s. P (ksReadyQueuesL1Bitmap s)" (wp: crunch_wps) crunch norqL2[wp]: insertNewCap "\s. P (ksReadyQueuesL2Bitmap s)" (wp: crunch_wps) -crunch ct[wp]: insertNewCap "\s. P (ksCurThread s)" - (wp: crunch_wps) crunch state_refs_of'[wp]: insertNewCap "\s. P (state_refs_of' s)" (wp: crunch_wps) -crunch cteCaps[wp]: updateNewFreeIndex "\s. P (cteCaps_of s)" crunch if_unsafe_then_cap'[wp]: updateNewFreeIndex "if_unsafe_then_cap'" lemma insertNewCap_ifunsafe'[wp]: @@ -5320,39 +5303,29 @@ lemma insertNewCap_ioports': apply (wpsimp wp: setCTE_ioports' getCTE_wp) by (clarsimp simp: cte_wp_at_ctes_of) -crunch irq_states' [wp]: insertNewCap valid_irq_states' - (wp: getCTE_wp') - -crunch vq'[wp]: insertNewCap valid_queues' - (wp: crunch_wps) - -crunch irqs_masked' [wp]: insertNewCap irqs_masked' - (wp: crunch_wps rule: irqs_masked_lift) - -crunch valid_machine_state'[wp]: insertNewCap valid_machine_state' - (wp: crunch_wps) - -crunch pspace_domain_valid[wp]: insertNewCap pspace_domain_valid - (wp: crunch_wps) - -crunch ct_not_inQ[wp]: insertNewCap "ct_not_inQ" - (wp: crunch_wps) - -crunch tcbState_inv[wp]: insertNewCap "obj_at' (\tcb. P (tcbState tcb)) t" - (wp: crunch_simps hoare_drop_imps) -crunch tcbDomain_inv[wp]: insertNewCap "obj_at' (\tcb. P (tcbDomain tcb)) t" - (wp: crunch_simps hoare_drop_imps) -crunch tcbPriority_inv[wp]: insertNewCap "obj_at' (\tcb. P (tcbPriority tcb)) t" +crunches insertNewCap + for irq_states'[wp]: valid_irq_states' + and irqs_masked' [wp]: irqs_masked' + and valid_machine_state'[wp]: valid_machine_state' + and pspace_domain_valid[wp]: pspace_domain_valid + and ct_not_inQ[wp]: "ct_not_inQ" + and tcbState_inv[wp]: "obj_at' (\tcb. P (tcbState tcb)) t" + and tcbDomain_inv[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t" + and tcbPriority_inv[wp]: "obj_at' (\tcb. P (tcbPriority tcb)) t" + and sched_queues_projs[wp]: "\s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)" + and tcbQueueds_of[wp]: "\s. P (tcbQueued |< tcbs_of' s)" + and valid_sched_pointers[wp]: valid_sched_pointers (wp: crunch_simps hoare_drop_imps) lemma insertNewCap_ct_idle_or_in_cur_domain'[wp]: "\ct_idle_or_in_cur_domain' and ct_active'\ insertNewCap parent slot cap \\_. ct_idle_or_in_cur_domain'\" -apply (wp ct_idle_or_in_cur_domain'_lift_futz[where Q=\]) -apply (rule_tac Q="\_. obj_at' (\tcb. tcbState tcb \ Structures_H.thread_state.Inactive) t and obj_at' (\tcb. d = tcbDomain tcb) t" - in hoare_strengthen_post) -apply (wp | clarsimp elim: obj_at'_weakenE)+ -apply (auto simp: obj_at'_def) -done + apply (wp ct_idle_or_in_cur_domain'_lift_futz[where Q=\]) + apply (rule_tac Q="\_. obj_at' (\tcb. tcbState tcb \ Structures_H.thread_state.Inactive) t and + obj_at' (\tcb. d = tcbDomain tcb) t" + in hoare_strengthen_post) + apply (wp | clarsimp elim: obj_at'_weakenE)+ + apply (auto simp: obj_at'_def) + done crunch ksDomScheduleIdx[wp]: insertNewCap "\s. P (ksDomScheduleIdx s)" (wp: crunch_simps hoare_drop_imps) @@ -5419,8 +5392,8 @@ lemma insertNewCap_invs': apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) apply (wp insertNewCap_valid_pspace' sch_act_wf_lift - valid_queues_lift cur_tcb_lift tcb_in_cur_domain'_lift - insertNewCap_valid_global_refs' + cur_tcb_lift tcb_in_cur_domain'_lift sym_heap_sched_pointers_lift + insertNewCap_valid_global_refs' valid_bitmaps_lift valid_arch_state_lift' insertNewCap_ioports' valid_irq_node_lift insertNewCap_valid_irq_handlers) apply (clarsimp simp: cte_wp_at_ctes_of) @@ -5502,9 +5475,6 @@ lemma createNewCaps_cap_to': apply fastforce done -crunch it[wp]: copyGlobalMappings "\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 @@ -5535,8 +5505,6 @@ lemma createNewCaps_IRQHandler[wp]: apply (wp | wpc | simp add: image_def | rule hoare_pre_cont)+ done -crunch ksIdleThread[wp]: updateCap "\s. P (ksIdleThread s)" - lemma createNewCaps_ct_active': "\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 diff --git a/proof/refine/X64/VSpace_R.thy b/proof/refine/X64/VSpace_R.thy index 51627c6037..89971ad2a9 100644 --- a/proof/refine/X64/VSpace_R.thy +++ b/proof/refine/X64/VSpace_R.thy @@ -111,7 +111,7 @@ lemma asidBits_asid_bits[simp]: asidHighBits_def asid_low_bits_def) lemma handleVMFault_corres: - "corres (fr \ dc) (tcb_at thread) (tcb_at' thread) + "corres (fr \ dc) (tcb_at thread and pspace_aligned and pspace_distinct) \ (handle_vm_fault thread fault) (handleVMFault thread fault)" apply (simp add: X64_H.handleVMFault_def handle_vm_fault_def) apply (rule corres_guard_imp) @@ -804,7 +804,7 @@ lemma message_info_from_data_eqv: lemma setMessageInfo_corres: "mi' = message_info_map mi \ - corres dc (tcb_at t) (tcb_at' t) + corres dc (tcb_at t and pspace_aligned and pspace_distinct) \ (set_message_info t mi) (setMessageInfo t mi')" apply (simp add: setMessageInfo_def set_message_info_def) apply (subgoal_tac "wordFromMessageInfo (message_info_map mi) = @@ -1707,22 +1707,6 @@ crunches storePDE, storePDPTE, storePML4E and norqL2[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" (simp: updateObject_default_def) -lemma storePDE_valid_queues [wp]: - "\Invariants_H.valid_queues\ storePDE p pde \\_. Invariants_H.valid_queues\" - by (wp valid_queues_lift | simp add: pred_tcb_at'_def)+ - -lemma storePDPTE_valid_queues [wp]: - "\Invariants_H.valid_queues\ storePDPTE p pde \\_. Invariants_H.valid_queues\" - by (wp valid_queues_lift | simp add: pred_tcb_at'_def)+ - -lemma storePML4E_valid_queues [wp]: - "\Invariants_H.valid_queues\ storePML4E p pde \\_. Invariants_H.valid_queues\" - by (wp valid_queues_lift | simp add: pred_tcb_at'_def)+ - -lemma storePDE_valid_queues' [wp]: - "\valid_queues'\ storePDE p pde \\_. valid_queues'\" - by (wp valid_queues_lift') - 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) @@ -1747,10 +1731,6 @@ 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)+ -lemma storePDPTE_valid_queues' [wp]: - "\valid_queues'\ storePDPTE p pdpte \\_. valid_queues'\" - by (wp valid_queues_lift') - lemma storePDPTE_state_refs' [wp]: "\\s. P (state_refs_of' s)\ storePDPTE p pdpte \\rv s. P (state_refs_of' s)\" apply (clarsimp simp: storePDPTE_def) @@ -1775,10 +1755,6 @@ lemma setObject_pdpte_ksInt [wp]: "\\s. P (ksInterruptState s)\ setObject p (pdpte::pdpte) \\_. \s. P (ksInterruptState s)\" by (wp setObject_ksInterrupt updateObject_default_inv|simp)+ -lemma storePML4E_valid_queues' [wp]: - "\valid_queues'\ storePML4E p pml4e \\_. valid_queues'\" - by (wp valid_queues_lift') - lemma storePML4E_state_refs' [wp]: "\\s. P (state_refs_of' s)\ storePML4E p pml4e \\rv s. P (state_refs_of' s)\" apply (clarsimp simp: storePML4E_def) @@ -2067,6 +2043,26 @@ crunches storePTE, storePDE, storePDPTE, storePML4E and gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" (wp: setObject_ksPSpace_only updateObject_default_inv) +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 storePDPTE_tcbs_of'[wp]: + "storePDPTE c (pdpte::pdpte) \\s. P' (tcbs_of' s)\" + unfolding storePDPTE_def + by setObject_easy_cases + +lemma storePML4E_tcbs_of'[wp]: + "storePML4E c (pml4e::pml4e) \\s. P' (tcbs_of' s)\" + unfolding storePML4E_def + by setObject_easy_cases + lemma storePDE_invs[wp]: "\invs' and valid_pde' pde\ storePDE p pde @@ -2077,7 +2073,7 @@ lemma storePDE_invs[wp]: irqs_masked_lift valid_arch_state_lift' valid_irq_node_lift cur_tcb_lift valid_irq_handlers_lift'' valid_ioports_lift'' - untyped_ranges_zero_lift + untyped_ranges_zero_lift valid_bitmaps_lift | simp add: cteCaps_of_def o_def)+ apply clarsimp done @@ -2092,7 +2088,7 @@ lemma storePDPTE_invs[wp]: irqs_masked_lift valid_arch_state_lift' valid_irq_node_lift cur_tcb_lift valid_irq_handlers_lift'' valid_ioports_lift'' - untyped_ranges_zero_lift + untyped_ranges_zero_lift valid_bitmaps_lift | simp add: cteCaps_of_def o_def)+ apply clarsimp done @@ -2107,7 +2103,7 @@ lemma storePML4E_invs[wp]: irqs_masked_lift valid_arch_state_lift' valid_irq_node_lift cur_tcb_lift valid_irq_handlers_lift'' valid_ioports_lift'' - untyped_ranges_zero_lift + untyped_ranges_zero_lift valid_bitmaps_lift | simp add: cteCaps_of_def o_def)+ apply clarsimp done @@ -2135,14 +2131,6 @@ crunch norqL1[wp]: storePTE "\s. P (ksReadyQueuesL1Bitmap s)" crunch norqL2[wp]: storePTE "\s. P (ksReadyQueuesL2Bitmap s)" (simp: updateObject_default_def) -lemma storePTE_valid_queues [wp]: - "\Invariants_H.valid_queues\ storePTE p pde \\_. Invariants_H.valid_queues\" - by (wp valid_queues_lift | simp add: pred_tcb_at'_def)+ - -lemma storePTE_valid_queues' [wp]: - "\valid_queues'\ storePTE p pde \\_. valid_queues'\" - by (wp valid_queues_lift') - lemma storePTE_iflive [wp]: "\if_live_then_nonz_cap'\ storePTE p pte \\rv. if_live_then_nonz_cap'\" apply (simp add: storePTE_def) @@ -2194,8 +2182,6 @@ lemma storePTE_valid_objs [wp]: apply (clarsimp simp: valid_obj'_def) done -crunch no_0_obj' [wp]: storePTE no_0_obj' - lemma storePTE_vms'[wp]: "\valid_machine_state'\ storePTE p pde \\_. valid_machine_state'\" apply (simp add: storePTE_def valid_machine_state'_def pointerInUserData_def @@ -2259,7 +2245,7 @@ lemma storePTE_invs [wp]: apply (wp sch_act_wf_lift valid_global_refs_lift' irqs_masked_lift valid_arch_state_lift' valid_irq_node_lift cur_tcb_lift valid_irq_handlers_lift'' valid_ioports_lift'' - untyped_ranges_zero_lift + untyped_ranges_zero_lift valid_bitmaps_lift | simp add: cteCaps_of_def o_def)+ apply clarsimp done @@ -2305,14 +2291,6 @@ 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_valid_queues [wp]: - "\Invariants_H.valid_queues\ setObject p (ap::asidpool) \\_. Invariants_H.valid_queues\" - by (wp valid_queues_lift | simp add: pred_tcb_at'_def)+ - -lemma setASIDPool_valid_queues' [wp]: - "\valid_queues'\ setObject p (ap::asidpool) \\_. valid_queues'\" - by (wp valid_queues_lift') - 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 @@ -2418,6 +2396,10 @@ 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_state'_def valid_pspace'_def) @@ -2426,7 +2408,7 @@ lemma setASIDPool_invs [wp]: valid_arch_state_lift' valid_irq_node_lift cur_tcb_lift valid_irq_handlers_lift'' valid_ioports_lift'' untyped_ranges_zero_lift - updateObject_default_inv + updateObject_default_inv valid_bitmaps_lift | simp add: cteCaps_of_def | rule setObject_ksPSpace_only)+ apply (clarsimp simp add: setObject_def o_def) diff --git a/spec/design/skel/KernelInit_H.thy b/spec/design/skel/KernelInit_H.thy index 490c64222a..063d5c90c3 100644 --- a/spec/design/skel/KernelInit_H.thy +++ b/spec/design/skel/KernelInit_H.thy @@ -65,7 +65,7 @@ newKernelState_def: ksDomSchedule = newKSDomSchedule, ksCurDomain = newKSCurDomain, ksDomainTime = newKSDomainTime, - ksReadyQueues = const [], + ksReadyQueues = const (TcbQueue None None), ksReadyQueuesL1Bitmap = const 0, ksReadyQueuesL2Bitmap = const 0, ksCurThread = error [], diff --git a/spec/design/skel/KernelStateData_H.thy b/spec/design/skel/KernelStateData_H.thy index 82a0ab755c..abb803e422 100644 --- a/spec/design/skel/KernelStateData_H.thy +++ b/spec/design/skel/KernelStateData_H.thy @@ -30,9 +30,7 @@ requalify_types (in Arch) subsection "The Kernel State" -type_synonym ready_queue = "machine_word list" -translations -(type) "machine_word list" <= (type) "ready_queue" +type_synonym ready_queue = tcb_queue text \We pull a fast one on haskell here ... although Haskell expects a KernelMonad which is a StateT monad in KernelData that wraps a MachineMonad, @@ -85,7 +83,7 @@ where return r od" -#INCLUDE_HASKELL SEL4/Model/StateData.lhs NOT doMachineOp KernelState ReadyQueue Kernel assert stateAssert findM funArray newKernelState capHasProperty -#INCLUDE_HASKELL SEL4/Model/StateData.lhs decls_only ONLY capHasProperty +#INCLUDE_HASKELL SEL4/Model/StateData.lhs decls_only ONLY capHasProperty ksReadyQueues_asrt ready_qs_runnable idleThreadNotQueued +#INCLUDE_HASKELL SEL4/Model/StateData.lhs NOT doMachineOp KernelState ReadyQueue Kernel assert stateAssert findM funArray newKernelState capHasProperty ksReadyQueues_asrt ready_qs_runnable idleThreadNotQueued end diff --git a/spec/haskell/src/SEL4/Kernel/Thread.lhs b/spec/haskell/src/SEL4/Kernel/Thread.lhs index 0a0fcff881..e3215bd567 100644 --- a/spec/haskell/src/SEL4/Kernel/Thread.lhs +++ b/spec/haskell/src/SEL4/Kernel/Thread.lhs @@ -19,7 +19,7 @@ We use the C preprocessor to select a target architecture. \begin{impdetails} % {-# BOOT-IMPORTS: SEL4.Model SEL4.Machine SEL4.Object.Structures SEL4.Object.Instances() SEL4.API.Types #-} -% {-# BOOT-EXPORTS: setDomain setMCPriority setPriority getThreadState setThreadState setBoundNotification getBoundNotification doIPCTransfer isRunnable restart suspend doReplyTransfer tcbSchedEnqueue tcbSchedDequeue rescheduleRequired timerTick possibleSwitchTo #-} +% {-# BOOT-EXPORTS: setDomain setMCPriority setPriority getThreadState setThreadState setBoundNotification getBoundNotification doIPCTransfer isRunnable restart suspend doReplyTransfer tcbSchedEnqueue tcbSchedDequeue rescheduleRequired timerTick possibleSwitchTo tcbQueueEmpty tcbQueuePrepend tcbQueueAppend tcbQueueInsert tcbQueueRemove #-} > import Prelude hiding (Word) > import SEL4.Config @@ -35,6 +35,7 @@ We use the C preprocessor to select a target architecture. > import Data.Bits hiding (countLeadingZeros) > import Data.Array > import Data.WordLib +> import Data.Maybe(fromJust, isJust) \end{impdetails} @@ -405,13 +406,15 @@ Note also that the level 2 bitmap array is stored in reverse in order to get bet > chooseThread :: Kernel () > chooseThread = do +> stateAssert ksReadyQueues_asrt "" +> stateAssert ready_qs_runnable "threads in the ready queues are runnable'" > curdom <- if numDomains > 1 then curDomain else return 0 > l1 <- getReadyQueuesL1Bitmap curdom > if l1 /= 0 > then do > prio <- getHighestPrio curdom > queue <- getQueue curdom prio -> let thread = head queue +> let thread = fromJust $ tcbQueueHead queue > runnable <- isRunnable thread > assert runnable "Scheduled a non-runnable thread" > switchToThread thread @@ -424,6 +427,10 @@ To switch to a new thread, we call the architecture-specific thread switch funct > switchToThread :: PPtr TCB -> Kernel () > switchToThread thread = do +> runnable <- isRunnable thread +> assert runnable "thread must be runnable" +> stateAssert ksReadyQueues_asrt "" +> stateAssert ready_qs_runnable "threads in the ready queues are runnable'" > Arch.switchToThread thread > tcbSchedDequeue thread > setCurThread thread @@ -432,6 +439,7 @@ Switching to the idle thread is similar, except that we call a different archite > switchToIdleThread :: Kernel () > switchToIdleThread = do +> stateAssert ready_qs_runnable "threads in the ready queues are runnable'" > thread <- getIdleThread > Arch.switchToIdleThread > setCurThread thread @@ -597,41 +605,135 @@ The following two functions place a thread at the beginning or end of its priori > modifyReadyQueuesL1Bitmap tdom $ > (\w -> w .&. (complement $ bit l1index)) +> tcbQueueEmpty :: TcbQueue -> Bool +> tcbQueueEmpty queue = tcbQueueHead queue == Nothing + +> tcbQueuePrepend :: TcbQueue -> PPtr TCB -> Kernel TcbQueue +> tcbQueuePrepend queue tcbPtr = do +> q <- if tcbQueueEmpty queue +> then return $ queue { tcbQueueEnd = Just tcbPtr } +> else do +> threadSet (\t -> t { tcbSchedNext = tcbQueueHead queue }) tcbPtr +> threadSet (\t -> t { tcbSchedPrev = Just tcbPtr }) (fromJust $ tcbQueueHead queue) +> return $ queue + +> return $ q { tcbQueueHead = Just tcbPtr} + +> tcbQueueAppend :: TcbQueue -> PPtr TCB -> Kernel TcbQueue +> tcbQueueAppend queue tcbPtr = do +> q <- if tcbQueueEmpty queue +> then return $ queue { tcbQueueHead = Just tcbPtr } +> else do +> threadSet (\t -> t { tcbSchedPrev = tcbQueueEnd queue }) tcbPtr +> threadSet (\t -> t { tcbSchedNext = Just tcbPtr }) (fromJust $ tcbQueueEnd queue) +> return $ queue + +> return $ q { tcbQueueEnd = Just tcbPtr} + +Insert a thread into the middle of a queue, immediately before afterPtr, where afterPtr is not the head of the queue + +> tcbQueueInsert :: PPtr TCB -> PPtr TCB -> Kernel () +> tcbQueueInsert tcbPtr afterPtr = do +> tcb <- getObject afterPtr +> beforePtrOpt <- return $ tcbSchedPrev tcb +> assert (beforePtrOpt /= Nothing) "afterPtr must not be the head of the list" +> beforePtr <- return $ fromJust beforePtrOpt +> assert (beforePtr /= afterPtr) "the tcbSchedPrev pointer of a TCB must never point to itself" + +> threadSet (\t -> t { tcbSchedPrev = Just beforePtr }) tcbPtr +> threadSet (\t -> t { tcbSchedNext = Just afterPtr}) tcbPtr +> threadSet (\t -> t { tcbSchedPrev = Just tcbPtr }) afterPtr +> threadSet (\t -> t { tcbSchedNext = Just tcbPtr }) beforePtr + +Remove a thread from a queue, which must originally contain the thread + +> tcbQueueRemove :: TcbQueue -> PPtr TCB -> Kernel TcbQueue +> tcbQueueRemove queue tcbPtr = do +> tcb <- getObject tcbPtr +> beforePtrOpt <- return $ tcbSchedPrev tcb +> afterPtrOpt <- return $ tcbSchedNext tcb + +> if tcbQueueHead queue == Just tcbPtr && tcbQueueEnd queue == Just tcbPtr + +The queue is the singleton containing tcbPtr + +> then return $ TcbQueue { tcbQueueHead = Nothing, tcbQueueEnd = Nothing } +> else +> if tcbQueueHead queue == Just tcbPtr + +tcbPtr is the head of the queue + +> then do +> assert (afterPtrOpt /= Nothing) "the queue is not a singleton" +> threadSet (\t -> t { tcbSchedPrev = Nothing }) (fromJust $ afterPtrOpt) +> threadSet (\t -> t { tcbSchedNext = Nothing }) tcbPtr +> return $ queue { tcbQueueHead = afterPtrOpt } +> else +> if tcbQueueEnd queue == Just tcbPtr + +tcbPtr is the end of the queue + +> then do +> assert (beforePtrOpt /= Nothing) "the queue is not a singleton" +> threadSet (\t -> t { tcbSchedNext = Nothing }) (fromJust $ beforePtrOpt) +> threadSet (\t -> t { tcbSchedPrev = Nothing }) tcbPtr +> return $ queue { tcbQueueEnd = beforePtrOpt } +> else do + +tcbPtr is in the middle of the queue + +> assert (afterPtrOpt /= Nothing) "the queue is not a singleton" +> assert (beforePtrOpt /= Nothing) "the queue is not a singleton" +> threadSet (\t -> t { tcbSchedNext = afterPtrOpt }) (fromJust $ beforePtrOpt) +> threadSet (\t -> t { tcbSchedPrev = beforePtrOpt }) (fromJust $ afterPtrOpt) +> threadSet (\t -> t { tcbSchedPrev = Nothing }) tcbPtr +> threadSet (\t -> t { tcbSchedNext = Nothing }) tcbPtr +> return queue + > tcbSchedEnqueue :: PPtr TCB -> Kernel () > tcbSchedEnqueue thread = do +> stateAssert ksReadyQueues_asrt "" +> runnable <- isRunnable thread +> assert runnable "thread must be runnable" > queued <- threadGet tcbQueued thread > unless queued $ do > tdom <- threadGet tcbDomain thread > prio <- threadGet tcbPriority thread > queue <- getQueue tdom prio -> setQueue tdom prio $ thread : queue -> when (null queue) $ addToBitmap tdom prio +> when (tcbQueueEmpty queue) $ addToBitmap tdom prio +> queue' <- tcbQueuePrepend queue thread +> setQueue tdom prio queue' > threadSet (\t -> t { tcbQueued = True }) thread > tcbSchedAppend :: PPtr TCB -> Kernel () > tcbSchedAppend thread = do +> stateAssert ksReadyQueues_asrt "" +> runnable <- isRunnable thread +> assert runnable "thread must be runnable" > queued <- threadGet tcbQueued thread > unless queued $ do > tdom <- threadGet tcbDomain thread > prio <- threadGet tcbPriority thread > queue <- getQueue tdom prio -> setQueue tdom prio $ queue ++ [thread] -> when (null queue) $ addToBitmap tdom prio +> when (tcbQueueEmpty queue) $ addToBitmap tdom prio +> queue' <- tcbQueueAppend queue thread +> setQueue tdom prio queue' > threadSet (\t -> t { tcbQueued = True }) thread The following function dequeues a thread, if it is queued. > tcbSchedDequeue :: PPtr TCB -> Kernel () > tcbSchedDequeue thread = do +> stateAssert ksReadyQueues_asrt "" > queued <- threadGet tcbQueued thread > when queued $ do > tdom <- threadGet tcbDomain thread > prio <- threadGet tcbPriority thread > queue <- getQueue tdom prio -> let queue' = filter (/=thread) queue +> queue' <- tcbQueueRemove queue thread > setQueue tdom prio queue' -> when (null queue') $ removeFromBitmap tdom prio > threadSet (\t -> t { tcbQueued = False }) thread +> when (tcbQueueEmpty queue') $ removeFromBitmap tdom prio \subsubsection{Timer Ticks} diff --git a/spec/haskell/src/SEL4/Model/StateData.lhs b/spec/haskell/src/SEL4/Model/StateData.lhs index 76663ed29c..29dc2ddaf6 100644 --- a/spec/haskell/src/SEL4/Model/StateData.lhs +++ b/spec/haskell/src/SEL4/Model/StateData.lhs @@ -127,7 +127,7 @@ Note that there is no error-signalling mechanism available to functions in "Kern The ready queue is simply a list of threads that are ready to run. Each thread in this list is at the same priority level. -> type ReadyQueue = [PPtr TCB] +> type ReadyQueue = TcbQueue This is a standard Haskell singly-linked list independent of the thread control block structures. However, in a real implementation, it @@ -153,7 +153,15 @@ replaces the previous one. > getCurThread = gets ksCurThread > setCurThread :: PPtr TCB -> Kernel () -> setCurThread tptr = modify (\ks -> ks { ksCurThread = tptr }) +> setCurThread tptr = do +> stateAssert idleThreadNotQueued "the idle thread cannot be in the ready queues" +> modify (\ks -> ks { ksCurThread = tptr }) + +In many places, we would like to be able to use the fact that threads in the +ready queues have runnable' thread state. We add an assertion that it does hold. + +> ready_qs_runnable :: KernelState -> Bool +> ready_qs_runnable _ = True Similarly, these functions access the idle thread pointer, the ready queue for a given priority level (adjusted to account for the active security domain), the requested action of the scheduler, and the interrupt handler state. @@ -232,7 +240,7 @@ A new kernel state structure contains an empty physical address space, a set of > ksCurDomain = 0, > ksDomainTime = 15, > ksReadyQueues = -> funPartialArray (const []) +> funPartialArray (const (TcbQueue {tcbQueueHead = Nothing, tcbQueueEnd = Nothing})) > ((0, 0), (fromIntegral numDomains, maxPriority)), > ksReadyQueuesL1Bitmap = funPartialArray (const 0) (0, fromIntegral numDomains), > ksReadyQueuesL2Bitmap = @@ -282,4 +290,12 @@ The function "findM" searches a list, returning the first item for which the giv > r <- f x > if r then return $ Just x else findM f xs +Several asserts about ksReadyQueues + +> ksReadyQueues_asrt :: KernelState -> Bool +> ksReadyQueues_asrt _ = True + +An assert that will say that the idle thread is not in a ready queue +> idleThreadNotQueued :: KernelState -> Bool +> idleThreadNotQueued _ = True diff --git a/spec/haskell/src/SEL4/Object/Endpoint.lhs b/spec/haskell/src/SEL4/Object/Endpoint.lhs index 497d50d575..873d91ea23 100644 --- a/spec/haskell/src/SEL4/Object/Endpoint.lhs +++ b/spec/haskell/src/SEL4/Object/Endpoint.lhs @@ -229,6 +229,7 @@ If an endpoint is deleted, then every pending IPC operation using it must be can > cancelAllIPC :: PPtr Endpoint -> Kernel () > cancelAllIPC epptr = do +> stateAssert ksReadyQueues_asrt "" > ep <- getEndpoint epptr > case ep of > IdleEP -> @@ -244,6 +245,7 @@ If a badged endpoint is recycled, then cancel every pending send operation using > cancelBadgedSends :: PPtr Endpoint -> Word -> Kernel () > cancelBadgedSends epptr badge = do +> stateAssert ksReadyQueues_asrt "" > ep <- getEndpoint epptr > case ep of > IdleEP -> return () diff --git a/spec/haskell/src/SEL4/Object/Instances.lhs b/spec/haskell/src/SEL4/Object/Instances.lhs index 5720f93ead..eb20a91117 100644 --- a/spec/haskell/src/SEL4/Object/Instances.lhs +++ b/spec/haskell/src/SEL4/Object/Instances.lhs @@ -138,6 +138,8 @@ By default, new threads are unable to change the security domains of other threa > tcbFaultHandler = CPtr 0, > tcbIPCBuffer = VPtr 0, > tcbBoundNotification = Nothing, +> tcbSchedPrev = Nothing, +> tcbSchedNext = Nothing, > tcbArch = newArchTCB } > injectKO = KOTCB > projectKO o = case o of diff --git a/spec/haskell/src/SEL4/Object/Notification.lhs b/spec/haskell/src/SEL4/Object/Notification.lhs index d462a19e81..ce735402f7 100644 --- a/spec/haskell/src/SEL4/Object/Notification.lhs +++ b/spec/haskell/src/SEL4/Object/Notification.lhs @@ -131,6 +131,7 @@ If a notification object is deleted, then pending receive operations must be can > cancelAllSignals :: PPtr Notification -> Kernel () > cancelAllSignals ntfnPtr = do +> stateAssert ksReadyQueues_asrt "" > ntfn <- getNotification ntfnPtr > case ntfnObj ntfn of > WaitingNtfn queue -> do diff --git a/spec/haskell/src/SEL4/Object/Structures.lhs b/spec/haskell/src/SEL4/Object/Structures.lhs index c3e27918e4..d3d1263e40 100644 --- a/spec/haskell/src/SEL4/Object/Structures.lhs +++ b/spec/haskell/src/SEL4/Object/Structures.lhs @@ -248,6 +248,14 @@ The TCB is used to store various data about the thread's current state: > tcbState :: ThreadState, > tcbMCP :: Priority, > tcbPriority :: Priority, + +\item a flag indicating whether the thread is a member of a ready queue. + Note that the flag is necessary, since although the tcbSchedPrev and tcbSchedNext fields listed below + are used only to navigate through a ready queue, we cannot say that a thread is queued + if and only if either its tcbSchedPrev or tcbSchedNext field is not Nothing. + For consider a thread that is the sole member of a ready queue. + It will have both its tcbSchedNext and tcbSchedPrev fields equal to Nothing, but it will still be tcbQueued. + > tcbQueued :: Bool, \item the thread's current fault state; @@ -270,6 +278,11 @@ The TCB is used to store various data about the thread's current state: > tcbBoundNotification :: Maybe (PPtr Notification), +\item the thread's pointers to the previous and next entries in a scheduling queue; + +> tcbSchedPrev :: Maybe (PPtr TCB), +> tcbSchedNext :: Maybe (PPtr TCB), + \item and any arch-specific TCB contents > tcbArch :: ArchTCB } @@ -476,4 +489,6 @@ Various operations on the free index of an Untyped cap. > endPtr = capPtr cap + PPtr (2 ^ capBlockSize cap) - 1 > untypedZeroRange _ = Nothing - +> data TcbQueue = TcbQueue { +> tcbQueueHead :: Maybe (PPtr TCB), +> tcbQueueEnd :: Maybe (PPtr TCB) }