From 4d5afb7c21844faba7756d9d294bf1d0c9e72a74 Mon Sep 17 00:00:00 2001 From: Rafal Kolanski Date: Fri, 24 Jul 2026 11:36:25 +1000 Subject: [PATCH 01/13] refine riscv64+x64: remove archThreadSet_if_live' This lemma was accidentally copied from AARCH64 during arch-split, and isn't needed on non-VCPU architectures. Signed-off-by: Rafal Kolanski --- proof/refine/RISCV64/ArchFinalise_R.thy | 14 -------------- proof/refine/X64/ArchFinalise_R.thy | 14 -------------- 2 files changed, 28 deletions(-) diff --git a/proof/refine/RISCV64/ArchFinalise_R.thy b/proof/refine/RISCV64/ArchFinalise_R.thy index 5e5ebd610c..5c7e8bfd9b 100644 --- a/proof/refine/RISCV64/ArchFinalise_R.thy +++ b/proof/refine/RISCV64/ArchFinalise_R.thy @@ -699,20 +699,6 @@ lemma archThreadSet_state_hyp_refs_of'[wp]: apply auto done -lemma archThreadSet_if_live'[wp]: - "\\s. if_live_then_nonz_cap' s \ - (\tcb. ko_at' tcb t s \ atcbVCPUPtr (f (tcbArch tcb)) \ None \ ex_nonz_cap_to' t s)\ - archThreadSet f t \\_. if_live_then_nonz_cap'\" - unfolding archThreadSet_def - apply (wpsimp wp: setObject_tcb_iflive' getObject_tcb_wp) - apply normalise_obj_at' - apply (clarsimp simp: tcb_cte_cases_def if_live_then_nonz_cap'_def cteSizeBits_def) - apply (erule_tac x=t in allE) - apply (erule impE) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def live'_def hyp_live'_def) - apply simp - done - lemma archThreadSet_ifunsafe'[wp]: "archThreadSet f t \if_unsafe_then_cap'\" unfolding archThreadSet_def diff --git a/proof/refine/X64/ArchFinalise_R.thy b/proof/refine/X64/ArchFinalise_R.thy index d08ae47553..72f8f7a950 100644 --- a/proof/refine/X64/ArchFinalise_R.thy +++ b/proof/refine/X64/ArchFinalise_R.thy @@ -738,20 +738,6 @@ lemma archThreadSet_state_hyp_refs_of'[wp]: apply auto done -lemma archThreadSet_if_live'[wp]: - "\\s. if_live_then_nonz_cap' s \ - (\tcb. ko_at' tcb t s \ atcbVCPUPtr (f (tcbArch tcb)) \ None \ ex_nonz_cap_to' t s)\ - archThreadSet f t \\_. if_live_then_nonz_cap'\" - unfolding archThreadSet_def - apply (wpsimp wp: setObject_tcb_iflive' getObject_tcb_wp) - apply normalise_obj_at' - apply (clarsimp simp: tcb_cte_cases_def if_live_then_nonz_cap'_def cteSizeBits_def) - apply (erule_tac x=t in allE) - apply (erule impE) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def live'_def hyp_live'_def) - apply simp - done - lemma archThreadSet_ifunsafe'[wp]: "archThreadSet f t \if_unsafe_then_cap'\" unfolding archThreadSet_def From b80a8358aba58ab1ddd8cecdec70160c3e91409f Mon Sep 17 00:00:00 2001 From: Rafal Kolanski Date: Thu, 23 Jul 2026 08:39:14 +1000 Subject: [PATCH 02/13] refine: make IncKernelInit.thy generic, use ARM version This theory file is identical on all arches except for header. Use the ARM version which appears to be the original. Signed-off-by: Rafal Kolanski --- proof/refine/AARCH64/IncKernelInit.thy | 13 ------------- proof/refine/ARM_HYP/IncKernelInit.thy | 13 ------------- proof/refine/{ARM => }/IncKernelInit.thy | 0 proof/refine/RISCV64/IncKernelInit.thy | 13 ------------- proof/refine/X64/IncKernelInit.thy | 13 ------------- 5 files changed, 52 deletions(-) delete mode 100644 proof/refine/AARCH64/IncKernelInit.thy delete mode 100644 proof/refine/ARM_HYP/IncKernelInit.thy rename proof/refine/{ARM => }/IncKernelInit.thy (100%) delete mode 100644 proof/refine/RISCV64/IncKernelInit.thy delete mode 100644 proof/refine/X64/IncKernelInit.thy diff --git a/proof/refine/AARCH64/IncKernelInit.thy b/proof/refine/AARCH64/IncKernelInit.thy deleted file mode 100644 index 7575b40427..0000000000 --- a/proof/refine/AARCH64/IncKernelInit.thy +++ /dev/null @@ -1,13 +0,0 @@ -(* - * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) - * - * SPDX-License-Identifier: GPL-2.0-only - *) - -theory IncKernelInit -imports ArchADT_H ArchTcb_R ArchArch_R -begin - -(* Dummy include file for kernel init *) - -end diff --git a/proof/refine/ARM_HYP/IncKernelInit.thy b/proof/refine/ARM_HYP/IncKernelInit.thy deleted file mode 100644 index 35d83f37db..0000000000 --- a/proof/refine/ARM_HYP/IncKernelInit.thy +++ /dev/null @@ -1,13 +0,0 @@ -(* - * Copyright 2014, General Dynamics C4 Systems - * - * SPDX-License-Identifier: GPL-2.0-only - *) - -theory IncKernelInit -imports ArchADT_H ArchTcb_R ArchArch_R -begin - -(* Dummy include file for kernel init *) - -end diff --git a/proof/refine/ARM/IncKernelInit.thy b/proof/refine/IncKernelInit.thy similarity index 100% rename from proof/refine/ARM/IncKernelInit.thy rename to proof/refine/IncKernelInit.thy diff --git a/proof/refine/RISCV64/IncKernelInit.thy b/proof/refine/RISCV64/IncKernelInit.thy deleted file mode 100644 index 7575b40427..0000000000 --- a/proof/refine/RISCV64/IncKernelInit.thy +++ /dev/null @@ -1,13 +0,0 @@ -(* - * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) - * - * SPDX-License-Identifier: GPL-2.0-only - *) - -theory IncKernelInit -imports ArchADT_H ArchTcb_R ArchArch_R -begin - -(* Dummy include file for kernel init *) - -end diff --git a/proof/refine/X64/IncKernelInit.thy b/proof/refine/X64/IncKernelInit.thy deleted file mode 100644 index 35d83f37db..0000000000 --- a/proof/refine/X64/IncKernelInit.thy +++ /dev/null @@ -1,13 +0,0 @@ -(* - * Copyright 2014, General Dynamics C4 Systems - * - * SPDX-License-Identifier: GPL-2.0-only - *) - -theory IncKernelInit -imports ArchADT_H ArchTcb_R ArchArch_R -begin - -(* Dummy include file for kernel init *) - -end From 4f59d8b4707fa92c1e8d8856e0e826b9cbd6b6ef Mon Sep 17 00:00:00 2001 From: Rafal Kolanski Date: Thu, 23 Jul 2026 08:42:55 +1000 Subject: [PATCH 03/13] refine: make KernelInit_R generic, use ARM version It makes sense to have the same set of axioms on all architectures, and is very convenient when it comes to phrasing top-level theorems. Because of this, the axioms include ckernel_init_valid_duplicates' on all architectures, even though vs_valid_duplicates' is trivially true on architectures that don't have page table duplicates (i.e. not 32-bit Arm). Having an axiom that is trivially satisfiable is redundant on these architectures, but harmless. Signed-off-by: Rafal Kolanski --- proof/refine/AARCH64/KernelInit_R.thy | 41 ---------------------- proof/refine/ARM_HYP/KernelInit_R.thy | 45 ------------------------- proof/refine/{ARM => }/KernelInit_R.thy | 3 ++ proof/refine/RISCV64/KernelInit_R.thy | 41 ---------------------- proof/refine/X64/KernelInit_R.thy | 41 ---------------------- 5 files changed, 3 insertions(+), 168 deletions(-) delete mode 100644 proof/refine/AARCH64/KernelInit_R.thy delete mode 100644 proof/refine/ARM_HYP/KernelInit_R.thy rename proof/refine/{ARM => }/KernelInit_R.thy (85%) delete mode 100644 proof/refine/RISCV64/KernelInit_R.thy delete mode 100644 proof/refine/X64/KernelInit_R.thy diff --git a/proof/refine/AARCH64/KernelInit_R.thy b/proof/refine/AARCH64/KernelInit_R.thy deleted file mode 100644 index 517a1a8a83..0000000000 --- a/proof/refine/AARCH64/KernelInit_R.thy +++ /dev/null @@ -1,41 +0,0 @@ -(* - * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) - * - * SPDX-License-Identifier: GPL-2.0-only - *) - -(* Kernel init refinement. Currently axiomatised. -*) - -theory KernelInit_R -imports - IncKernelInit - "AInvs.KernelInit_AI" -begin - -(* Axiomatisation of the rest of the initialisation code *) -axiomatization where - init_refinement: - "Init_H \ lift_state_relation state_relation `` Init_A" - -axiomatization where - ckernel_init_invs: - "\((tc,s),x) \ Init_H. invs' s" - -axiomatization where - ckernel_init_sch_norm: - "((tc,s),x) \ Init_H \ ksSchedulerAction s = ResumeCurrentThread" - -axiomatization where - ckernel_init_ctr: - "((tc,s),x) \ Init_H \ ct_running' s" - -axiomatization where - ckernel_init_domain_time: - "((tc,s),x) \ Init_H \ ksDomainTime s \ 0" - -axiomatization where - ckernel_init_domain_list: - "((tc,s),x) \ Init_H \ length (ksDomSchedule s) > 0 \ (\(d,time) \ set (ksDomSchedule s). time > 0)" - -end diff --git a/proof/refine/ARM_HYP/KernelInit_R.thy b/proof/refine/ARM_HYP/KernelInit_R.thy deleted file mode 100644 index 59d308fa31..0000000000 --- a/proof/refine/ARM_HYP/KernelInit_R.thy +++ /dev/null @@ -1,45 +0,0 @@ -(* - * Copyright 2014, General Dynamics C4 Systems - * - * SPDX-License-Identifier: GPL-2.0-only - *) - -(* Kernel init refinement. Currently axiomatised. -*) - -theory KernelInit_R -imports - IncKernelInit - "AInvs.KernelInit_AI" -begin - -(* Axiomatisation of the rest of the initialisation code *) -axiomatization where - init_refinement: - "Init_H \ lift_state_relation state_relation `` Init_A" - -axiomatization where - ckernel_init_valid_duplicates': - "\((tc,s),x) \ Init_H. vs_valid_duplicates' (ksPSpace s)" - -axiomatization where - ckernel_init_invs: - "\((tc,s),x) \ Init_H. invs' s" - -axiomatization where - ckernel_init_sch_norm: - "((tc,s),x) \ Init_H \ ksSchedulerAction s = ResumeCurrentThread" - -axiomatization where - ckernel_init_ctr: - "((tc,s),x) \ Init_H \ ct_running' s" - -axiomatization where - ckernel_init_domain_time: - "((tc,s),x) \ Init_H \ ksDomainTime s \ 0" - -axiomatization where - ckernel_init_domain_list: - "((tc,s),x) \ Init_H \ length (ksDomSchedule s) > 0 \ (\(d,time) \ set (ksDomSchedule s). time > 0)" - -end diff --git a/proof/refine/ARM/KernelInit_R.thy b/proof/refine/KernelInit_R.thy similarity index 85% rename from proof/refine/ARM/KernelInit_R.thy rename to proof/refine/KernelInit_R.thy index 59d308fa31..67f7fd2870 100644 --- a/proof/refine/ARM/KernelInit_R.thy +++ b/proof/refine/KernelInit_R.thy @@ -18,6 +18,9 @@ axiomatization where init_refinement: "Init_H \ lift_state_relation state_relation `` Init_A" +(* This axiom is only needed on architectures with page table duplicates (32-bit Arm). + For other architectures, vs_valid_duplicates' is trivially True, making this axiom + redundant but harmless. *) axiomatization where ckernel_init_valid_duplicates': "\((tc,s),x) \ Init_H. vs_valid_duplicates' (ksPSpace s)" diff --git a/proof/refine/RISCV64/KernelInit_R.thy b/proof/refine/RISCV64/KernelInit_R.thy deleted file mode 100644 index 517a1a8a83..0000000000 --- a/proof/refine/RISCV64/KernelInit_R.thy +++ /dev/null @@ -1,41 +0,0 @@ -(* - * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) - * - * SPDX-License-Identifier: GPL-2.0-only - *) - -(* Kernel init refinement. Currently axiomatised. -*) - -theory KernelInit_R -imports - IncKernelInit - "AInvs.KernelInit_AI" -begin - -(* Axiomatisation of the rest of the initialisation code *) -axiomatization where - init_refinement: - "Init_H \ lift_state_relation state_relation `` Init_A" - -axiomatization where - ckernel_init_invs: - "\((tc,s),x) \ Init_H. invs' s" - -axiomatization where - ckernel_init_sch_norm: - "((tc,s),x) \ Init_H \ ksSchedulerAction s = ResumeCurrentThread" - -axiomatization where - ckernel_init_ctr: - "((tc,s),x) \ Init_H \ ct_running' s" - -axiomatization where - ckernel_init_domain_time: - "((tc,s),x) \ Init_H \ ksDomainTime s \ 0" - -axiomatization where - ckernel_init_domain_list: - "((tc,s),x) \ Init_H \ length (ksDomSchedule s) > 0 \ (\(d,time) \ set (ksDomSchedule s). time > 0)" - -end diff --git a/proof/refine/X64/KernelInit_R.thy b/proof/refine/X64/KernelInit_R.thy deleted file mode 100644 index 7eb8466fd0..0000000000 --- a/proof/refine/X64/KernelInit_R.thy +++ /dev/null @@ -1,41 +0,0 @@ -(* - * Copyright 2014, General Dynamics C4 Systems - * - * SPDX-License-Identifier: GPL-2.0-only - *) - -(* Kernel init refinement. Currently axiomatised. -*) - -theory KernelInit_R -imports - IncKernelInit - "AInvs.KernelInit_AI" -begin - -(* Axiomatisation of the rest of the initialisation code *) -axiomatization where - init_refinement: - "Init_H \ lift_state_relation state_relation `` Init_A" - -axiomatization where - ckernel_init_invs: - "\((tc,s),x) \ Init_H. invs' s" - -axiomatization where - ckernel_init_sch_norm: - "((tc,s),x) \ Init_H \ ksSchedulerAction s = ResumeCurrentThread" - -axiomatization where - ckernel_init_ctr: - "((tc,s),x) \ Init_H \ ct_running' s" - -axiomatization where - ckernel_init_domain_time: - "((tc,s),x) \ Init_H \ ksDomainTime s \ 0" - -axiomatization where - ckernel_init_domain_list: - "((tc,s),x) \ Init_H \ length (ksDomSchedule s) > 0 \ (\(d,time) \ set (ksDomSchedule s). time > 0)" - -end From 346c9bf5827934dfa84e02fa4c0bd612c5264ac1 Mon Sep 17 00:00:00 2001 From: Rafal Kolanski Date: Thu, 23 Jul 2026 09:16:13 +1000 Subject: [PATCH 04/13] refine: Refine given arch prefix In preparation for arch-split. Create Refine.thy and update import hierarchy. PageTableDuplicates import remains in Arch theory, in preparation for removal on non-Arm-32 architectures. Signed-off-by: Rafal Kolanski --- .../AARCH64/{Refine.thy => ArchRefine.thy} | 10 +++------- proof/refine/AARCH64/EmptyFail_H.thy | 2 +- proof/refine/AARCH64/orphanage/Orphanage.thy | 2 +- .../refine/ARM/{Refine.thy => ArchRefine.thy} | 10 +++------- proof/refine/ARM/EmptyFail_H.thy | 2 +- proof/refine/ARM/orphanage/Orphanage.thy | 2 +- .../ARM_HYP/{Refine.thy => ArchRefine.thy} | 10 +++------- proof/refine/ARM_HYP/EmptyFail_H.thy | 2 +- proof/refine/ARM_HYP/orphanage/Orphanage.thy | 2 +- .../RISCV64/{Refine.thy => ArchRefine.thy} | 10 +++------- proof/refine/RISCV64/EmptyFail_H.thy | 2 +- proof/refine/RISCV64/orphanage/Orphanage.thy | 2 +- proof/refine/Refine.thy | 18 ++++++++++++++++++ .../refine/X64/{Refine.thy => ArchRefine.thy} | 10 +++------- proof/refine/X64/EmptyFail_H.thy | 2 +- proof/refine/X64/orphanage/Orphanage.thy | 2 +- 16 files changed, 43 insertions(+), 45 deletions(-) rename proof/refine/AARCH64/{Refine.thy => ArchRefine.thy} (99%) rename proof/refine/ARM/{Refine.thy => ArchRefine.thy} (99%) rename proof/refine/ARM_HYP/{Refine.thy => ArchRefine.thy} (99%) rename proof/refine/RISCV64/{Refine.thy => ArchRefine.thy} (99%) create mode 100644 proof/refine/Refine.thy rename proof/refine/X64/{Refine.thy => ArchRefine.thy} (99%) diff --git a/proof/refine/AARCH64/Refine.thy b/proof/refine/AARCH64/ArchRefine.thy similarity index 99% rename from proof/refine/AARCH64/Refine.thy rename to proof/refine/AARCH64/ArchRefine.thy index 01482fedd1..25031a38cd 100644 --- a/proof/refine/AARCH64/Refine.thy +++ b/proof/refine/AARCH64/ArchRefine.thy @@ -5,15 +5,11 @@ * SPDX-License-Identifier: GPL-2.0-only *) -(* - The main theorem -*) +(* Main abstract-to-design refinement theorem - architecture-specific proofs *) -theory Refine +theory ArchRefine imports - KernelInit_R - ArchADT_H - InitLemmas + Refine PageTableDuplicates begin diff --git a/proof/refine/AARCH64/EmptyFail_H.thy b/proof/refine/AARCH64/EmptyFail_H.thy index c80f3b9642..76b436dc93 100644 --- a/proof/refine/AARCH64/EmptyFail_H.thy +++ b/proof/refine/AARCH64/EmptyFail_H.thy @@ -6,7 +6,7 @@ *) theory EmptyFail_H -imports Refine +imports ArchRefine begin crunch_ignore (empty_fail) diff --git a/proof/refine/AARCH64/orphanage/Orphanage.thy b/proof/refine/AARCH64/orphanage/Orphanage.thy index 3fcfb0fe1d..a6499b26f0 100644 --- a/proof/refine/AARCH64/orphanage/Orphanage.thy +++ b/proof/refine/AARCH64/orphanage/Orphanage.thy @@ -5,7 +5,7 @@ *) theory Orphanage -imports Refine.Refine +imports Refine.ArchRefine begin text \ diff --git a/proof/refine/ARM/Refine.thy b/proof/refine/ARM/ArchRefine.thy similarity index 99% rename from proof/refine/ARM/Refine.thy rename to proof/refine/ARM/ArchRefine.thy index 6cee7e05fc..5a9360142a 100644 --- a/proof/refine/ARM/Refine.thy +++ b/proof/refine/ARM/ArchRefine.thy @@ -4,15 +4,11 @@ * SPDX-License-Identifier: GPL-2.0-only *) -(* - The main theorem -*) +(* Main abstract-to-design refinement theorem - architecture-specific proofs *) -theory Refine +theory ArchRefine imports - KernelInit_R - ArchADT_H - InitLemmas + Refine PageTableDuplicates begin diff --git a/proof/refine/ARM/EmptyFail_H.thy b/proof/refine/ARM/EmptyFail_H.thy index 8311dbf969..307c8cf3b0 100644 --- a/proof/refine/ARM/EmptyFail_H.thy +++ b/proof/refine/ARM/EmptyFail_H.thy @@ -5,7 +5,7 @@ *) theory EmptyFail_H -imports Refine +imports ArchRefine begin crunch_ignore (empty_fail) diff --git a/proof/refine/ARM/orphanage/Orphanage.thy b/proof/refine/ARM/orphanage/Orphanage.thy index c8e9205b20..0b0a9c41b3 100644 --- a/proof/refine/ARM/orphanage/Orphanage.thy +++ b/proof/refine/ARM/orphanage/Orphanage.thy @@ -5,7 +5,7 @@ *) theory Orphanage -imports Refine.Refine +imports Refine.ArchRefine begin text \ diff --git a/proof/refine/ARM_HYP/Refine.thy b/proof/refine/ARM_HYP/ArchRefine.thy similarity index 99% rename from proof/refine/ARM_HYP/Refine.thy rename to proof/refine/ARM_HYP/ArchRefine.thy index 64a5008d8b..606d407387 100644 --- a/proof/refine/ARM_HYP/Refine.thy +++ b/proof/refine/ARM_HYP/ArchRefine.thy @@ -4,15 +4,11 @@ * SPDX-License-Identifier: GPL-2.0-only *) -(* - The main theorem -*) +(* Main abstract-to-design refinement theorem - architecture-specific proofs *) -theory Refine +theory ArchRefine imports - KernelInit_R - ArchADT_H - InitLemmas + Refine PageTableDuplicates begin diff --git a/proof/refine/ARM_HYP/EmptyFail_H.thy b/proof/refine/ARM_HYP/EmptyFail_H.thy index a029e1c388..d93d0f3aea 100644 --- a/proof/refine/ARM_HYP/EmptyFail_H.thy +++ b/proof/refine/ARM_HYP/EmptyFail_H.thy @@ -5,7 +5,7 @@ *) theory EmptyFail_H -imports Refine +imports ArchRefine begin crunch_ignore (empty_fail) diff --git a/proof/refine/ARM_HYP/orphanage/Orphanage.thy b/proof/refine/ARM_HYP/orphanage/Orphanage.thy index 5cd8c85783..0aca407708 100644 --- a/proof/refine/ARM_HYP/orphanage/Orphanage.thy +++ b/proof/refine/ARM_HYP/orphanage/Orphanage.thy @@ -5,7 +5,7 @@ *) theory Orphanage -imports Refine.Refine +imports Refine.ArchRefine begin (* FIXME: place holder, Orphanage not proved for ARM_HYP *) diff --git a/proof/refine/RISCV64/Refine.thy b/proof/refine/RISCV64/ArchRefine.thy similarity index 99% rename from proof/refine/RISCV64/Refine.thy rename to proof/refine/RISCV64/ArchRefine.thy index 676dab18fb..48151faa0e 100644 --- a/proof/refine/RISCV64/Refine.thy +++ b/proof/refine/RISCV64/ArchRefine.thy @@ -4,15 +4,11 @@ * SPDX-License-Identifier: GPL-2.0-only *) -(* - The main theorem -*) +(* Main abstract-to-design refinement theorem - architecture-specific proofs *) -theory Refine +theory ArchRefine imports - KernelInit_R - ArchADT_H - InitLemmas + Refine PageTableDuplicates begin diff --git a/proof/refine/RISCV64/EmptyFail_H.thy b/proof/refine/RISCV64/EmptyFail_H.thy index faa3eae0e6..c6ce24d158 100644 --- a/proof/refine/RISCV64/EmptyFail_H.thy +++ b/proof/refine/RISCV64/EmptyFail_H.thy @@ -5,7 +5,7 @@ *) theory EmptyFail_H -imports Refine +imports ArchRefine begin crunch_ignore (empty_fail) diff --git a/proof/refine/RISCV64/orphanage/Orphanage.thy b/proof/refine/RISCV64/orphanage/Orphanage.thy index ae293474e4..87509d4f06 100644 --- a/proof/refine/RISCV64/orphanage/Orphanage.thy +++ b/proof/refine/RISCV64/orphanage/Orphanage.thy @@ -5,7 +5,7 @@ *) theory Orphanage -imports Refine.Refine +imports Refine.ArchRefine begin text \ diff --git a/proof/refine/Refine.thy b/proof/refine/Refine.thy new file mode 100644 index 0000000000..1378eb1b4c --- /dev/null +++ b/proof/refine/Refine.thy @@ -0,0 +1,18 @@ +(* + * Copyright 2014, General Dynamics C4 Systems + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * Copyright 2023, Proofcraft Pty Ltd + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +(* The main abstract-to-design refinement theorem *) + +theory Refine +imports + KernelInit_R + ArchADT_H + InitLemmas +begin + +end diff --git a/proof/refine/X64/Refine.thy b/proof/refine/X64/ArchRefine.thy similarity index 99% rename from proof/refine/X64/Refine.thy rename to proof/refine/X64/ArchRefine.thy index bdeb6a1909..0475040f43 100644 --- a/proof/refine/X64/Refine.thy +++ b/proof/refine/X64/ArchRefine.thy @@ -4,15 +4,11 @@ * SPDX-License-Identifier: GPL-2.0-only *) -(* - The main theorem -*) +(* Main abstract-to-design refinement theorem - architecture-specific proofs *) -theory Refine +theory ArchRefine imports - KernelInit_R - ArchADT_H - InitLemmas + Refine PageTableDuplicates begin diff --git a/proof/refine/X64/EmptyFail_H.thy b/proof/refine/X64/EmptyFail_H.thy index 6f0d94bb1e..e91d0b7a07 100644 --- a/proof/refine/X64/EmptyFail_H.thy +++ b/proof/refine/X64/EmptyFail_H.thy @@ -5,7 +5,7 @@ *) theory EmptyFail_H -imports Refine +imports ArchRefine begin crunch_ignore (empty_fail) diff --git a/proof/refine/X64/orphanage/Orphanage.thy b/proof/refine/X64/orphanage/Orphanage.thy index c1539dd8df..4e954d73c9 100644 --- a/proof/refine/X64/orphanage/Orphanage.thy +++ b/proof/refine/X64/orphanage/Orphanage.thy @@ -5,7 +5,7 @@ *) theory Orphanage -imports Refine.Refine +imports Refine.ArchRefine begin (* FIXME: place holder, Orphanage not proved for X64 *) From 6a1dceab94c761a0c99394aedd5320679562a48c Mon Sep 17 00:00:00 2001 From: Rafal Kolanski Date: Tue, 28 Jul 2026 18:54:26 +1000 Subject: [PATCH 05/13] refine: arch-split Refine Signed-off-by: Rafal Kolanski --- proof/refine/AARCH64/ArchRefine.thy | 901 +++------------------------ proof/refine/ARM/ArchRefine.thy | 931 ++++------------------------ proof/refine/ARM_HYP/ArchRefine.thy | 919 +++------------------------ proof/refine/RISCV64/ArchRefine.thy | 890 +++----------------------- proof/refine/Refine.thy | 824 ++++++++++++++++++++++++ proof/refine/X64/ArchRefine.thy | 910 ++++----------------------- 6 files changed, 1326 insertions(+), 4049 deletions(-) diff --git a/proof/refine/AARCH64/ArchRefine.thy b/proof/refine/AARCH64/ArchRefine.thy index 25031a38cd..4af618c90d 100644 --- a/proof/refine/AARCH64/ArchRefine.thy +++ b/proof/refine/AARCH64/ArchRefine.thy @@ -1,6 +1,6 @@ (* - * Copyright 2023, Proofcraft Pty Ltd * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * Copyright 2023, Proofcraft Pty Ltd * * SPDX-License-Identifier: GPL-2.0-only *) @@ -10,16 +10,17 @@ theory ArchRefine imports Refine - PageTableDuplicates begin -context begin interpretation Arch . (*FIXME: arch-split*) +context Arch begin arch_global_naming + +named_theorems Refine_assms text \User memory content is the same on both levels\ lemma typ_at_AUserDataI: "\ typ_at (AArch (AUserData sz)) p s; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned' s'; pspace_distinct' s'; n < 2 ^ (pageBitsForSize sz - pageBits) \ - \ typ_at' UserDataT (p + n * 2 ^ pageBits) s'" + \ typ_at' UserDataT (p + n * 2 ^ pageBits) s'" apply (clarsimp simp add: obj_at_def a_type_def) apply (simp split: Structures_A.kernel_object.split_asm arch_kernel_obj.split_asm split: if_split_asm) @@ -41,7 +42,7 @@ lemma typ_at_AUserDataI: lemma typ_at_ADeviceDataI: "\ typ_at (AArch (ADeviceData sz)) p s; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned' s'; pspace_distinct' s'; n < 2 ^ (pageBitsForSize sz - pageBits) \ - \ typ_at' UserDataDeviceT (p + n * 2 ^ pageBits) s'" + \ typ_at' UserDataDeviceT (p + n * 2 ^ pageBits) s'" apply (clarsimp simp add: obj_at_def a_type_def ) apply (simp split: Structures_A.kernel_object.split_asm arch_kernel_obj.split_asm split: if_split_asm) @@ -63,7 +64,7 @@ lemma typ_at_ADeviceDataI: lemma typ_at_UserDataI: "\ typ_at' UserDataT (p && ~~ mask pageBits) s'; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned s \ - \ \sz. typ_at (AArch (AUserData sz)) (p && ~~ mask (pageBitsForSize sz)) s" + \ \sz. typ_at (AArch (AUserData sz)) (p && ~~ mask (pageBitsForSize sz)) s" apply (clarsimp simp: exists_disj obj_at'_def typ_at'_def ko_wp_at'_def) apply (frule (1) in_related_pspace_dom) apply (clarsimp simp: pspace_dom_def) @@ -92,7 +93,7 @@ lemma typ_at_UserDataI: lemma typ_at_DeviceDataI: "\ typ_at' UserDataDeviceT (p && ~~ mask pageBits) s'; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned s \ - \ \sz. typ_at (AArch (ADeviceData sz)) (p && ~~ mask (pageBitsForSize sz)) s" + \ \sz. typ_at (AArch (ADeviceData sz)) (p && ~~ mask (pageBitsForSize sz)) s" apply (clarsimp simp: exists_disj obj_at'_def typ_at'_def ko_wp_at'_def) apply (frule (1) in_related_pspace_dom) apply (clarsimp simp: pspace_dom_def) @@ -118,209 +119,74 @@ lemma typ_at_DeviceDataI: apply (simp add: obj_at_def a_type_def) done -lemma pointerInUserData_relation: +lemma and_mask_pbfs_shiftr_pageBits_limit: + "p && mask (pageBitsForSize sz) >> pageBits < 2 ^ (pageBitsForSize sz - pageBits)" for p :: obj_ref + apply (rule shiftr_less_t2n') + apply (simp add: pbfs_atleast_pageBits mask_twice) + apply (case_tac sz; simp add: bit_simps) + done + +lemma p_and_not_mask_pbfs_add_mask_pbfs_eq: + "(p && ~~ mask (pageBitsForSize sz)) + (p && mask (pageBitsForSize sz) >> pageBits) * 2 ^ pageBits + = p && ~~ mask pageBits" + for p :: obj_ref + by (simp flip: shiftl_t2n' + add: shiftr_shiftl1 mask_out_add_aligned is_aligned_neg_mask pbfs_atleast_pageBits + word_plus_and_or_coroll2 add.commute) + +lemma pointerInUserData_relation[Refine_assms]: "\ (s,s') \ state_relation; valid_state' s'; valid_state s\ \ pointerInUserData p s' = in_user_frame p s" apply (simp add: pointerInUserData_def in_user_frame_def) apply (rule iffI) - apply (erule typ_at_UserDataI, (clarsimp simp: valid_state_def)+)[1] + apply (erule typ_at_UserDataI; clarsimp simp: valid_state_def) apply clarsimp - apply (drule_tac sz = sz and - n = "(p && mask (pageBitsForSize sz)) >> pageBits" - in typ_at_AUserDataI [where s = s and s' = s']) - apply (fastforce simp: valid_state'_def)+ - apply (rule shiftr_less_t2n') - apply (simp add: pbfs_atleast_pageBits mask_twice) - apply (case_tac sz, simp_all add: bit_simps)[1] - apply (subgoal_tac "(p && ~~ mask (pageBitsForSize sz)) + (p && mask (pageBitsForSize sz) >> pageBits) * 2 ^ pageBits = (p && ~~ mask pageBits)") - apply simp - apply (subst mult.commute) - apply (subst shiftl_t2n [symmetric]) - apply (simp add: shiftr_shiftl1) - apply (subst mask_out_add_aligned) - apply (rule is_aligned_neg_mask) - apply (simp add: pbfs_atleast_pageBits) - apply (subst add.commute) - apply (simp add: word_plus_and_or_coroll2) + apply (drule_tac sz=sz and n="(p && mask (pageBitsForSize sz)) >> pageBits" + in typ_at_AUserDataI [where s = s and s' = s']) + apply (fastforce simp: valid_state'_def and_mask_pbfs_shiftr_pageBits_limit)+ + apply (erule arg_cong[where f="\p. typ_at' _ p s'", THEN iffD1, rotated]) + apply (simp add: p_and_not_mask_pbfs_add_mask_pbfs_eq) done -lemma pointerInDeviceData_relation: +lemma pointerInDeviceData_relation[Refine_assms]: "\ (s,s') \ state_relation; valid_state' s'; valid_state s\ \ pointerInDeviceData p s' = in_device_frame p s" apply (simp add: pointerInDeviceData_def in_device_frame_def) apply (rule iffI) - apply (erule typ_at_DeviceDataI, (clarsimp simp: valid_state_def)+)[1] + apply (erule typ_at_DeviceDataI; clarsimp simp: valid_state_def) apply clarsimp - apply (drule_tac sz = sz and - n = "(p && mask (pageBitsForSize sz)) >> pageBits" - in typ_at_ADeviceDataI [where s = s and s' = s']) - apply (fastforce simp: valid_state'_def)+ - apply (rule shiftr_less_t2n') - apply (simp add: pbfs_atleast_pageBits mask_twice) - apply (case_tac sz, simp_all add: bit_simps)[1] - apply (subgoal_tac "(p && ~~ mask (pageBitsForSize sz)) + (p && mask (pageBitsForSize sz) >> pageBits) * 2 ^ pageBits = (p && ~~ mask pageBits)") - apply simp - apply (subst mult.commute) - apply (subst shiftl_t2n [symmetric]) - apply (simp add: shiftr_shiftl1) - apply (subst mask_out_add_aligned) - apply (rule is_aligned_neg_mask) - apply (simp add: pbfs_atleast_pageBits) - apply (subst add.commute) - apply (simp add: word_plus_and_or_coroll2) + apply (drule_tac sz=sz and n="(p && mask (pageBitsForSize sz)) >> pageBits" + in typ_at_ADeviceDataI[where s=s and s'=s']) + apply (fastforce simp: valid_state'_def and_mask_pbfs_shiftr_pageBits_limit)+ + apply (erule arg_cong[where f="\p. typ_at' _ p s'", THEN iffD1, rotated]) + apply (simp add: p_and_not_mask_pbfs_add_mask_pbfs_eq) done -lemma user_mem_relation: +lemma user_mem_relation[Refine_assms]: "\(s,s') \ state_relation; valid_state' s'; valid_state s\ \ user_mem' s' = user_mem s" - apply (rule ext) - apply (clarsimp simp: user_mem_def user_mem'_def pointerInUserData_relation pointerInDeviceData_relation) - apply (simp add: state_relation_def) - done + by (rule ext) + (clarsimp simp: user_mem_def user_mem'_def pointerInUserData_relation pointerInDeviceData_relation + state_relation_def) -lemma device_mem_relation: +lemma device_mem_relation[Refine_assms]: "\(s,s') \ state_relation; valid_state' s'; valid_state s\ \ device_mem' s' = device_mem s" - apply (rule ext) - apply (clarsimp simp: device_mem_def device_mem'_def pointerInUserData_relation - pointerInDeviceData_relation) - done + by (rule ext) + (clarsimp simp: device_mem_def device_mem'_def pointerInUserData_relation + pointerInDeviceData_relation) -lemma absKState_correct: - assumes invs: "einvs (s :: det_ext state)" and invs': "invs' s'" - assumes rel: "(s,s') \ state_relation" - shows "absKState s' = abs_state s" - using assms - apply (intro state.equality, simp_all add: absKState_def abs_state_def) - apply (rule absHeap_correct; clarsimp elim!: state_relationE) - apply (rule absCDT_correct; clarsimp) - apply (rule absIsOriginalCap_correct; clarsimp) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (clarsimp simp: state_relation_def) - apply (rule absSchedulerAction_correct, simp add: state_relation_def) - apply (simp add: domSchedule_map_relation) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def ready_queues_relation_def ready_queue_relation_def Let_def - list_queue_relation_def) - apply (fastforce dest: heap_ls_is_walk) - apply (clarsimp simp: user_mem_relation invs_def invs'_def) - apply (simp add: state_relation_def) - apply (rule absInterruptIRQNode_correct, simp add: state_relation_def) - apply (rule absInterruptStates_correct, simp add: state_relation_def) - apply (rule absArchState_correct, simp) - apply (rule absExst_correct; simp) - done - -text \The top-level invariance\ - -lemma set_thread_state_sched_act: - "\(\s. runnable state) and (\s. P (scheduler_action s))\ - set_thread_state thread state - \\rs s. P (scheduler_action (s::det_state))\" - apply (simp add: set_thread_state_def) - apply wp - apply (simp add: set_thread_state_act_def) - apply wp - apply (rule hoare_pre_cont) - apply (rule_tac Q'="\rv. (\s. runnable ts) and (\s. P (scheduler_action s))" - in hoare_strengthen_post) - apply wp - apply force - apply (wp gts_st_tcb_at)+ - apply (rule_tac Q'="\rv. st_tcb_at ((=) state) thread and (\s. runnable state) and (\s. P (scheduler_action s))" in hoare_strengthen_post) - apply (simp add: st_tcb_at_def) - apply (wp obj_set_prop_at)+ - apply (force simp: st_tcb_at_def obj_at_def) - apply wp - apply clarsimp - done - -lemma activate_thread_sched_act: +lemma arch_activate_thread_sched_act[Refine_assms]: "\ct_in_state activatable and (\s. P (scheduler_action s))\ - activate_thread - \\rs s. P (scheduler_action (s::det_state))\" - by (simp add: activate_thread_def set_thread_state_def arch_activate_idle_thread_def - | (wp set_thread_state_sched_act gts_wp)+ | wpc)+ - -lemma schedule_sched_act_rct[wp]: - "\\\ Schedule_A.schedule - \\rs (s::det_state). scheduler_action s = resume_cur_thread\" - unfolding Schedule_A.schedule_def - by (wpsimp) - -lemma call_kernel_sched_act_rct[wp]: - "\einvs and (\s. e \ Interrupt \ ct_running s) and (\s. scheduler_action s = resume_cur_thread)\ - call_kernel e - \\rs (s::det_state). scheduler_action s = resume_cur_thread\" - unfolding call_kernel_def - by (wpsimp wp: activate_thread_sched_act handle_spurious_irq_invs simp: active_from_running) - -lemma kernel_entry_invs: - "\einvs and (\s. e \ Interrupt \ ct_running s) - and (\s. 0 < domain_time s) and valid_domain_list and (ct_running or ct_idle) - and (\s. scheduler_action s = resume_cur_thread)\ - kernel_entry e us - \\rv. einvs and (\s. ct_running s \ ct_idle s) - and (\s. 0 < domain_time s) and valid_domain_list - and (\s. scheduler_action s = resume_cur_thread)\" - apply (rule_tac Q'="\rv. invs and (\s. ct_running s \ ct_idle s) and valid_sched and - (\s. 0 < domain_time s) and valid_domain_list and - valid_list and (\s. scheduler_action s = resume_cur_thread)" - in hoare_post_imp) - apply clarsimp - apply (simp add: kernel_entry_def) - apply (wp akernel_invs_det_ext call_kernel_valid_sched thread_set_invs_trivial - thread_set_not_state_valid_sched - hoare_vcg_disj_lift ct_in_state_thread_state_lift thread_set_no_change_tcb_state - call_kernel_domain_time_inv_det_ext call_kernel_domain_list_inv_det_ext - hoare_weak_lift_imp valid_domain_list_lift - | clarsimp simp add: tcb_cap_cases_def active_from_running)+ - done - -definition - "full_invs \ {((tc, s :: det_ext state), m, e). einvs s \ - (ct_running s \ ct_idle s) \ - (m = KernelMode \ e \ None) \ - (m = UserMode \ ct_running s) \ - (m = IdleMode \ ct_idle s) \ - (e \ None \ e \ Some Interrupt \ ct_running s) \ - 0 < domain_time s \ valid_domain_list s \ - (scheduler_action s = resume_cur_thread)}" - -crunch do_user_op - for valid_list: valid_list - and valid_sched: valid_sched - and sched_act: "\s. P (scheduler_action s)" - and domain_fields_inv[wp]: "domain_fields P" - -lemma do_user_op_invs2: - "\einvs and ct_running and (\s. scheduler_action s = resume_cur_thread) - and (\s. 0 < domain_time s) and valid_domain_list \ - do_user_op f tc - \\_. (einvs and ct_running and (\s. scheduler_action s = resume_cur_thread)) - and (\s. 0 < domain_time s) and valid_domain_list \" - apply (rule_tac Q'="\_. valid_list and valid_sched and - (\s. scheduler_action s = resume_cur_thread) and (invs and ct_running) and - (\s. 0 < domain_time s) and valid_domain_list" - in hoare_strengthen_post) - apply (wpsimp wp: do_user_op_valid_list do_user_op_valid_sched do_user_op_sched_act - valid_domain_list_lift do_user_op_invs) - apply force - done + arch_activate_idle_thread t + \\rs s. P (scheduler_action (s::det_state))\" + by (wpsimp simp: arch_activate_idle_thread_def) -lemmas ext_init_def = ext_init_det_ext_ext_def ext_init_unit_def - -lemma valid_list_init[simp]: +lemma valid_list_init[Refine_assms, simp]: "valid_list init_A_st" by (simp add: valid_list_2_def init_A_st_def ext_init_def init_cdt_def) -lemmas valid_list_inits[simp] = valid_list_init[simplified] - -lemma valid_sched_init[simp]: +lemma valid_sched_init[Refine_assms, simp]: "valid_sched init_A_st" apply (simp add: valid_sched_def init_A_st_def ext_init_def) apply (clarsimp simp: init_kheap_def st_tcb_at_kh_def obj_at_kh_def @@ -332,69 +198,24 @@ lemma valid_sched_init[simp]: etcb_at'_def etcbs_of'_def) done -lemma valid_domain_list_init[simp]: +lemma valid_domain_list_init[Refine_assms, simp]: "valid_domain_list init_A_st" by (simp add: init_A_st_def ext_init_def valid_domain_list_def) -lemma akernel_invariant: - "ADT_A uop \ full_invs" - unfolding full_invs_def - apply (rule invariantI) - apply (clarsimp simp: ADT_A_def subset_iff) - apply (frule bspec[OF akernel_init_invs]) - apply (simp add: Let_def Init_A_def) - apply (simp add: init_A_st_def ext_init_def) - apply (clarsimp simp: ADT_A_def global_automaton_def) - - apply (rename_tac tc' s' mode' e' tc s mode e) - apply (elim disjE) - apply ((clarsimp simp: kernel_call_A_def - | drule use_valid[OF _ kernel_entry_invs])+)[2] - apply ((clarsimp simp: do_user_op_A_def monad_to_transition_def - check_active_irq_A_def - | drule use_valid[OF _ do_user_op_invs2] - | drule use_valid[OF _ check_active_irq_invs_just_running])+)[2] - apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs])+)[1] - apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) - apply ((clarsimp simp add: do_user_op_A_def check_active_irq_A_def - | drule use_valid[OF _ do_user_op_invs2] - | drule use_valid[OF _ check_active_irq_invs_just_running])+)[1] - apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) - apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) - apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs])+)[1] - apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs_just_idle])+)[1] - apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs])+)[1] - done - -lemma dmo_getActiveIRQ_notin_non_kernel_IRQs[wp]: - "\\\ doMachineOp (getActiveIRQ True) \\irq _. irq \ Some ` non_kernel_IRQs\" - unfolding doMachineOp_def - by (wpsimp simp: getActiveIRQ_def in_monad split: if_split_asm) +lemma valid_domain_time_init[Refine_assms, simp]: + "0 < domain_time init_A_st" + by (simp add: init_A_st_def) -lemma ckernel_invs: - "\invs' and (\s. e \ Interrupt \ ct_running' s) and - (\s. ksSchedulerAction s = ResumeCurrentThread)\ - callKernel e - \\rs. (\s. ksSchedulerAction s = ResumeCurrentThread) - and (invs' and (ct_running' or ct_idle'))\" - unfolding callKernel_def - by (wpsimp wp: activate_invs' activate_sch_act schedule_sch - schedule_sch_act_simple he_invs' schedule_invs' hoare_vcg_if_lift3 - hoare_drop_imp[where Q'="\_. kernelExitAssertions"] - hoare_drop_imp[where Q'="\rv _. rv = None"] - simp: no_irq_getActiveIRQ - | strengthen non_kernel_IRQs_strg)+ +lemma sched_act_init[Refine_assms, simp]: + "scheduler_action init_A_st = resume_cur_thread" + by (simp add: init_A_st_def) defs fastpathKernelAssertions_def: "fastpathKernelAssertions \ \s. (\asid_high ap. armKSASIDTable (ksArchState s) asid_high = Some ap \ asid_pool_at' ap s)" -lemma fastpathKernelAssertions_cross: +lemma fastpathKernelAssertions_cross[Refine_assms]: "\ (s,s') \ state_relation; invs s; valid_arch_state' s'\ \ fastpathKernelAssertions s'" unfolding fastpathKernelAssertions_def apply clarsimp @@ -407,582 +228,52 @@ lemma fastpathKernelAssertions_cross: fastforce simp: mask_def asid_high_bits_def) done -(* this is only needed for callKernel, where we have invs' on concrete side *) -lemma corres_cross_over_fastpathKernelAssertions: - "\ \s. P s \ invs s; \s'. Q s' \ invs' s'; - corres r P (Q and fastpathKernelAssertions) f g \ \ - corres r P Q f g" - by (rule corres_cross_over_guard[where Q="Q and fastpathKernelAssertions"]) - (fastforce elim: fastpathKernelAssertions_cross)+ - -defs kernelExitAssertions_def: - "kernelExitAssertions s \ 0 < ksDomainTime s" - -lemma callKernel_domain_time_left: - "\\\ callKernel e \\_ s. 0 < ksDomainTime s\" - unfolding callKernel_def kernelExitAssertions_def by wpsimp - -lemma doMachineOp_sch_act_simple[wp]: - "doMachineOp f \sch_act_simple\" - by (wp sch_act_simple_lift) - -lemma kernelEntry_invs': - "\ invs' and (\s. e \ Interrupt \ ct_running' s) and - (ct_running' or ct_idle') and - (\s. ksSchedulerAction s = ResumeCurrentThread) and - (\s. 0 < ksDomainTime s) \ - kernelEntry e tc - \\rs. (\s. ksSchedulerAction s = ResumeCurrentThread) and - (invs' and (ct_running' or ct_idle')) and - (\s. 0 < ksDomainTime s) \" - apply (simp add: kernelEntry_def) - apply (wp ckernel_invs callKernel_domain_time_left - threadSet_invs_trivial threadSet_ct_running' - TcbAcc_R.dmo_invs' hoare_weak_lift_imp - doMachineOp_ct_in_state' doMachineOp_sch_act_simple - callKernel_domain_time_left - | clarsimp simp: user_memory_update_def no_irq_def tcb_at_invs')+ - done +(* interface lemma, no vs duplicates on this architecture *) +lemma callKernel_valid_duplicates'[Refine_assms]: + "\invs' and (\s. vs_valid_duplicates' (ksPSpace s)) and + (\s. ksSchedulerAction s = ResumeCurrentThread) and + (\s. e \ Interrupt \ ct_running' s)\ + callKernel e + \\rv s. vs_valid_duplicates' (ksPSpace s)\" + by wpsimp + +(* interface lemma, no vs duplicates on this architecture *) +lemma doUserOp_valid_duplicates'[Refine_assms]: + "doUserOp f tc \\s. vs_valid_duplicates' (ksPSpace s)\" + by wpsimp -lemma ptable_lift_abs_state[simp]: +(* interface lemma, no vs duplicates on this architecture *) +lemma checkActiveIRQ_valid_duplicates'[Refine_assms]: + "checkActiveIRQ \\s. vs_valid_duplicates' (ksPSpace s)\" + by wpsimp + +lemma tcb_hyp_refs'_atcbContextSet[Refine_assms, simp]: + "tcb_hyp_refs' (atcbContextSet tc atcb) = tcb_hyp_refs' atcb" + by (simp add: atcbContextSet_def) + +lemma ptable_lift_abs_state[Refine_assms, simp]: "ptable_lift t (abs_state s) = ptable_lift t s" by (simp add: ptable_lift_def abs_state_def) -lemma ptable_rights_abs_state[simp]: +lemma ptable_rights_abs_state[Refine_assms, simp]: "ptable_rights t (abs_state s) = ptable_rights t s" by (simp add: ptable_rights_def abs_state_def) -lemma ptable_rights_imp_UserData: - assumes invs: "einvs s" and invs': "invs' s'" - assumes rel: "(s,s') : state_relation" - assumes rights: "ptable_rights t (absKState s') x \ {}" - assumes trans: - "ptable_lift t (absKState s') x = Some (AARCH64.addrFromPPtr y)" - shows "pointerInUserData y s' \ pointerInDeviceData y s'" -proof - - from invs invs' rel have [simp]: "absKState s' = abs_state s" - by - (rule absKState_correct, simp_all) - from invs have valid: "valid_state s" by auto - from invs' have valid': "valid_state' s'" by auto - have "in_user_frame y s \ in_device_frame y s " - by (rule ptable_rights_imp_frame[OF valid rights[simplified] - trans[simplified]]) - thus ?thesis - by (auto simp add: pointerInUserData_relation[OF rel valid' valid] - pointerInDeviceData_relation[OF rel valid' valid]) -qed - -lemma device_update_invs': - "\invs'\doMachineOp (device_memory_update ds) - \\_. invs'\" - apply (simp add: doMachineOp_def device_memory_update_def simpler_modify_def select_f_def - gets_def get_def bind_def valid_def return_def) - by (clarsimp simp: invs'_def valid_state'_def valid_irq_states'_def valid_machine_state'_def) - -crunch doMachineOp - for ksDomainTime[wp]: "\s. P (ksDomainTime s)" - -lemma doUserOp_invs': - "\invs' and ex_abs einvs and - (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_running' and - (\s. 0 < ksDomainTime s)\ - doUserOp f tc - \\_. invs' and - (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_running' and - (\s. 0 < ksDomainTime s)\" - apply (simp add: doUserOp_def split_def ex_abs_def) - apply (wp device_update_invs' doMachineOp_ct_in_state' - | (wp (once) dmo_invs', wpsimp simp: no_irq_modify device_memory_update_def - user_memory_update_def))+ - apply (clarsimp simp: user_memory_update_def simpler_modify_def - restrict_map_def - split: option.splits) - apply (frule ptable_rights_imp_UserData[rotated 2], auto) - done - - -text \The top-level correspondence\ - -lemma None_drop: - "P \ x = None \ P" - by simp - -lemma contract_all_imp_strg': - "P \ P' \ P'' \ (\x. R x \ Q x) \ \x. R x \ P \ Q x \ P' \ P''" - by blast - -lemma kernel_corres': - "corres dc (einvs and (\s. event \ Interrupt \ ct_running s) and (ct_running or ct_idle) - and (\s. scheduler_action s = resume_cur_thread) and valid_domain_list) - (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and - (\s. ksSchedulerAction s = ResumeCurrentThread)) - (call_kernel event) - (do _ \ runExceptT $ - handleEvent event `~catchError~` - (\_. withoutPreemption $ maybeHandleInterrupt True); - _ \ ThreadDecls_H.schedule; - activateThread - od)" - unfolding call_kernel_def - apply (corres corres: handleEvent_corres corres_machine_op maybeHandleInterrupt_corres - simp: irq_state_independent_def - | corres_cases_both)+ - apply (wpsimp wp: handle_event_valid_sched)+ - apply (corres corres: schedule_corres activateThread_corres) - apply (wpsimp wp: schedule_invs' hoare_vcg_if_lift2 dmo_getActiveIRQ_non_kernel - handle_spurious_irq_invs - valid_domain_list_lift[of handle_spurious_irq] - valid_domain_list_lift[of "handle_interrupt irq" for irq] - valid_domain_list_lift[of "do_machine_op mop" for mop] - | simp add: maybe_handle_interrupt_def cong: rev_conj_cong - | strengthen None_drop contract_all_imp_strg')+ - apply (rule_tac Q'="\_. valid_domain_list and valid_sched and invs and valid_list" and - E'="\_. valid_domain_list and valid_sched and invs and valid_list" - in hoare_strengthen_postE) - apply (wpsimp wp: handle_event_valid_sched handle_event_domain_list_inv) - apply simp - apply simp - apply (wpsimp | strengthen non_kernel_IRQs_strg None_drop)+ - apply (clarsimp simp: active_from_running schact_is_rct_def) - apply (clarsimp simp: active_from_running') - done - -lemma kernel_corres: - "corres dc (einvs and (\s. event \ Interrupt \ ct_running s) and (ct_running or ct_idle) and - (\s. scheduler_action s = resume_cur_thread) and - (\s. 0 < domain_time s \ valid_domain_list s)) - (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and - (\s. ksSchedulerAction s = ResumeCurrentThread)) - (call_kernel event) (callKernel event)" - unfolding callKernel_def K_bind_def - apply (rule corres_cross_over_fastpathKernelAssertions, blast+) - apply (rule corres_stateAssert_r) - apply (rule corres_guard_imp) - apply (rule corres_add_noop_lhs2) - apply (simp only: bind_assoc[symmetric]) - apply (rule corres_split[where r'=dc and - R="\_ s. 0 < domain_time s \ valid_domain_list s" and - R'="\_. \"]) - apply (simp only: bind_assoc) - apply (rule kernel_corres') - apply (rule corres_bind_return2, rule corres_stateAssert_assume_stronger) - apply simp - apply (simp add: kernelExitAssertions_def state_relation_def) - apply (wp call_kernel_domain_time_inv_det_ext call_kernel_domain_list_inv_det_ext) - apply wp - apply clarsimp - apply clarsimp - done - -lemma user_mem_corres: - "corres (=) invs invs' (gets (\x. g (user_mem x))) (gets (\x. g (user_mem' x)))" - by (clarsimp simp add: gets_def get_def return_def bind_def - invs_def invs'_def - corres_underlying_def user_mem_relation) - -lemma device_mem_corres: - "corres (=) invs invs' (gets (\x. g (device_mem x))) (gets (\x. g (device_mem' x)))" - by (clarsimp simp add: gets_def get_def return_def bind_def - invs_def invs'_def - corres_underlying_def device_mem_relation) - -lemma entry_corres: - "corres (=) (einvs and (\s. event \ Interrupt \ ct_running s) and - (\s. 0 < domain_time s) and valid_domain_list and (ct_running or ct_idle) and - (\s. scheduler_action s = resume_cur_thread)) - (invs' and (\s. event \ Interrupt \ ct_running' s) and - (\s. 0 < ksDomainTime s) and (ct_running' or ct_idle') and - (\s. ksSchedulerAction s = ResumeCurrentThread)) - (kernel_entry event tc) (kernelEntry event tc)" - apply (simp add: kernel_entry_def kernelEntry_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getCurThread_corres]) - apply (rule corres_split) - apply simp - 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) - apply (clarsimp simp: tcb_cte_cases_def cteSizeBits_def) - apply (rule corres_split[OF kernel_corres]) - apply (rule corres_split_eqr[OF getCurThread_corres]) - apply (rule threadGet_corres) - apply (simp add: tcb_relation_def arch_tcb_relation_def - arch_tcb_context_get_def atcbContextGet_def) - apply wp+ - apply (rule hoare_strengthen_post, rule akernel_invs_det_ext, - 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 - threadSet_invs_trivial threadSet_ct_running' - thread_set_not_state_valid_sched hoare_weak_lift_imp - hoare_vcg_disj_lift ct_in_state_thread_state_lift - thread_set_no_change_tcb_state - | simp add: tcb_cap_cases_def ct_in_state'_def schact_is_rct_def - | (wps, wp threadSet_st_tcb_at2) )+ - apply (clarsimp simp: invs_def cur_tcb_def valid_state_def valid_pspace_def) - apply (clarsimp simp: ct_in_state'_def) - done - -lemma corres_gets_machine_state: - "corres (=) \ \ (gets (f \ machine_state)) (gets (f \ ksMachineState))" - by (clarsimp simp: gets_def corres_underlying_def - in_monad bind_def get_def return_def state_relation_def) - -lemma do_user_op_corres: - "corres (=) (einvs and ct_running) - (invs' and (%s. ksSchedulerAction s = ResumeCurrentThread) and - ct_running') - (do_user_op f tc) (doUserOp f tc)" - apply (simp add: do_user_op_def doUserOp_def split_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getCurThread_corres]) - apply (rule_tac r'="(=)" and P=einvs and P'=invs' in corres_split) - apply (fastforce dest: absKState_correct [rotated]) - apply (rule_tac r'="(=)" and P=einvs and P'=invs' in corres_split) - apply (fastforce dest: absKState_correct [rotated]) - apply (rule_tac r'="(=)" and P=invs and P'=invs' in corres_split) - apply (rule user_mem_corres) - apply (rule_tac r'="(=)" and P=invs and P'=invs' in corres_split) - apply (rule device_mem_corres) - apply (rule_tac r'="(=)" in corres_split) - apply (rule corres_gets_machine_state) - apply (rule_tac F = "dom (rvb \ addrFromPPtr) \ - dom rvd" in corres_gen_asm) - apply (rule_tac F = "dom (rvc \ addrFromPPtr) \ dom rvd" in corres_gen_asm) - apply simp - apply (rule_tac r'="(=)" in corres_split[OF corres_select]) - apply simp - apply (rule corres_underlying_split[OF corres_machine_op]) - apply simp - apply (rule corres_underlying_trivial) - apply (simp add: user_memory_update_def) - apply (wp | simp)+ - apply (rule corres_underlying_split[OF corres_machine_op,where Q = dc and Q'=dc]) - apply (rule corres_underlying_trivial) - apply (wp | simp add: dc_def device_memory_update_def)+ - apply (clarsimp simp: invs_def valid_state_def pspace_respects_device_region_def) - apply fastforce - done - -lemma ct_running_related: - "\ (a, c) \ state_relation; ct_running' c \ - \ ct_running a" - apply (clarsimp simp: ct_in_state_def ct_in_state'_def - curthread_relation) - apply (frule(1) st_tcb_at_coerce_abstract) - apply (erule st_tcb_weakenE) - apply (case_tac st, simp_all)[1] - done - -lemma ct_idle_related: - "\ (a, c) \ state_relation; ct_idle' c \ - \ ct_idle a" - apply (clarsimp simp: ct_in_state_def ct_in_state'_def - curthread_relation) - apply (frule(1) st_tcb_at_coerce_abstract) - apply (erule st_tcb_weakenE) - apply (case_tac st, simp_all)[1] - done - -definition - "full_invs' \ {((tc,s),m,e). invs' s \ - ex_abs (einvs::det_ext state \ bool) s \ - ksSchedulerAction s = ResumeCurrentThread \ - (ct_running' s \ ct_idle' s) \ - (m = KernelMode \ e \ None) \ - (m = UserMode \ ct_running' s) \ - (m = IdleMode \ ct_idle' s) \ - (e \ None \ e \ Some Interrupt \ ct_running' s) \ - 0 < ksDomainTime s}" - -lemma check_active_irq_corres': - "corres (=) \ \ (check_active_irq) (checkActiveIRQ)" - apply (simp add: check_active_irq_def checkActiveIRQ_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF corres_machine_op[OF corres_underlying_trivial], where R="\_. \" and R'="\_. \"]) - apply wpsimp+ - done - -lemma check_active_irq_corres: - "corres (=) - (invs and (ct_running or ct_idle) and einvs and (\s. scheduler_action s = resume_cur_thread) - and (\s. 0 < domain_time s) and valid_domain_list) - (invs' and (\s. ksSchedulerAction s = ResumeCurrentThread) - and (\s. 0 < ksDomainTime s) and (ct_running' or ct_idle')) - (check_active_irq) (checkActiveIRQ)" - apply (rule corres_guard_imp) - apply (rule check_active_irq_corres', auto) - done - -lemma checkActiveIRQ_just_running_corres: - "corres (=) - (invs and ct_running and einvs and (\s. scheduler_action s = resume_cur_thread) - and (\s. 0 < domain_time s) and valid_domain_list) - (invs' and ct_running' - and (\s. 0 < ksDomainTime s) - and (\s. ksSchedulerAction s = ResumeCurrentThread)) - (check_active_irq) (checkActiveIRQ)" - apply (rule corres_guard_imp) - apply (rule check_active_irq_corres', auto) - done - -lemma checkActiveIRQ_just_idle_corres: - "corres (=) - (invs and ct_idle and einvs and (\s. scheduler_action s = resume_cur_thread) - and (\s. 0 < domain_time s) and valid_domain_list) - (invs' and ct_idle' - and (\s. 0 < ksDomainTime s) - and (\s. ksSchedulerAction s = ResumeCurrentThread)) - (check_active_irq) (checkActiveIRQ)" - apply (rule corres_guard_imp) - apply (rule check_active_irq_corres', auto) - done - -lemma checkActiveIRQ_invs': - "\invs' and ex_abs invs and (ct_running' or ct_idle') - and (\s. ksSchedulerAction s = ResumeCurrentThread)\ - checkActiveIRQ - \\_. invs' and (ct_running' or ct_idle') - and (\s. ksSchedulerAction s = ResumeCurrentThread)\" - apply (simp add: checkActiveIRQ_def ex_abs_def) - apply (wp dmo_invs' | simp)+ - done - -lemma checkActiveIRQ_invs'_just_running: - "\invs' and ex_abs invs and ct_running' - and (\s. ksSchedulerAction s = ResumeCurrentThread)\ - checkActiveIRQ - \\_. invs' and ct_running' - and (\s. ksSchedulerAction s = ResumeCurrentThread)\" - apply (simp add: checkActiveIRQ_def) - apply (wp | simp)+ - done - -lemma checkActiveIRQ_invs'_just_idle: - "\invs' and ex_abs invs and ct_idle' - and (\s. ksSchedulerAction s = ResumeCurrentThread)\ - checkActiveIRQ - \\_. invs' and ct_idle' - and (\s. ksSchedulerAction s = ResumeCurrentThread)\" - apply (simp add: checkActiveIRQ_def) - apply (wp | simp)+ - done - -lemma sched_act_rct_related: - "\ (a, c) \ state_relation; ksSchedulerAction c = ResumeCurrentThread\ - \ scheduler_action a = resume_cur_thread" - by (case_tac "scheduler_action a", simp_all add: state_relation_def) - -lemma domain_time_rel_eq: - "(a, c) \ state_relation \ P (ksDomainTime c) = P (domain_time a)" - by (clarsimp simp: state_relation_def) - -crunch doUserOp, checkActiveIRQ - for valid_objs': valid_objs' - (wp: crunch_wps - rule: doUserOp_def) (* FIXME: crunch can't find the rule of locale-defined constant *) - -lemma valid_domain_list_2_cross: - "\valid_dom_schedule'_2 sched idx start; domain_list_map dom_list = sched \ - \ valid_domain_list_2 start idx dom_list" - by (fastforce simp: valid_domain_list_2_def valid_dom_schedule'_2_def ucast_eq_0 is_up - split: prod.splits) - -lemma valid_domain_list_from_invs': - "\ (s, s') \ state_relation; invs' s' \ \ valid_domain_list s" - by (clarsimp simp: valid_domain_list_2_cross invs'_def valid_state'_def elim!: state_relationE) - -lemma ckernel_invariant: - "ADT_H uop \ full_invs'" - unfolding full_invs'_def - supply word_neq_0_conv[simp] - supply domain_time_rel_eq[simp] - apply (rule invariantI) - apply (clarsimp simp add: ADT_H_def) - apply (subst conj_commute, simp) - apply (rule conjI) - apply (frule init_refinement[simplified subset_eq, THEN bspec]) - apply (clarsimp simp: ex_abs_def lift_state_relation_def) - apply (frule akernel_init_invs[THEN bspec]) - apply (rule_tac x = s in exI) - apply (clarsimp simp: Init_A_def) - apply (insert ckernel_init_invs)[1] - apply clarsimp - apply (frule ckernel_init_sch_norm) - apply (frule ckernel_init_ctr) - apply (frule ckernel_init_domain_time) - apply (frule ckernel_init_domain_list) - apply (fastforce simp: Init_H_def) - apply (clarsimp simp: ADT_A_def ADT_H_def global_automaton_def) - - apply (erule_tac P="a \ (\x. b x)" for a b in disjE) - - apply (clarsimp simp: kernel_call_H_def) - - apply (drule use_valid[OF _ valid_corres_combined - [OF kernel_entry_invs entry_corres], - OF _ kernelEntry_invs'[THEN hoare_weaken_pre]]) - apply fastforce - - apply (clarsimp simp: ex_abs_def sch_act_simple_def ct_running_related ct_idle_related - sched_act_rct_related) - apply (rule exI, rule conjI, assumption) - apply simp - apply (fastforce simp: ex_abs_def sch_act_simple_def ct_running_related ct_idle_related - sched_act_rct_related valid_domain_list_from_invs') - apply (clarsimp simp: kernel_call_H_def) - apply (fastforce simp: ex_abs_def sch_act_simple_def ct_running_related ct_idle_related - sched_act_rct_related) - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp add: do_user_op_H_def monad_to_transition_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule doUserOp_valid_objs') - apply (rule valid_corres_combined[OF do_user_op_invs2 corres_guard_imp2[OF do_user_op_corres]]) - apply clarsimp - apply (rule doUserOp_invs'[THEN hoare_weaken_pre]) - apply (fastforce simp: ex_abs_def) - apply (clarsimp simp: invs_valid_objs' ex_abs_def, rule_tac x=s in exI, - clarsimp simp: ct_running_related sched_act_rct_related valid_domain_list_from_invs') - apply (clarsimp simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related) - - apply (erule_tac P="a \ b \ c \ (\x. d x)" for a b c d in disjE) - apply (clarsimp simp add: do_user_op_H_def monad_to_transition_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule doUserOp_valid_objs') - apply (rule valid_corres_combined[OF do_user_op_invs2 corres_guard_imp2[OF do_user_op_corres]]) - apply clarsimp - apply (rule doUserOp_invs'[THEN hoare_weaken_pre]) - apply (fastforce simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related - valid_domain_list_from_invs') - apply (fastforce simp: ex_abs_def) - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: check_active_irq_H_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule checkActiveIRQ_valid_objs') - apply (rule valid_corres_combined[OF check_active_irq_invs_just_running checkActiveIRQ_just_running_corres]) - apply (rule checkActiveIRQ_invs'_just_running[THEN hoare_weaken_pre]) - apply (fastforce simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related - valid_domain_list_from_invs') - apply (fastforce simp: ex_abs_def) - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: check_active_irq_H_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule checkActiveIRQ_valid_objs') - apply (rule valid_corres_combined[OF check_active_irq_invs_just_idle checkActiveIRQ_just_idle_corres]) - apply (rule checkActiveIRQ_invs'_just_idle[THEN hoare_weaken_pre]) - apply clarsimp - apply (fastforce simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_idle_related sched_act_rct_related - valid_domain_list_from_invs') - apply (fastforce simp: ex_abs_def) - - apply (clarsimp simp: check_active_irq_H_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule checkActiveIRQ_valid_objs') - apply (rule valid_corres_combined[OF check_active_irq_invs check_active_irq_corres]) - apply (rule checkActiveIRQ_invs'[THEN hoare_weaken_pre]) - apply clarsimp - apply (fastforce simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_running_related ct_idle_related sched_act_rct_related - valid_domain_list_from_invs') - apply (fastforce simp: ex_abs_def) - done +lemma arch_tcb_relation_arch_context_set[Refine_assms]: + "arch_tcb_relation atcb atcb' + \ arch_tcb_relation (arch_tcb_context_set tc atcb) (atcbContextSet tc atcb')" + by (simp add: arch_tcb_relation_def arch_tcb_context_set_def atcbContextSet_def) -text \The top-level theorem\ - -lemma fw_sim_A_H: - "LI (ADT_A uop) - (ADT_H uop) - (lift_state_relation state_relation) - (full_invs \ full_invs')" - apply (unfold LI_def full_invs_def full_invs'_def) - apply (simp add: ADT_H_def ADT_A_def) - apply (intro conjI) - apply (rule init_refinement) - apply (clarsimp simp: rel_semi_def relcomp_unfold in_lift_state_relation_eq) - apply (rename_tac tc ak m ev tc' ck' m' ev' ck) - apply (simp add: global_automaton_def) - - apply (erule_tac P="a \ (\x. b x)" for a b in disjE) - apply (clarsimp simp add: kernel_call_H_def kernel_call_A_def) - apply (rule rev_mp, rule_tac tc=tc and event=x in entry_corres) - apply (clarsimp simp: corres_underlying_def) - apply (drule (1) bspec) - apply (clarsimp simp: sch_act_simple_def) - apply (drule (1) bspec) - apply clarsimp - apply (rule conjI) - apply clarsimp - apply (rule_tac x=b in exI) - apply (rule conjI) - apply (rule impI, simp) - apply (frule (2) ct_running_related) - apply clarsimp - apply (rule_tac x=b in exI) - apply (drule use_valid, rule kernelEntry_invs') - apply (simp add: sch_act_simple_def) - apply clarsimp - apply (frule (1) ct_idle_related) - apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: do_user_op_H_def do_user_op_A_def monad_to_transition_def) - apply (rule rev_mp, rule_tac tc1=tc and f1=uop and P="ct_running and einvs" in corres_guard_imp2[OF do_user_op_corres]) - apply simp - apply (clarsimp simp add: corres_underlying_def) - apply (drule (1) bspec, clarsimp) - apply (drule (1) bspec, clarsimp) - apply fastforce - - apply (erule_tac P="a \ b \ c \ (\x. d x)" for a b c d in disjE) - apply (clarsimp simp: do_user_op_H_def do_user_op_A_def monad_to_transition_def) - apply (rule rev_mp, rule_tac tc1=tc and f1=uop and P="ct_running and einvs" in corres_guard_imp2[OF do_user_op_corres]) - apply simp - apply (clarsimp simp add: corres_underlying_def) - apply (drule (1) bspec, clarsimp) - apply (drule (1) bspec, clarsimp) - apply fastforce - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def) - apply (rule rev_mp, rule check_active_irq_corres) - apply (clarsimp simp: corres_underlying_def) - apply fastforce - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def) - apply (rule rev_mp, rule check_active_irq_corres) - apply (clarsimp simp: corres_underlying_def) - apply fastforce - - apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def) - apply (rule rev_mp, rule check_active_irq_corres) - apply (clarsimp simp: corres_underlying_def) - apply fastforce - - apply (clarsimp simp: absKState_correct dest!: lift_state_relationD) - done +lemma arch_tcb_relation_arch_context_get[Refine_assms]: + "arch_tcb_relation atcb atcb' \ arch_tcb_context_get atcb = atcbContextGet atcb'" + by (simp add: arch_tcb_relation_def arch_tcb_context_get_def atcbContextGet_def) -theorem refinement: - "ADT_H uop \ ADT_A uop" - apply (rule sim_imp_refines) - apply (rule L_invariantI) - apply (rule akernel_invariant) - apply (rule ckernel_invariant) - apply (rule fw_sim_A_H) - done +end (* Arch *) -end +interpretation Refine?: Refine +proof goal_cases + interpret Arch . + case 1 show ?case by (intro_locales; (unfold_locales; (fact Refine_assms)?)?) +qed end diff --git a/proof/refine/ARM/ArchRefine.thy b/proof/refine/ARM/ArchRefine.thy index 5a9360142a..04b2727d51 100644 --- a/proof/refine/ARM/ArchRefine.thy +++ b/proof/refine/ARM/ArchRefine.thy @@ -12,26 +12,27 @@ imports PageTableDuplicates begin -context begin interpretation Arch . (*FIXME: arch-split*) +context Arch begin arch_global_naming + +named_theorems Refine_assms text \User memory content is the same on both levels\ lemma typ_at_AUserDataI: "\ typ_at (AArch (AUserData sz)) p s; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned' s'; pspace_distinct' s'; n < 2 ^ (pageBitsForSize sz - pageBits) \ - \ typ_at' UserDataT (p + n * 2 ^ pageBits) s'" - apply (clarsimp simp add: obj_at_def a_type_def ) + \ typ_at' UserDataT (p + n * 2 ^ pageBits) s'" + apply (clarsimp simp add: obj_at_def a_type_def) apply (simp split: Structures_A.kernel_object.split_asm arch_kernel_obj.split_asm split: if_split_asm) apply (drule(1) pspace_relation_absD) apply (clarsimp) apply (drule_tac x = "p + n * 2 ^ pageBits" in spec) apply (drule_tac x = "\_ obj. obj = KOUserData" in spec) - apply (clarsimp simp: obj_at'_def typ_at'_def ko_wp_at'_def - projectKOs) + apply (clarsimp simp: obj_at'_def typ_at'_def ko_wp_at'_def) apply (rule exI [where x = KOUserData]) apply (drule mp) apply (rule exI [where x = n]) - apply simp + apply (simp add: shiftl_t2n) apply (clarsimp simp: pspace_aligned'_def) apply (drule (1) bspec [OF _ domI]) apply (clarsimp simp: objBits_simps) @@ -41,7 +42,7 @@ lemma typ_at_AUserDataI: lemma typ_at_ADeviceDataI: "\ typ_at (AArch (ADeviceData sz)) p s; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned' s'; pspace_distinct' s'; n < 2 ^ (pageBitsForSize sz - pageBits) \ - \ typ_at' UserDataDeviceT (p + n * 2 ^ pageBits) s'" + \ typ_at' UserDataDeviceT (p + n * 2 ^ pageBits) s'" apply (clarsimp simp add: obj_at_def a_type_def ) apply (simp split: Structures_A.kernel_object.split_asm arch_kernel_obj.split_asm split: if_split_asm) @@ -49,12 +50,11 @@ lemma typ_at_ADeviceDataI: apply (clarsimp) apply (drule_tac x = "p + n * 2 ^ pageBits" in spec) apply (drule_tac x = "\_ obj. obj = KOUserDataDevice" in spec) - apply (clarsimp simp: obj_at'_def typ_at'_def ko_wp_at'_def - projectKOs) + apply (clarsimp simp: obj_at'_def typ_at'_def ko_wp_at'_def) apply (rule exI [where x = KOUserDataDevice]) apply (drule mp) apply (rule exI [where x = n]) - apply simp + apply (simp add: shiftl_t2n) apply (clarsimp simp: pspace_aligned'_def) apply (drule (1) bspec [OF _ domI]) apply (clarsimp simp: objBits_simps) @@ -64,10 +64,8 @@ lemma typ_at_ADeviceDataI: lemma typ_at_UserDataI: "\ typ_at' UserDataT (p && ~~ mask pageBits) s'; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned s \ - \ \sz. typ_at (AArch (AUserData sz)) (p && ~~ mask (pageBitsForSize sz)) s" - apply (clarsimp simp: exists_disj obj_at'_def typ_at'_def ko_wp_at'_def - projectKOs) - + \ \sz. typ_at (AArch (AUserData sz)) (p && ~~ mask (pageBitsForSize sz)) s" + apply (clarsimp simp: exists_disj obj_at'_def typ_at'_def ko_wp_at'_def) apply (frule (1) in_related_pspace_dom) apply (clarsimp simp: pspace_dom_def) apply (clarsimp simp: pspace_relation_def dom_def) @@ -77,8 +75,8 @@ lemma typ_at_UserDataI: apply clarsimp apply (subst mask_lower_twice [where n = pageBits, OF pbfs_atleast_pageBits, symmetric]) apply (clarsimp simp: obj_relation_cuts_def2 pte_relation_def - cte_relation_def other_obj_relation_def tcb_relation_cut_def - pde_relation_def other_aobj_relation_def + cte_relation_def other_obj_relation_def other_aobj_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) @@ -95,10 +93,8 @@ lemma typ_at_UserDataI: lemma typ_at_DeviceDataI: "\ typ_at' UserDataDeviceT (p && ~~ mask pageBits) s'; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned s \ - \ \sz. typ_at (AArch (ADeviceData sz)) (p && ~~ mask (pageBitsForSize sz)) s" - apply (clarsimp simp: exists_disj obj_at'_def typ_at'_def ko_wp_at'_def - projectKOs) - + \ \sz. typ_at (AArch (ADeviceData sz)) (p && ~~ mask (pageBitsForSize sz)) s" + apply (clarsimp simp: exists_disj obj_at'_def typ_at'_def ko_wp_at'_def) apply (frule (1) in_related_pspace_dom) apply (clarsimp simp: pspace_dom_def) apply (clarsimp simp: pspace_relation_def dom_def) @@ -108,8 +104,8 @@ lemma typ_at_DeviceDataI: apply clarsimp apply (subst mask_lower_twice [where n = pageBits, OF pbfs_atleast_pageBits, symmetric]) apply (clarsimp simp: obj_relation_cuts_def2 pte_relation_def - cte_relation_def other_obj_relation_def tcb_relation_cut_def - pde_relation_def other_aobj_relation_def + cte_relation_def other_obj_relation_def other_aobj_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) @@ -123,860 +119,141 @@ lemma typ_at_DeviceDataI: apply (simp add: obj_at_def a_type_def) done -lemma pointerInUserData_relation: +lemma and_mask_pbfs_shiftr_pageBits_limit: + "p && mask (pageBitsForSize sz) >> pageBits < 2 ^ (pageBitsForSize sz - pageBits)" for p :: obj_ref + apply (rule shiftr_less_t2n') + apply (simp add: pbfs_atleast_pageBits mask_twice) + apply (case_tac sz; simp add: pageBits_def) + done + +lemma p_and_not_mask_pbfs_add_mask_pbfs_eq: + "(p && ~~ mask (pageBitsForSize sz)) + (p && mask (pageBitsForSize sz) >> pageBits) * 2 ^ pageBits + = p && ~~ mask pageBits" + for p :: obj_ref + by (simp flip: shiftl_t2n' + add: shiftr_shiftl1 mask_out_add_aligned is_aligned_neg_mask pbfs_atleast_pageBits + word_plus_and_or_coroll2 add.commute) + +lemma pointerInUserData_relation[Refine_assms]: "\ (s,s') \ state_relation; valid_state' s'; valid_state s\ \ pointerInUserData p s' = in_user_frame p s" apply (simp add: pointerInUserData_def in_user_frame_def) apply (rule iffI) - apply (erule typ_at_UserDataI, (clarsimp simp: valid_state_def)+)[1] + apply (erule typ_at_UserDataI; clarsimp simp: valid_state_def) apply clarsimp - apply (drule_tac sz = sz and - n = "(p && mask (pageBitsForSize sz)) >> pageBits" - in typ_at_AUserDataI [where s = s and s' = s']) - apply (fastforce simp: valid_state'_def)+ - apply (rule shiftr_less_t2n') - apply (simp add: pbfs_atleast_pageBits mask_twice) - apply (case_tac sz, simp_all)[1] - apply (subgoal_tac "(p && ~~ mask (pageBitsForSize sz)) + (p && mask (pageBitsForSize sz) >> pageBits) * 2 ^ pageBits = (p && ~~ mask pageBits)") - apply simp - apply (subst mult.commute) - apply (subst shiftl_t2n [symmetric]) - apply (simp add: shiftr_shiftl1) - apply (subst mask_out_add_aligned) - apply (rule is_aligned_neg_mask) - apply (simp add: pbfs_atleast_pageBits) - apply (subst add.commute) - apply (simp add: word_plus_and_or_coroll2) + apply (drule_tac sz=sz and n="(p && mask (pageBitsForSize sz)) >> pageBits" + in typ_at_AUserDataI [where s = s and s' = s']) + apply (fastforce simp: valid_state'_def and_mask_pbfs_shiftr_pageBits_limit)+ + apply (erule arg_cong[where f="\p. typ_at' _ p s'", THEN iffD1, rotated]) + apply (simp add: p_and_not_mask_pbfs_add_mask_pbfs_eq) done -lemma pointerInDeviceData_relation: +lemma pointerInDeviceData_relation[Refine_assms]: "\ (s,s') \ state_relation; valid_state' s'; valid_state s\ \ pointerInDeviceData p s' = in_device_frame p s" apply (simp add: pointerInDeviceData_def in_device_frame_def) apply (rule iffI) - apply (erule typ_at_DeviceDataI, (clarsimp simp: valid_state_def)+)[1] + apply (erule typ_at_DeviceDataI; clarsimp simp: valid_state_def) apply clarsimp - apply (drule_tac sz = sz and - n = "(p && mask (pageBitsForSize sz)) >> pageBits" - in typ_at_ADeviceDataI [where s = s and s' = s']) - apply (fastforce simp: valid_state'_def)+ - apply (rule shiftr_less_t2n') - apply (simp add: pbfs_atleast_pageBits mask_twice) - apply (case_tac sz, simp_all)[1] - apply (subgoal_tac "(p && ~~ mask (pageBitsForSize sz)) + (p && mask (pageBitsForSize sz) >> pageBits) * 2 ^ pageBits = (p && ~~ mask pageBits)") - apply simp - apply (subst mult.commute) - apply (subst shiftl_t2n [symmetric]) - apply (simp add: shiftr_shiftl1) - apply (subst mask_out_add_aligned) - apply (rule is_aligned_neg_mask) - apply (simp add: pbfs_atleast_pageBits) - apply (subst add.commute) - apply (simp add: word_plus_and_or_coroll2) + apply (drule_tac sz=sz and n="(p && mask (pageBitsForSize sz)) >> pageBits" + in typ_at_ADeviceDataI[where s=s and s'=s']) + apply (fastforce simp: valid_state'_def and_mask_pbfs_shiftr_pageBits_limit)+ + apply (erule arg_cong[where f="\p. typ_at' _ p s'", THEN iffD1, rotated]) + apply (simp add: p_and_not_mask_pbfs_add_mask_pbfs_eq) done -lemma user_mem_relation: +lemma user_mem_relation[Refine_assms]: "\(s,s') \ state_relation; valid_state' s'; valid_state s\ \ user_mem' s' = user_mem s" - apply (rule ext) - apply (clarsimp simp: user_mem_def user_mem'_def pointerInUserData_relation pointerInDeviceData_relation) - apply (simp add: state_relation_def) - done + by (rule ext) + (clarsimp simp: user_mem_def user_mem'_def pointerInUserData_relation pointerInDeviceData_relation + state_relation_def) -lemma device_mem_relation: +lemma device_mem_relation[Refine_assms]: "\(s,s') \ state_relation; valid_state' s'; valid_state s\ \ device_mem' s' = device_mem s" - apply (rule ext) - apply (clarsimp simp: device_mem_def device_mem'_def pointerInUserData_relation - pointerInDeviceData_relation) - done + by (rule ext) + (clarsimp simp: device_mem_def device_mem'_def pointerInUserData_relation + pointerInDeviceData_relation) -lemma absKState_correct: -assumes invs: "einvs (s :: det_ext state)" and invs': "invs' s'" -assumes rel: "(s,s') \ state_relation" -shows "absKState s' = abs_state s" - using assms - apply (intro state.equality, simp_all add: absKState_def abs_state_def) - apply (rule absHeap_correct; clarsimp elim!: state_relationE) - apply (rule absCDT_correct; clarsimp) - apply (rule absIsOriginalCap_correct; clarsimp) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (clarsimp simp: state_relation_def) - apply (rule absSchedulerAction_correct, simp add: state_relation_def) - apply (simp add: domSchedule_map_relation) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def ready_queues_relation_def ready_queue_relation_def Let_def - list_queue_relation_def) - apply (fastforce dest: heap_ls_is_walk) - apply (clarsimp simp: user_mem_relation invs_def invs'_def) - apply (simp add: state_relation_def) - apply (rule absInterruptIRQNode_correct, simp add: state_relation_def) - apply (rule absInterruptStates_correct, simp add: state_relation_def) - apply (rule absArchState_correct, simp) - apply (rule absExst_correct; simp) - done - -text \The top-level invariance\ - -lemma set_thread_state_sched_act: - "\(\s. runnable state) and (\s. P (scheduler_action s))\ - set_thread_state thread state - \\rs s. P (scheduler_action (s::det_state))\" - apply (simp add: set_thread_state_def) - apply wp - apply (simp add: set_thread_state_act_def) - apply wp - apply (rule hoare_pre_cont) - apply (rule_tac Q'="\rv. (\s. runnable ts) and (\s. P (scheduler_action s))" - in hoare_strengthen_post) - apply wp - apply force - apply (wp gts_st_tcb_at)+ - apply (rule_tac Q'="\rv. st_tcb_at ((=) state) thread and (\s. runnable state) and (\s. P (scheduler_action s))" in hoare_strengthen_post) - apply (simp add: st_tcb_at_def) - apply (wp obj_set_prop_at)+ - apply (force simp: st_tcb_at_def obj_at_def) - apply wp - apply clarsimp - done - -lemma activate_thread_sched_act: +lemma arch_activate_thread_sched_act[Refine_assms]: "\ct_in_state activatable and (\s. P (scheduler_action s))\ - activate_thread - \\rs s. P (scheduler_action (s::det_state))\" - by (simp add: activate_thread_def set_thread_state_def arch_activate_idle_thread_def - | (wp set_thread_state_sched_act gts_wp)+ | wpc)+ - -lemma schedule_sched_act_rct[wp]: - "\\\ Schedule_A.schedule - \\rs (s::det_state). scheduler_action s = resume_cur_thread\" - unfolding Schedule_A.schedule_def - by (wpsimp) - -lemma call_kernel_sched_act_rct[wp]: - "\einvs and (\s. e \ Interrupt \ ct_running s) - and (\s. scheduler_action s = resume_cur_thread)\ - call_kernel e - \\rs (s::det_state). scheduler_action s = resume_cur_thread\" - apply (simp add: call_kernel_def) - apply (wpsimp wp: activate_thread_sched_act handle_spurious_irq_invs) - apply (clarsimp simp: active_from_running) - done - -lemma kernel_entry_invs: - "\einvs and (\s. e \ Interrupt \ ct_running s) - and (\s. 0 < domain_time s) and valid_domain_list and (ct_running or ct_idle) - and (\s. scheduler_action s = resume_cur_thread)\ - kernel_entry e us - \\rv. einvs and (\s. ct_running s \ ct_idle s) - and (\s. 0 < domain_time s) and valid_domain_list - and (\s. scheduler_action s = resume_cur_thread)\" - apply (rule_tac Q'="\rv. invs and (\s. ct_running s \ ct_idle s) and valid_sched and - (\s. 0 < domain_time s) and valid_domain_list and - valid_list and (\s. scheduler_action s = resume_cur_thread)" - in hoare_post_imp) - apply clarsimp - apply (simp add: kernel_entry_def) - apply (wp akernel_invs_det_ext call_kernel_valid_sched thread_set_invs_trivial - thread_set_not_state_valid_sched - hoare_vcg_disj_lift ct_in_state_thread_state_lift thread_set_no_change_tcb_state - call_kernel_domain_time_inv_det_ext call_kernel_domain_list_inv_det_ext - hoare_weak_lift_imp valid_domain_list_lift - | clarsimp simp add: tcb_cap_cases_def active_from_running)+ - done + arch_activate_idle_thread t + \\rs s. P (scheduler_action (s::det_state))\" + by (wpsimp simp: arch_activate_idle_thread_def) -definition - "full_invs \ {((tc, s :: det_ext state), m, e). einvs s \ - (ct_running s \ ct_idle s) \ - (m = KernelMode \ e \ None) \ - (m = UserMode \ ct_running s) \ - (m = IdleMode \ ct_idle s) \ - (e \ None \ e \ Some Interrupt \ ct_running s) \ - 0 < domain_time s \ valid_domain_list s \ - (scheduler_action s = resume_cur_thread)}" - -crunch do_user_op - for valid_list: valid_list - and valid_sched: valid_sched - and sched_act: "\s. P (scheduler_action s)" - and domain_fields_inv[wp]: "domain_fields P" - -lemma do_user_op_invs2: - "\einvs and ct_running and (\s. scheduler_action s = resume_cur_thread) - and (\s. 0 < domain_time s) and valid_domain_list \ - do_user_op f tc - \\_. (einvs and ct_running and (\s. scheduler_action s = resume_cur_thread)) - and (\s. 0 < domain_time s) and valid_domain_list \" - apply (rule_tac Q'="\_. valid_list and valid_sched and - (\s. scheduler_action s = resume_cur_thread) and (invs and ct_running) and - (\s. 0 < domain_time s) and valid_domain_list" - in hoare_strengthen_post) - apply (wpsimp wp: do_user_op_valid_list do_user_op_valid_sched do_user_op_sched_act - valid_domain_list_lift do_user_op_invs) - apply force - done - -lemmas ext_init_def = ext_init_det_ext_ext_def ext_init_unit_def - -lemma valid_list_init[simp]: +lemma valid_list_init[Refine_assms, simp]: "valid_list init_A_st" by (simp add: valid_list_2_def init_A_st_def ext_init_def init_cdt_def) -lemmas valid_list_inits[simp] = valid_list_init[simplified] - -lemma valid_sched_init[simp]: +lemma valid_sched_init[Refine_assms, simp]: "valid_sched init_A_st" apply (simp add: valid_sched_def init_A_st_def ext_init_def) apply (clarsimp simp: init_kheap_def st_tcb_at_kh_def obj_at_kh_def - obj_at_def idle_thread_ptr_def init_globals_frame_def - init_global_pd_def valid_queues_2_def ct_not_in_q_def not_queued_def - valid_sched_action_def is_activatable_def + obj_at_def idle_thread_ptr_def + valid_queues_2_def ct_not_in_q_def not_queued_def + valid_sched_action_def is_activatable_def init_irq_node_ptr_def + init_global_pd_def init_globals_frame_def ct_in_cur_domain_2_def valid_blocked_2_def valid_idle_etcb_def etcb_at'_def etcbs_of'_def) done -lemma valid_domain_list_init[simp]: +lemma valid_domain_list_init[Refine_assms, simp]: "valid_domain_list init_A_st" by (simp add: init_A_st_def ext_init_def valid_domain_list_def) -lemma akernel_invariant: - "ADT_A uop \ full_invs" - unfolding full_invs_def - apply (rule invariantI) - apply (clarsimp simp: ADT_A_def subset_iff) - apply (frule bspec[OF akernel_init_invs]) - apply (simp add: Let_def Init_A_def) - apply (simp add: init_A_st_def ext_init_def) - apply (clarsimp simp: ADT_A_def global_automaton_def) - - apply (rename_tac tc' s' mode' e' tc s mode e) - apply (elim disjE) - apply ((clarsimp simp: kernel_call_A_def - | drule use_valid[OF _ kernel_entry_invs])+)[2] - apply ((clarsimp simp: do_user_op_A_def monad_to_transition_def - check_active_irq_A_def - | drule use_valid[OF _ do_user_op_invs2] - | drule use_valid[OF _ check_active_irq_invs_just_running])+)[2] - apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs])+)[1] - apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) - apply ((clarsimp simp add: do_user_op_A_def check_active_irq_A_def - | drule use_valid[OF _ do_user_op_invs2] - | drule use_valid[OF _ check_active_irq_invs_just_running])+)[1] - apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) - apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) - apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs])+)[1] - apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs_just_idle])+)[1] - apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs])+)[1] - done +lemma valid_domain_time_init[Refine_assms, simp]: + "0 < domain_time init_A_st" + by (simp add: init_A_st_def) + +lemma sched_act_init[Refine_assms, simp]: + "scheduler_action init_A_st = resume_cur_thread" + by (simp add: init_A_st_def) -lemma ckernel_invs: - "\invs' and (\s. vs_valid_duplicates' (ksPSpace s)) and - (\s. e \ Interrupt \ ct_running' s) and - (\s. ksSchedulerAction s = ResumeCurrentThread)\ - callKernel e - \\rs. (\s. ksSchedulerAction s = ResumeCurrentThread) - and (invs' and (ct_running' or ct_idle'))\" - unfolding callKernel_def - by (wpsimp wp: activate_invs' activate_sch_act schedule_sch schedule_sch_act_simple he_invs' - schedule_invs' hoare_drop_imp[where Q'="\_. kernelExitAssertions"] - simp: no_irq_getActiveIRQ)+ - -lemma fastpathKernelAssertions_cross: +lemma fastpathKernelAssertions_cross[Refine_assms]: "\ (s,s') \ state_relation; invs s; valid_arch_state' s'\ \ fastpathKernelAssertions s'" unfolding fastpathKernelAssertions_def by simp -(* this is only needed for callKernel, where we have invs' on concrete side *) -lemma corres_cross_over_fastpathKernelAssertions: - "\ \s. P s \ invs s; \s'. Q s' \ invs' s'; - corres r P (Q and fastpathKernelAssertions) f g \ \ - corres r P Q f g" - by (rule corres_cross_over_guard[where Q="Q and fastpathKernelAssertions"]) - (fastforce elim: fastpathKernelAssertions_cross)+ - -defs kernelExitAssertions_def: - "kernelExitAssertions s \ 0 < ksDomainTime s" - -lemma callKernel_domain_time_left: - "\\\ callKernel e \\_ s. 0 < ksDomainTime s\" - unfolding callKernel_def kernelExitAssertions_def by wpsimp - -lemma kernelEntry_invs': - "\ invs' and (\s. e \ Interrupt \ ct_running' s) and - (ct_running' or ct_idle') and - (\s. vs_valid_duplicates' (ksPSpace s)) and - (\s. ksSchedulerAction s = ResumeCurrentThread) and - (\s. 0 < ksDomainTime s) \ - kernelEntry e tc - \\rs. (\s. ksSchedulerAction s = ResumeCurrentThread) and - (invs' and (ct_running' or ct_idle')) and - (\s. vs_valid_duplicates' (ksPSpace s)) and - (\s. 0 < ksDomainTime s) \" - apply (simp add: kernelEntry_def) - apply (wp ckernel_invs callKernel_valid_duplicates' callKernel_domain_time_left - threadSet_invs_trivial threadSet_ct_running' - TcbAcc_R.dmo_invs' hoare_weak_lift_imp - callKernel_domain_time_left - | clarsimp simp: user_memory_update_def no_irq_def tcb_at_invs')+ - done +(* vs duplicate interface lemma *) +lemmas [Refine_assms] = callKernel_valid_duplicates' + +lemma doUserOp_valid_duplicates'[Refine_assms]: + "doUserOp f tc \\s. vs_valid_duplicates' (ksPSpace s)\" + by (simp add: doUserOp_def split_def) + (wpsimp wp: dmo_invs') + +lemma checkActiveIRQ_valid_duplicates'[Refine_assms]: + "checkActiveIRQ \\s. vs_valid_duplicates' (ksPSpace s)\" + by (wpsimp simp: checkActiveIRQ_def) + +lemma tcb_hyp_refs'_atcbContextSet[Refine_assms, simp]: + "tcb_hyp_refs' (atcbContextSet tc atcb) = tcb_hyp_refs' atcb" + by (simp add: atcbContextSet_def) -lemma ptable_lift_abs_state[simp]: +lemma ptable_lift_abs_state[Refine_assms, simp]: "ptable_lift t (abs_state s) = ptable_lift t s" by (simp add: ptable_lift_def abs_state_def) -lemma ptable_rights_abs_state[simp]: +lemma ptable_rights_abs_state[Refine_assms, simp]: "ptable_rights t (abs_state s) = ptable_rights t s" by (simp add: ptable_rights_def abs_state_def) -lemma ptable_rights_imp_UserData: - assumes invs: "einvs s" and invs': "invs' s'" - assumes rel: "(s,s') : state_relation" - assumes rights: "ptable_rights t (absKState s') x \ {}" - assumes trans: - "ptable_lift t (absKState s') x = Some (ARM.addrFromPPtr y)" - shows "pointerInUserData y s' \ pointerInDeviceData y s'" -proof - - from invs invs' rel have [simp]: "absKState s' = abs_state s" - by - (rule absKState_correct, simp_all) - from invs have valid: "valid_state s" by auto - from invs' have valid': "valid_state' s'" by auto - have "in_user_frame y s \ in_device_frame y s " - by (rule ptable_rights_imp_frame[OF valid rights[simplified] - trans[simplified]]) - thus ?thesis - by (auto simp add: pointerInUserData_relation[OF rel valid' valid] - pointerInDeviceData_relation[OF rel valid' valid]) -qed - - -lemma device_update_invs': - "\invs'\doMachineOp (device_memory_update ds) - \\_. invs'\" - apply (simp add: doMachineOp_def device_memory_update_def simpler_modify_def select_f_def - gets_def get_def bind_def valid_def return_def) - by (clarsimp simp: invs'_def valid_state'_def valid_irq_states'_def valid_machine_state'_def) - -lemmas ex_abs_def = ex_abs_underlying_def[where sr=state_relation and P=G,abs_def] for G - -crunch doMachineOp - for ksDomainTime[wp]: "\s. P (ksDomainTime s)" - -lemma doUserOp_invs': - "\invs' and ex_abs einvs and - (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_running' and - (\s. 0 < ksDomainTime s)\ - doUserOp f tc - \\_. invs' and - (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_running' and - (\s. 0 < ksDomainTime s)\" - apply (simp add: doUserOp_def split_def ex_abs_def) - apply (wp device_update_invs' - | (wp (once) dmo_invs', wpsimp simp: no_irq_modify device_memory_update_def - user_memory_update_def))+ - apply (clarsimp simp: user_memory_update_def simpler_modify_def - restrict_map_def - split: option.splits) - apply (frule ptable_rights_imp_UserData[rotated 2], auto) - done - -lemma doUserOp_valid_duplicates': - "\\s. vs_valid_duplicates' (ksPSpace s)\ - doUserOp f tc - \\_ s. vs_valid_duplicates' (ksPSpace s)\" - apply (simp add: doUserOp_def split_def) - apply (wp dmo_invs') - apply clarsimp - done - -text \The top-level correspondence\ - -lemma contract_all_imp_strg': - "P \ P' \ P'' \ (\x. R x \ Q x) \ \x. R x \ P \ Q x \ P' \ P''" - by blast - -lemma kernel_corres': - "corres dc (einvs and (\s. event \ Interrupt \ ct_running s) and (ct_running or ct_idle) - and (\s. scheduler_action s = resume_cur_thread) and valid_domain_list) - (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and - (\s. ksSchedulerAction s = ResumeCurrentThread) and - (\s. vs_valid_duplicates' (ksPSpace s))) - (call_kernel event) - (do _ \ runExceptT $ - handleEvent event `~catchError~` - (\_. withoutPreemption $ maybeHandleInterrupt True); - _ \ ThreadDecls_H.schedule; - activateThread - od)" - apply (simp add: call_kernel_def) - apply (corres corres: handleEvent_corres maybeHandleInterrupt_corres) - apply (wpsimp wp: handle_event_valid_sched)+ - apply (rule corres_split[OF schedule_corres]) - apply (rule activateThread_corres) - apply (wpsimp wp: handle_interrupt_valid_sched[unfolded non_kernel_IRQs_def, simplified] - handle_spurious_irq_invs schedule_invs' hoare_vcg_if_lift2 - hoare_drop_imps - valid_domain_list_lift[of handle_spurious_irq] - valid_domain_list_lift[of "handle_interrupt irq" for irq] - valid_domain_list_lift[of "do_machine_op mop" for mop] - simp: maybe_handle_interrupt_def)+ - apply (rule_tac Q'="\_. valid_domain_list and valid_sched and invs and valid_list" and - E'="\_. valid_domain_list and valid_sched and invs and valid_list" - in hoare_strengthen_postE) - apply (wpsimp wp: handle_event_valid_sched)+ - apply (clarsimp simp: active_from_running schact_is_rct_def) - apply (clarsimp simp: active_from_running') - done - -lemma kernel_corres: - "corres dc (einvs and (\s. event \ Interrupt \ ct_running s) and (ct_running or ct_idle) and - (\s. scheduler_action s = resume_cur_thread) and - (\s. 0 < domain_time s \ valid_domain_list s)) - (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and - (\s. ksSchedulerAction s = ResumeCurrentThread) and - (\s. vs_valid_duplicates' (ksPSpace s))) - (call_kernel event) (callKernel event)" - unfolding callKernel_def K_bind_def - apply (rule corres_cross_over_fastpathKernelAssertions, blast+) - apply (rule corres_stateAssert_r) - apply (rule corres_guard_imp) - apply (rule corres_add_noop_lhs2) - apply (simp only: bind_assoc[symmetric]) - apply (rule corres_split[where r'=dc and - R="\_ s. 0 < domain_time s \ valid_domain_list s" and - R'="\_. \"]) - apply (simp only: bind_assoc) - apply (rule kernel_corres') - apply (rule corres_bind_return2, rule corres_stateAssert_assume_stronger) - apply simp - apply (simp add: kernelExitAssertions_def state_relation_def) - apply (wp call_kernel_domain_time_inv_det_ext call_kernel_domain_list_inv_det_ext) - apply wp - apply clarsimp - apply clarsimp - done - -lemma user_mem_corres: - "corres (=) invs invs' (gets (\x. g (user_mem x))) (gets (\x. g (user_mem' x)))" - by (clarsimp simp add: gets_def get_def return_def bind_def - invs_def invs'_def - corres_underlying_def user_mem_relation) - -lemma device_mem_corres: - "corres (=) invs invs' (gets (\x. g (device_mem x))) (gets (\x. g (device_mem' x)))" - by (clarsimp simp add: gets_def get_def return_def bind_def - invs_def invs'_def - corres_underlying_def device_mem_relation) - -lemma entry_corres: - "corres (=) (einvs and (\s. event \ Interrupt \ ct_running s) and - (\s. 0 < domain_time s) and valid_domain_list and (ct_running or ct_idle) and - (\s. scheduler_action s = resume_cur_thread)) - (invs' and (\s. event \ Interrupt \ ct_running' s) and - (\s. 0 < ksDomainTime s) and (ct_running' or ct_idle') and - (\s. ksSchedulerAction s = ResumeCurrentThread) and - (\s. vs_valid_duplicates' (ksPSpace s))) - (kernel_entry event tc) (kernelEntry event tc)" - apply (simp add: kernel_entry_def kernelEntry_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getCurThread_corres]) - apply (rule corres_split) - apply simp - apply (rule threadset_corresT; simp?) - apply (simp add: tcb_relation_def arch_tcb_relation_def - arch_tcb_context_set_def atcbContextSet_def) - apply (clarsimp simp: tcb_cap_cases_def) - apply (clarsimp simp: tcb_cte_cases_def tcb_cte_cases_neqs) - apply (rule corres_split[OF kernel_corres]) - apply (rule corres_split_eqr[OF getCurThread_corres]) - apply (rule threadGet_corres) - apply (simp add: tcb_relation_def arch_tcb_relation_def - arch_tcb_context_get_def atcbContextGet_def) - apply wp+ - apply (rule hoare_strengthen_post, rule akernel_invs_det_ext, fastforce simp: invs_def cur_tcb_def) - apply (rule hoare_strengthen_post, rule ckernel_invs, simp add: invs'_def cur_tcb'_def) - apply (wp thread_set_invs_trivial - threadSet_invs_trivial threadSet_ct_running' - thread_set_not_state_valid_sched hoare_weak_lift_imp - hoare_vcg_disj_lift ct_in_state_thread_state_lift - thread_set_no_change_tcb_state - | simp add: tcb_cap_cases_def ct_in_state'_def schact_is_rct_def - | (wps, wp threadSet_st_tcb_at2) )+ - apply (fastforce simp: invs_def cur_tcb_def) - apply (clarsimp simp: ct_in_state'_def) - done - -lemma corres_gets_machine_state: - "corres (=) \ \ (gets (f \ machine_state)) (gets (f \ ksMachineState))" - by (clarsimp simp: gets_def corres_underlying_def - in_monad bind_def get_def return_def state_relation_def) - -lemma do_user_op_corres: - "corres (=) (einvs and ct_running) - (invs' and (%s. ksSchedulerAction s = ResumeCurrentThread) and - ct_running') - (do_user_op f tc) (doUserOp f tc)" - apply (simp add: do_user_op_def doUserOp_def split_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getCurThread_corres]) - apply (rule_tac r'="(=)" and P=einvs and P'=invs' in corres_split) - apply (fastforce dest: absKState_correct [rotated]) - apply (rule_tac r'="(=)" and P=einvs and P'=invs' in corres_split) - apply (fastforce dest: absKState_correct [rotated]) - apply (rule_tac r'="(=)" and P=invs and P'=invs' in corres_split) - apply (rule user_mem_corres) - apply (rule_tac r'="(=)" and P=invs and P'=invs' in corres_split) - apply (rule device_mem_corres) - apply (rule_tac r'="(=)" in corres_split) - apply (rule corres_gets_machine_state) - apply (rule_tac F = "dom (rvb \ addrFromPPtr) \ - dom rvd" in corres_gen_asm) - apply (rule_tac F = "dom (rvc \ addrFromPPtr) \ dom rvd" in corres_gen_asm) - apply simp - apply (rule_tac r'="(=)" in corres_split[OF corres_select]) - apply simp - apply (rule corres_underlying_split[OF corres_machine_op]) - apply simp - apply (rule corres_underlying_trivial) - apply (simp add: user_memory_update_def) - apply (wp | simp)+ - apply (rule corres_underlying_split[OF corres_machine_op,where Q = dc and Q'=dc]) - apply (rule corres_underlying_trivial) - apply (wp | simp add: dc_def device_memory_update_def)+ - apply (clarsimp simp: invs_def valid_state_def pspace_respects_device_region_def) - apply fastforce - done - -lemma ct_running_related: - "\ (a, c) \ state_relation; ct_running' c \ - \ ct_running a" - apply (clarsimp simp: ct_in_state_def ct_in_state'_def - curthread_relation) - apply (frule(1) st_tcb_at_coerce_abstract) - apply (erule st_tcb_weakenE) - apply (case_tac st, simp_all)[1] - done +lemma arch_tcb_relation_arch_context_set[Refine_assms]: + "arch_tcb_relation atcb atcb' + \ arch_tcb_relation (arch_tcb_context_set tc atcb) (atcbContextSet tc atcb')" + by (simp add: arch_tcb_relation_def arch_tcb_context_set_def atcbContextSet_def) -lemma ct_idle_related: - "\ (a, c) \ state_relation; ct_idle' c \ - \ ct_idle a" - apply (clarsimp simp: ct_in_state_def ct_in_state'_def - curthread_relation) - apply (frule(1) st_tcb_at_coerce_abstract) - apply (erule st_tcb_weakenE) - apply (case_tac st, simp_all)[1] - done +lemma arch_tcb_relation_arch_context_get[Refine_assms]: + "arch_tcb_relation atcb atcb' \ arch_tcb_context_get atcb = atcbContextGet atcb'" + by (simp add: arch_tcb_relation_def arch_tcb_context_get_def atcbContextGet_def) -definition - "full_invs' \ {((tc,s),m,e). invs' s \ vs_valid_duplicates' (ksPSpace s) \ - ex_abs (einvs::det_ext state \ bool) s \ - ksSchedulerAction s = ResumeCurrentThread \ - (ct_running' s \ ct_idle' s) \ - (m = KernelMode \ e \ None) \ - (m = UserMode \ ct_running' s) \ - (m = IdleMode \ ct_idle' s) \ - (e \ None \ e \ Some Interrupt \ ct_running' s) \ - 0 < ksDomainTime s}" - -lemma checkActiveIRQ_valid_duplicates': - "\\s. vs_valid_duplicates' (ksPSpace s)\ - checkActiveIRQ - \\_ s. vs_valid_duplicates' (ksPSpace s)\" - apply (simp add: checkActiveIRQ_def) - apply wpsimp - done - -lemma check_active_irq_corres': - "corres (=) \ \ (check_active_irq) (checkActiveIRQ)" - apply (simp add: check_active_irq_def checkActiveIRQ_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF corres_machine_op[OF corres_underlying_trivial], where R="\_. \" and R'="\_. \"]) - apply wpsimp+ - done - -lemma check_active_irq_corres: - "corres (=) - (invs and (ct_running or ct_idle) and einvs and (\s. scheduler_action s = resume_cur_thread) - and (\s. 0 < domain_time s) and valid_domain_list) - (invs' and (\s. ksSchedulerAction s = ResumeCurrentThread) - and (\s. 0 < ksDomainTime s) and (ct_running' or ct_idle') - and (\s. vs_valid_duplicates' (ksPSpace s))) - (check_active_irq) (checkActiveIRQ)" - apply (rule corres_guard_imp) - apply (rule check_active_irq_corres', auto) - done - -lemma checkActiveIRQ_just_running_corres: - "corres (=) - (invs and ct_running and einvs and (\s. scheduler_action s = resume_cur_thread) - and (\s. 0 < domain_time s) and valid_domain_list) - (invs' and ct_running' and (\s. vs_valid_duplicates' (ksPSpace s)) - and (\s. 0 < ksDomainTime s) - and (\s. ksSchedulerAction s = ResumeCurrentThread)) - (check_active_irq) (checkActiveIRQ)" - apply (rule corres_guard_imp) - apply (rule check_active_irq_corres', auto) - done +end (* Arch *) -lemma checkActiveIRQ_just_idle_corres: - "corres (=) - (invs and ct_idle and einvs and (\s. scheduler_action s = resume_cur_thread) - and (\s. 0 < domain_time s) and valid_domain_list) - (invs' and ct_idle' and (\s. vs_valid_duplicates' (ksPSpace s)) - and (\s. 0 < ksDomainTime s) - and (\s. ksSchedulerAction s = ResumeCurrentThread)) - (check_active_irq) (checkActiveIRQ)" - apply (rule corres_guard_imp) - apply (rule check_active_irq_corres', auto) - done - -lemma checkActiveIRQ_invs': - "\invs' and ex_abs invs and (ct_running' or ct_idle') - and (\s. ksSchedulerAction s = ResumeCurrentThread)\ - checkActiveIRQ - \\_. invs' and (ct_running' or ct_idle') - and (\s. ksSchedulerAction s = ResumeCurrentThread)\" - apply (simp add: checkActiveIRQ_def ex_abs_def) - apply (wp dmo_invs' | simp)+ - done - -lemma checkActiveIRQ_invs'_just_running: - "\invs' and ex_abs invs and ct_running' - and (\s. ksSchedulerAction s = ResumeCurrentThread)\ - checkActiveIRQ - \\_. invs' and ct_running' - and (\s. ksSchedulerAction s = ResumeCurrentThread)\" - apply (simp add: checkActiveIRQ_def) - apply (wp | simp)+ - done - -lemma checkActiveIRQ_invs'_just_idle: - "\invs' and ex_abs invs and ct_idle' - and (\s. ksSchedulerAction s = ResumeCurrentThread)\ - checkActiveIRQ - \\_. invs' and ct_idle' - and (\s. ksSchedulerAction s = ResumeCurrentThread)\" - apply (simp add: checkActiveIRQ_def) - apply (wp | simp)+ - done - -lemma sched_act_rct_related: - "\ (a, c) \ state_relation; ksSchedulerAction c = ResumeCurrentThread\ - \ scheduler_action a = resume_cur_thread" - by (case_tac "scheduler_action a", simp_all add: state_relation_def) - -lemma domain_time_rel_eq: - "(a, c) \ state_relation \ P (ksDomainTime c) = P (domain_time a)" - by (clarsimp simp: state_relation_def) - -lemma valid_domain_list_2_cross: - "\valid_dom_schedule'_2 sched idx start; domain_list_map dom_list = sched \ - \ valid_domain_list_2 start idx dom_list" - by (fastforce simp: valid_domain_list_2_def valid_dom_schedule'_2_def ucast_eq_0 is_up - split: prod.splits) - -lemma valid_domain_list_from_invs': - "\ (s, s') \ state_relation; invs' s' \ \ valid_domain_list s" - by (clarsimp simp: valid_domain_list_2_cross invs'_def valid_state'_def elim!: state_relationE) - -lemma ckernel_invariant: - "ADT_H uop \ full_invs'" - unfolding full_invs'_def - supply word_neq_0_conv[simp] - supply domain_time_rel_eq[simp] - apply (rule invariantI) - apply (clarsimp simp add: ADT_H_def) - apply (subst conj_commute, simp) - apply (rule conjI) - apply (drule ckernel_init_valid_duplicates'[rule_format], simp) - apply (rule conjI) - apply (frule init_refinement[simplified subset_eq, THEN bspec]) - apply (clarsimp simp: ex_abs_def lift_state_relation_def) - apply (frule akernel_init_invs[THEN bspec]) - apply (rule_tac x = s in exI) - apply (clarsimp simp: Init_A_def) - apply (insert ckernel_init_invs)[1] - apply clarsimp - apply (frule ckernel_init_sch_norm) - apply (frule ckernel_init_ctr) - apply (frule ckernel_init_domain_time) - apply (frule ckernel_init_domain_list) - apply (fastforce simp: Init_H_def) - apply (clarsimp simp: ADT_A_def ADT_H_def global_automaton_def) - - apply (erule_tac P="a \ (\x. b x)" for a b in disjE) - - apply (clarsimp simp: kernel_call_H_def) - - apply (drule use_valid[OF _ valid_corres_combined - [OF kernel_entry_invs entry_corres], - OF _ kernelEntry_invs'[THEN hoare_weaken_pre]]) - subgoal by fastforce - apply (clarsimp simp: ex_abs_def sch_act_simple_def ct_running_related ct_idle_related - sched_act_rct_related) - apply (rule exI, rule conjI, assumption) - apply simp - apply (fastforce simp: ex_abs_def sch_act_simple_def ct_running_related ct_idle_related - sched_act_rct_related valid_domain_list_from_invs') - apply (clarsimp simp: kernel_call_H_def) - subgoal by (fastforce simp: ex_abs_def sch_act_simple_def ct_running_related ct_idle_related - sched_act_rct_related) - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp add: do_user_op_H_def monad_to_transition_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule doUserOp_valid_duplicates') - apply (rule valid_corres_combined[OF do_user_op_invs2 corres_guard_imp2[OF do_user_op_corres]]) - apply clarsimp - apply (rule doUserOp_invs'[THEN hoare_weaken_pre]) - apply (fastforce simp: ex_abs_def) - apply (clarsimp simp: ex_abs_def, rule_tac x=s in exI, - clarsimp simp: ct_running_related sched_act_rct_related valid_domain_list_from_invs') - apply (clarsimp simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related) - - apply (erule_tac P="a \ b \ c \ (\x. d x)" for a b c d in disjE) - apply (clarsimp simp add: do_user_op_H_def monad_to_transition_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule doUserOp_valid_duplicates') - apply (rule valid_corres_combined[OF do_user_op_invs2 corres_guard_imp2[OF do_user_op_corres]]) - apply clarsimp - apply (rule doUserOp_invs'[THEN hoare_weaken_pre]) - apply (fastforce simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related - valid_domain_list_from_invs') - apply (fastforce simp: ex_abs_def) - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: check_active_irq_H_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule checkActiveIRQ_valid_duplicates') - apply (rule valid_corres_combined[OF check_active_irq_invs_just_running checkActiveIRQ_just_running_corres]) - apply (rule checkActiveIRQ_invs'_just_running[THEN hoare_weaken_pre]) - apply (fastforce simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related - valid_domain_list_from_invs') - apply (fastforce simp: ex_abs_def) - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: check_active_irq_H_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule checkActiveIRQ_valid_duplicates') - apply (rule valid_corres_combined[OF check_active_irq_invs_just_idle checkActiveIRQ_just_idle_corres]) - apply (rule checkActiveIRQ_invs'_just_idle[THEN hoare_weaken_pre]) - apply clarsimp - apply (fastforce simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_idle_related sched_act_rct_related - valid_domain_list_from_invs') - apply (fastforce simp: ex_abs_def) - - apply (clarsimp simp: check_active_irq_H_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule checkActiveIRQ_valid_duplicates') - apply (rule valid_corres_combined[OF check_active_irq_invs check_active_irq_corres]) - apply (rule checkActiveIRQ_invs'[THEN hoare_weaken_pre]) - apply clarsimp - apply (fastforce simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_running_related ct_idle_related sched_act_rct_related - valid_domain_list_from_invs') - apply (fastforce simp: ex_abs_def) - done - -text \The top-level theorem\ - -lemma fw_sim_A_H: - "LI (ADT_A uop) - (ADT_H uop) - (lift_state_relation state_relation) - (full_invs \ full_invs')" - apply (unfold LI_def full_invs_def full_invs'_def) - apply (simp add: ADT_H_def ADT_A_def) - apply (intro conjI) - apply (rule init_refinement) - apply (clarsimp simp: rel_semi_def relcomp_unfold in_lift_state_relation_eq) - apply (rename_tac tc ak m ev tc' ck' m' ev' ck) - apply (simp add: global_automaton_def) - - apply (erule_tac P="a \ (\x. b x)" for a b in disjE) - apply (clarsimp simp add: kernel_call_H_def kernel_call_A_def) - apply (rule rev_mp, rule_tac tc=tc and event=x in entry_corres) - apply (clarsimp simp: corres_underlying_def) - apply (drule (1) bspec) - apply (clarsimp simp: sch_act_simple_def) - apply (drule (1) bspec) - apply clarsimp - apply (rule conjI) - apply clarsimp - apply (rule_tac x=b in exI) - apply (rule conjI) - apply (rule impI, simp) - apply (frule (2) ct_running_related) - apply clarsimp - apply (rule_tac x=b in exI) - apply (drule use_valid, rule kernelEntry_invs') - apply (simp add: sch_act_simple_def) - apply clarsimp - apply (frule (1) ct_idle_related) - apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: do_user_op_H_def do_user_op_A_def monad_to_transition_def) - apply (rule rev_mp, rule_tac tc1=tc and f1=uop and P="ct_running and einvs" in corres_guard_imp2[OF do_user_op_corres]) - apply simp - apply (clarsimp simp add: corres_underlying_def) - apply (drule (1) bspec, clarsimp) - apply (drule (1) bspec, clarsimp) - apply fastforce - - apply (erule_tac P="a \ b \ c \ (\x. d x)" for a b c d in disjE) - apply (clarsimp simp: do_user_op_H_def do_user_op_A_def monad_to_transition_def) - apply (rule rev_mp, rule_tac tc1=tc and f1=uop and P="ct_running and einvs" in corres_guard_imp2[OF do_user_op_corres]) - apply simp - apply (clarsimp simp add: corres_underlying_def) - apply (drule (1) bspec, clarsimp) - apply (drule (1) bspec, clarsimp) - apply fastforce - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def) - apply (rule rev_mp, rule check_active_irq_corres) - apply (clarsimp simp: corres_underlying_def) - apply fastforce - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def) - apply (rule rev_mp, rule check_active_irq_corres) - apply (clarsimp simp: corres_underlying_def) - apply fastforce - - apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def) - apply (rule rev_mp, rule check_active_irq_corres) - apply (clarsimp simp: corres_underlying_def) - apply fastforce - - apply (clarsimp simp: absKState_correct dest!: lift_state_relationD) - done - -theorem refinement: - "ADT_H uop \ ADT_A uop" - apply (rule sim_imp_refines) - apply (rule L_invariantI) - apply (rule akernel_invariant) - apply (rule ckernel_invariant) - apply (rule fw_sim_A_H) - done - -end +interpretation Refine?: Refine +proof goal_cases + interpret Arch . + case 1 show ?case by (intro_locales; (unfold_locales; (fact Refine_assms)?)?) +qed end diff --git a/proof/refine/ARM_HYP/ArchRefine.thy b/proof/refine/ARM_HYP/ArchRefine.thy index 606d407387..29b9bf0ea6 100644 --- a/proof/refine/ARM_HYP/ArchRefine.thy +++ b/proof/refine/ARM_HYP/ArchRefine.thy @@ -12,14 +12,16 @@ imports PageTableDuplicates begin -context begin interpretation Arch . (*FIXME: arch-split*) +context Arch begin arch_global_naming + +named_theorems Refine_assms text \User memory content is the same on both levels\ lemma typ_at_AUserDataI: "\ typ_at (AArch (AUserData sz)) p s; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned' s'; pspace_distinct' s'; n < 2 ^ (pageBitsForSize sz - pageBits) \ - \ typ_at' UserDataT (p + n * 2 ^ pageBits) s'" - apply (clarsimp simp add: obj_at_def a_type_def ) + \ typ_at' UserDataT (p + n * 2 ^ pageBits) s'" + apply (clarsimp simp add: obj_at_def a_type_def) apply (simp split: Structures_A.kernel_object.split_asm arch_kernel_obj.split_asm split: if_split_asm) apply (drule(1) pspace_relation_absD) @@ -30,7 +32,7 @@ lemma typ_at_AUserDataI: apply (rule exI [where x = KOUserData]) apply (drule mp) apply (rule exI [where x = n]) - apply simp + apply (simp add: shiftl_t2n) apply (clarsimp simp: pspace_aligned'_def) apply (drule (1) bspec [OF _ domI]) apply (clarsimp simp: objBits_simps) @@ -40,7 +42,7 @@ lemma typ_at_AUserDataI: lemma typ_at_ADeviceDataI: "\ typ_at (AArch (ADeviceData sz)) p s; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned' s'; pspace_distinct' s'; n < 2 ^ (pageBitsForSize sz - pageBits) \ - \ typ_at' UserDataDeviceT (p + n * 2 ^ pageBits) s'" + \ typ_at' UserDataDeviceT (p + n * 2 ^ pageBits) s'" apply (clarsimp simp add: obj_at_def a_type_def ) apply (simp split: Structures_A.kernel_object.split_asm arch_kernel_obj.split_asm split: if_split_asm) @@ -52,7 +54,7 @@ lemma typ_at_ADeviceDataI: apply (rule exI [where x = KOUserDataDevice]) apply (drule mp) apply (rule exI [where x = n]) - apply simp + apply (simp add: shiftl_t2n) apply (clarsimp simp: pspace_aligned'_def) apply (drule (1) bspec [OF _ domI]) apply (clarsimp simp: objBits_simps) @@ -62,9 +64,8 @@ lemma typ_at_ADeviceDataI: lemma typ_at_UserDataI: "\ typ_at' UserDataT (p && ~~ mask pageBits) s'; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned s \ - \ \sz. typ_at (AArch (AUserData sz)) (p && ~~ mask (pageBitsForSize sz)) s" + \ \sz. typ_at (AArch (AUserData sz)) (p && ~~ mask (pageBitsForSize sz)) s" apply (clarsimp simp: exists_disj obj_at'_def typ_at'_def ko_wp_at'_def) - apply (frule (1) in_related_pspace_dom) apply (clarsimp simp: pspace_dom_def) apply (clarsimp simp: pspace_relation_def dom_def) @@ -92,9 +93,8 @@ lemma typ_at_UserDataI: lemma typ_at_DeviceDataI: "\ typ_at' UserDataDeviceT (p && ~~ mask pageBits) s'; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned s \ - \ \sz. typ_at (AArch (ADeviceData sz)) (p && ~~ mask (pageBitsForSize sz)) s" + \ \sz. typ_at (AArch (ADeviceData sz)) (p && ~~ mask (pageBitsForSize sz)) s" apply (clarsimp simp: exists_disj obj_at'_def typ_at'_def ko_wp_at'_def) - apply (frule (1) in_related_pspace_dom) apply (clarsimp simp: pspace_dom_def) apply (clarsimp simp: pspace_relation_def dom_def) @@ -119,870 +119,141 @@ lemma typ_at_DeviceDataI: apply (simp add: obj_at_def a_type_def) done -lemma pointerInUserData_relation: +lemma and_mask_pbfs_shiftr_pageBits_limit: + "p && mask (pageBitsForSize sz) >> pageBits < 2 ^ (pageBitsForSize sz - pageBits)" for p :: obj_ref + apply (rule shiftr_less_t2n') + apply (simp add: pbfs_atleast_pageBits mask_twice) + apply (case_tac sz; simp add: pageBits_def) + done + +lemma p_and_not_mask_pbfs_add_mask_pbfs_eq: + "(p && ~~ mask (pageBitsForSize sz)) + (p && mask (pageBitsForSize sz) >> pageBits) * 2 ^ pageBits + = p && ~~ mask pageBits" + for p :: obj_ref + by (simp flip: shiftl_t2n' + add: shiftr_shiftl1 mask_out_add_aligned is_aligned_neg_mask pbfs_atleast_pageBits + word_plus_and_or_coroll2 add.commute) + +lemma pointerInUserData_relation[Refine_assms]: "\ (s,s') \ state_relation; valid_state' s'; valid_state s\ \ pointerInUserData p s' = in_user_frame p s" apply (simp add: pointerInUserData_def in_user_frame_def) apply (rule iffI) - apply (erule typ_at_UserDataI, (clarsimp simp: valid_state_def)+)[1] + apply (erule typ_at_UserDataI; clarsimp simp: valid_state_def) apply clarsimp - apply (drule_tac sz = sz and - n = "(p && mask (pageBitsForSize sz)) >> pageBits" - in typ_at_AUserDataI [where s = s and s' = s']) - apply (fastforce simp: valid_state'_def)+ - apply (rule shiftr_less_t2n') - apply (simp add: pbfs_atleast_pageBits mask_twice) - apply (case_tac sz, simp_all)[1] - apply (subgoal_tac "(p && ~~ mask (pageBitsForSize sz)) + (p && mask (pageBitsForSize sz) >> pageBits) * 2 ^ pageBits = (p && ~~ mask pageBits)") - apply simp - apply (subst mult.commute) - apply (subst shiftl_t2n [symmetric]) - apply (simp add: shiftr_shiftl1) - apply (subst mask_out_add_aligned) - apply (rule is_aligned_neg_mask) - apply (simp add: pbfs_atleast_pageBits) - apply (subst add.commute) - apply (simp add: word_plus_and_or_coroll2) + apply (drule_tac sz=sz and n="(p && mask (pageBitsForSize sz)) >> pageBits" + in typ_at_AUserDataI [where s = s and s' = s']) + apply (fastforce simp: valid_state'_def and_mask_pbfs_shiftr_pageBits_limit)+ + apply (erule arg_cong[where f="\p. typ_at' _ p s'", THEN iffD1, rotated]) + apply (simp add: p_and_not_mask_pbfs_add_mask_pbfs_eq) done -lemma pointerInDeviceData_relation: +lemma pointerInDeviceData_relation[Refine_assms]: "\ (s,s') \ state_relation; valid_state' s'; valid_state s\ \ pointerInDeviceData p s' = in_device_frame p s" apply (simp add: pointerInDeviceData_def in_device_frame_def) apply (rule iffI) - apply (erule typ_at_DeviceDataI, (clarsimp simp: valid_state_def)+)[1] + apply (erule typ_at_DeviceDataI; clarsimp simp: valid_state_def) apply clarsimp - apply (drule_tac sz = sz and - n = "(p && mask (pageBitsForSize sz)) >> pageBits" - in typ_at_ADeviceDataI [where s = s and s' = s']) - apply (fastforce simp: valid_state'_def)+ - apply (rule shiftr_less_t2n') - apply (simp add: pbfs_atleast_pageBits mask_twice) - apply (case_tac sz, simp_all)[1] - apply (subgoal_tac "(p && ~~ mask (pageBitsForSize sz)) + (p && mask (pageBitsForSize sz) >> pageBits) * 2 ^ pageBits = (p && ~~ mask pageBits)") - apply simp - apply (subst mult.commute) - apply (subst shiftl_t2n [symmetric]) - apply (simp add: shiftr_shiftl1) - apply (subst mask_out_add_aligned) - apply (rule is_aligned_neg_mask) - apply (simp add: pbfs_atleast_pageBits) - apply (subst add.commute) - apply (simp add: word_plus_and_or_coroll2) + apply (drule_tac sz=sz and n="(p && mask (pageBitsForSize sz)) >> pageBits" + in typ_at_ADeviceDataI[where s=s and s'=s']) + apply (fastforce simp: valid_state'_def and_mask_pbfs_shiftr_pageBits_limit)+ + apply (erule arg_cong[where f="\p. typ_at' _ p s'", THEN iffD1, rotated]) + apply (simp add: p_and_not_mask_pbfs_add_mask_pbfs_eq) done -lemma user_mem_relation: +lemma user_mem_relation[Refine_assms]: "\(s,s') \ state_relation; valid_state' s'; valid_state s\ \ user_mem' s' = user_mem s" - apply (rule ext) - apply (clarsimp simp: user_mem_def user_mem'_def pointerInUserData_relation pointerInDeviceData_relation) - apply (simp add: state_relation_def) - done + by (rule ext) + (clarsimp simp: user_mem_def user_mem'_def pointerInUserData_relation pointerInDeviceData_relation + state_relation_def) -lemma device_mem_relation: +lemma device_mem_relation[Refine_assms]: "\(s,s') \ state_relation; valid_state' s'; valid_state s\ \ device_mem' s' = device_mem s" - apply (rule ext) - apply (clarsimp simp: device_mem_def device_mem'_def pointerInUserData_relation - pointerInDeviceData_relation) - done + by (rule ext) + (clarsimp simp: device_mem_def device_mem'_def pointerInUserData_relation + pointerInDeviceData_relation) -lemma absKState_correct: -assumes invs: "einvs (s :: det_ext state)" and invs': "invs' s'" -assumes rel: "(s,s') \ state_relation" -shows "absKState s' = abs_state s" - using assms - apply (intro state.equality, simp_all add: absKState_def abs_state_def) - apply (rule absHeap_correct; clarsimp elim!: state_relationE) - apply (rule absCDT_correct; clarsimp) - apply (rule absIsOriginalCap_correct; clarsimp) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (clarsimp simp: state_relation_def) - apply (rule absSchedulerAction_correct, simp add: state_relation_def) - apply (simp add: domSchedule_map_relation) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def ready_queues_relation_def ready_queue_relation_def Let_def - list_queue_relation_def) - apply (fastforce dest: heap_ls_is_walk) - apply (clarsimp simp: user_mem_relation invs_def invs'_def) - apply (simp add: state_relation_def) - apply (rule absInterruptIRQNode_correct, simp add: state_relation_def) - apply (rule absInterruptStates_correct, simp add: state_relation_def) - apply (rule absArchState_correct, simp) - apply (rule absExst_correct; simp) - done - -text \The top-level invariance\ - -lemma set_thread_state_sched_act: - "\(\s. runnable state) and (\s. P (scheduler_action s))\ - set_thread_state thread state - \\rs s. P (scheduler_action (s::det_state))\" - apply (simp add: set_thread_state_def) - apply wp - apply (simp add: set_thread_state_act_def) - apply wp - apply (rule hoare_pre_cont) - apply (rule_tac Q'="\rv. (\s. runnable ts) and (\s. P (scheduler_action s))" - in hoare_strengthen_post) - apply wp - apply force - apply (wp gts_st_tcb_at)+ - apply (rule_tac Q'="\rv. st_tcb_at ((=) state) thread and (\s. runnable state) and (\s. P (scheduler_action s))" in hoare_strengthen_post) - apply (simp add: st_tcb_at_def) - apply (wp obj_set_prop_at)+ - apply (force simp: st_tcb_at_def obj_at_def) - apply wp - apply clarsimp - done - -lemma activate_thread_sched_act: +lemma arch_activate_thread_sched_act[Refine_assms]: "\ct_in_state activatable and (\s. P (scheduler_action s))\ - activate_thread - \\rs s. P (scheduler_action (s::det_state))\" - by (simp add: activate_thread_def set_thread_state_def arch_activate_idle_thread_def - | (wp set_thread_state_sched_act gts_wp)+ | wpc)+ - -lemma schedule_sched_act_rct[wp]: - "\\\ Schedule_A.schedule - \\rs (s::det_state). scheduler_action s = resume_cur_thread\" - unfolding Schedule_A.schedule_def - by (wpsimp) - -lemma call_kernel_sched_act_rct[wp]: - "\einvs and (\s. e \ Interrupt \ ct_running s) and (\s. scheduler_action s = resume_cur_thread)\ - call_kernel e - \\rs (s::det_state). scheduler_action s = resume_cur_thread\" - unfolding call_kernel_def - by (wpsimp wp: activate_thread_sched_act handle_spurious_irq_invs simp: active_from_running) - -lemma kernel_entry_invs: - "\einvs and (\s. e \ Interrupt \ ct_running s) - and (\s. 0 < domain_time s) and valid_domain_list and (ct_running or ct_idle) - and (\s. scheduler_action s = resume_cur_thread)\ - kernel_entry e us - \\rv. einvs and (\s. ct_running s \ ct_idle s) - and (\s. 0 < domain_time s) and valid_domain_list - and (\s. scheduler_action s = resume_cur_thread)\" - apply (rule_tac Q'="\rv. invs and (\s. ct_running s \ ct_idle s) and valid_sched and - (\s. 0 < domain_time s) and valid_domain_list and - valid_list and (\s. scheduler_action s = resume_cur_thread)" - in hoare_post_imp) - apply clarsimp - apply (simp add: kernel_entry_def) - apply (wp akernel_invs_det_ext call_kernel_valid_sched thread_set_invs_trivial - thread_set_not_state_valid_sched - hoare_vcg_disj_lift ct_in_state_thread_state_lift thread_set_no_change_tcb_state - call_kernel_domain_time_inv_det_ext call_kernel_domain_list_inv_det_ext - hoare_weak_lift_imp valid_domain_list_lift - | clarsimp simp add: tcb_cap_cases_def active_from_running)+ - done - -definition - "full_invs \ {((tc, s :: det_ext state), m, e). einvs s \ - (ct_running s \ ct_idle s) \ - (m = KernelMode \ e \ None) \ - (m = UserMode \ ct_running s) \ - (m = IdleMode \ ct_idle s) \ - (e \ None \ e \ Some Interrupt \ ct_running s) \ - 0 < domain_time s \ valid_domain_list s \ - (scheduler_action s = resume_cur_thread)}" - -crunch do_user_op - for valid_list: valid_list - and valid_sched: valid_sched - and sched_act: "\s. P (scheduler_action s)" - and domain_fields_inv[wp]: "domain_fields P" - -lemma do_user_op_invs2: - "\einvs and ct_running and (\s. scheduler_action s = resume_cur_thread) - and (\s. 0 < domain_time s) and valid_domain_list \ - do_user_op f tc - \\_. (einvs and ct_running and (\s. scheduler_action s = resume_cur_thread)) - and (\s. 0 < domain_time s) and valid_domain_list \" - apply (rule_tac Q'="\_. valid_list and valid_sched and - (\s. scheduler_action s = resume_cur_thread) and (invs and ct_running) and - (\s. 0 < domain_time s) and valid_domain_list" - in hoare_strengthen_post) - apply (wpsimp wp: do_user_op_valid_list do_user_op_valid_sched do_user_op_sched_act - valid_domain_list_lift do_user_op_invs) - apply force - done - -lemmas ext_init_def = ext_init_det_ext_ext_def ext_init_unit_def + arch_activate_idle_thread t + \\rs s. P (scheduler_action (s::det_state))\" + by (wpsimp simp: arch_activate_idle_thread_def) -lemma valid_list_init[simp]: +lemma valid_list_init[Refine_assms, simp]: "valid_list init_A_st" by (simp add: valid_list_2_def init_A_st_def ext_init_def init_cdt_def) -lemmas valid_list_inits[simp] = valid_list_init[simplified] - -lemma valid_sched_init[simp]: +lemma valid_sched_init[Refine_assms, simp]: "valid_sched init_A_st" apply (simp add: valid_sched_def init_A_st_def ext_init_def) apply (clarsimp simp: init_kheap_def st_tcb_at_kh_def obj_at_kh_def - obj_at_def idle_thread_ptr_def init_globals_frame_def + obj_at_def idle_thread_ptr_def valid_queues_2_def ct_not_in_q_def not_queued_def - valid_sched_action_def is_activatable_def us_global_pd_ptr_def + valid_sched_action_def is_activatable_def init_irq_node_ptr_def + us_global_pd_ptr_def ct_in_cur_domain_2_def valid_blocked_2_def valid_idle_etcb_def etcb_at'_def etcbs_of'_def) done -lemma valid_domain_list_init[simp]: +lemma valid_domain_list_init[Refine_assms, simp]: "valid_domain_list init_A_st" by (simp add: init_A_st_def ext_init_def valid_domain_list_def) -lemma akernel_invariant: - "ADT_A uop \ full_invs" - unfolding full_invs_def - apply (rule invariantI) - apply (clarsimp simp: ADT_A_def subset_iff) - apply (frule bspec[OF akernel_init_invs]) - apply (simp add: Let_def Init_A_def) - apply (simp add: init_A_st_def ext_init_def) - apply (clarsimp simp: ADT_A_def global_automaton_def) - - apply (rename_tac tc' s' mode' e' tc s mode e) - apply (elim disjE) - apply ((clarsimp simp: kernel_call_A_def - | drule use_valid[OF _ kernel_entry_invs])+)[2] - apply ((clarsimp simp: do_user_op_A_def monad_to_transition_def - check_active_irq_A_def - | drule use_valid[OF _ do_user_op_invs2] - | drule use_valid[OF _ check_active_irq_invs_just_running])+)[2] - apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs])+)[1] - apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) - apply ((clarsimp simp add: do_user_op_A_def check_active_irq_A_def - | drule use_valid[OF _ do_user_op_invs2] - | drule use_valid[OF _ check_active_irq_invs_just_running])+)[1] - apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) - apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) - apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs])+)[1] - apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs_just_idle])+)[1] - apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs])+)[1] - done +lemma valid_domain_time_init[Refine_assms, simp]: + "0 < domain_time init_A_st" + by (simp add: init_A_st_def) + +lemma sched_act_init[Refine_assms, simp]: + "scheduler_action init_A_st = resume_cur_thread" + by (simp add: init_A_st_def) -lemma ckernel_invs: - "\invs' and (\s. vs_valid_duplicates' (ksPSpace s)) and - (\s. e \ Interrupt \ ct_running' s) and - (\s. ksSchedulerAction s = ResumeCurrentThread)\ - callKernel e - \\rs. (\s. ksSchedulerAction s = ResumeCurrentThread) - and (invs' and (ct_running' or ct_idle'))\" - unfolding callKernel_def - by (wpsimp wp: activate_invs' activate_sch_act schedule_sch - schedule_sch_act_simple he_invs' schedule_invs' hoare_vcg_if_lift3 - hoare_drop_imp[where Q'="\_. kernelExitAssertions"] - hoare_drop_imp[where Q'="\rv _. rv = None"] - simp: no_irq_getActiveIRQ - | strengthen non_kernel_IRQs_strg)+ - -lemma fastpathKernelAssertions_cross: +lemma fastpathKernelAssertions_cross[Refine_assms]: "\ (s,s') \ state_relation; invs s; valid_arch_state' s'\ \ fastpathKernelAssertions s'" unfolding fastpathKernelAssertions_def by simp -(* this is only needed for callKernel, where we have invs' on concrete side *) -lemma corres_cross_over_fastpathKernelAssertions: - "\ \s. P s \ invs s; \s'. Q s' \ invs' s'; - corres r P (Q and fastpathKernelAssertions) f g \ \ - corres r P Q f g" - by (rule corres_cross_over_guard[where Q="Q and fastpathKernelAssertions"]) - (fastforce elim: fastpathKernelAssertions_cross)+ - -defs kernelExitAssertions_def: - "kernelExitAssertions s \ 0 < ksDomainTime s" - -lemma callKernel_domain_time_left: - "\\\ callKernel e \\_ s. 0 < ksDomainTime s\" - unfolding callKernel_def kernelExitAssertions_def by wpsimp - -lemma kernelEntry_invs': - "\ invs' and (\s. e \ Interrupt \ ct_running' s) and - (ct_running' or ct_idle') and - (\s. vs_valid_duplicates' (ksPSpace s)) and - (\s. ksSchedulerAction s = ResumeCurrentThread) and - (\s. 0 < ksDomainTime s) \ - kernelEntry e tc - \\rs. (\s. ksSchedulerAction s = ResumeCurrentThread) and - (invs' and (ct_running' or ct_idle')) and - (\s. vs_valid_duplicates' (ksPSpace s)) and - (\s. 0 < ksDomainTime s) \" - apply (simp add: kernelEntry_def) - apply (wp ckernel_invs callKernel_valid_duplicates' callKernel_domain_time_left - threadSet_invs_trivial threadSet_ct_running' - TcbAcc_R.dmo_invs' callKernel_domain_time_left - hoare_weak_lift_imp - | clarsimp simp: user_memory_update_def no_irq_def tcb_at_invs' atcbContextSet_def)+ - done +(* vs duplicate interface lemma *) +lemmas [Refine_assms] = callKernel_valid_duplicates' + +lemma doUserOp_valid_duplicates'[Refine_assms]: + "doUserOp f tc \\s. vs_valid_duplicates' (ksPSpace s)\" + by (simp add: doUserOp_def split_def) + (wpsimp wp: dmo_invs') -lemma ptable_lift_abs_state[simp]: +lemma checkActiveIRQ_valid_duplicates'[Refine_assms]: + "checkActiveIRQ \\s. vs_valid_duplicates' (ksPSpace s)\" + by (wpsimp simp: checkActiveIRQ_def) + +lemma tcb_hyp_refs'_atcbContextSet[Refine_assms, simp]: + "tcb_hyp_refs' (atcbContextSet tc atcb) = tcb_hyp_refs' atcb" + by (simp add: atcbContextSet_def) + +lemma ptable_lift_abs_state[Refine_assms, simp]: "ptable_lift t (abs_state s) = ptable_lift t s" by (simp add: ptable_lift_def abs_state_def) -lemma ptable_rights_abs_state[simp]: +lemma ptable_rights_abs_state[Refine_assms, simp]: "ptable_rights t (abs_state s) = ptable_rights t s" by (simp add: ptable_rights_def abs_state_def) -lemma ptable_rights_imp_UserData: - assumes invs: "einvs s" and invs': "invs' s'" - assumes rel: "(s,s') : state_relation" - assumes rights: "ptable_rights t (absKState s') x \ {}" - assumes trans: - "ptable_lift t (absKState s') x = Some (ARM_HYP.addrFromPPtr y)" - shows "pointerInUserData y s' \ pointerInDeviceData y s'" -proof - - from invs invs' rel have [simp]: "absKState s' = abs_state s" - by - (rule absKState_correct, simp_all) - from invs have valid: "valid_state s" by auto - from invs' have valid': "valid_state' s'" by auto - have "in_user_frame y s \ in_device_frame y s " - by (rule ptable_rights_imp_frame[OF valid rights[simplified] - trans[simplified]]) - thus ?thesis - by (auto simp add: pointerInUserData_relation[OF rel valid' valid] - pointerInDeviceData_relation[OF rel valid' valid]) -qed +lemma arch_tcb_relation_arch_context_set[Refine_assms]: + "arch_tcb_relation atcb atcb' + \ arch_tcb_relation (arch_tcb_context_set tc atcb) (atcbContextSet tc atcb')" + by (simp add: arch_tcb_relation_def arch_tcb_context_set_def atcbContextSet_def) -lemma device_update_invs': - "\invs'\doMachineOp (device_memory_update ds) - \\_. invs'\" - apply (simp add: doMachineOp_def device_memory_update_def simpler_modify_def select_f_def - gets_def get_def bind_def valid_def return_def) - by (clarsimp simp: invs'_def valid_state'_def valid_irq_states'_def valid_machine_state'_def) - -crunch doMachineOp - for ksDomainTime[wp]: "\s. P (ksDomainTime s)" - -lemma doUserOp_invs': - "\invs' and ex_abs einvs and - (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_running' and - (\s. 0 < ksDomainTime s)\ - doUserOp f tc - \\_. invs' and - (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_running' and - (\s. 0 < ksDomainTime s)\" - apply (simp add: doUserOp_def split_def ex_abs_def) - apply (wp device_update_invs' - | (wp (once) dmo_invs', wpsimp simp: no_irq_modify device_memory_update_def - user_memory_update_def))+ - apply (clarsimp simp: user_memory_update_def simpler_modify_def - restrict_map_def - split: option.splits) - apply (frule ptable_rights_imp_UserData[rotated 2], auto) - done +lemma arch_tcb_relation_arch_context_get[Refine_assms]: + "arch_tcb_relation atcb atcb' \ arch_tcb_context_get atcb = atcbContextGet atcb'" + by (simp add: arch_tcb_relation_def arch_tcb_context_get_def atcbContextGet_def) -lemma doUserOp_valid_duplicates': - "\\s. vs_valid_duplicates' (ksPSpace s)\ - doUserOp f tc - \\_ s. vs_valid_duplicates' (ksPSpace s)\" - apply (simp add: doUserOp_def split_def) - apply (wp dmo_invs') - apply clarsimp - done - -lemma None_drop: - "P \ x = None \ P" - by simp +end (* Arch *) -lemma Ex_Some_conv: - "((\y. x = Some y) \ P x) = (\y. x = Some y \ P (Some y))" - by auto - -text \The top-level correspondence\ - -lemma contract_all_imp_strg': - "P \ P' \ P'' \ (\x. R x \ Q x) \ \x. R x \ P \ Q x \ P' \ P''" - by blast - -lemma kernel_corres': - "corres dc (einvs and (\s. event \ Interrupt \ ct_running s) and (ct_running or ct_idle) - and (\s. scheduler_action s = resume_cur_thread) and valid_domain_list) - (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and - (\s. ksSchedulerAction s = ResumeCurrentThread) and - (\s. vs_valid_duplicates' (ksPSpace s))) - (call_kernel event) - (do _ \ runExceptT $ - handleEvent event `~catchError~` - (\_. withoutPreemption $ maybeHandleInterrupt True); - _ \ ThreadDecls_H.schedule; - activateThread - od)" - unfolding call_kernel_def - apply (corres corres: handleEvent_corres corres_machine_op maybeHandleInterrupt_corres - simp: irq_state_independent_def - | corres_cases_both)+ - apply (wpsimp wp: handle_event_valid_sched)+ - apply (corres corres: schedule_corres activateThread_corres) - apply (wpsimp wp: schedule_invs' hoare_vcg_if_lift2 dmo_getActiveIRQ_non_kernel - handle_spurious_irq_invs - valid_domain_list_lift[of handle_spurious_irq] - valid_domain_list_lift[of "handle_interrupt irq" for irq] - valid_domain_list_lift[of "do_machine_op mop" for mop] - cong: rev_conj_cong - simp: maybe_handle_interrupt_def - | strengthen None_drop contract_all_imp_strg' - | subst Ex_Some_conv)+ - apply (rule_tac Q'="\_. valid_domain_list and valid_sched and invs and valid_list" and - E'="\_. valid_domain_list and valid_sched and invs and valid_list" - in hoare_strengthen_postE) - apply (wpsimp wp: handle_event_valid_sched hoare_vcg_if_lift3 - | strengthen non_kernel_IRQs_strg None_drop)+ - apply (clarsimp simp: active_from_running schact_is_rct_def) - apply (clarsimp simp: active_from_running') - done - -lemma kernel_corres: - "corres dc (einvs and (\s. event \ Interrupt \ ct_running s) and (ct_running or ct_idle) and - (\s. scheduler_action s = resume_cur_thread) and - (\s. 0 < domain_time s \ valid_domain_list s)) - (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and - (\s. ksSchedulerAction s = ResumeCurrentThread) and - (\s. vs_valid_duplicates' (ksPSpace s))) - (call_kernel event) (callKernel event)" - unfolding callKernel_def K_bind_def - apply (rule corres_cross_over_fastpathKernelAssertions, blast+) - apply (rule corres_stateAssert_r) - apply (rule corres_guard_imp) - apply (rule corres_add_noop_lhs2) - apply (simp only: bind_assoc[symmetric]) - apply (rule corres_split[where r'=dc and - R="\_ s. 0 < domain_time s \ valid_domain_list s" and - R'="\_. \"]) - apply (simp only: bind_assoc) - apply (rule kernel_corres') - apply (rule corres_bind_return2, rule corres_stateAssert_assume_stronger) - apply simp - apply (simp add: kernelExitAssertions_def state_relation_def) - apply (wp call_kernel_domain_time_inv_det_ext call_kernel_domain_list_inv_det_ext) - apply wp - apply clarsimp - apply clarsimp - done - -lemma user_mem_corres: - "corres (=) invs invs' (gets (\x. g (user_mem x))) (gets (\x. g (user_mem' x)))" - by (clarsimp simp add: gets_def get_def return_def bind_def - invs_def invs'_def - corres_underlying_def user_mem_relation) - -lemma device_mem_corres: - "corres (=) invs invs' (gets (\x. g (device_mem x))) (gets (\x. g (device_mem' x)))" - by (clarsimp simp add: gets_def get_def return_def bind_def - invs_def invs'_def - corres_underlying_def device_mem_relation) - -lemma entry_corres: - "corres (=) (einvs and (\s. event \ Interrupt \ ct_running s) and - (\s. 0 < domain_time s) and valid_domain_list and (ct_running or ct_idle) and - (\s. scheduler_action s = resume_cur_thread)) - (invs' and (\s. event \ Interrupt \ ct_running' s) and - (\s. 0 < ksDomainTime s) and (ct_running' or ct_idle') and - (\s. ksSchedulerAction s = ResumeCurrentThread) and - (\s. vs_valid_duplicates' (ksPSpace s))) - (kernel_entry event tc) (kernelEntry event tc)" - apply (simp add: kernel_entry_def kernelEntry_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getCurThread_corres]) - apply (rule corres_split) - apply simp - apply (rule threadset_corresT; simp?) - apply (simp add: tcb_relation_def arch_tcb_relation_def - arch_tcb_context_set_def atcbContextSet_def) - apply (clarsimp simp: tcb_cap_cases_def) - apply (clarsimp simp: tcb_cte_cases_def tcb_cte_cases_neqs) - apply (rule corres_split[OF kernel_corres]) - apply (rule corres_split_eqr[OF getCurThread_corres]) - apply (rule threadGet_corres) - apply (simp add: tcb_relation_def arch_tcb_relation_def - arch_tcb_context_get_def atcbContextGet_def) - apply wp+ - apply (rule hoare_strengthen_post, rule akernel_invs_det_ext, - 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 - threadSet_invs_trivial threadSet_ct_running' - thread_set_not_state_valid_sched hoare_weak_lift_imp - hoare_vcg_disj_lift ct_in_state_thread_state_lift - thread_set_no_change_tcb_state - | simp add: tcb_cap_cases_def ct_in_state'_def schact_is_rct_def - | (wps, wp threadSet_st_tcb_at2) )+ - apply (clarsimp simp: invs_def cur_tcb_def valid_state_def valid_pspace_def) - apply (clarsimp simp: ct_in_state'_def) - done - -lemma corres_gets_machine_state: - "corres (=) \ \ (gets (f \ machine_state)) (gets (f \ ksMachineState))" - by (clarsimp simp: gets_def corres_underlying_def - in_monad bind_def get_def return_def state_relation_def) - -lemma do_user_op_corres: - "corres (=) (einvs and ct_running) - (invs' and (%s. ksSchedulerAction s = ResumeCurrentThread) and - ct_running') - (do_user_op f tc) (doUserOp f tc)" - apply (simp add: do_user_op_def doUserOp_def split_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getCurThread_corres]) - apply (rule_tac r'="(=)" and P=einvs and P'=invs' in corres_split) - apply (fastforce dest: absKState_correct [rotated]) - apply (rule_tac r'="(=)" and P=einvs and P'=invs' in corres_split) - apply (fastforce dest: absKState_correct [rotated]) - apply (rule_tac r'="(=)" and P=invs and P'=invs' in corres_split) - apply (rule user_mem_corres) - apply (rule_tac r'="(=)" and P=invs and P'=invs' in corres_split) - apply (rule device_mem_corres) - apply (rule_tac r'="(=)" in corres_split) - apply (rule corres_gets_machine_state) - apply (rule_tac F = "dom (rvb \ addrFromPPtr) \ - dom rvd" in corres_gen_asm) - apply (rule_tac F = "dom (rvc \ addrFromPPtr) \ dom rvd" in corres_gen_asm) - apply simp - apply (rule_tac r'="(=)" in corres_split[OF corres_select]) - apply simp - apply (rule corres_underlying_split[OF corres_machine_op]) - apply simp - apply (rule corres_underlying_trivial) - apply (simp add: user_memory_update_def) - apply (wp | simp)+ - apply (rule corres_underlying_split[OF corres_machine_op,where Q = dc and Q'=dc]) - apply (rule corres_underlying_trivial) - apply (wp | simp add: dc_def device_memory_update_def)+ - apply (clarsimp simp: invs_def valid_state_def pspace_respects_device_region_def) - apply fastforce - done - -lemma ct_running_related: - "\ (a, c) \ state_relation; ct_running' c \ - \ ct_running a" - apply (clarsimp simp: ct_in_state_def ct_in_state'_def - curthread_relation) - apply (frule(1) st_tcb_at_coerce_abstract) - apply (erule st_tcb_weakenE) - apply (case_tac st, simp_all)[1] - done - -lemma ct_idle_related: - "\ (a, c) \ state_relation; ct_idle' c \ - \ ct_idle a" - apply (clarsimp simp: ct_in_state_def ct_in_state'_def - curthread_relation) - apply (frule(1) st_tcb_at_coerce_abstract) - apply (erule st_tcb_weakenE) - apply (case_tac st, simp_all)[1] - done - -definition - "full_invs' \ {((tc,s),m,e). invs' s \ vs_valid_duplicates' (ksPSpace s) \ - ex_abs (einvs::det_ext state \ bool) s \ - ksSchedulerAction s = ResumeCurrentThread \ - (ct_running' s \ ct_idle' s) \ - (m = KernelMode \ e \ None) \ - (m = UserMode \ ct_running' s) \ - (m = IdleMode \ ct_idle' s) \ - (e \ None \ e \ Some Interrupt \ ct_running' s) \ - 0 < ksDomainTime s}" - -lemma checkActiveIRQ_valid_duplicates': - "\\s. vs_valid_duplicates' (ksPSpace s)\ - checkActiveIRQ - \\_ s. vs_valid_duplicates' (ksPSpace s)\" - apply (simp add: checkActiveIRQ_def) - apply wpsimp - done - -lemma check_active_irq_corres': - "corres (=) \ \ (check_active_irq) (checkActiveIRQ)" - apply (simp add: check_active_irq_def checkActiveIRQ_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF corres_machine_op[OF corres_underlying_trivial], where R="\_. \" and R'="\_. \"]) - apply wpsimp+ - done - -lemma check_active_irq_corres: - "corres (=) - (invs and (ct_running or ct_idle) and einvs and (\s. scheduler_action s = resume_cur_thread) - and (\s. 0 < domain_time s) and valid_domain_list) - (invs' and (\s. ksSchedulerAction s = ResumeCurrentThread) - and (\s. 0 < ksDomainTime s) and (ct_running' or ct_idle') - and (\s. vs_valid_duplicates' (ksPSpace s))) - (check_active_irq) (checkActiveIRQ)" - apply (rule corres_guard_imp) - apply (rule check_active_irq_corres', auto) - done - -lemma checkActiveIRQ_just_running_corres: - "corres (=) - (invs and ct_running and einvs and (\s. scheduler_action s = resume_cur_thread) - and (\s. 0 < domain_time s) and valid_domain_list) - (invs' and ct_running' and (\s. vs_valid_duplicates' (ksPSpace s)) - and (\s. 0 < ksDomainTime s) - and (\s. ksSchedulerAction s = ResumeCurrentThread)) - (check_active_irq) (checkActiveIRQ)" - apply (rule corres_guard_imp) - apply (rule check_active_irq_corres', auto) - done - -lemma checkActiveIRQ_just_idle_corres: - "corres (=) - (invs and ct_idle and einvs and (\s. scheduler_action s = resume_cur_thread) - and (\s. 0 < domain_time s) and valid_domain_list) - (invs' and ct_idle' and (\s. vs_valid_duplicates' (ksPSpace s)) - and (\s. 0 < ksDomainTime s) - and (\s. ksSchedulerAction s = ResumeCurrentThread)) - (check_active_irq) (checkActiveIRQ)" - apply (rule corres_guard_imp) - apply (rule check_active_irq_corres', auto) - done - -lemma checkActiveIRQ_invs': - "\invs' and ex_abs invs and (ct_running' or ct_idle') - and (\s. ksSchedulerAction s = ResumeCurrentThread)\ - checkActiveIRQ - \\_. invs' and (ct_running' or ct_idle') - and (\s. ksSchedulerAction s = ResumeCurrentThread)\" - apply (simp add: checkActiveIRQ_def ex_abs_def) - apply (wp dmo_invs' | simp)+ - done - -lemma checkActiveIRQ_invs'_just_running: - "\invs' and ex_abs invs and ct_running' - and (\s. ksSchedulerAction s = ResumeCurrentThread)\ - checkActiveIRQ - \\_. invs' and ct_running' - and (\s. ksSchedulerAction s = ResumeCurrentThread)\" - apply (simp add: checkActiveIRQ_def) - apply (wp | simp)+ - done - -lemma checkActiveIRQ_invs'_just_idle: - "\invs' and ex_abs invs and ct_idle' - and (\s. ksSchedulerAction s = ResumeCurrentThread)\ - checkActiveIRQ - \\_. invs' and ct_idle' - and (\s. ksSchedulerAction s = ResumeCurrentThread)\" - apply (simp add: checkActiveIRQ_def) - apply (wp | simp)+ - done - -lemma sched_act_rct_related: - "\ (a, c) \ state_relation; ksSchedulerAction c = ResumeCurrentThread\ - \ scheduler_action a = resume_cur_thread" - by (case_tac "scheduler_action a", simp_all add: state_relation_def) - -lemma domain_time_rel_eq: - "(a, c) \ state_relation \ P (ksDomainTime c) = P (domain_time a)" - by (clarsimp simp: state_relation_def) - -lemma valid_domain_list_2_cross: - "\valid_dom_schedule'_2 sched idx start; domain_list_map dom_list = sched \ - \ valid_domain_list_2 start idx dom_list" - by (fastforce simp: valid_domain_list_2_def valid_dom_schedule'_2_def ucast_eq_0 is_up - split: prod.splits) - -lemma valid_domain_list_from_invs': - "\ (s, s') \ state_relation; invs' s' \ \ valid_domain_list s" - by (clarsimp simp: valid_domain_list_2_cross invs'_def valid_state'_def elim!: state_relationE) - -lemma ckernel_invariant: - "ADT_H uop \ full_invs'" - unfolding full_invs'_def - supply word_neq_0_conv[simp] - supply domain_time_rel_eq[simp] - apply (rule invariantI) - apply (clarsimp simp add: ADT_H_def) - apply (subst conj_commute, simp) - apply (rule conjI) - apply (drule ckernel_init_valid_duplicates'[rule_format], simp) - apply (rule conjI) - apply (frule init_refinement[simplified subset_eq, THEN bspec]) - apply (clarsimp simp: ex_abs_def lift_state_relation_def) - apply (frule akernel_init_invs[THEN bspec]) - apply (rule_tac x = s in exI) - apply (clarsimp simp: Init_A_def) - apply (insert ckernel_init_invs)[1] - apply clarsimp - apply (frule ckernel_init_sch_norm) - apply (frule ckernel_init_ctr) - apply (frule ckernel_init_domain_time) - apply (frule ckernel_init_domain_list) - apply (fastforce simp: Init_H_def) - apply (clarsimp simp: ADT_A_def ADT_H_def global_automaton_def) - - apply (erule_tac P="a \ (\x. b x)" for a b in disjE) - - apply (clarsimp simp: kernel_call_H_def) - - apply (drule use_valid[OF _ valid_corres_combined - [OF kernel_entry_invs entry_corres], - OF _ kernelEntry_invs'[THEN hoare_weaken_pre]]) - subgoal by fastforce - apply (clarsimp simp: ex_abs_def sch_act_simple_def ct_running_related ct_idle_related - sched_act_rct_related) - apply (rule exI, rule conjI, assumption) - apply simp - apply (fastforce simp: ex_abs_def sch_act_simple_def ct_running_related ct_idle_related - sched_act_rct_related valid_domain_list_from_invs') - apply (clarsimp simp: kernel_call_H_def) - subgoal by (fastforce simp: ex_abs_def sch_act_simple_def ct_running_related ct_idle_related - sched_act_rct_related) - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp add: do_user_op_H_def monad_to_transition_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule doUserOp_valid_duplicates') - apply (rule valid_corres_combined[OF do_user_op_invs2 corres_guard_imp2[OF do_user_op_corres]]) - apply clarsimp - apply (rule doUserOp_invs'[THEN hoare_weaken_pre]) - apply (fastforce simp: ex_abs_def) - apply (clarsimp simp: ex_abs_def, rule_tac x=s in exI, - clarsimp simp: ct_running_related sched_act_rct_related valid_domain_list_from_invs') - apply (clarsimp simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related) - - apply (erule_tac P="a \ b \ c \ (\x. d x)" for a b c d in disjE) - apply (clarsimp simp add: do_user_op_H_def monad_to_transition_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule doUserOp_valid_duplicates') - apply (rule valid_corres_combined[OF do_user_op_invs2 corres_guard_imp2[OF do_user_op_corres]]) - apply clarsimp - apply (rule doUserOp_invs'[THEN hoare_weaken_pre]) - apply (fastforce simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related - valid_domain_list_from_invs') - apply (fastforce simp: ex_abs_def) - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: check_active_irq_H_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule checkActiveIRQ_valid_duplicates') - apply (rule valid_corres_combined[OF check_active_irq_invs_just_running checkActiveIRQ_just_running_corres]) - apply (rule checkActiveIRQ_invs'_just_running[THEN hoare_weaken_pre]) - apply (fastforce simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related - valid_domain_list_from_invs') - apply (fastforce simp: ex_abs_def) - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: check_active_irq_H_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule checkActiveIRQ_valid_duplicates') - apply (rule valid_corres_combined[OF check_active_irq_invs_just_idle checkActiveIRQ_just_idle_corres]) - apply (rule checkActiveIRQ_invs'_just_idle[THEN hoare_weaken_pre]) - apply clarsimp - apply (fastforce simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_idle_related sched_act_rct_related - valid_domain_list_from_invs') - apply (fastforce simp: ex_abs_def) - - apply (clarsimp simp: check_active_irq_H_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule checkActiveIRQ_valid_duplicates') - apply (rule valid_corres_combined[OF check_active_irq_invs check_active_irq_corres]) - apply (rule checkActiveIRQ_invs'[THEN hoare_weaken_pre]) - apply clarsimp - apply (fastforce simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_running_related ct_idle_related sched_act_rct_related - valid_domain_list_from_invs') - apply (fastforce simp: ex_abs_def) - done - -text \The top-level theorem\ - -lemma fw_sim_A_H: - "LI (ADT_A uop) - (ADT_H uop) - (lift_state_relation state_relation) - (full_invs \ full_invs')" - apply (unfold LI_def full_invs_def full_invs'_def) - apply (simp add: ADT_H_def ADT_A_def) - apply (intro conjI) - apply (rule init_refinement) - apply (clarsimp simp: rel_semi_def relcomp_unfold in_lift_state_relation_eq) - apply (rename_tac tc ak m ev tc' ck' m' ev' ck) - apply (simp add: global_automaton_def) - - apply (erule_tac P="a \ (\x. b x)" for a b in disjE) - apply (clarsimp simp add: kernel_call_H_def kernel_call_A_def) - apply (rule rev_mp, rule_tac tc=tc and event=x in entry_corres) - apply (clarsimp simp: corres_underlying_def) - apply (drule (1) bspec) - apply (clarsimp simp: sch_act_simple_def) - apply (drule (1) bspec) - apply clarsimp - apply (rule conjI) - apply clarsimp - apply (rule_tac x=b in exI) - apply (rule conjI) - apply (rule impI, simp) - apply (frule (2) ct_running_related) - apply clarsimp - apply (rule_tac x=b in exI) - apply (drule use_valid, rule kernelEntry_invs') - apply (simp add: sch_act_simple_def) - apply clarsimp - apply (frule (1) ct_idle_related) - apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: do_user_op_H_def do_user_op_A_def monad_to_transition_def) - apply (rule rev_mp, rule_tac tc1=tc and f1=uop and P="ct_running and einvs" in corres_guard_imp2[OF do_user_op_corres]) - apply simp - apply (clarsimp simp add: corres_underlying_def) - apply (drule (1) bspec, clarsimp) - apply (drule (1) bspec, clarsimp) - apply fastforce - - apply (erule_tac P="a \ b \ c \ (\x. d x)" for a b c d in disjE) - apply (clarsimp simp: do_user_op_H_def do_user_op_A_def monad_to_transition_def) - apply (rule rev_mp, rule_tac tc1=tc and f1=uop and P="ct_running and einvs" in corres_guard_imp2[OF do_user_op_corres]) - apply simp - apply (clarsimp simp add: corres_underlying_def) - apply (drule (1) bspec, clarsimp) - apply (drule (1) bspec, clarsimp) - apply fastforce - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def) - apply (rule rev_mp, rule check_active_irq_corres) - apply (clarsimp simp: corres_underlying_def) - apply fastforce - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def) - apply (rule rev_mp, rule check_active_irq_corres) - apply (clarsimp simp: corres_underlying_def) - apply fastforce - - apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def) - apply (rule rev_mp, rule check_active_irq_corres) - apply (clarsimp simp: corres_underlying_def) - apply fastforce - - apply (clarsimp simp: absKState_correct dest!: lift_state_relationD) - done - -theorem refinement: - "ADT_H uop \ ADT_A uop" - apply (rule sim_imp_refines) - apply (rule L_invariantI) - apply (rule akernel_invariant) - apply (rule ckernel_invariant) - apply (rule fw_sim_A_H) - done - -end +interpretation Refine?: Refine +proof goal_cases + interpret Arch . + case 1 show ?case by (intro_locales; (unfold_locales; (fact Refine_assms)?)?) +qed end diff --git a/proof/refine/RISCV64/ArchRefine.thy b/proof/refine/RISCV64/ArchRefine.thy index 48151faa0e..18125469ab 100644 --- a/proof/refine/RISCV64/ArchRefine.thy +++ b/proof/refine/RISCV64/ArchRefine.thy @@ -9,17 +9,18 @@ theory ArchRefine imports Refine - PageTableDuplicates begin -context begin interpretation Arch . (*FIXME: arch-split*) +context Arch begin arch_global_naming + +named_theorems Refine_assms text \User memory content is the same on both levels\ lemma typ_at_AUserDataI: "\ typ_at (AArch (AUserData sz)) p s; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned' s'; pspace_distinct' s'; n < 2 ^ (pageBitsForSize sz - pageBits) \ - \ typ_at' UserDataT (p + n * 2 ^ pageBits) s'" - apply (clarsimp simp add: obj_at_def a_type_def ) + \ typ_at' UserDataT (p + n * 2 ^ pageBits) s'" + apply (clarsimp simp add: obj_at_def a_type_def) apply (simp split: Structures_A.kernel_object.split_asm arch_kernel_obj.split_asm split: if_split_asm) apply (drule(1) pspace_relation_absD) @@ -40,7 +41,7 @@ lemma typ_at_AUserDataI: lemma typ_at_ADeviceDataI: "\ typ_at (AArch (ADeviceData sz)) p s; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned' s'; pspace_distinct' s'; n < 2 ^ (pageBitsForSize sz - pageBits) \ - \ typ_at' UserDataDeviceT (p + n * 2 ^ pageBits) s'" + \ typ_at' UserDataDeviceT (p + n * 2 ^ pageBits) s'" apply (clarsimp simp add: obj_at_def a_type_def ) apply (simp split: Structures_A.kernel_object.split_asm arch_kernel_obj.split_asm split: if_split_asm) @@ -62,7 +63,7 @@ lemma typ_at_ADeviceDataI: lemma typ_at_UserDataI: "\ typ_at' UserDataT (p && ~~ mask pageBits) s'; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned s \ - \ \sz. typ_at (AArch (AUserData sz)) (p && ~~ mask (pageBitsForSize sz)) s" + \ \sz. typ_at (AArch (AUserData sz)) (p && ~~ mask (pageBitsForSize sz)) s" apply (clarsimp simp: exists_disj obj_at'_def typ_at'_def ko_wp_at'_def) apply (frule (1) in_related_pspace_dom) apply (clarsimp simp: pspace_dom_def) @@ -91,7 +92,7 @@ lemma typ_at_UserDataI: lemma typ_at_DeviceDataI: "\ typ_at' UserDataDeviceT (p && ~~ mask pageBits) s'; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned s \ - \ \sz. typ_at (AArch (ADeviceData sz)) (p && ~~ mask (pageBitsForSize sz)) s" + \ \sz. typ_at (AArch (ADeviceData sz)) (p && ~~ mask (pageBitsForSize sz)) s" apply (clarsimp simp: exists_disj obj_at'_def typ_at'_def ko_wp_at'_def) apply (frule (1) in_related_pspace_dom) apply (clarsimp simp: pspace_dom_def) @@ -117,845 +118,152 @@ lemma typ_at_DeviceDataI: apply (simp add: obj_at_def a_type_def) done -lemma pointerInUserData_relation: +lemma and_mask_pbfs_shiftr_pageBits_limit: + "p && mask (pageBitsForSize sz) >> pageBits < 2 ^ (pageBitsForSize sz - pageBits)" for p :: obj_ref + apply (rule shiftr_less_t2n') + apply (simp add: pbfs_atleast_pageBits mask_twice) + apply (case_tac sz; simp add: bit_simps) + done + +lemma p_and_not_mask_pbfs_add_mask_pbfs_eq: + "(p && ~~ mask (pageBitsForSize sz)) + (p && mask (pageBitsForSize sz) >> pageBits) * 2 ^ pageBits + = p && ~~ mask pageBits" + for p :: obj_ref + by (simp flip: shiftl_t2n' + add: shiftr_shiftl1 mask_out_add_aligned is_aligned_neg_mask pbfs_atleast_pageBits + word_plus_and_or_coroll2 add.commute) + +lemma pointerInUserData_relation[Refine_assms]: "\ (s,s') \ state_relation; valid_state' s'; valid_state s\ \ pointerInUserData p s' = in_user_frame p s" apply (simp add: pointerInUserData_def in_user_frame_def) apply (rule iffI) - apply (erule typ_at_UserDataI, (clarsimp simp: valid_state_def)+)[1] + apply (erule typ_at_UserDataI; clarsimp simp: valid_state_def) apply clarsimp - apply (drule_tac sz = sz and - n = "(p && mask (pageBitsForSize sz)) >> pageBits" - in typ_at_AUserDataI [where s = s and s' = s']) - apply (fastforce simp: valid_state'_def)+ - apply (rule shiftr_less_t2n') - apply (simp add: pbfs_atleast_pageBits mask_twice) - apply (case_tac sz, simp_all add: bit_simps)[1] - apply (subgoal_tac "(p && ~~ mask (pageBitsForSize sz)) + (p && mask (pageBitsForSize sz) >> pageBits) * 2 ^ pageBits = (p && ~~ mask pageBits)") - apply simp - apply (subst mult.commute) - apply (subst shiftl_t2n [symmetric]) - apply (simp add: shiftr_shiftl1) - apply (subst mask_out_add_aligned) - apply (rule is_aligned_neg_mask) - apply (simp add: pbfs_atleast_pageBits) - apply (subst add.commute) - apply (simp add: word_plus_and_or_coroll2) + apply (drule_tac sz=sz and n="(p && mask (pageBitsForSize sz)) >> pageBits" + in typ_at_AUserDataI [where s = s and s' = s']) + apply (fastforce simp: valid_state'_def and_mask_pbfs_shiftr_pageBits_limit)+ + apply (erule arg_cong[where f="\p. typ_at' _ p s'", THEN iffD1, rotated]) + apply (simp add: p_and_not_mask_pbfs_add_mask_pbfs_eq) done -lemma pointerInDeviceData_relation: +lemma pointerInDeviceData_relation[Refine_assms]: "\ (s,s') \ state_relation; valid_state' s'; valid_state s\ \ pointerInDeviceData p s' = in_device_frame p s" apply (simp add: pointerInDeviceData_def in_device_frame_def) apply (rule iffI) - apply (erule typ_at_DeviceDataI, (clarsimp simp: valid_state_def)+)[1] + apply (erule typ_at_DeviceDataI; clarsimp simp: valid_state_def) apply clarsimp - apply (drule_tac sz = sz and - n = "(p && mask (pageBitsForSize sz)) >> pageBits" - in typ_at_ADeviceDataI [where s = s and s' = s']) - apply (fastforce simp: valid_state'_def)+ - apply (rule shiftr_less_t2n') - apply (simp add: pbfs_atleast_pageBits mask_twice) - apply (case_tac sz, simp_all add: bit_simps)[1] - apply (subgoal_tac "(p && ~~ mask (pageBitsForSize sz)) + (p && mask (pageBitsForSize sz) >> pageBits) * 2 ^ pageBits = (p && ~~ mask pageBits)") - apply simp - apply (subst mult.commute) - apply (subst shiftl_t2n [symmetric]) - apply (simp add: shiftr_shiftl1) - apply (subst mask_out_add_aligned) - apply (rule is_aligned_neg_mask) - apply (simp add: pbfs_atleast_pageBits) - apply (subst add.commute) - apply (simp add: word_plus_and_or_coroll2) + apply (drule_tac sz=sz and n="(p && mask (pageBitsForSize sz)) >> pageBits" + in typ_at_ADeviceDataI[where s=s and s'=s']) + apply (fastforce simp: valid_state'_def and_mask_pbfs_shiftr_pageBits_limit)+ + apply (erule arg_cong[where f="\p. typ_at' _ p s'", THEN iffD1, rotated]) + apply (simp add: p_and_not_mask_pbfs_add_mask_pbfs_eq) done -lemma user_mem_relation: +lemma user_mem_relation[Refine_assms]: "\(s,s') \ state_relation; valid_state' s'; valid_state s\ \ user_mem' s' = user_mem s" - apply (rule ext) - apply (clarsimp simp: user_mem_def user_mem'_def pointerInUserData_relation pointerInDeviceData_relation) - apply (simp add: state_relation_def) - done + by (rule ext) + (clarsimp simp: user_mem_def user_mem'_def pointerInUserData_relation pointerInDeviceData_relation + state_relation_def) -lemma device_mem_relation: +lemma device_mem_relation[Refine_assms]: "\(s,s') \ state_relation; valid_state' s'; valid_state s\ \ device_mem' s' = device_mem s" - apply (rule ext) - apply (clarsimp simp: device_mem_def device_mem'_def pointerInUserData_relation - pointerInDeviceData_relation) - done - -lemma absKState_correct: - assumes invs: "einvs (s :: det_ext state)" and invs': "invs' s'" - assumes rel: "(s,s') \ state_relation" - shows "absKState s' = abs_state s" - using assms - apply (intro state.equality, simp_all add: absKState_def abs_state_def) - apply (rule absHeap_correct; clarsimp elim!: state_relationE) - apply (rule absCDT_correct; clarsimp) - apply (rule absIsOriginalCap_correct; clarsimp) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (clarsimp simp: state_relation_def) - apply (rule absSchedulerAction_correct, simp add: state_relation_def) - apply (simp add: domSchedule_map_relation) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def ready_queues_relation_def ready_queue_relation_def Let_def - list_queue_relation_def) - apply (fastforce dest: heap_ls_is_walk) - apply (clarsimp simp: user_mem_relation invs_def invs'_def) - apply (simp add: state_relation_def) - apply (rule absInterruptIRQNode_correct, simp add: state_relation_def) - apply (rule absInterruptStates_correct, simp add: state_relation_def) - apply (rule absArchState_correct, simp) - apply (rule absExst_correct; simp) - done - -text \The top-level invariance\ - -lemma set_thread_state_sched_act: - "\(\s. runnable state) and (\s. P (scheduler_action s))\ - set_thread_state thread state - \\rs s. P (scheduler_action (s::det_state))\" - apply (simp add: set_thread_state_def) - apply wp - apply (simp add: set_thread_state_act_def) - apply wp - apply (rule hoare_pre_cont) - apply (rule_tac Q'="\rv. (\s. runnable ts) and (\s. P (scheduler_action s))" - in hoare_strengthen_post) - apply wp - apply force - apply (wp gts_st_tcb_at)+ - apply (rule_tac Q'="\rv. st_tcb_at ((=) state) thread and (\s. runnable state) and (\s. P (scheduler_action s))" in hoare_strengthen_post) - apply (simp add: st_tcb_at_def) - apply (wp obj_set_prop_at)+ - apply (force simp: st_tcb_at_def obj_at_def) - apply wp - apply clarsimp - done + by (rule ext) + (clarsimp simp: device_mem_def device_mem'_def pointerInUserData_relation + pointerInDeviceData_relation) -lemma activate_thread_sched_act: +lemma arch_activate_thread_sched_act[Refine_assms]: "\ct_in_state activatable and (\s. P (scheduler_action s))\ - activate_thread - \\rs s. P (scheduler_action (s::det_state))\" - by (simp add: activate_thread_def set_thread_state_def arch_activate_idle_thread_def - | (wp set_thread_state_sched_act gts_wp)+ | wpc)+ - -lemma schedule_sched_act_rct[wp]: - "\\\ Schedule_A.schedule - \\rs (s::det_state). scheduler_action s = resume_cur_thread\" - unfolding Schedule_A.schedule_def - by (wpsimp) - -lemma call_kernel_sched_act_rct[wp]: - "\einvs and (\s. e \ Interrupt \ ct_running s) and (\s. scheduler_action s = resume_cur_thread)\ - call_kernel e - \\rs (s::det_state). scheduler_action s = resume_cur_thread\" - unfolding call_kernel_def - by (wpsimp wp: activate_thread_sched_act handle_spurious_irq_invs simp: active_from_running) - -lemma kernel_entry_invs: - "\einvs and (\s. e \ Interrupt \ ct_running s) - and (\s. 0 < domain_time s) and valid_domain_list and (ct_running or ct_idle) - and (\s. scheduler_action s = resume_cur_thread)\ - kernel_entry e us - \\rv. einvs and (\s. ct_running s \ ct_idle s) - and (\s. 0 < domain_time s) and valid_domain_list - and (\s. scheduler_action s = resume_cur_thread)\" - apply (rule_tac Q'="\rv. invs and (\s. ct_running s \ ct_idle s) and valid_sched and - (\s. 0 < domain_time s) and valid_domain_list and - valid_list and (\s. scheduler_action s = resume_cur_thread)" - in hoare_post_imp) - apply clarsimp - apply (simp add: kernel_entry_def) - apply (wp akernel_invs_det_ext call_kernel_valid_sched thread_set_invs_trivial - thread_set_not_state_valid_sched - hoare_vcg_disj_lift ct_in_state_thread_state_lift thread_set_no_change_tcb_state - call_kernel_domain_time_inv_det_ext call_kernel_domain_list_inv_det_ext - hoare_weak_lift_imp valid_domain_list_lift - | clarsimp simp add: tcb_cap_cases_def active_from_running)+ - done - -definition - "full_invs \ {((tc, s :: det_ext state), m, e). einvs s \ - (ct_running s \ ct_idle s) \ - (m = KernelMode \ e \ None) \ - (m = UserMode \ ct_running s) \ - (m = IdleMode \ ct_idle s) \ - (e \ None \ e \ Some Interrupt \ ct_running s) \ - 0 < domain_time s \ valid_domain_list s \ - (scheduler_action s = resume_cur_thread)}" - -crunch do_user_op - for valid_list: valid_list - and valid_sched: valid_sched - and sched_act: "\s. P (scheduler_action s)" - and domain_fields_inv[wp]: "domain_fields P" - -lemma do_user_op_invs2: - "\einvs and ct_running and (\s. scheduler_action s = resume_cur_thread) - and (\s. 0 < domain_time s) and valid_domain_list \ - do_user_op f tc - \\_. (einvs and ct_running and (\s. scheduler_action s = resume_cur_thread)) - and (\s. 0 < domain_time s) and valid_domain_list \" - apply (rule_tac Q'="\_. valid_list and valid_sched and - (\s. scheduler_action s = resume_cur_thread) and (invs and ct_running) and - (\s. 0 < domain_time s) and valid_domain_list" - in hoare_strengthen_post) - apply (wpsimp wp: do_user_op_valid_list do_user_op_valid_sched do_user_op_sched_act - valid_domain_list_lift do_user_op_invs) - apply force - done - -lemmas ext_init_def = ext_init_det_ext_ext_def ext_init_unit_def + arch_activate_idle_thread t + \\rs s. P (scheduler_action (s::det_state))\" + by (wpsimp simp: arch_activate_idle_thread_def) -lemma valid_list_init[simp]: +lemma valid_list_init[Refine_assms, simp]: "valid_list init_A_st" by (simp add: valid_list_2_def init_A_st_def ext_init_def init_cdt_def) -lemmas valid_list_inits[simp] = valid_list_init[simplified] - -lemma valid_sched_init[simp]: +lemma valid_sched_init[Refine_assms, simp]: "valid_sched init_A_st" apply (simp add: valid_sched_def init_A_st_def ext_init_def) apply (clarsimp simp: init_kheap_def st_tcb_at_kh_def obj_at_kh_def obj_at_def idle_thread_ptr_def valid_queues_2_def ct_not_in_q_def not_queued_def valid_sched_action_def is_activatable_def init_irq_node_ptr_def - riscv_global_pt_ptr_def init_global_pt_def + init_global_pt_def riscv_global_pt_ptr_def ct_in_cur_domain_2_def valid_blocked_2_def valid_idle_etcb_def etcb_at'_def etcbs_of'_def) done -lemma valid_domain_list_init[simp]: +lemma valid_domain_list_init[Refine_assms, simp]: "valid_domain_list init_A_st" by (simp add: init_A_st_def ext_init_def valid_domain_list_def) -lemma akernel_invariant: - "ADT_A uop \ full_invs" - unfolding full_invs_def - apply (rule invariantI) - apply (clarsimp simp: ADT_A_def subset_iff) - apply (frule bspec[OF akernel_init_invs]) - apply (simp add: Let_def Init_A_def) - apply (simp add: init_A_st_def ext_init_def) - apply (clarsimp simp: ADT_A_def global_automaton_def) - - apply (rename_tac tc' s' mode' e' tc s mode e) - apply (elim disjE) - apply ((clarsimp simp: kernel_call_A_def - | drule use_valid[OF _ kernel_entry_invs])+)[2] - apply ((clarsimp simp: do_user_op_A_def monad_to_transition_def - check_active_irq_A_def - | drule use_valid[OF _ do_user_op_invs2] - | drule use_valid[OF _ check_active_irq_invs_just_running])+)[2] - apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs])+)[1] - apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) - apply ((clarsimp simp add: do_user_op_A_def check_active_irq_A_def - | drule use_valid[OF _ do_user_op_invs2] - | drule use_valid[OF _ check_active_irq_invs_just_running])+)[1] - apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) - apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) - apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs])+)[1] - apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs_just_idle])+)[1] - apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs])+)[1] - done +lemma valid_domain_time_init[Refine_assms, simp]: + "0 < domain_time init_A_st" + by (simp add: init_A_st_def) -lemma ckernel_invs: - "\invs' and (\s. e \ Interrupt \ ct_running' s) and - (\s. ksSchedulerAction s = ResumeCurrentThread)\ - callKernel e - \\rs. (\s. ksSchedulerAction s = ResumeCurrentThread) and (invs' and (ct_running' or ct_idle'))\" - unfolding callKernel_def - by (wpsimp wp: activate_invs' activate_sch_act schedule_sch schedule_sch_act_simple he_invs' - schedule_invs' hoare_drop_imps - simp: no_irq_getActiveIRQ) +lemma sched_act_init[Refine_assms, simp]: + "scheduler_action init_A_st = resume_cur_thread" + by (simp add: init_A_st_def) (* nothing extra needed on this architecture *) defs fastpathKernelAssertions_def: "fastpathKernelAssertions \ \s. True" -lemma fastpathKernelAssertions_cross: +lemma fastpathKernelAssertions_cross[Refine_assms]: "\ (s,s') \ state_relation; invs s; valid_arch_state' s'\ \ fastpathKernelAssertions s'" unfolding fastpathKernelAssertions_def - by simp - -(* this is only needed for callKernel, where we have invs' on concrete side *) -lemma corres_cross_over_fastpathKernelAssertions: - "\ \s. P s \ invs s; \s'. Q s' \ invs' s'; - corres r P (Q and fastpathKernelAssertions) f g \ \ - corres r P Q f g" - by (rule corres_cross_over_guard[where Q="Q and fastpathKernelAssertions"]) - (fastforce elim: fastpathKernelAssertions_cross)+ - -defs kernelExitAssertions_def: - "kernelExitAssertions s \ 0 < ksDomainTime s" - -lemma callKernel_domain_time_left: - "\\\ callKernel e \\_ s. 0 < ksDomainTime s\" - unfolding callKernel_def kernelExitAssertions_def by wpsimp - -lemma doMachineOp_sch_act_simple: - "doMachineOp f \sch_act_simple\" - by (wp sch_act_simple_lift) - -lemma kernelEntry_invs': - "\ invs' and (\s. e \ Interrupt \ ct_running' s) and - (ct_running' or ct_idle') and - (\s. ksSchedulerAction s = ResumeCurrentThread) and - (\s. 0 < ksDomainTime s) \ - kernelEntry e tc - \\rs. (\s. ksSchedulerAction s = ResumeCurrentThread) and - (invs' and (ct_running' or ct_idle')) and - (\s. 0 < ksDomainTime s) \" - apply (simp add: kernelEntry_def) - apply (wp ckernel_invs callKernel_domain_time_left - threadSet_invs_trivial threadSet_ct_running' - TcbAcc_R.dmo_invs' hoare_weak_lift_imp - doMachineOp_ct_in_state' doMachineOp_sch_act_simple - callKernel_domain_time_left - | clarsimp simp: user_memory_update_def no_irq_def tcb_at_invs')+ - done - -lemma ptable_lift_abs_state[simp]: - "ptable_lift t (abs_state s) = ptable_lift t s" - by (simp add: ptable_lift_def abs_state_def) - -lemma ptable_rights_abs_state[simp]: - "ptable_rights t (abs_state s) = ptable_rights t s" - by (simp add: ptable_rights_def abs_state_def) - -lemma ptable_rights_imp_UserData: - assumes invs: "einvs s" and invs': "invs' s'" - assumes rel: "(s,s') : state_relation" - assumes rights: "ptable_rights t (absKState s') x \ {}" - assumes trans: - "ptable_lift t (absKState s') x = Some (RISCV64.addrFromPPtr y)" - shows "pointerInUserData y s' \ pointerInDeviceData y s'" -proof - - from invs invs' rel have [simp]: "absKState s' = abs_state s" - by - (rule absKState_correct, simp_all) - from invs have valid: "valid_state s" by auto - from invs' have valid': "valid_state' s'" by auto - have "in_user_frame y s \ in_device_frame y s " - by (rule ptable_rights_imp_frame[OF valid rights[simplified] - trans[simplified]]) - thus ?thesis - by (auto simp add: pointerInUserData_relation[OF rel valid' valid] - pointerInDeviceData_relation[OF rel valid' valid]) -qed + by clarsimp -lemma device_update_invs': - "\invs'\doMachineOp (device_memory_update ds) - \\_. invs'\" - apply (simp add: doMachineOp_def device_memory_update_def simpler_modify_def select_f_def - gets_def get_def bind_def valid_def return_def) - by (clarsimp simp: invs'_def valid_state'_def valid_irq_states'_def valid_machine_state'_def) - -crunch doMachineOp - for ksDomainTime[wp]: "\s. P (ksDomainTime s)" - -lemma doUserOp_invs': - "\invs' and ex_abs einvs and - (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_running' and - (\s. 0 < ksDomainTime s)\ - doUserOp f tc - \\_. invs' and - (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_running' and - (\s. 0 < ksDomainTime s)\" - apply (simp add: doUserOp_def split_def ex_abs_def) - apply (wp device_update_invs' doMachineOp_ct_in_state' - | (wp (once) dmo_invs', wpsimp simp: no_irq_modify device_memory_update_def - user_memory_update_def))+ - apply (clarsimp simp: user_memory_update_def simpler_modify_def - restrict_map_def - split: option.splits) - apply (frule ptable_rights_imp_UserData[rotated 2], auto) - done - - -text \The top-level correspondence\ - -lemma contract_all_imp_strg': - "P \ P' \ P'' \ (\x. R x \ Q x) \ \x. R x \ P \ Q x \ P' \ P''" - by blast - -lemma kernel_corres': - "corres dc (einvs and (\s. event \ Interrupt \ ct_running s) and (ct_running or ct_idle) - and (\s. scheduler_action s = resume_cur_thread) and valid_domain_list) - (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and - (\s. ksSchedulerAction s = ResumeCurrentThread)) - (call_kernel event) - (do _ \ runExceptT $ - handleEvent event `~catchError~` - (\_. withoutPreemption $ maybeHandleInterrupt True); - _ \ ThreadDecls_H.schedule; - activateThread - od)" - unfolding call_kernel_def - apply (corres simp: irq_state_independent_def - corres: handleEvent_corres maybeHandleInterrupt_corres - | corres_cases_both)+ - apply (wpsimp wp: handle_event_valid_sched)+ - apply (corres corres: schedule_corres activateThread_corres) - apply (wpsimp wp: handle_interrupt_valid_sched[unfolded non_kernel_IRQs_def, simplified] - schedule_invs' hoare_vcg_if_lift2 hoare_drop_imps handle_spurious_irq_invs - valid_domain_list_lift[of handle_spurious_irq] - valid_domain_list_lift[of "handle_interrupt irq" for irq] - valid_domain_list_lift[of "do_machine_op mop" for mop] - simp: maybe_handle_interrupt_def)+ - apply (rule_tac Q'="\_. valid_domain_list and valid_sched and invs and valid_list" and - E'="\_. valid_domain_list and valid_sched and invs and valid_list" - in hoare_strengthen_postE) - apply (wpsimp wp: handle_event_valid_sched)+ - apply (clarsimp simp: active_from_running schact_is_rct_def) - apply (clarsimp simp: active_from_running') - done - -lemma kernel_corres: - "corres dc (einvs and (\s. event \ Interrupt \ ct_running s) and (ct_running or ct_idle) and - (\s. scheduler_action s = resume_cur_thread) and - (\s. 0 < domain_time s \ valid_domain_list s)) - (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and - (\s. ksSchedulerAction s = ResumeCurrentThread)) - (call_kernel event) (callKernel event)" - unfolding callKernel_def K_bind_def - apply (rule corres_cross_over_fastpathKernelAssertions, blast+) - apply (rule corres_stateAssert_r) - apply (rule corres_guard_imp) - apply (rule corres_add_noop_lhs2) - apply (simp only: bind_assoc[symmetric]) - apply (rule corres_split[where r'=dc and - R="\_ s. 0 < domain_time s \ valid_domain_list s" and - R'="\_. \"]) - apply (simp only: bind_assoc) - apply (rule kernel_corres') - apply (rule corres_bind_return2, rule corres_stateAssert_assume_stronger) - apply simp - apply (simp add: kernelExitAssertions_def state_relation_def) - apply (wp call_kernel_domain_time_inv_det_ext call_kernel_domain_list_inv_det_ext) - apply wp - apply clarsimp - apply clarsimp - done - -lemma user_mem_corres: - "corres (=) invs invs' (gets (\x. g (user_mem x))) (gets (\x. g (user_mem' x)))" - by (clarsimp simp add: gets_def get_def return_def bind_def - invs_def invs'_def - corres_underlying_def user_mem_relation) - -lemma device_mem_corres: - "corres (=) invs invs' (gets (\x. g (device_mem x))) (gets (\x. g (device_mem' x)))" - by (clarsimp simp add: gets_def get_def return_def bind_def - invs_def invs'_def - corres_underlying_def device_mem_relation) - -lemma entry_corres: - "corres (=) (einvs and (\s. event \ Interrupt \ ct_running s) and - (\s. 0 < domain_time s) and valid_domain_list and (ct_running or ct_idle) and - (\s. scheduler_action s = resume_cur_thread)) - (invs' and (\s. event \ Interrupt \ ct_running' s) and - (\s. 0 < ksDomainTime s) and (ct_running' or ct_idle') and - (\s. ksSchedulerAction s = ResumeCurrentThread)) - (kernel_entry event tc) (kernelEntry event tc)" - apply (simp add: kernel_entry_def kernelEntry_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getCurThread_corres]) - apply (rule corres_split) - apply simp - apply (rule threadset_corresT; simp?) - apply (simp add: tcb_relation_def arch_tcb_relation_def - arch_tcb_context_set_def atcbContextSet_def) - apply (clarsimp simp: tcb_cap_cases_def) - apply (clarsimp simp: tcb_cte_cases_def tcb_cte_cases_neqs) - apply (rule corres_split[OF kernel_corres]) - apply (rule corres_split_eqr[OF getCurThread_corres]) - apply (rule threadGet_corres) - apply (simp add: tcb_relation_def arch_tcb_relation_def - arch_tcb_context_get_def atcbContextGet_def) - apply wp+ - apply (rule hoare_strengthen_post, rule akernel_invs_det_ext, - 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 - threadSet_invs_trivial threadSet_ct_running' - thread_set_not_state_valid_sched hoare_weak_lift_imp - hoare_vcg_disj_lift ct_in_state_thread_state_lift - thread_set_no_change_tcb_state - | simp add: tcb_cap_cases_def ct_in_state'_def schact_is_rct_def - | (wps, wp threadSet_st_tcb_at2) )+ - apply (clarsimp simp: invs_def cur_tcb_def valid_state_def valid_pspace_def) - apply (clarsimp simp: ct_in_state'_def) - done - -lemma corres_gets_machine_state: - "corres (=) \ \ (gets (f \ machine_state)) (gets (f \ ksMachineState))" - by (clarsimp simp: gets_def corres_underlying_def - in_monad bind_def get_def return_def state_relation_def) - -lemma do_user_op_corres: - "corres (=) (einvs and ct_running) - (invs' and (%s. ksSchedulerAction s = ResumeCurrentThread) and - ct_running') - (do_user_op f tc) (doUserOp f tc)" - apply (simp add: do_user_op_def doUserOp_def split_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getCurThread_corres]) - apply (rule_tac r'="(=)" and P=einvs and P'=invs' in corres_split) - apply (fastforce dest: absKState_correct [rotated]) - apply (rule_tac r'="(=)" and P=einvs and P'=invs' in corres_split) - apply (fastforce dest: absKState_correct [rotated]) - apply (rule_tac r'="(=)" and P=invs and P'=invs' in corres_split) - apply (rule user_mem_corres) - apply (rule_tac r'="(=)" and P=invs and P'=invs' in corres_split) - apply (rule device_mem_corres) - apply (rule_tac r'="(=)" in corres_split) - apply (rule corres_gets_machine_state) - apply (rule_tac F = "dom (rvb \ addrFromPPtr) \ - dom rvd" in corres_gen_asm) - apply (rule_tac F = "dom (rvc \ addrFromPPtr) \ dom rvd" in corres_gen_asm) - apply simp - apply (rule_tac r'="(=)" in corres_split[OF corres_select]) - apply simp - apply (rule corres_underlying_split[OF corres_machine_op]) - apply simp - apply (rule corres_underlying_trivial) - apply (simp add: user_memory_update_def) - apply (wp | simp)+ - apply (rule corres_underlying_split[OF corres_machine_op,where Q = dc and Q'=dc]) - apply (rule corres_underlying_trivial) - apply (wp | simp add: dc_def device_memory_update_def)+ - apply (clarsimp simp: invs_def valid_state_def pspace_respects_device_region_def) - apply fastforce - done - -lemma ct_running_related: - "\ (a, c) \ state_relation; ct_running' c \ - \ ct_running a" - apply (clarsimp simp: ct_in_state_def ct_in_state'_def - curthread_relation) - apply (frule(1) st_tcb_at_coerce_abstract) - apply (erule st_tcb_weakenE) - apply (case_tac st, simp_all)[1] - done - -lemma ct_idle_related: - "\ (a, c) \ state_relation; ct_idle' c \ - \ ct_idle a" - apply (clarsimp simp: ct_in_state_def ct_in_state'_def - curthread_relation) - apply (frule(1) st_tcb_at_coerce_abstract) - apply (erule st_tcb_weakenE) - apply (case_tac st, simp_all)[1] - done +(* interface lemma, no vs duplicates on this architecture *) +lemma callKernel_valid_duplicates'[Refine_assms]: + "\invs' and (\s. vs_valid_duplicates' (ksPSpace s)) and + (\s. ksSchedulerAction s = ResumeCurrentThread) and + (\s. e \ Interrupt \ ct_running' s)\ + callKernel e + \\rv s. vs_valid_duplicates' (ksPSpace s)\" + by wpsimp -definition - "full_invs' \ {((tc,s),m,e). invs' s \ - ex_abs (einvs::det_ext state \ bool) s \ - ksSchedulerAction s = ResumeCurrentThread \ - (ct_running' s \ ct_idle' s) \ - (m = KernelMode \ e \ None) \ - (m = UserMode \ ct_running' s) \ - (m = IdleMode \ ct_idle' s) \ - (e \ None \ e \ Some Interrupt \ ct_running' s) \ - 0 < ksDomainTime s}" - -lemma check_active_irq_corres': - "corres (=) \ \ (check_active_irq) (checkActiveIRQ)" - apply (simp add: check_active_irq_def checkActiveIRQ_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF corres_machine_op[OF corres_underlying_trivial], where R="\_. \" and R'="\_. \"]) - apply wpsimp+ - done +(* interface lemma, no vs duplicates on this architecture *) +lemma doUserOp_valid_duplicates'[Refine_assms]: + "doUserOp f tc \\s. vs_valid_duplicates' (ksPSpace s)\" + by wpsimp -lemma check_active_irq_corres: - "corres (=) - (invs and (ct_running or ct_idle) and einvs and (\s. scheduler_action s = resume_cur_thread) - and (\s. 0 < domain_time s) and valid_domain_list) - (invs' and (\s. ksSchedulerAction s = ResumeCurrentThread) - and (\s. 0 < ksDomainTime s) and (ct_running' or ct_idle')) - (check_active_irq) (checkActiveIRQ)" - apply (rule corres_guard_imp) - apply (rule check_active_irq_corres', auto) - done +(* interface lemma, no vs duplicates on this architecture *) +lemma checkActiveIRQ_valid_duplicates'[Refine_assms]: + "checkActiveIRQ \\s. vs_valid_duplicates' (ksPSpace s)\" + by wpsimp -lemma checkActiveIRQ_just_running_corres: - "corres (=) - (invs and ct_running and einvs and (\s. scheduler_action s = resume_cur_thread) - and (\s. 0 < domain_time s) and valid_domain_list) - (invs' and ct_running' - and (\s. 0 < ksDomainTime s) - and (\s. ksSchedulerAction s = ResumeCurrentThread)) - (check_active_irq) (checkActiveIRQ)" - apply (rule corres_guard_imp) - apply (rule check_active_irq_corres', auto) - done +lemma tcb_hyp_refs'_atcbContextSet[Refine_assms, simp]: + "tcb_hyp_refs' (atcbContextSet tc atcb) = tcb_hyp_refs' atcb" + by (simp add: atcbContextSet_def) -lemma checkActiveIRQ_just_idle_corres: - "corres (=) - (invs and ct_idle and einvs and (\s. scheduler_action s = resume_cur_thread) - and (\s. 0 < domain_time s) and valid_domain_list) - (invs' and ct_idle' - and (\s. 0 < ksDomainTime s) - and (\s. ksSchedulerAction s = ResumeCurrentThread)) - (check_active_irq) (checkActiveIRQ)" - apply (rule corres_guard_imp) - apply (rule check_active_irq_corres', auto) - done - -lemma checkActiveIRQ_invs': - "\invs' and ex_abs invs and (ct_running' or ct_idle') - and (\s. ksSchedulerAction s = ResumeCurrentThread)\ - checkActiveIRQ - \\_. invs' and (ct_running' or ct_idle') - and (\s. ksSchedulerAction s = ResumeCurrentThread)\" - apply (simp add: checkActiveIRQ_def ex_abs_def) - apply (wp dmo_invs' | simp)+ - done - -lemma checkActiveIRQ_invs'_just_running: - "\invs' and ex_abs invs and ct_running' - and (\s. ksSchedulerAction s = ResumeCurrentThread)\ - checkActiveIRQ - \\_. invs' and ct_running' - and (\s. ksSchedulerAction s = ResumeCurrentThread)\" - apply (simp add: checkActiveIRQ_def) - apply (wp | simp)+ - done +lemma ptable_lift_abs_state[Refine_assms, simp]: + "ptable_lift t (abs_state s) = ptable_lift t s" + by (simp add: ptable_lift_def abs_state_def) -lemma checkActiveIRQ_invs'_just_idle: - "\invs' and ex_abs invs and ct_idle' - and (\s. ksSchedulerAction s = ResumeCurrentThread)\ - checkActiveIRQ - \\_. invs' and ct_idle' - and (\s. ksSchedulerAction s = ResumeCurrentThread)\" - apply (simp add: checkActiveIRQ_def) - apply (wp | simp)+ - done +lemma ptable_rights_abs_state[Refine_assms, simp]: + "ptable_rights t (abs_state s) = ptable_rights t s" + by (simp add: ptable_rights_def abs_state_def) -lemma sched_act_rct_related: - "\ (a, c) \ state_relation; ksSchedulerAction c = ResumeCurrentThread\ - \ scheduler_action a = resume_cur_thread" - by (case_tac "scheduler_action a", simp_all add: state_relation_def) - -lemma domain_time_rel_eq: - "(a, c) \ state_relation \ P (ksDomainTime c) = P (domain_time a)" - by (clarsimp simp: state_relation_def) - -crunch doUserOp, checkActiveIRQ - for valid_objs': valid_objs' - (wp: crunch_wps - rule: doUserOp_def) (* FIXME: crunch can't find the rule of locale-defined constant *) - -lemma valid_domain_list_2_cross: - "\valid_dom_schedule'_2 sched idx start; domain_list_map dom_list = sched \ - \ valid_domain_list_2 start idx dom_list" - by (fastforce simp: valid_domain_list_2_def valid_dom_schedule'_2_def ucast_eq_0 is_up - split: prod.splits) - -lemma valid_domain_list_from_invs': - "\ (s, s') \ state_relation; invs' s' \ \ valid_domain_list s" - by (clarsimp simp: valid_domain_list_2_cross invs'_def valid_state'_def elim!: state_relationE) - -lemma ckernel_invariant: - "ADT_H uop \ full_invs'" - unfolding full_invs'_def - supply word_neq_0_conv[simp] - supply domain_time_rel_eq[simp] - apply (rule invariantI) - apply (clarsimp simp add: ADT_H_def) - apply (subst conj_commute, simp) - apply (rule conjI) - apply (frule init_refinement[simplified subset_eq, THEN bspec]) - apply (clarsimp simp: ex_abs_def lift_state_relation_def) - apply (frule akernel_init_invs[THEN bspec]) - apply (rule_tac x = s in exI) - apply (clarsimp simp: Init_A_def) - apply (insert ckernel_init_invs)[1] - apply clarsimp - apply (frule ckernel_init_sch_norm) - apply (frule ckernel_init_ctr) - apply (frule ckernel_init_domain_time) - apply (frule ckernel_init_domain_list) - apply (fastforce simp: Init_H_def) - apply (clarsimp simp: ADT_A_def ADT_H_def global_automaton_def) - - apply (erule_tac P="a \ (\x. b x)" for a b in disjE) - - apply (clarsimp simp: kernel_call_H_def) - - apply (drule use_valid[OF _ valid_corres_combined - [OF kernel_entry_invs entry_corres], - OF _ kernelEntry_invs'[THEN hoare_weaken_pre]]) - apply fastforce - - apply (clarsimp simp: ex_abs_def sch_act_simple_def ct_running_related ct_idle_related - sched_act_rct_related) - apply (rule exI, rule conjI, assumption) - apply simp - apply (fastforce simp: ex_abs_def sch_act_simple_def ct_running_related ct_idle_related - sched_act_rct_related valid_domain_list_from_invs') - apply (clarsimp simp: kernel_call_H_def) - apply (fastforce simp: ex_abs_def sch_act_simple_def ct_running_related ct_idle_related - sched_act_rct_related) - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp add: do_user_op_H_def monad_to_transition_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule doUserOp_valid_objs') - apply (rule valid_corres_combined[OF do_user_op_invs2 corres_guard_imp2[OF do_user_op_corres]]) - apply clarsimp - apply (rule doUserOp_invs'[THEN hoare_weaken_pre]) - apply (fastforce simp: ex_abs_def) - apply (clarsimp simp: invs_valid_objs' ex_abs_def, rule_tac x=s in exI, - clarsimp simp: ct_running_related sched_act_rct_related valid_domain_list_from_invs') - apply (clarsimp simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related) - - apply (erule_tac P="a \ b \ c \ (\x. d x)" for a b c d in disjE) - apply (clarsimp simp add: do_user_op_H_def monad_to_transition_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule doUserOp_valid_objs') - apply (rule valid_corres_combined[OF do_user_op_invs2 corres_guard_imp2[OF do_user_op_corres]]) - apply clarsimp - apply (rule doUserOp_invs'[THEN hoare_weaken_pre]) - apply (fastforce simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related - valid_domain_list_from_invs') - apply (fastforce simp: ex_abs_def) - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: check_active_irq_H_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule checkActiveIRQ_valid_objs') - apply (rule valid_corres_combined[OF check_active_irq_invs_just_running checkActiveIRQ_just_running_corres]) - apply (rule checkActiveIRQ_invs'_just_running[THEN hoare_weaken_pre]) - apply (fastforce simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related - valid_domain_list_from_invs') - apply (fastforce simp: ex_abs_def) - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: check_active_irq_H_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule checkActiveIRQ_valid_objs') - apply (rule valid_corres_combined[OF check_active_irq_invs_just_idle checkActiveIRQ_just_idle_corres]) - apply (rule checkActiveIRQ_invs'_just_idle[THEN hoare_weaken_pre]) - apply clarsimp - apply (fastforce simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_idle_related sched_act_rct_related - valid_domain_list_from_invs') - apply (fastforce simp: ex_abs_def) - - apply (clarsimp simp: check_active_irq_H_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule checkActiveIRQ_valid_objs') - apply (rule valid_corres_combined[OF check_active_irq_invs check_active_irq_corres]) - apply (rule checkActiveIRQ_invs'[THEN hoare_weaken_pre]) - apply clarsimp - apply (fastforce simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_running_related ct_idle_related sched_act_rct_related - valid_domain_list_from_invs') - apply (fastforce simp: ex_abs_def) - done +lemma arch_tcb_relation_arch_context_set[Refine_assms]: + "arch_tcb_relation atcb atcb' + \ arch_tcb_relation (arch_tcb_context_set tc atcb) (atcbContextSet tc atcb')" + by (simp add: arch_tcb_relation_def arch_tcb_context_set_def atcbContextSet_def) -text \The top-level theorem\ - -lemma fw_sim_A_H: - "LI (ADT_A uop) - (ADT_H uop) - (lift_state_relation state_relation) - (full_invs \ full_invs')" - apply (unfold LI_def full_invs_def full_invs'_def) - apply (simp add: ADT_H_def ADT_A_def) - apply (intro conjI) - apply (rule init_refinement) - apply (clarsimp simp: rel_semi_def relcomp_unfold in_lift_state_relation_eq) - apply (rename_tac tc ak m ev tc' ck' m' ev' ck) - apply (simp add: global_automaton_def) - - apply (erule_tac P="a \ (\x. b x)" for a b in disjE) - apply (clarsimp simp add: kernel_call_H_def kernel_call_A_def) - apply (rule rev_mp, rule_tac tc=tc and event=x in entry_corres) - apply (clarsimp simp: corres_underlying_def) - apply (drule (1) bspec) - apply (clarsimp simp: sch_act_simple_def) - apply (drule (1) bspec) - apply clarsimp - apply (rule conjI) - apply clarsimp - apply (rule_tac x=b in exI) - apply (rule conjI) - apply (rule impI, simp) - apply (frule (2) ct_running_related) - apply clarsimp - apply (rule_tac x=b in exI) - apply (drule use_valid, rule kernelEntry_invs') - apply (simp add: sch_act_simple_def) - apply clarsimp - apply (frule (1) ct_idle_related) - apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: do_user_op_H_def do_user_op_A_def monad_to_transition_def) - apply (rule rev_mp, rule_tac tc1=tc and f1=uop and P="ct_running and einvs" in corres_guard_imp2[OF do_user_op_corres]) - apply simp - apply (clarsimp simp add: corres_underlying_def) - apply (drule (1) bspec, clarsimp) - apply (drule (1) bspec, clarsimp) - apply fastforce - - apply (erule_tac P="a \ b \ c \ (\x. d x)" for a b c d in disjE) - apply (clarsimp simp: do_user_op_H_def do_user_op_A_def monad_to_transition_def) - apply (rule rev_mp, rule_tac tc1=tc and f1=uop and P="ct_running and einvs" in corres_guard_imp2[OF do_user_op_corres]) - apply simp - apply (clarsimp simp add: corres_underlying_def) - apply (drule (1) bspec, clarsimp) - apply (drule (1) bspec, clarsimp) - apply fastforce - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def) - apply (rule rev_mp, rule check_active_irq_corres) - apply (clarsimp simp: corres_underlying_def) - apply fastforce - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def) - apply (rule rev_mp, rule check_active_irq_corres) - apply (clarsimp simp: corres_underlying_def) - apply fastforce - - apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def) - apply (rule rev_mp, rule check_active_irq_corres) - apply (clarsimp simp: corres_underlying_def) - apply fastforce - - apply (clarsimp simp: absKState_correct dest!: lift_state_relationD) - done +lemma arch_tcb_relation_arch_context_get[Refine_assms]: + "arch_tcb_relation atcb atcb' \ arch_tcb_context_get atcb = atcbContextGet atcb'" + by (simp add: arch_tcb_relation_def arch_tcb_context_get_def atcbContextGet_def) -theorem refinement: - "ADT_H uop \ ADT_A uop" - apply (rule sim_imp_refines) - apply (rule L_invariantI) - apply (rule akernel_invariant) - apply (rule ckernel_invariant) - apply (rule fw_sim_A_H) - done +end (* Arch *) -end +interpretation Refine?: Refine +proof goal_cases + interpret Arch . + case 1 show ?case by (intro_locales; (unfold_locales; (fact Refine_assms)?)?) +qed end diff --git a/proof/refine/Refine.thy b/proof/refine/Refine.thy index 1378eb1b4c..e5dc5cd8c4 100644 --- a/proof/refine/Refine.thy +++ b/proof/refine/Refine.thy @@ -15,4 +15,828 @@ imports InitLemmas begin +arch_requalify_facts no_irq_getActiveIRQ (* FIXME arch-split: Machine_AI *) +arch_requalify_facts no_irq_modify (* FIXME arch-split: Machine_AI *) + +locale Refine = + assumes user_mem_relation: + "\s s'. + \(s,s') \ state_relation; valid_state' s'; valid_state s\ + \ user_mem' s' = user_mem s" + assumes device_mem_relation: + "\s s'. + \(s,s') \ state_relation; valid_state' s'; valid_state s\ + \ device_mem' s' = device_mem s" + assumes arch_activate_thread_sched_act: + "\t P. + \ct_in_state activatable and (\s. P (scheduler_action s))\ + arch_activate_idle_thread t + \\rs s. P (scheduler_action (s::det_state))\" + assumes valid_list_init[simp]: + "valid_list (init_A_st :: det_state)" + assumes sched_act_init[simp]: + "scheduler_action (init_A_st :: det_state) = resume_cur_thread" + (* sched_act_init being in the simpset automatically expands this to a no-longer-abbreviated + valid_sched_2 term we don't want to type out, but it's still used to simplify the proofs *) + assumes valid_sched_init[simplified, simp]: + "valid_sched (init_A_st :: det_state)" + assumes valid_domain_list_init[simp]: + "valid_domain_list (init_A_st :: det_state)" + assumes valid_domain_time_init[simp]: + "0 < domain_time (init_A_st :: det_state)" + assumes fastpathKernelAssertions_cross: + "\s s'. \(s,s') \ state_relation; invs s; valid_arch_state' s'\ \ fastpathKernelAssertions s'" + assumes callKernel_valid_duplicates': + "\e. + \invs' and (\s. vs_valid_duplicates' (ksPSpace s)) and + (\s. ksSchedulerAction s = ResumeCurrentThread) and + (\s. e \ Interrupt \ ct_running' s)\ + callKernel e + \\rv s. vs_valid_duplicates' (ksPSpace s)\" + assumes doUserOp_valid_duplicates': + "\f tc. doUserOp f tc \\s. vs_valid_duplicates' (ksPSpace s)\" + assumes checkActiveIRQ_valid_duplicates': + "checkActiveIRQ \\s. vs_valid_duplicates' (ksPSpace s)\" + assumes tcb_hyp_refs'_atcbContextSet[simp]: + "\tc atcb. tcb_hyp_refs' (atcbContextSet tc atcb) = tcb_hyp_refs' atcb" + assumes ptable_lift_abs_state[simp]: + "\t (s::det_state). ptable_lift t (abs_state s) = ptable_lift t s" + assumes ptable_rights_abs_state[simp]: + "\t (s::det_state). ptable_rights t (abs_state s) = ptable_rights t s" + assumes pointerInUserData_relation: + "\s s' p. + \ (s,s') \ state_relation; valid_state' s'; valid_state s\ + \ pointerInUserData p s' = in_user_frame p s" + assumes pointerInDeviceData_relation: + "\s s' p. + \ (s,s') \ state_relation; valid_state' s'; valid_state s\ + \ pointerInDeviceData p s' = in_device_frame p s" + assumes arch_tcb_relation_arch_context_set: + "\atcb atcb' tc. + arch_tcb_relation atcb atcb' + \ arch_tcb_relation (arch_tcb_context_set tc atcb) (atcbContextSet tc atcb')" + assumes arch_tcb_relation_arch_context_get: + "\atcb atcb'. + arch_tcb_relation atcb atcb' \ arch_tcb_context_get atcb = atcbContextGet atcb'" +begin + +lemma absKState_correct: + assumes invs: "einvs (s :: det_ext state)" and invs': "invs' s'" + assumes rel: "(s,s') \ state_relation" + shows "absKState s' = abs_state s" + using assms + apply (intro state.equality, simp_all add: absKState_def abs_state_def) + apply (rule absHeap_correct; clarsimp elim!: state_relationE) + apply (rule absCDT_correct; clarsimp) + apply (rule absIsOriginalCap_correct; clarsimp) + apply (simp add: state_relation_def) + apply (simp add: state_relation_def) + apply (clarsimp simp: state_relation_def) + apply (rule absSchedulerAction_correct, simp add: state_relation_def) + apply (simp add: domSchedule_map_relation) + apply (simp add: state_relation_def) + apply (simp add: state_relation_def) + apply (simp add: state_relation_def) + apply (simp add: state_relation_def) + apply (simp add: state_relation_def ready_queues_relation_def ready_queue_relation_def Let_def + list_queue_relation_def) + apply (fastforce dest: heap_ls_is_walk) + apply (clarsimp simp: user_mem_relation invs_def invs'_def) + apply (simp add: state_relation_def) + apply (rule absInterruptIRQNode_correct, simp add: state_relation_def) + apply (rule absInterruptStates_correct, simp add: state_relation_def) + apply (rule absArchState_correct, simp) + apply (rule absExst_correct; simp) + done + +end (* Refine *) + +text \The top-level invariance\ + +lemma set_thread_state_sched_act: + "\(\s. runnable state) and (\s. P (scheduler_action s))\ + set_thread_state thread state + \\rs s. P (scheduler_action (s::det_state))\" + apply (simp add: set_thread_state_def) + apply wp + apply (simp add: set_thread_state_act_def) + apply wp + apply (rule hoare_pre_cont) + apply (rule_tac Q'="\rv. (\s. runnable ts) and (\s. P (scheduler_action s))" + in hoare_strengthen_post) + apply wp + apply force + apply (wp gts_st_tcb_at)+ + apply (rule_tac Q'="\rv. st_tcb_at ((=) state) thread + and (\s. runnable state) + and (\s. P (scheduler_action s))" + in hoare_strengthen_post) + apply (simp add: st_tcb_at_def) + apply (wp obj_set_prop_at)+ + apply (force simp: st_tcb_at_def obj_at_def) + apply wp + apply clarsimp + done + +lemma schedule_sched_act_rct[wp]: + "\\\ Schedule_A.schedule + \\rs (s::det_state). scheduler_action s = resume_cur_thread\" + unfolding Schedule_A.schedule_def + by (wpsimp) + +context Refine begin + +lemma activate_thread_sched_act: + "\ct_in_state activatable and (\s. P (scheduler_action s))\ + activate_thread + \\rs s. P (scheduler_action (s::det_state))\" + by (wpsimp simp: activate_thread_def set_thread_state_def + wp: set_thread_state_sched_act gts_wp arch_activate_thread_sched_act) + +lemma call_kernel_sched_act_rct[wp]: + "\einvs and (\s. e \ Interrupt \ ct_running s) and (\s. scheduler_action s = resume_cur_thread)\ + call_kernel e + \\rs (s::det_state). scheduler_action s = resume_cur_thread\" + unfolding call_kernel_def + by (wpsimp wp: activate_thread_sched_act handle_spurious_irq_invs simp: active_from_running) + +lemma kernel_entry_invs: + "\einvs and (\s. e \ Interrupt \ ct_running s) + and (\s. 0 < domain_time s) and valid_domain_list and (ct_running or ct_idle) + and (\s. scheduler_action s = resume_cur_thread)\ + kernel_entry e us + \\rv. einvs and (\s. ct_running s \ ct_idle s) + and (\s. 0 < domain_time s) and valid_domain_list + and (\s. scheduler_action s = resume_cur_thread)\" + apply (rule_tac Q'="\rv. invs and (\s. ct_running s \ ct_idle s) and valid_sched and + (\s. 0 < domain_time s) and valid_domain_list and + valid_list and (\s. scheduler_action s = resume_cur_thread)" + in hoare_post_imp) + apply clarsimp + apply (simp add: kernel_entry_def) + apply (wp akernel_invs_det_ext call_kernel_valid_sched thread_set_invs_trivial + thread_set_not_state_valid_sched + hoare_vcg_disj_lift ct_in_state_thread_state_lift thread_set_no_change_tcb_state + call_kernel_domain_time_inv_det_ext call_kernel_domain_list_inv_det_ext + hoare_weak_lift_imp valid_domain_list_lift + | clarsimp simp add: tcb_cap_cases_def active_from_running)+ + done + +end (* Refine *) + +definition full_invs :: "(('user_context \ det_ext state) \ mode \ event option) set" where + "full_invs \ {((tc, s :: det_ext state), m, e). + einvs s \ + (ct_running s \ ct_idle s) \ + (m = KernelMode \ e \ None) \ + (m = UserMode \ ct_running s) \ + (m = IdleMode \ ct_idle s) \ + (e \ None \ e \ Some Interrupt \ ct_running s) \ + 0 < domain_time s \ valid_domain_list s \ + (scheduler_action s = resume_cur_thread)}" + +crunch do_user_op + for valid_list: valid_list + and valid_sched: valid_sched + and sched_act: "\s. P (scheduler_action s)" + and domain_fields_inv[wp]: "domain_fields P" + +lemma do_user_op_invs2: + "\einvs and ct_running and (\s. scheduler_action s = resume_cur_thread) + and (\s. 0 < domain_time s) and valid_domain_list \ + do_user_op f tc + \\_. (einvs and ct_running and (\s. scheduler_action s = resume_cur_thread)) + and (\s. 0 < domain_time s) and valid_domain_list \" + apply (rule_tac Q'="\_. valid_list and valid_sched and + (\s. scheduler_action s = resume_cur_thread) and (invs and ct_running) and + (\s. 0 < domain_time s) and valid_domain_list" + in hoare_strengthen_post) + apply (wpsimp wp: do_user_op_valid_list do_user_op_valid_sched do_user_op_sched_act + valid_domain_list_lift do_user_op_invs) + apply force + done + +lemmas ext_init_def = ext_init_det_ext_ext_def ext_init_unit_def + +lemma (in Refine) akernel_invariant: + "ADT_A uop \ full_invs" + unfolding full_invs_def + apply (rule invariantI) + apply (clarsimp simp: ADT_A_def subset_iff) + apply (frule bspec[OF akernel_init_invs]) + apply (simp add: Let_def Init_A_def ext_init_def) + apply (clarsimp simp: ADT_A_def global_automaton_def) + apply (rename_tac tc' s' mode' e' tc s mode e) + apply (elim disjE) + apply ((clarsimp simp: kernel_call_A_def + | drule use_valid[OF _ kernel_entry_invs])+)[2] + apply ((clarsimp simp: do_user_op_A_def monad_to_transition_def + check_active_irq_A_def + | drule use_valid[OF _ do_user_op_invs2] + | drule use_valid[OF _ check_active_irq_invs_just_running])+)[2] + apply ((clarsimp simp add: check_active_irq_A_def + | drule use_valid[OF _ check_active_irq_invs])+)[1] + apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) + apply ((clarsimp simp add: do_user_op_A_def check_active_irq_A_def + | drule use_valid[OF _ do_user_op_invs2] + | drule use_valid[OF _ check_active_irq_invs_just_running])+)[1] + apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) + apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) + apply ((clarsimp simp add: check_active_irq_A_def + | drule use_valid[OF _ check_active_irq_invs])+)[1] + apply ((clarsimp simp add: check_active_irq_A_def + | drule use_valid[OF _ check_active_irq_invs_just_idle])+)[1] + apply ((clarsimp simp add: check_active_irq_A_def + | drule use_valid[OF _ check_active_irq_invs])+)[1] + done + +lemma dmo_getActiveIRQ_notin_non_kernel_IRQs[wp]: + "\\\ doMachineOp (getActiveIRQ True) \\irq _. irq \ Some ` non_kernel_IRQs\" + by (wp dmo_lift' getActiveIRQ_neq_non_kernel) + +lemma ckernel_invs: + "\invs' and (\s. vs_valid_duplicates' (ksPSpace s)) and + (\s. e \ Interrupt \ ct_running' s) and + (\s. ksSchedulerAction s = ResumeCurrentThread)\ + callKernel e + \\rs. (\s. ksSchedulerAction s = ResumeCurrentThread) + and (invs' and (ct_running' or ct_idle'))\" + unfolding callKernel_def + by (wpsimp wp: activate_invs' activate_sch_act schedule_sch + schedule_sch_act_simple he_invs' schedule_invs' hoare_vcg_if_lift3 + hoare_drop_imp[where Q'="\_. kernelExitAssertions"] + hoare_drop_imp[where Q'="\rv _. rv = None"] + simp: no_irq_getActiveIRQ + | strengthen non_kernel_IRQs_strg)+ + +(* this is only needed for callKernel, where we have invs' on concrete side *) +lemma (in Refine) corres_cross_over_fastpathKernelAssertions: + "\ \s. P s \ invs s; \s'. Q s' \ invs' s'; + corres r P (Q and fastpathKernelAssertions) f g \ \ + corres r P Q f g" + by (rule corres_cross_over_guard[where Q="Q and fastpathKernelAssertions"]) + (fastforce elim: fastpathKernelAssertions_cross)+ + +defs kernelExitAssertions_def: + "kernelExitAssertions s \ 0 < ksDomainTime s" + +lemma callKernel_domain_time_left: + "\\\ callKernel e \\_ s. 0 < ksDomainTime s\" + unfolding callKernel_def kernelExitAssertions_def by wpsimp + +lemma doMachineOp_sch_act_simple[wp]: + "doMachineOp f \sch_act_simple\" + by (wp sch_act_simple_lift) + +lemma device_update_invs': + "doMachineOp (device_memory_update ds) \invs'\" + apply (simp add: doMachineOp_def device_memory_update_def simpler_modify_def select_f_def + gets_def get_def bind_def valid_def return_def) + by (clarsimp simp: invs'_def valid_state'_def valid_irq_states'_def valid_machine_state'_def) + +crunch doMachineOp + for ksDomainTime[wp]: "\s. P (ksDomainTime s)" + +context Refine begin + +lemma kernelEntry_invs': + "\ invs' and (\s. e \ Interrupt \ ct_running' s) and + (ct_running' or ct_idle') and + (\s. vs_valid_duplicates' (ksPSpace s)) and + (\s. ksSchedulerAction s = ResumeCurrentThread) and + (\s. 0 < ksDomainTime s) \ + kernelEntry e tc + \\rs. (\s. ksSchedulerAction s = ResumeCurrentThread) and + (invs' and (ct_running' or ct_idle')) and + (\s. vs_valid_duplicates' (ksPSpace s)) and + (\s. 0 < ksDomainTime s) \" + apply (simp add: kernelEntry_def) + apply (wp ckernel_invs callKernel_domain_time_left callKernel_valid_duplicates' + threadSet_invs_trivial threadSet_ct_running' + TcbAcc_R.dmo_invs' hoare_weak_lift_imp + doMachineOp_ct_in_state' doMachineOp_sch_act_simple + callKernel_domain_time_left + | clarsimp simp: user_memory_update_def no_irq_def tcb_at_invs')+ + done + +lemma ptable_rights_imp_UserData: + assumes invs: "einvs s" and invs': "invs' s'" + assumes rel: "(s,s') : state_relation" + assumes rights: "ptable_rights t (absKState s') x \ {}" + assumes trans: + "ptable_lift t (absKState s') x = Some (addrFromPPtr y)" + shows "pointerInUserData y s' \ pointerInDeviceData y s'" +proof - + from invs invs' rel have [simp]: "absKState s' = abs_state s" + by - (rule absKState_correct, simp_all) + from invs have valid: "valid_state s" by auto + from invs' have valid': "valid_state' s'" by auto + have "in_user_frame y s \ in_device_frame y s " + by (rule ptable_rights_imp_frame[OF valid rights[simplified] trans[simplified]]) + thus ?thesis + by (auto simp add: pointerInUserData_relation[OF rel valid' valid] + pointerInDeviceData_relation[OF rel valid' valid]) +qed + +lemma doUserOp_invs': + "\invs' and ex_abs einvs and + (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_running' and + (\s. 0 < ksDomainTime s)\ + doUserOp f tc + \\_. invs' and + (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_running' and + (\s. 0 < ksDomainTime s)\" + apply (simp add: doUserOp_def split_def ex_abs_def) + apply (wp device_update_invs' doMachineOp_ct_in_state' + | (wp (once) dmo_invs', wpsimp simp: no_irq_modify device_memory_update_def + user_memory_update_def))+ + apply (clarsimp simp: user_memory_update_def simpler_modify_def + restrict_map_def + split: option.splits) + apply (frule ptable_rights_imp_UserData[rotated 2], auto) + done + +end (* Refine *) + +text \The top-level correspondence\ + +lemma None_drop: + "P \ x = None \ P" + by simp + +lemma contract_all_imp_strg': + "P \ P' \ P'' \ (\x. R x \ Q x) \ \x. R x \ P \ Q x \ P' \ P''" + by blast + +lemma kernel_corres': + "corres dc (einvs and (\s. event \ Interrupt \ ct_running s) and (ct_running or ct_idle) + and (\s. scheduler_action s = resume_cur_thread) and valid_domain_list) + (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and + (\s. ksSchedulerAction s = ResumeCurrentThread) and + (\s. vs_valid_duplicates' (ksPSpace s))) + (call_kernel event) + (do _ \ runExceptT $ + handleEvent event `~catchError~` + (\_. withoutPreemption $ maybeHandleInterrupt True); + _ \ ThreadDecls_H.schedule; + activateThread + od)" + unfolding call_kernel_def + apply (corres corres: handleEvent_corres corres_machine_op maybeHandleInterrupt_corres + | corres_cases_both)+ + apply (wpsimp wp: handle_event_valid_sched)+ + apply (corres corres: schedule_corres activateThread_corres) + apply (wpsimp wp: schedule_invs' hoare_vcg_if_lift2 dmo_getActiveIRQ_non_kernel + handle_spurious_irq_invs + valid_domain_list_lift[of handle_spurious_irq] + valid_domain_list_lift[of "handle_interrupt irq" for irq] + valid_domain_list_lift[of "do_machine_op mop" for mop] + | simp add: maybe_handle_interrupt_def cong: rev_conj_cong + | strengthen None_drop contract_all_imp_strg')+ + apply (rule_tac Q'="\_. valid_domain_list and valid_sched and invs and valid_list" and + E'="\_. valid_domain_list and valid_sched and invs and valid_list" + in hoare_strengthen_postE) + apply (wpsimp wp: handle_event_valid_sched handle_event_domain_list_inv) + apply simp + apply simp + apply (wpsimp | strengthen non_kernel_IRQs_strg None_drop)+ + apply (clarsimp simp: active_from_running schact_is_rct_def) + apply (clarsimp simp: active_from_running') + done + +lemma corres_gets_machine_state: + "corres (=) \ \ (gets (f \ machine_state)) (gets (f \ ksMachineState))" + by (clarsimp simp: gets_def corres_underlying_def + in_monad bind_def get_def return_def state_relation_def) + +context Refine begin + +lemma kernel_corres: + "corres dc (einvs and (\s. event \ Interrupt \ ct_running s) and (ct_running or ct_idle) and + (\s. scheduler_action s = resume_cur_thread) and + (\s. 0 < domain_time s \ valid_domain_list s)) + (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and + (\s. ksSchedulerAction s = ResumeCurrentThread) and + (\s. vs_valid_duplicates' (ksPSpace s))) + (call_kernel event) (callKernel event)" + unfolding callKernel_def K_bind_def + apply (rule corres_cross_over_fastpathKernelAssertions, blast+) + apply (rule corres_stateAssert_r) + apply (rule corres_guard_imp) + apply (rule corres_add_noop_lhs2) + apply (simp only: bind_assoc[symmetric]) + apply (rule corres_split[where r'=dc and + R="\_ s. 0 < domain_time s \ valid_domain_list s" and + R'="\_. \"]) + apply (simp only: bind_assoc) + apply (rule kernel_corres') + apply (rule corres_bind_return2, rule corres_stateAssert_assume_stronger) + apply simp + apply (simp add: kernelExitAssertions_def state_relation_def) + apply (wp call_kernel_domain_time_inv_det_ext call_kernel_domain_list_inv_det_ext) + apply wp + apply clarsimp + apply clarsimp + done + +lemma user_mem_corres: + "corres (=) invs invs' (gets (\x. g (user_mem x))) (gets (\x. g (user_mem' x)))" + by (clarsimp simp add: gets_def get_def return_def bind_def + invs_def invs'_def + corres_underlying_def user_mem_relation) + +lemma device_mem_corres: + "corres (=) invs invs' (gets (\x. g (device_mem x))) (gets (\x. g (device_mem' x)))" + by (clarsimp simp add: gets_def get_def return_def bind_def + invs_def invs'_def + corres_underlying_def device_mem_relation) + +lemma entry_corres: + "corres (=) (einvs and (\s. event \ Interrupt \ ct_running s) and + (\s. 0 < domain_time s) and valid_domain_list and (ct_running or ct_idle) and + (\s. scheduler_action s = resume_cur_thread)) + (invs' and (\s. event \ Interrupt \ ct_running' s) and + (\s. 0 < ksDomainTime s) and (ct_running' or ct_idle') and + (\s. ksSchedulerAction s = ResumeCurrentThread) and + (\s. vs_valid_duplicates' (ksPSpace s))) + (kernel_entry event tc) (kernelEntry event tc)" + apply (simp add: kernel_entry_def kernelEntry_def) + apply (rule corres_guard_imp) + apply (rule corres_split[OF getCurThread_corres]) + apply (rule corres_split) + apply simp + apply (rule threadset_corresT; simp?) + apply (clarsimp simp: tcb_relation_def arch_tcb_relation_arch_context_set) + apply (clarsimp simp: tcb_cap_cases_def tcb_cte_cases_neqs) + apply (clarsimp simp: tcb_cap_cases_def tcb_cte_cases_def tcb_cte_cases_neqs) + apply (rule corres_split[OF kernel_corres]) + apply (rule corres_split_eqr[OF getCurThread_corres]) + apply (rule threadGet_corres) + apply (clarsimp simp add: tcb_relation_def arch_tcb_relation_arch_context_get) + apply wp+ + 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 + threadSet_invs_trivial threadSet_ct_running' + thread_set_not_state_valid_sched hoare_weak_lift_imp + hoare_vcg_disj_lift ct_in_state_thread_state_lift + thread_set_no_change_tcb_state + | simp add: tcb_cap_cases_def ct_in_state'_def schact_is_rct_def + | (wps, wp threadSet_st_tcb_at2) )+ + apply (clarsimp simp: invs_def cur_tcb_def valid_state_def valid_pspace_def) + apply (clarsimp simp: ct_in_state'_def) + done + +lemma do_user_op_corres: + "corres (=) (einvs and ct_running) + (invs' and (%s. ksSchedulerAction s = ResumeCurrentThread) and + ct_running') + (do_user_op f tc) (doUserOp f tc)" + apply (simp add: do_user_op_def doUserOp_def split_def) + apply (rule corres_guard_imp) + apply (rule corres_split[OF getCurThread_corres]) + apply (rule_tac r'="(=)" and P=einvs and P'=invs' in corres_split) + apply (fastforce dest: absKState_correct [rotated]) + apply (rule_tac r'="(=)" and P=einvs and P'=invs' in corres_split) + apply (fastforce dest: absKState_correct [rotated]) + apply (rule_tac r'="(=)" and P=invs and P'=invs' in corres_split) + apply (rule user_mem_corres) + apply (rule_tac r'="(=)" and P=invs and P'=invs' in corres_split) + apply (rule device_mem_corres) + apply (rule_tac r'="(=)" in corres_split) + apply (rule corres_gets_machine_state) + apply (rule_tac F = "dom (rvb \ addrFromPPtr) \ - dom rvd" in corres_gen_asm) + apply (rule_tac F = "dom (rvc \ addrFromPPtr) \ dom rvd" in corres_gen_asm) + apply simp + apply (rule_tac r'="(=)" in corres_split[OF corres_select]) + apply simp + apply (rule corres_underlying_split[OF corres_machine_op]) + apply simp + apply (rule corres_underlying_trivial) + apply (simp add: user_memory_update_def) + apply (wp | simp)+ + apply (rule corres_underlying_split[OF corres_machine_op,where Q = dc and Q'=dc]) + apply (rule corres_underlying_trivial) + apply (wp | simp add: dc_def device_memory_update_def)+ + apply (clarsimp simp: invs_def valid_state_def pspace_respects_device_region_def + ptrFormPAddr_addFromPPtr) + apply fastforce + done + +end (* Refine *) + +lemma ct_running_related: + "\ (a, c) \ state_relation; ct_running' c \ + \ ct_running a" + apply (clarsimp simp: ct_in_state_def ct_in_state'_def + curthread_relation) + apply (frule(1) st_tcb_at_coerce_abstract) + apply (erule st_tcb_weakenE) + apply (case_tac st, simp_all)[1] + done + +lemma ct_idle_related: + "\ (a, c) \ state_relation; ct_idle' c \ + \ ct_idle a" + apply (clarsimp simp: ct_in_state_def ct_in_state'_def + curthread_relation) + apply (frule(1) st_tcb_at_coerce_abstract) + apply (erule st_tcb_weakenE) + apply (case_tac st, simp_all)[1] + done + +definition full_invs' :: "(('user_context \ global.kernel_state) \ mode \ event option) set" where + "full_invs' \ {((tc,s),m,e). + invs' s \ vs_valid_duplicates' (ksPSpace s) \ + ex_abs (einvs::det_ext state \ bool) s \ + ksSchedulerAction s = ResumeCurrentThread \ + (ct_running' s \ ct_idle' s) \ + (m = KernelMode \ e \ None) \ + (m = UserMode \ ct_running' s) \ + (m = IdleMode \ ct_idle' s) \ + (e \ None \ e \ Some Interrupt \ ct_running' s) \ + 0 < ksDomainTime s}" + +lemma check_active_irq_corres': + "corres (=) \ \ (check_active_irq) (checkActiveIRQ)" + by (simp add: check_active_irq_def checkActiveIRQ_def) + corres + +lemma check_active_irq_corres: + "corres (=) + (invs and (ct_running or ct_idle) and einvs and (\s. scheduler_action s = resume_cur_thread) + and (\s. 0 < domain_time s) and valid_domain_list) + (invs' and (\s. ksSchedulerAction s = ResumeCurrentThread) + and (\s. 0 < ksDomainTime s) and (ct_running' or ct_idle')) + (check_active_irq) (checkActiveIRQ)" + by (corres corres: check_active_irq_corres') + +lemma checkActiveIRQ_just_running_corres: + "corres (=) + (invs and ct_running and einvs and (\s. scheduler_action s = resume_cur_thread) + and (\s. 0 < domain_time s) and valid_domain_list) + (invs' and ct_running' + and (\s. 0 < ksDomainTime s) + and (\s. ksSchedulerAction s = ResumeCurrentThread)) + (check_active_irq) (checkActiveIRQ)" + by (corres corres: check_active_irq_corres') + +lemma checkActiveIRQ_just_idle_corres: + "corres (=) + (invs and ct_idle and einvs and (\s. scheduler_action s = resume_cur_thread) + and (\s. 0 < domain_time s) and valid_domain_list) + (invs' and ct_idle' + and (\s. 0 < ksDomainTime s) + and (\s. ksSchedulerAction s = ResumeCurrentThread)) + (check_active_irq) (checkActiveIRQ)" + by (corres corres: check_active_irq_corres') + +lemma checkActiveIRQ_invs': + "\invs' and ex_abs invs and (ct_running' or ct_idle') + and (\s. ksSchedulerAction s = ResumeCurrentThread)\ + checkActiveIRQ + \\_. invs' and (ct_running' or ct_idle') and (\s. ksSchedulerAction s = ResumeCurrentThread)\" + by (simp add: checkActiveIRQ_def ex_abs_def) + (wpsimp wp: dmo_invs') + +lemma checkActiveIRQ_invs'_just_running: + "\invs' and ex_abs invs and ct_running' and (\s. ksSchedulerAction s = ResumeCurrentThread)\ + checkActiveIRQ + \\_. invs' and ct_running' and (\s. ksSchedulerAction s = ResumeCurrentThread)\" + by (wpsimp simp: checkActiveIRQ_def) + +lemma checkActiveIRQ_invs'_just_idle: + "\invs' and ex_abs invs and ct_idle' and (\s. ksSchedulerAction s = ResumeCurrentThread)\ + checkActiveIRQ + \\_. invs' and ct_idle' and (\s. ksSchedulerAction s = ResumeCurrentThread)\" + by (wpsimp simp: checkActiveIRQ_def) + +lemma sched_act_rct_related: + "\ (a, c) \ state_relation; ksSchedulerAction c = ResumeCurrentThread\ + \ scheduler_action a = resume_cur_thread" + by (case_tac "scheduler_action a", simp_all add: state_relation_def) + +lemma domain_time_rel_eq: + "(a, c) \ state_relation \ P (ksDomainTime c) = P (domain_time a)" + by (clarsimp simp: state_relation_def) + +crunch doUserOp, checkActiveIRQ + for valid_objs': valid_objs' + (wp: crunch_wps + rule: doUserOp_def) (* FIXME: crunch can't find the rule of locale-defined constant *) + +lemma valid_domain_list_2_cross: + "\valid_dom_schedule'_2 sched idx start; domain_list_map dom_list = sched \ + \ valid_domain_list_2 start idx dom_list" + by (fastforce simp: valid_domain_list_2_def valid_dom_schedule'_2_def ucast_eq_0 is_up + split: prod.splits) + +lemma valid_domain_list_from_invs': + "\ (s, s') \ state_relation; invs' s' \ \ valid_domain_list s" + by (clarsimp simp: valid_domain_list_2_cross invs'_def valid_state'_def elim!: state_relationE) + +context Refine begin + +lemma ckernel_invariant: + "ADT_H uop \ full_invs'" + unfolding full_invs'_def + supply word_neq_0_conv[simp] + supply domain_time_rel_eq[simp] + apply (rule invariantI) + apply (clarsimp simp add: ADT_H_def) + apply (subst conj_commute, simp) + apply (rule conjI) + apply (drule ckernel_init_valid_duplicates'[rule_format], simp) + apply (rule conjI) + apply (frule init_refinement[simplified subset_eq, THEN bspec]) + apply (clarsimp simp: ex_abs_def lift_state_relation_def) + apply (frule akernel_init_invs[THEN bspec]) + apply (rule_tac x=s in exI) + apply (clarsimp simp: Init_A_def) + apply (insert ckernel_init_invs)[1] + apply clarsimp + apply (frule ckernel_init_sch_norm) + apply (frule ckernel_init_ctr) + apply (frule ckernel_init_domain_time) + apply (frule ckernel_init_domain_list) + apply (fastforce simp: Init_H_def) + apply (clarsimp simp: ADT_A_def ADT_H_def global_automaton_def) + apply (erule_tac P="a \ (\x. b x)" for a b in disjE) + apply (clarsimp simp: kernel_call_H_def) + apply (drule use_valid[OF _ valid_corres_combined + [OF kernel_entry_invs entry_corres], + OF _ kernelEntry_invs'[THEN hoare_weaken_pre]]) + apply fastforce + apply (clarsimp simp: ex_abs_def sch_act_simple_def ct_running_related ct_idle_related + sched_act_rct_related) + apply (rule exI, rule conjI, assumption) + apply simp + apply (fastforce simp: ex_abs_def sch_act_simple_def ct_running_related ct_idle_related + sched_act_rct_related valid_domain_list_from_invs') + apply (clarsimp simp: kernel_call_H_def) + apply (fastforce simp: ex_abs_def sch_act_simple_def ct_running_related ct_idle_related + sched_act_rct_related) + + apply (erule_tac P="a \ b" for a b in disjE) + apply (clarsimp simp add: do_user_op_H_def monad_to_transition_def) + apply (drule use_valid) + apply (rule hoare_vcg_conj_lift) + apply (rule doUserOp_valid_objs') + apply (rule hoare_vcg_conj_lift) + apply (rule doUserOp_valid_duplicates') + apply (rule valid_corres_combined[OF do_user_op_invs2 corres_guard_imp2[OF do_user_op_corres]]) + apply clarsimp + apply (rule doUserOp_invs'[THEN hoare_weaken_pre]) + apply (fastforce simp: ex_abs_def) + apply (clarsimp simp: invs_valid_objs' ex_abs_def, rule_tac x=s in exI, + clarsimp simp: ct_running_related sched_act_rct_related valid_domain_list_from_invs') + apply (clarsimp simp: ex_abs_def) + apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related) + + apply (erule_tac P="a \ b \ c \ (\x. d x)" for a b c d in disjE) + apply (clarsimp simp add: do_user_op_H_def monad_to_transition_def) + apply (drule use_valid) + apply (rule hoare_vcg_conj_lift) + apply (rule doUserOp_valid_objs') + apply (rule hoare_vcg_conj_lift) + apply (rule doUserOp_valid_duplicates') + apply (rule valid_corres_combined[OF do_user_op_invs2 corres_guard_imp2[OF do_user_op_corres]]) + apply clarsimp + apply (rule doUserOp_invs'[THEN hoare_weaken_pre]) + apply (fastforce simp: ex_abs_def) + apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related + valid_domain_list_from_invs') + apply (fastforce simp: ex_abs_def) + + apply (erule_tac P="a \ b" for a b in disjE) + apply (clarsimp simp: check_active_irq_H_def) + apply (drule use_valid) + apply (rule hoare_vcg_conj_lift) + apply (rule checkActiveIRQ_valid_objs') + apply (rule hoare_vcg_conj_lift) + apply (rule checkActiveIRQ_valid_duplicates') + apply (rule valid_corres_combined[OF check_active_irq_invs_just_running checkActiveIRQ_just_running_corres]) + apply (rule checkActiveIRQ_invs'_just_running[THEN hoare_weaken_pre]) + apply (fastforce simp: ex_abs_def) + apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related + valid_domain_list_from_invs') + apply (fastforce simp: ex_abs_def) + + apply (erule_tac P="a \ b" for a b in disjE) + apply (clarsimp simp: check_active_irq_H_def) + apply (drule use_valid) + apply (rule hoare_vcg_conj_lift) + apply (rule checkActiveIRQ_valid_objs') + apply (rule hoare_vcg_conj_lift) + apply (rule checkActiveIRQ_valid_duplicates') + apply (rule valid_corres_combined[OF check_active_irq_invs_just_idle checkActiveIRQ_just_idle_corres]) + apply (rule checkActiveIRQ_invs'_just_idle[THEN hoare_weaken_pre]) + apply clarsimp + apply (fastforce simp: ex_abs_def) + apply (fastforce simp: ex_abs_def ct_idle_related sched_act_rct_related + valid_domain_list_from_invs') + apply (fastforce simp: ex_abs_def) + + apply (clarsimp simp: check_active_irq_H_def) + apply (drule use_valid) + apply (rule hoare_vcg_conj_lift) + apply (rule checkActiveIRQ_valid_objs') + apply (rule hoare_vcg_conj_lift) + apply (rule checkActiveIRQ_valid_duplicates') + apply (rule valid_corres_combined[OF check_active_irq_invs check_active_irq_corres]) + apply (rule checkActiveIRQ_invs'[THEN hoare_weaken_pre]) + apply clarsimp + apply (fastforce simp: ex_abs_def) + apply (fastforce simp: ex_abs_def ct_running_related ct_idle_related sched_act_rct_related + valid_domain_list_from_invs') + apply (fastforce simp: ex_abs_def) + done + +text \The top-level theorem\ + +lemma fw_sim_A_H: + "LI (ADT_A uop) + (ADT_H uop) + (lift_state_relation state_relation) + (full_invs \ full_invs')" + apply (unfold LI_def full_invs_def full_invs'_def) + apply (simp add: ADT_H_def ADT_A_def) + apply (intro conjI) + apply (rule init_refinement) + apply (clarsimp simp: rel_semi_def relcomp_unfold in_lift_state_relation_eq) + apply (rename_tac tc ak m ev tc' ck' m' ev' ck) + apply (simp add: global_automaton_def) + + apply (erule_tac P="a \ (\x. b x)" for a b in disjE) + apply (clarsimp simp add: kernel_call_H_def kernel_call_A_def) + apply (rule rev_mp, rule_tac tc=tc and event=x in entry_corres) + apply (clarsimp simp: corres_underlying_def) + apply (drule (1) bspec) + apply (clarsimp simp: sch_act_simple_def) + apply (drule (1) bspec) + apply clarsimp + apply (rule conjI) + apply clarsimp + apply (rule_tac x=b in exI) + apply (rule conjI) + apply (rule impI, simp) + apply (frule (2) ct_running_related) + apply clarsimp + apply (rule_tac x=b in exI) + apply (drule use_valid, rule kernelEntry_invs') + apply (simp add: sch_act_simple_def) + apply clarsimp + apply (frule (1) ct_idle_related) + apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) + + apply (erule_tac P="a \ b" for a b in disjE) + apply (clarsimp simp: do_user_op_H_def do_user_op_A_def monad_to_transition_def) + apply (rule rev_mp, rule_tac tc1=tc and f1=uop and P="ct_running and einvs" in corres_guard_imp2[OF do_user_op_corres]) + apply simp + apply (clarsimp simp add: corres_underlying_def) + apply (drule (1) bspec, clarsimp) + apply (drule (1) bspec, clarsimp) + apply fastforce + + apply (erule_tac P="a \ b \ c \ (\x. d x)" for a b c d in disjE) + apply (clarsimp simp: do_user_op_H_def do_user_op_A_def monad_to_transition_def) + apply (rule rev_mp, rule_tac tc1=tc and f1=uop and P="ct_running and einvs" in corres_guard_imp2[OF do_user_op_corres]) + apply simp + apply (clarsimp simp add: corres_underlying_def) + apply (drule (1) bspec, clarsimp) + apply (drule (1) bspec, clarsimp) + apply fastforce + + apply (erule_tac P="a \ b" for a b in disjE) + apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def) + apply (rule rev_mp, rule check_active_irq_corres) + apply (clarsimp simp: corres_underlying_def) + apply fastforce + + apply (erule_tac P="a \ b" for a b in disjE) + apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def) + apply (rule rev_mp, rule check_active_irq_corres) + apply (clarsimp simp: corres_underlying_def) + apply fastforce + + apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def) + apply (rule rev_mp, rule check_active_irq_corres) + apply (clarsimp simp: corres_underlying_def) + apply fastforce + + apply (clarsimp simp: absKState_correct dest!: lift_state_relationD) + done + +theorem refinement: + "ADT_H uop \ ADT_A uop" + apply (rule sim_imp_refines) + apply (rule L_invariantI) + apply (rule akernel_invariant) + apply (rule ckernel_invariant) + apply (rule fw_sim_A_H) + done + +end (* Refine *) + end diff --git a/proof/refine/X64/ArchRefine.thy b/proof/refine/X64/ArchRefine.thy index 0475040f43..5f51a7ffeb 100644 --- a/proof/refine/X64/ArchRefine.thy +++ b/proof/refine/X64/ArchRefine.thy @@ -9,29 +9,29 @@ theory ArchRefine imports Refine - PageTableDuplicates begin -context begin interpretation Arch . (*FIXME: arch-split*) +context Arch begin arch_global_naming + +named_theorems Refine_assms text \User memory content is the same on both levels\ lemma typ_at_AUserDataI: "\ typ_at (AArch (AUserData sz)) p s; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned' s'; pspace_distinct' s'; n < 2 ^ (pageBitsForSize sz - pageBits) \ - \ typ_at' UserDataT (p + n * 2 ^ pageBits) s'" - apply (clarsimp simp add: obj_at_def a_type_def ) + \ typ_at' UserDataT (p + n * 2 ^ pageBits) s'" + apply (clarsimp simp add: obj_at_def a_type_def) apply (simp split: Structures_A.kernel_object.split_asm arch_kernel_obj.split_asm split: if_split_asm) apply (drule(1) pspace_relation_absD) apply (clarsimp) apply (drule_tac x = "p + n * 2 ^ pageBits" in spec) apply (drule_tac x = "\_ obj. obj = KOUserData" in spec) - apply (clarsimp simp: obj_at'_def typ_at'_def ko_wp_at'_def - projectKOs) + apply (clarsimp simp: obj_at'_def typ_at'_def ko_wp_at'_def) apply (rule exI [where x = KOUserData]) apply (drule mp) apply (rule exI [where x = n]) - apply simp + apply (simp add: shiftl_t2n) apply (clarsimp simp: pspace_aligned'_def) apply (drule (1) bspec [OF _ domI]) apply (clarsimp simp: objBits_simps) @@ -41,7 +41,7 @@ lemma typ_at_AUserDataI: lemma typ_at_ADeviceDataI: "\ typ_at (AArch (ADeviceData sz)) p s; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned' s'; pspace_distinct' s'; n < 2 ^ (pageBitsForSize sz - pageBits) \ - \ typ_at' UserDataDeviceT (p + n * 2 ^ pageBits) s'" + \ typ_at' UserDataDeviceT (p + n * 2 ^ pageBits) s'" apply (clarsimp simp add: obj_at_def a_type_def ) apply (simp split: Structures_A.kernel_object.split_asm arch_kernel_obj.split_asm split: if_split_asm) @@ -49,12 +49,11 @@ lemma typ_at_ADeviceDataI: apply (clarsimp) apply (drule_tac x = "p + n * 2 ^ pageBits" in spec) apply (drule_tac x = "\_ obj. obj = KOUserDataDevice" in spec) - apply (clarsimp simp: obj_at'_def typ_at'_def ko_wp_at'_def - projectKOs) + apply (clarsimp simp: obj_at'_def typ_at'_def ko_wp_at'_def) apply (rule exI [where x = KOUserDataDevice]) apply (drule mp) apply (rule exI [where x = n]) - apply simp + apply (simp add: shiftl_t2n) apply (clarsimp simp: pspace_aligned'_def) apply (drule (1) bspec [OF _ domI]) apply (clarsimp simp: objBits_simps) @@ -64,10 +63,8 @@ lemma typ_at_ADeviceDataI: lemma typ_at_UserDataI: "\ typ_at' UserDataT (p && ~~ mask pageBits) s'; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned s \ - \ \sz. typ_at (AArch (AUserData sz)) (p && ~~ mask (pageBitsForSize sz)) s" - apply (clarsimp simp: exists_disj obj_at'_def typ_at'_def ko_wp_at'_def - projectKOs) - + \ \sz. typ_at (AArch (AUserData sz)) (p && ~~ mask (pageBitsForSize sz)) s" + apply (clarsimp simp: exists_disj obj_at'_def typ_at'_def ko_wp_at'_def) apply (frule (1) in_related_pspace_dom) apply (clarsimp simp: pspace_dom_def) apply (clarsimp simp: pspace_relation_def dom_def) @@ -95,10 +92,8 @@ lemma typ_at_UserDataI: lemma typ_at_DeviceDataI: "\ typ_at' UserDataDeviceT (p && ~~ mask pageBits) s'; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned s \ - \ \sz. typ_at (AArch (ADeviceData sz)) (p && ~~ mask (pageBitsForSize sz)) s" - apply (clarsimp simp: exists_disj obj_at'_def typ_at'_def ko_wp_at'_def - projectKOs) - + \ \sz. typ_at (AArch (ADeviceData sz)) (p && ~~ mask (pageBitsForSize sz)) s" + apply (clarsimp simp: exists_disj obj_at'_def typ_at'_def ko_wp_at'_def) apply (frule (1) in_related_pspace_dom) apply (clarsimp simp: pspace_dom_def) apply (clarsimp simp: pspace_relation_def dom_def) @@ -123,841 +118,152 @@ lemma typ_at_DeviceDataI: apply (simp add: obj_at_def a_type_def) done -lemma pointerInUserData_relation: +lemma and_mask_pbfs_shiftr_pageBits_limit: + "p && mask (pageBitsForSize sz) >> pageBits < 2 ^ (pageBitsForSize sz - pageBits)" for p :: obj_ref + apply (rule shiftr_less_t2n') + apply (simp add: pbfs_atleast_pageBits mask_twice) + apply (case_tac sz; simp add: bit_simps) + done + +lemma p_and_not_mask_pbfs_add_mask_pbfs_eq: + "(p && ~~ mask (pageBitsForSize sz)) + (p && mask (pageBitsForSize sz) >> pageBits) * 2 ^ pageBits + = p && ~~ mask pageBits" + for p :: obj_ref + by (simp flip: shiftl_t2n' + add: shiftr_shiftl1 mask_out_add_aligned is_aligned_neg_mask pbfs_atleast_pageBits + word_plus_and_or_coroll2 add.commute) + +lemma pointerInUserData_relation[Refine_assms]: "\ (s,s') \ state_relation; valid_state' s'; valid_state s\ \ pointerInUserData p s' = in_user_frame p s" apply (simp add: pointerInUserData_def in_user_frame_def) apply (rule iffI) - apply (erule typ_at_UserDataI, (clarsimp simp: valid_state_def)+)[1] + apply (erule typ_at_UserDataI; clarsimp simp: valid_state_def) apply clarsimp - apply (drule_tac sz = sz and - n = "(p && mask (pageBitsForSize sz)) >> pageBits" - in typ_at_AUserDataI [where s = s and s' = s']) - apply (fastforce simp: valid_state'_def)+ - apply (rule shiftr_less_t2n') - apply (simp add: pbfs_atleast_pageBits mask_twice) - apply (case_tac sz, simp_all add: bit_simps)[1] - apply (subgoal_tac "(p && ~~ mask (pageBitsForSize sz)) + (p && mask (pageBitsForSize sz) >> pageBits) * 2 ^ pageBits = (p && ~~ mask pageBits)") - apply simp - apply (subst mult.commute) - apply (subst shiftl_t2n [symmetric]) - apply (simp add: shiftr_shiftl1) - apply (subst mask_out_add_aligned) - apply (rule is_aligned_neg_mask) - apply (simp add: pbfs_atleast_pageBits) - apply (subst add.commute) - apply (simp add: word_plus_and_or_coroll2) + apply (drule_tac sz=sz and n="(p && mask (pageBitsForSize sz)) >> pageBits" + in typ_at_AUserDataI [where s = s and s' = s']) + apply (fastforce simp: valid_state'_def and_mask_pbfs_shiftr_pageBits_limit)+ + apply (erule arg_cong[where f="\p. typ_at' _ p s'", THEN iffD1, rotated]) + apply (simp add: p_and_not_mask_pbfs_add_mask_pbfs_eq) done -lemma pointerInDeviceData_relation: +lemma pointerInDeviceData_relation[Refine_assms]: "\ (s,s') \ state_relation; valid_state' s'; valid_state s\ \ pointerInDeviceData p s' = in_device_frame p s" apply (simp add: pointerInDeviceData_def in_device_frame_def) apply (rule iffI) - apply (erule typ_at_DeviceDataI, (clarsimp simp: valid_state_def)+)[1] + apply (erule typ_at_DeviceDataI; clarsimp simp: valid_state_def) apply clarsimp - apply (drule_tac sz = sz and - n = "(p && mask (pageBitsForSize sz)) >> pageBits" - in typ_at_ADeviceDataI [where s = s and s' = s']) - apply (fastforce simp: valid_state'_def)+ - apply (rule shiftr_less_t2n') - apply (simp add: pbfs_atleast_pageBits mask_twice) - apply (case_tac sz, simp_all add: bit_simps)[1] - apply (subgoal_tac "(p && ~~ mask (pageBitsForSize sz)) + (p && mask (pageBitsForSize sz) >> pageBits) * 2 ^ pageBits = (p && ~~ mask pageBits)") - apply simp - apply (subst mult.commute) - apply (subst shiftl_t2n [symmetric]) - apply (simp add: shiftr_shiftl1) - apply (subst mask_out_add_aligned) - apply (rule is_aligned_neg_mask) - apply (simp add: pbfs_atleast_pageBits) - apply (subst add.commute) - apply (simp add: word_plus_and_or_coroll2) + apply (drule_tac sz=sz and n="(p && mask (pageBitsForSize sz)) >> pageBits" + in typ_at_ADeviceDataI[where s=s and s'=s']) + apply (fastforce simp: valid_state'_def and_mask_pbfs_shiftr_pageBits_limit)+ + apply (erule arg_cong[where f="\p. typ_at' _ p s'", THEN iffD1, rotated]) + apply (simp add: p_and_not_mask_pbfs_add_mask_pbfs_eq) done -lemma user_mem_relation: +lemma user_mem_relation[Refine_assms]: "\(s,s') \ state_relation; valid_state' s'; valid_state s\ \ user_mem' s' = user_mem s" - apply (rule ext) - apply (clarsimp simp: user_mem_def user_mem'_def pointerInUserData_relation pointerInDeviceData_relation) - apply (simp add: state_relation_def) - done + by (rule ext) + (clarsimp simp: user_mem_def user_mem'_def pointerInUserData_relation pointerInDeviceData_relation + state_relation_def) -lemma device_mem_relation: +lemma device_mem_relation[Refine_assms]: "\(s,s') \ state_relation; valid_state' s'; valid_state s\ \ device_mem' s' = device_mem s" - apply (rule ext) - apply (clarsimp simp: device_mem_def device_mem'_def pointerInUserData_relation - pointerInDeviceData_relation) - done + by (rule ext) + (clarsimp simp: device_mem_def device_mem'_def pointerInUserData_relation + pointerInDeviceData_relation) -lemma absKState_correct: -assumes invs: "einvs (s :: det_ext state)" and invs': "invs' s'" -assumes rel: "(s,s') \ state_relation" -shows "absKState s' = abs_state s" - using assms - apply (intro state.equality, simp_all add: absKState_def abs_state_def) - apply (rule absHeap_correct; clarsimp elim!: state_relationE) - apply (rule absCDT_correct; clarsimp) - apply (rule absIsOriginalCap_correct; clarsimp) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (clarsimp simp: state_relation_def) - apply (rule absSchedulerAction_correct, simp add: state_relation_def) - apply (simp add: domSchedule_map_relation) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def ready_queues_relation_def ready_queue_relation_def Let_def - list_queue_relation_def) - apply (fastforce dest: heap_ls_is_walk) - apply (clarsimp simp: user_mem_relation invs_def invs'_def) - apply (simp add: state_relation_def) - apply (rule absInterruptIRQNode_correct, simp add: state_relation_def) - apply (rule absInterruptStates_correct, simp add: state_relation_def) - apply (rule absArchState_correct, simp) - apply (rule absExst_correct; simp) - done - -text \The top-level invariance\ - -lemma set_thread_state_sched_act: - "\(\s. runnable state) and (\s. P (scheduler_action s))\ - set_thread_state thread state - \\rs s. P (scheduler_action (s::det_state))\" - apply (simp add: set_thread_state_def) - apply wp - apply (simp add: set_thread_state_act_def) - apply wp - apply (rule hoare_pre_cont) - apply (rule_tac Q'="\rv. (\s. runnable ts) and (\s. P (scheduler_action s))" - in hoare_strengthen_post) - apply wp - apply force - apply (wp gts_st_tcb_at)+ - apply (rule_tac Q'="\rv. st_tcb_at ((=) state) thread and (\s. runnable state) and (\s. P (scheduler_action s))" in hoare_strengthen_post) - apply (simp add: st_tcb_at_def) - apply (wp obj_set_prop_at)+ - apply (force simp: st_tcb_at_def obj_at_def) - apply wp - apply clarsimp - done - -lemma activate_thread_sched_act: +lemma arch_activate_thread_sched_act[Refine_assms]: "\ct_in_state activatable and (\s. P (scheduler_action s))\ - activate_thread - \\rs s. P (scheduler_action (s::det_state))\" - by (simp add: activate_thread_def set_thread_state_def arch_activate_idle_thread_def - | (wp set_thread_state_sched_act gts_wp)+ | wpc)+ - -lemma schedule_sched_act_rct[wp]: - "\\\ Schedule_A.schedule - \\rs (s::det_state). scheduler_action s = resume_cur_thread\" - unfolding Schedule_A.schedule_def - by (wpsimp) - -lemma call_kernel_sched_act_rct[wp]: - "\einvs and (\s. e \ Interrupt \ ct_running s) and (\s. scheduler_action s = resume_cur_thread)\ - call_kernel e - \\rs (s::det_state). scheduler_action s = resume_cur_thread\" - unfolding call_kernel_def - by (wpsimp wp: activate_thread_sched_act handle_spurious_irq_invs simp: active_from_running) - -lemma kernel_entry_invs: - "\einvs and (\s. e \ Interrupt \ ct_running s) - and (\s. 0 < domain_time s) and valid_domain_list and (ct_running or ct_idle) - and (\s. scheduler_action s = resume_cur_thread)\ - kernel_entry e us - \\rv. einvs and (\s. ct_running s \ ct_idle s) - and (\s. 0 < domain_time s) and valid_domain_list - and (\s. scheduler_action s = resume_cur_thread)\" - apply (rule_tac Q'="\rv. invs and (\s. ct_running s \ ct_idle s) and valid_sched and - (\s. 0 < domain_time s) and valid_domain_list and - valid_list and (\s. scheduler_action s = resume_cur_thread)" - in hoare_post_imp) - apply clarsimp - apply (simp add: kernel_entry_def) - apply (wp akernel_invs_det_ext call_kernel_valid_sched thread_set_invs_trivial - thread_set_not_state_valid_sched - hoare_vcg_disj_lift ct_in_state_thread_state_lift thread_set_no_change_tcb_state - call_kernel_domain_time_inv_det_ext call_kernel_domain_list_inv_det_ext - hoare_weak_lift_imp valid_domain_list_lift - | clarsimp simp add: tcb_cap_cases_def active_from_running)+ - done - -definition - "full_invs \ {((tc, s :: det_ext state), m, e). einvs s \ - (ct_running s \ ct_idle s) \ - (m = KernelMode \ e \ None) \ - (m = UserMode \ ct_running s) \ - (m = IdleMode \ ct_idle s) \ - (e \ None \ e \ Some Interrupt \ ct_running s) \ - 0 < domain_time s \ valid_domain_list s \ - (scheduler_action s = resume_cur_thread)}" - -crunch do_user_op - for valid_list: valid_list - and valid_sched: valid_sched - and sched_act: "\s. P (scheduler_action s)" - and domain_fields_inv[wp]: "domain_fields P" - -lemma do_user_op_invs2: - "\einvs and ct_running and (\s. scheduler_action s = resume_cur_thread) - and (\s. 0 < domain_time s) and valid_domain_list \ - do_user_op f tc - \\_. (einvs and ct_running and (\s. scheduler_action s = resume_cur_thread)) - and (\s. 0 < domain_time s) and valid_domain_list \" - apply (rule_tac Q'="\_. valid_list and valid_sched and - (\s. scheduler_action s = resume_cur_thread) and (invs and ct_running) and - (\s. 0 < domain_time s) and valid_domain_list" - in hoare_strengthen_post) - apply (wpsimp wp: do_user_op_valid_list do_user_op_valid_sched do_user_op_sched_act - valid_domain_list_lift do_user_op_invs) - apply force - done + arch_activate_idle_thread t + \\rs s. P (scheduler_action (s::det_state))\" + by (wpsimp simp: arch_activate_idle_thread_def) -lemmas ext_init_def = ext_init_det_ext_ext_def ext_init_unit_def - -lemma valid_list_init[simp]: +lemma valid_list_init[Refine_assms, simp]: "valid_list init_A_st" by (simp add: valid_list_2_def init_A_st_def ext_init_def init_cdt_def) -lemmas valid_list_inits[simp] = valid_list_init[simplified] - -lemma valid_sched_init[simp]: +lemma valid_sched_init[Refine_assms, simp]: "valid_sched init_A_st" apply (simp add: valid_sched_def init_A_st_def ext_init_def) apply (clarsimp simp: init_kheap_def st_tcb_at_kh_def obj_at_kh_def - obj_at_def idle_thread_ptr_def init_global_pml4_def - init_global_pd_def valid_queues_2_def ct_not_in_q_def not_queued_def - valid_sched_action_def is_activatable_def init_global_pdpt_def + obj_at_def idle_thread_ptr_def + valid_queues_2_def ct_not_in_q_def not_queued_def + valid_sched_action_def is_activatable_def init_irq_node_ptr_def + init_global_pml4_def init_global_pdpt_def init_global_pd_def ct_in_cur_domain_2_def valid_blocked_2_def valid_idle_etcb_def etcb_at'_def etcbs_of'_def) done -lemma valid_domain_list_init[simp]: +lemma valid_domain_list_init[Refine_assms, simp]: "valid_domain_list init_A_st" by (simp add: init_A_st_def ext_init_def valid_domain_list_def) -lemma akernel_invariant: - "ADT_A uop \ full_invs" - unfolding full_invs_def - apply (rule invariantI) - apply (clarsimp simp: ADT_A_def subset_iff) - apply (frule bspec[OF akernel_init_invs]) - apply (simp add: Let_def Init_A_def) - apply (simp add: init_A_st_def ext_init_def) - apply (clarsimp simp: ADT_A_def global_automaton_def) - - apply (rename_tac tc' s' mode' e' tc s mode e) - apply (elim disjE) - apply ((clarsimp simp: kernel_call_A_def - | drule use_valid[OF _ kernel_entry_invs])+)[2] - apply ((clarsimp simp: do_user_op_A_def monad_to_transition_def - check_active_irq_A_def - | drule use_valid[OF _ do_user_op_invs2] - | drule use_valid[OF _ check_active_irq_invs_just_running])+)[2] - apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs])+)[1] - apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) - apply ((clarsimp simp add: do_user_op_A_def check_active_irq_A_def - | drule use_valid[OF _ do_user_op_invs2] - | drule use_valid[OF _ check_active_irq_invs_just_running])+)[1] - apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) - apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) - apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs])+)[1] - apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs_just_idle])+)[1] - apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs])+)[1] - done +lemma valid_domain_time_init[Refine_assms, simp]: + "0 < domain_time init_A_st" + by (simp add: init_A_st_def) -lemma ckernel_invs: - "\invs' and (\s. e \ Interrupt \ ct_running' s) and - (\s. ksSchedulerAction s = ResumeCurrentThread)\ - callKernel e - \\rs. (\s. ksSchedulerAction s = ResumeCurrentThread) and (invs' and (ct_running' or ct_idle'))\" - unfolding callKernel_def - by (wpsimp wp: activate_invs' activate_sch_act schedule_sch - schedule_sch_act_simple he_invs' schedule_invs' - hoare_drop_imp[where Q'="\_. kernelExitAssertions"] - simp: no_irq_getActiveIRQ) +lemma sched_act_init[Refine_assms, simp]: + "scheduler_action init_A_st = resume_cur_thread" + by (simp add: init_A_st_def) (* nothing extra needed on this architecture *) defs fastpathKernelAssertions_def: "fastpathKernelAssertions \ \s. True" -lemma fastpathKernelAssertions_cross: +lemma fastpathKernelAssertions_cross[Refine_assms]: "\ (s,s') \ state_relation; invs s; valid_arch_state' s'\ \ fastpathKernelAssertions s'" unfolding fastpathKernelAssertions_def - by simp - -(* this is only needed for callKernel, where we have invs' on concrete side *) -lemma corres_cross_over_fastpathKernelAssertions: - "\ \s. P s \ invs s; \s'. Q s' \ invs' s'; - corres r P (Q and fastpathKernelAssertions) f g \ \ - corres r P Q f g" - by (rule corres_cross_over_guard[where Q="Q and fastpathKernelAssertions"]) - (fastforce elim: fastpathKernelAssertions_cross)+ - -defs kernelExitAssertions_def: - "kernelExitAssertions s \ 0 < ksDomainTime s" - -lemma callKernel_domain_time_left: - "\\\ callKernel e \\_ s. 0 < ksDomainTime s\" - unfolding callKernel_def kernelExitAssertions_def by wpsimp - -lemma kernelEntry_invs': - "\ invs' and (\s. e \ Interrupt \ ct_running' s) and - (ct_running' or ct_idle') and - (\s. ksSchedulerAction s = ResumeCurrentThread) and - (\s. 0 < ksDomainTime s) \ - kernelEntry e tc - \\rs. (\s. ksSchedulerAction s = ResumeCurrentThread) and - (invs' and (ct_running' or ct_idle')) and - (\s. 0 < ksDomainTime s) \" - apply (simp add: kernelEntry_def) - apply (wp ckernel_invs callKernel_domain_time_left - threadSet_invs_trivial threadSet_ct_running' - TcbAcc_R.dmo_invs' hoare_weak_lift_imp - callKernel_domain_time_left - | clarsimp simp: user_memory_update_def no_irq_def tcb_at_invs')+ - done - -lemma ptable_lift_abs_state[simp]: - "ptable_lift t (abs_state s) = ptable_lift t s" - by (simp add: ptable_lift_def abs_state_def) - -lemma ptable_rights_abs_state[simp]: - "ptable_rights t (abs_state s) = ptable_rights t s" - by (simp add: ptable_rights_def abs_state_def) - -lemma ptable_rights_imp_UserData: - assumes invs: "einvs s" and invs': "invs' s'" - assumes rel: "(s,s') : state_relation" - assumes rights: "ptable_rights t (absKState s') x \ {}" - assumes trans: - "ptable_lift t (absKState s') x = Some (X64.addrFromPPtr y)" - shows "pointerInUserData y s' \ pointerInDeviceData y s'" -proof - - from invs invs' rel have [simp]: "absKState s' = abs_state s" - by - (rule absKState_correct, simp_all) - from invs have valid: "valid_state s" by auto - from invs' have valid': "valid_state' s'" by auto - have "in_user_frame y s \ in_device_frame y s " - by (rule ptable_rights_imp_frame[OF valid rights[simplified] - trans[simplified]]) - thus ?thesis - by (auto simp add: pointerInUserData_relation[OF rel valid' valid] - pointerInDeviceData_relation[OF rel valid' valid]) -qed - -lemma device_update_invs': - "\invs'\doMachineOp (device_memory_update ds) - \\_. invs'\" - apply (simp add: doMachineOp_def device_memory_update_def simpler_modify_def select_f_def - gets_def get_def bind_def valid_def return_def) - by (clarsimp simp: invs'_def valid_state'_def valid_irq_states'_def valid_machine_state'_def) - -crunch doMachineOp - for ksDomainTime[wp]: "\s. P (ksDomainTime s)" - -lemma doUserOp_invs': - "\invs' and ex_abs einvs and - (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_running' and - (\s. 0 < ksDomainTime s)\ - doUserOp f tc - \\_. invs' and - (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_running' and - (\s. 0 < ksDomainTime s)\" - apply (simp add: doUserOp_def split_def ex_abs_def) - apply (wp device_update_invs' - | (wp (once) dmo_invs', wpsimp simp: no_irq_modify device_memory_update_def - user_memory_update_def))+ - apply (clarsimp simp: user_memory_update_def simpler_modify_def - restrict_map_def - split: option.splits) - apply (frule ptable_rights_imp_UserData[rotated 2], auto) - done - + by clarsimp -text \The top-level correspondence\ - -lemma contract_all_imp_strg': - "P \ P' \ P'' \ (\x. R x \ Q x) \ \x. R x \ P \ Q x \ P' \ P''" - by blast - -lemma kernel_corres': - "corres dc (einvs and (\s. event \ Interrupt \ ct_running s) and (ct_running or ct_idle) - and (\s. scheduler_action s = resume_cur_thread) and valid_domain_list) - (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and - (\s. ksSchedulerAction s = ResumeCurrentThread)) - (call_kernel event) - (do _ \ runExceptT $ - handleEvent event `~catchError~` - (\_. withoutPreemption $ maybeHandleInterrupt True); - _ \ ThreadDecls_H.schedule; - activateThread - od)" - unfolding call_kernel_def - apply (corres corres: handleEvent_corres maybeHandleInterrupt_corres) - apply (wpsimp wp: handle_event_valid_sched)+ - apply (rule corres_split[OF schedule_corres]) - apply (rule activateThread_corres) - apply (wpsimp wp: schedule_invs' hoare_vcg_if_lift2 hoare_drop_imps handle_spurious_irq_invs - handle_interrupt_valid_sched[unfolded non_kernel_IRQs_def, simplified] - valid_domain_list_lift[of handle_spurious_irq] - valid_domain_list_lift[of "handle_interrupt irq" for irq] - valid_domain_list_lift[of "do_machine_op mop" for mop] - simp: maybe_handle_interrupt_def)+ - apply (rule_tac Q'="\_. valid_domain_list and valid_sched and invs and valid_list" and - E'="\_. valid_domain_list and valid_sched and invs and valid_list" - in hoare_strengthen_postE) - apply (wpsimp wp: handle_event_valid_sched)+ - apply (clarsimp simp: active_from_running schact_is_rct_def) - apply (clarsimp simp: active_from_running') - done - -lemma user_mem_corres: - "corres (=) invs invs' (gets (\x. g (user_mem x))) (gets (\x. g (user_mem' x)))" - by (clarsimp simp add: gets_def get_def return_def bind_def - invs_def invs'_def - corres_underlying_def user_mem_relation) - -lemma device_mem_corres: - "corres (=) invs invs' (gets (\x. g (device_mem x))) (gets (\x. g (device_mem' x)))" - by (clarsimp simp add: gets_def get_def return_def bind_def - invs_def invs'_def - corres_underlying_def device_mem_relation) - -lemma kernel_corres: - "corres dc (einvs and (\s. event \ Interrupt \ ct_running s) and (ct_running or ct_idle) and - (\s. scheduler_action s = resume_cur_thread) and - (\s. 0 < domain_time s \ valid_domain_list s)) - (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and - (\s. ksSchedulerAction s = ResumeCurrentThread) and - (\s. vs_valid_duplicates' (ksPSpace s))) - (call_kernel event) (callKernel event)" - unfolding callKernel_def K_bind_def - apply (rule corres_cross_over_fastpathKernelAssertions, blast+) - apply (rule corres_stateAssert_r) - apply (rule corres_guard_imp) - apply (rule corres_add_noop_lhs2) - apply (simp only: bind_assoc[symmetric]) - apply (rule corres_split[where r'=dc and - R="\_ s. 0 < domain_time s \ valid_domain_list s" and - R'="\_. \"]) - apply (simp only: bind_assoc) - apply (rule kernel_corres') - apply (rule corres_bind_return2, rule corres_stateAssert_assume_stronger) - apply simp - apply (simp add: kernelExitAssertions_def state_relation_def) - apply (wp call_kernel_domain_time_inv_det_ext call_kernel_domain_list_inv_det_ext) - apply wp - apply clarsimp - apply clarsimp - done - - -lemma entry_corres: - "corres (=) (einvs and (\s. event \ Interrupt \ ct_running s) and - (\s. 0 < domain_time s) and valid_domain_list and (ct_running or ct_idle) and - (\s. scheduler_action s = resume_cur_thread)) - (invs' and (\s. event \ Interrupt \ ct_running' s) and - (\s. 0 < ksDomainTime s) and (ct_running' or ct_idle') and - (\s. ksSchedulerAction s = ResumeCurrentThread)) - (kernel_entry event tc) (kernelEntry event tc)" - apply (simp add: kernel_entry_def kernelEntry_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getCurThread_corres]) - apply (rule corres_split) - apply simp - 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) - apply (clarsimp simp: tcb_cte_cases_def cteSizeBits_def) - apply (rule corres_split[OF kernel_corres]) - apply (rule corres_split_eqr[OF getCurThread_corres]) - apply (rule threadGet_corres) - apply (simp add: tcb_relation_def arch_tcb_relation_def - arch_tcb_context_get_def atcbContextGet_def) - apply wp+ - apply (rule hoare_strengthen_post, rule akernel_invs_det_ext, - 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 - threadSet_invs_trivial threadSet_ct_running' - thread_set_not_state_valid_sched hoare_weak_lift_imp - hoare_vcg_disj_lift ct_in_state_thread_state_lift - thread_set_no_change_tcb_state - | simp add: tcb_cap_cases_def ct_in_state'_def schact_is_rct_def - | (wps, wp threadSet_st_tcb_at2) )+ - apply (clarsimp simp: invs_def cur_tcb_def valid_state_def valid_pspace_def) - apply (clarsimp simp: ct_in_state'_def) - done - -lemma corres_gets_machine_state: - "corres (=) \ \ (gets (f \ machine_state)) (gets (f \ ksMachineState))" - by (clarsimp simp: gets_def corres_underlying_def - in_monad bind_def get_def return_def state_relation_def) - -lemma do_user_op_corres: - "corres (=) (einvs and ct_running) - (invs' and (%s. ksSchedulerAction s = ResumeCurrentThread) and - ct_running') - (do_user_op f tc) (doUserOp f tc)" - apply (simp add: do_user_op_def doUserOp_def split_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getCurThread_corres]) - apply (rule_tac r'="(=)" and P=einvs and P'=invs' in corres_split) - apply (fastforce dest: absKState_correct [rotated]) - apply (rule_tac r'="(=)" and P=einvs and P'=invs' in corres_split) - apply (fastforce dest: absKState_correct [rotated]) - apply (rule_tac r'="(=)" and P=invs and P'=invs' in corres_split) - apply (rule user_mem_corres) - apply (rule_tac r'="(=)" and P=invs and P'=invs' in corres_split) - apply (rule device_mem_corres) - apply (rule_tac r'="(=)" in corres_split) - apply (rule corres_gets_machine_state) - apply (rule_tac F = "dom (rvb \ addrFromPPtr) \ - dom rvd" in corres_gen_asm) - apply (rule_tac F = "dom (rvc \ addrFromPPtr) \ dom rvd" in corres_gen_asm) - apply simp - apply (rule_tac r'="(=)" in corres_split[OF corres_select]) - apply simp - apply (rule corres_underlying_split[OF corres_machine_op]) - apply simp - apply (rule corres_underlying_trivial) - apply (simp add: user_memory_update_def) - apply (wp | simp)+ - apply (rule corres_underlying_split[OF corres_machine_op,where Q = dc and Q'=dc]) - apply (rule corres_underlying_trivial) - apply (wp | simp add: dc_def device_memory_update_def)+ - apply (clarsimp simp: invs_def valid_state_def pspace_respects_device_region_def) - apply fastforce - done - -lemma ct_running_related: - "\ (a, c) \ state_relation; ct_running' c \ - \ ct_running a" - apply (clarsimp simp: ct_in_state_def ct_in_state'_def - curthread_relation) - apply (frule(1) st_tcb_at_coerce_abstract) - apply (erule st_tcb_weakenE) - apply (case_tac st, simp_all)[1] - done - -lemma ct_idle_related: - "\ (a, c) \ state_relation; ct_idle' c \ - \ ct_idle a" - apply (clarsimp simp: ct_in_state_def ct_in_state'_def - curthread_relation) - apply (frule(1) st_tcb_at_coerce_abstract) - apply (erule st_tcb_weakenE) - apply (case_tac st, simp_all)[1] - done - -definition - "full_invs' \ {((tc,s),m,e). invs' s \ - ex_abs (einvs::det_ext state \ bool) s \ - ksSchedulerAction s = ResumeCurrentThread \ - (ct_running' s \ ct_idle' s) \ - (m = KernelMode \ e \ None) \ - (m = UserMode \ ct_running' s) \ - (m = IdleMode \ ct_idle' s) \ - (e \ None \ e \ Some Interrupt \ ct_running' s) \ - 0 < ksDomainTime s}" - -lemma check_active_irq_corres': - "corres (=) \ \ (check_active_irq) (checkActiveIRQ)" - apply (simp add: check_active_irq_def checkActiveIRQ_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF corres_machine_op[OF corres_underlying_trivial], where R="\_. \" and R'="\_. \"]) - apply wpsimp+ - done - -lemma check_active_irq_corres: - "corres (=) - (invs and (ct_running or ct_idle) and einvs and (\s. scheduler_action s = resume_cur_thread) - and (\s. 0 < domain_time s) and valid_domain_list) - (invs' and (\s. ksSchedulerAction s = ResumeCurrentThread) - and (\s. 0 < ksDomainTime s) and (ct_running' or ct_idle')) - (check_active_irq) (checkActiveIRQ)" - apply (rule corres_guard_imp) - apply (rule check_active_irq_corres', auto) - done +(* interface lemma, no vs duplicates on this architecture *) +lemma callKernel_valid_duplicates'[Refine_assms]: + "\invs' and (\s. vs_valid_duplicates' (ksPSpace s)) and + (\s. ksSchedulerAction s = ResumeCurrentThread) and + (\s. e \ Interrupt \ ct_running' s)\ + callKernel e + \\rv s. vs_valid_duplicates' (ksPSpace s)\" + by wpsimp -lemma checkActiveIRQ_just_running_corres: - "corres (=) - (invs and ct_running and einvs and (\s. scheduler_action s = resume_cur_thread) - and (\s. 0 < domain_time s) and valid_domain_list) - (invs' and ct_running' - and (\s. 0 < ksDomainTime s) - and (\s. ksSchedulerAction s = ResumeCurrentThread)) - (check_active_irq) (checkActiveIRQ)" - apply (rule corres_guard_imp) - apply (rule check_active_irq_corres', auto) - done +(* interface lemma, no vs duplicates on this architecture *) +lemma doUserOp_valid_duplicates'[Refine_assms]: + "doUserOp f tc \\s. vs_valid_duplicates' (ksPSpace s)\" + by wpsimp -lemma checkActiveIRQ_just_idle_corres: - "corres (=) - (invs and ct_idle and einvs and (\s. scheduler_action s = resume_cur_thread) - and (\s. 0 < domain_time s) and valid_domain_list) - (invs' and ct_idle' - and (\s. 0 < ksDomainTime s) - and (\s. ksSchedulerAction s = ResumeCurrentThread)) - (check_active_irq) (checkActiveIRQ)" - apply (rule corres_guard_imp) - apply (rule check_active_irq_corres', auto) - done +(* interface lemma, no vs duplicates on this architecture *) +lemma checkActiveIRQ_valid_duplicates'[Refine_assms]: + "checkActiveIRQ \\s. vs_valid_duplicates' (ksPSpace s)\" + by wpsimp -lemma checkActiveIRQ_invs': - "\invs' and ex_abs invs and (ct_running' or ct_idle') - and (\s. ksSchedulerAction s = ResumeCurrentThread)\ - checkActiveIRQ - \\_. invs' and (ct_running' or ct_idle') - and (\s. ksSchedulerAction s = ResumeCurrentThread)\" - apply (simp add: checkActiveIRQ_def ex_abs_def) - apply (wp dmo_invs' | simp)+ - done +lemma tcb_hyp_refs'_atcbContextSet[Refine_assms, simp]: + "tcb_hyp_refs' (atcbContextSet tc atcb) = tcb_hyp_refs' atcb" + by (simp add: atcbContextSet_def) -lemma checkActiveIRQ_invs'_just_running: - "\invs' and ex_abs invs and ct_running' - and (\s. ksSchedulerAction s = ResumeCurrentThread)\ - checkActiveIRQ - \\_. invs' and ct_running' - and (\s. ksSchedulerAction s = ResumeCurrentThread)\" - apply (simp add: checkActiveIRQ_def) - apply (wp | simp)+ - done +lemma ptable_lift_abs_state[Refine_assms, simp]: + "ptable_lift t (abs_state s) = ptable_lift t s" + by (simp add: ptable_lift_def abs_state_def) -lemma checkActiveIRQ_invs'_just_idle: - "\invs' and ex_abs invs and ct_idle' - and (\s. ksSchedulerAction s = ResumeCurrentThread)\ - checkActiveIRQ - \\_. invs' and ct_idle' - and (\s. ksSchedulerAction s = ResumeCurrentThread)\" - apply (simp add: checkActiveIRQ_def) - apply (wp | simp)+ - done +lemma ptable_rights_abs_state[Refine_assms, simp]: + "ptable_rights t (abs_state s) = ptable_rights t s" + by (simp add: ptable_rights_def abs_state_def) -lemma sched_act_rct_related: - "\ (a, c) \ state_relation; ksSchedulerAction c = ResumeCurrentThread\ - \ scheduler_action a = resume_cur_thread" - by (case_tac "scheduler_action a", simp_all add: state_relation_def) - -lemma domain_time_rel_eq: - "(a, c) \ state_relation \ P (ksDomainTime c) = P (domain_time a)" - by (clarsimp simp: state_relation_def) - -crunch doUserOp, checkActiveIRQ - for valid_objs': valid_objs' - (wp: crunch_wps - rule: doUserOp_def) (* FIXME: crunch can't find the rule of locale-defined constant *) - -lemma valid_domain_list_2_cross: - "\valid_dom_schedule'_2 sched idx start; domain_list_map dom_list = sched \ - \ valid_domain_list_2 start idx dom_list" - by (fastforce simp: valid_domain_list_2_def valid_dom_schedule'_2_def ucast_eq_0 is_up - split: prod.splits) - -lemma valid_domain_list_from_invs': - "\ (s, s') \ state_relation; invs' s' \ \ valid_domain_list s" - by (clarsimp simp: valid_domain_list_2_cross invs'_def valid_state'_def elim!: state_relationE) - -lemma ckernel_invariant: - "ADT_H uop \ full_invs'" - unfolding full_invs'_def - supply word_neq_0_conv[simp] - supply domain_time_rel_eq[simp] - apply (rule invariantI) - apply (clarsimp simp add: ADT_H_def) - apply (subst conj_commute, simp) - apply (rule conjI) - apply (frule init_refinement[simplified subset_eq, THEN bspec]) - apply (clarsimp simp: ex_abs_def lift_state_relation_def) - apply (frule akernel_init_invs[THEN bspec]) - apply (rule_tac x = s in exI) - apply (clarsimp simp: Init_A_def) - apply (insert ckernel_init_invs)[1] - apply clarsimp - apply (frule ckernel_init_sch_norm) - apply (frule ckernel_init_ctr) - apply (frule ckernel_init_domain_time) - apply (frule ckernel_init_domain_list) - apply (fastforce simp: Init_H_def) - apply (clarsimp simp: ADT_A_def ADT_H_def global_automaton_def) - - apply (erule_tac P="a \ (\x. b x)" for a b in disjE) - - apply (clarsimp simp: kernel_call_H_def) - - apply (drule use_valid[OF _ valid_corres_combined - [OF kernel_entry_invs entry_corres], - OF _ kernelEntry_invs'[THEN hoare_weaken_pre]]) - apply fastforce - - apply (clarsimp simp: ex_abs_def sch_act_simple_def ct_running_related ct_idle_related - sched_act_rct_related) - apply (rule exI, rule conjI, assumption) - apply simp - apply (fastforce simp: ex_abs_def sch_act_simple_def ct_running_related ct_idle_related - sched_act_rct_related valid_domain_list_from_invs') - apply (clarsimp simp: kernel_call_H_def) - apply (fastforce simp: ex_abs_def sch_act_simple_def ct_running_related ct_idle_related - sched_act_rct_related) - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp add: do_user_op_H_def monad_to_transition_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule doUserOp_valid_objs') - apply (rule valid_corres_combined[OF do_user_op_invs2 corres_guard_imp2[OF do_user_op_corres]]) - apply clarsimp - apply (rule doUserOp_invs'[THEN hoare_weaken_pre]) - apply (fastforce simp: ex_abs_def) - apply (clarsimp simp: invs_valid_objs' ex_abs_def, rule_tac x=s in exI, - clarsimp simp: ct_running_related sched_act_rct_related valid_domain_list_from_invs') - apply (clarsimp simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related) - - apply (erule_tac P="a \ b \ c \ (\x. d x)" for a b c d in disjE) - apply (clarsimp simp add: do_user_op_H_def monad_to_transition_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule doUserOp_valid_objs') - apply (rule valid_corres_combined[OF do_user_op_invs2 corres_guard_imp2[OF do_user_op_corres]]) - apply clarsimp - apply (rule doUserOp_invs'[THEN hoare_weaken_pre]) - apply (fastforce simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related - valid_domain_list_from_invs') - apply (fastforce simp: ex_abs_def) - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: check_active_irq_H_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule checkActiveIRQ_valid_objs') - apply (rule valid_corres_combined[OF check_active_irq_invs_just_running checkActiveIRQ_just_running_corres]) - apply (rule checkActiveIRQ_invs'_just_running[THEN hoare_weaken_pre]) - apply (fastforce simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related - valid_domain_list_from_invs') - apply (fastforce simp: ex_abs_def) - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: check_active_irq_H_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule checkActiveIRQ_valid_objs') - apply (rule valid_corres_combined[OF check_active_irq_invs_just_idle checkActiveIRQ_just_idle_corres]) - apply (rule checkActiveIRQ_invs'_just_idle[THEN hoare_weaken_pre]) - apply clarsimp - apply (fastforce simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_idle_related sched_act_rct_related - valid_domain_list_from_invs') - apply (fastforce simp: ex_abs_def) - - apply (clarsimp simp: check_active_irq_H_def) - apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) - apply (rule checkActiveIRQ_valid_objs') - apply (rule valid_corres_combined[OF check_active_irq_invs check_active_irq_corres]) - apply (rule checkActiveIRQ_invs'[THEN hoare_weaken_pre]) - apply clarsimp - apply (fastforce simp: ex_abs_def) - apply (fastforce simp: ex_abs_def ct_running_related ct_idle_related sched_act_rct_related - valid_domain_list_from_invs') - apply (fastforce simp: ex_abs_def) - done +lemma arch_tcb_relation_arch_context_set[Refine_assms]: + "arch_tcb_relation atcb atcb' + \ arch_tcb_relation (arch_tcb_context_set tc atcb) (atcbContextSet tc atcb')" + by (simp add: arch_tcb_relation_def arch_tcb_context_set_def atcbContextSet_def) -text \The top-level theorem\ - -lemma fw_sim_A_H: - "LI (ADT_A uop) - (ADT_H uop) - (lift_state_relation state_relation) - (full_invs \ full_invs')" - apply (unfold LI_def full_invs_def full_invs'_def) - apply (simp add: ADT_H_def ADT_A_def) - apply (intro conjI) - apply (rule init_refinement) - apply (clarsimp simp: rel_semi_def relcomp_unfold in_lift_state_relation_eq) - apply (rename_tac tc ak m ev tc' ck' m' ev' ck) - apply (simp add: global_automaton_def) - - apply (erule_tac P="a \ (\x. b x)" for a b in disjE) - apply (clarsimp simp add: kernel_call_H_def kernel_call_A_def) - apply (rule rev_mp, rule_tac tc=tc and event=x in entry_corres) - apply (clarsimp simp: corres_underlying_def) - apply (drule (1) bspec) - apply (clarsimp simp: sch_act_simple_def) - apply (drule (1) bspec) - apply clarsimp - apply (rule conjI) - apply clarsimp - apply (rule_tac x=b in exI) - apply (rule conjI) - apply (rule impI, simp) - apply (frule (2) ct_running_related) - apply clarsimp - apply (rule_tac x=b in exI) - apply (drule use_valid, rule kernelEntry_invs') - apply (simp add: sch_act_simple_def) - apply clarsimp - apply (frule (1) ct_idle_related) - apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: do_user_op_H_def do_user_op_A_def monad_to_transition_def) - apply (rule rev_mp, rule_tac tc1=tc and f1=uop and P="ct_running and einvs" in corres_guard_imp2[OF do_user_op_corres]) - apply simp - apply (clarsimp simp add: corres_underlying_def) - apply (drule (1) bspec, clarsimp) - apply (drule (1) bspec, clarsimp) - apply fastforce - - apply (erule_tac P="a \ b \ c \ (\x. d x)" for a b c d in disjE) - apply (clarsimp simp: do_user_op_H_def do_user_op_A_def monad_to_transition_def) - apply (rule rev_mp, rule_tac tc1=tc and f1=uop and P="ct_running and einvs" in corres_guard_imp2[OF do_user_op_corres]) - apply simp - apply (clarsimp simp add: corres_underlying_def) - apply (drule (1) bspec, clarsimp) - apply (drule (1) bspec, clarsimp) - apply fastforce - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def) - apply (rule rev_mp, rule check_active_irq_corres) - apply (clarsimp simp: corres_underlying_def) - apply fastforce - - apply (erule_tac P="a \ b" for a b in disjE) - apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def) - apply (rule rev_mp, rule check_active_irq_corres) - apply (clarsimp simp: corres_underlying_def) - apply fastforce - - apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def) - apply (rule rev_mp, rule check_active_irq_corres) - apply (clarsimp simp: corres_underlying_def) - apply fastforce - - apply (clarsimp simp: absKState_correct dest!: lift_state_relationD) - done +lemma arch_tcb_relation_arch_context_get[Refine_assms]: + "arch_tcb_relation atcb atcb' \ arch_tcb_context_get atcb = atcbContextGet atcb'" + by (simp add: arch_tcb_relation_def arch_tcb_context_get_def atcbContextGet_def) -theorem refinement: - "ADT_H uop \ ADT_A uop" - apply (rule sim_imp_refines) - apply (rule L_invariantI) - apply (rule akernel_invariant) - apply (rule ckernel_invariant) - apply (rule fw_sim_A_H) - done +end (* Arch *) -end +interpretation Refine?: Refine +proof goal_cases + interpret Arch . + case 1 show ?case by (intro_locales; (unfold_locales; (fact Refine_assms)?)?) +qed end From eef5cb88822c0051b46454e70287ba17108b57f1 Mon Sep 17 00:00:00 2001 From: Rafal Kolanski Date: Thu, 23 Jul 2026 18:44:36 +1000 Subject: [PATCH 06/13] refine: remove PageTableDuplicates on 64-bit architectures We previously removed everything from these theories. Now we can remove them as they are only included from ArchRefine.thy on ARM and ARM_HYP. Signed-off-by: Rafal Kolanski --- proof/refine/AARCH64/PageTableDuplicates.thy | 11 ----------- proof/refine/RISCV64/PageTableDuplicates.thy | 11 ----------- proof/refine/X64/PageTableDuplicates.thy | 11 ----------- 3 files changed, 33 deletions(-) delete mode 100644 proof/refine/AARCH64/PageTableDuplicates.thy delete mode 100644 proof/refine/RISCV64/PageTableDuplicates.thy delete mode 100644 proof/refine/X64/PageTableDuplicates.thy diff --git a/proof/refine/AARCH64/PageTableDuplicates.thy b/proof/refine/AARCH64/PageTableDuplicates.thy deleted file mode 100644 index fb67e177fe..0000000000 --- a/proof/refine/AARCH64/PageTableDuplicates.thy +++ /dev/null @@ -1,11 +0,0 @@ -(* - * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) - * - * SPDX-License-Identifier: GPL-2.0-only - *) - -theory PageTableDuplicates -imports ArchSyscall_R -begin - -end diff --git a/proof/refine/RISCV64/PageTableDuplicates.thy b/proof/refine/RISCV64/PageTableDuplicates.thy deleted file mode 100644 index fb67e177fe..0000000000 --- a/proof/refine/RISCV64/PageTableDuplicates.thy +++ /dev/null @@ -1,11 +0,0 @@ -(* - * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) - * - * SPDX-License-Identifier: GPL-2.0-only - *) - -theory PageTableDuplicates -imports ArchSyscall_R -begin - -end diff --git a/proof/refine/X64/PageTableDuplicates.thy b/proof/refine/X64/PageTableDuplicates.thy deleted file mode 100644 index 8c3c3c5d22..0000000000 --- a/proof/refine/X64/PageTableDuplicates.thy +++ /dev/null @@ -1,11 +0,0 @@ -(* - * Copyright 2014, General Dynamics C4 Systems - * - * SPDX-License-Identifier: GPL-2.0-only - *) - -theory PageTableDuplicates -imports ArchSyscall_R -begin - -end From 852beeb9b550793b414762803641b301d94ff1e3 Mon Sep 17 00:00:00 2001 From: Rafal Kolanski Date: Thu, 23 Jul 2026 17:15:42 +1000 Subject: [PATCH 07/13] refine: remove InitLemmas Contents were generic and identical on all architectures, now integrated into Refine.thy Signed-off-by: Rafal Kolanski --- proof/refine/AARCH64/InitLemmas.thy | 30 ----------------------------- proof/refine/ARM/InitLemmas.thy | 30 ----------------------------- proof/refine/ARM_HYP/InitLemmas.thy | 30 ----------------------------- proof/refine/RISCV64/InitLemmas.thy | 30 ----------------------------- proof/refine/Refine.thy | 13 ++++++++++++- proof/refine/X64/InitLemmas.thy | 30 ----------------------------- 6 files changed, 12 insertions(+), 151 deletions(-) delete mode 100644 proof/refine/AARCH64/InitLemmas.thy delete mode 100644 proof/refine/ARM/InitLemmas.thy delete mode 100644 proof/refine/ARM_HYP/InitLemmas.thy delete mode 100644 proof/refine/RISCV64/InitLemmas.thy delete mode 100644 proof/refine/X64/InitLemmas.thy diff --git a/proof/refine/AARCH64/InitLemmas.thy b/proof/refine/AARCH64/InitLemmas.thy deleted file mode 100644 index eecc244436..0000000000 --- a/proof/refine/AARCH64/InitLemmas.thy +++ /dev/null @@ -1,30 +0,0 @@ -(* - * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) - * - * SPDX-License-Identifier: GPL-2.0-only - *) - -(* General lemmas removed from KernelInit *) - -theory InitLemmas -imports IncKernelInit -begin - -declare headM_tailM_Cons[simp] - -declare cart_singletons[simp] - -declare less_1_simp[simp] - -declare is_aligned_no_overflow[simp] - -declare unless_True[simp] - -declare maybe_fail_bind_fail[simp] - -crunch setPriority - for cte_wp_at'[wp]: "cte_wp_at' P p" (simp: crunch_simps) -crunch setPriority - for irq_node'[wp]: "\s. P (irq_node' s)" (simp: crunch_simps) - -end diff --git a/proof/refine/ARM/InitLemmas.thy b/proof/refine/ARM/InitLemmas.thy deleted file mode 100644 index cf63858484..0000000000 --- a/proof/refine/ARM/InitLemmas.thy +++ /dev/null @@ -1,30 +0,0 @@ -(* - * Copyright 2014, General Dynamics C4 Systems - * - * SPDX-License-Identifier: GPL-2.0-only - *) - -(* General lemmas removed from KernelInit *) - -theory InitLemmas -imports IncKernelInit -begin - -declare headM_tailM_Cons[simp] - -declare cart_singletons[simp] - -declare less_1_simp[simp] - -declare is_aligned_no_overflow[simp] - -declare unless_True[simp] - -declare maybe_fail_bind_fail[simp] - -crunch setPriority - for cte_wp_at'[wp]: "cte_wp_at' P p" (simp: crunch_simps) -crunch setPriority - for irq_node'[wp]: "\s. P (irq_node' s)" (simp: crunch_simps) - -end diff --git a/proof/refine/ARM_HYP/InitLemmas.thy b/proof/refine/ARM_HYP/InitLemmas.thy deleted file mode 100644 index cf63858484..0000000000 --- a/proof/refine/ARM_HYP/InitLemmas.thy +++ /dev/null @@ -1,30 +0,0 @@ -(* - * Copyright 2014, General Dynamics C4 Systems - * - * SPDX-License-Identifier: GPL-2.0-only - *) - -(* General lemmas removed from KernelInit *) - -theory InitLemmas -imports IncKernelInit -begin - -declare headM_tailM_Cons[simp] - -declare cart_singletons[simp] - -declare less_1_simp[simp] - -declare is_aligned_no_overflow[simp] - -declare unless_True[simp] - -declare maybe_fail_bind_fail[simp] - -crunch setPriority - for cte_wp_at'[wp]: "cte_wp_at' P p" (simp: crunch_simps) -crunch setPriority - for irq_node'[wp]: "\s. P (irq_node' s)" (simp: crunch_simps) - -end diff --git a/proof/refine/RISCV64/InitLemmas.thy b/proof/refine/RISCV64/InitLemmas.thy deleted file mode 100644 index e7c1d3e1f3..0000000000 --- a/proof/refine/RISCV64/InitLemmas.thy +++ /dev/null @@ -1,30 +0,0 @@ -(* - * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) - * - * SPDX-License-Identifier: GPL-2.0-only - *) - -(* General lemmas removed from KernelInit *) - -theory InitLemmas -imports IncKernelInit -begin - -declare headM_tailM_Cons[simp] - -declare cart_singletons[simp] - -declare less_1_simp[simp] - -declare is_aligned_no_overflow[simp] - -declare unless_True[simp] - -declare maybe_fail_bind_fail[simp] - -crunch setPriority - for cte_wp_at'[wp]: "cte_wp_at' P p" (simp: crunch_simps) -crunch setPriority - for irq_node'[wp]: "\s. P (irq_node' s)" (simp: crunch_simps) - -end diff --git a/proof/refine/Refine.thy b/proof/refine/Refine.thy index e5dc5cd8c4..744f20dd80 100644 --- a/proof/refine/Refine.thy +++ b/proof/refine/Refine.thy @@ -12,12 +12,23 @@ theory Refine imports KernelInit_R ArchADT_H - InitLemmas begin arch_requalify_facts no_irq_getActiveIRQ (* FIXME arch-split: Machine_AI *) arch_requalify_facts no_irq_modify (* FIXME arch-split: Machine_AI *) +lemmas [simp] = + headM_tailM_Cons + cart_singletons + less_1_simp + is_aligned_no_overflow + maybe_fail_bind_fail + +crunch setPriority + for cte_wp_at'[wp]: "cte_wp_at' P p" + and irq_node'[wp]: "\s. P (irq_node' s)" + (simp: crunch_simps) + locale Refine = assumes user_mem_relation: "\s s'. diff --git a/proof/refine/X64/InitLemmas.thy b/proof/refine/X64/InitLemmas.thy deleted file mode 100644 index cf63858484..0000000000 --- a/proof/refine/X64/InitLemmas.thy +++ /dev/null @@ -1,30 +0,0 @@ -(* - * Copyright 2014, General Dynamics C4 Systems - * - * SPDX-License-Identifier: GPL-2.0-only - *) - -(* General lemmas removed from KernelInit *) - -theory InitLemmas -imports IncKernelInit -begin - -declare headM_tailM_Cons[simp] - -declare cart_singletons[simp] - -declare less_1_simp[simp] - -declare is_aligned_no_overflow[simp] - -declare unless_True[simp] - -declare maybe_fail_bind_fail[simp] - -crunch setPriority - for cte_wp_at'[wp]: "cte_wp_at' P p" (simp: crunch_simps) -crunch setPriority - for irq_node'[wp]: "\s. P (irq_node' s)" (simp: crunch_simps) - -end From 0f338aa45ffafb306049fda67ec45feca09f6f89 Mon Sep 17 00:00:00 2001 From: Rafal Kolanski Date: Thu, 23 Jul 2026 18:36:25 +1000 Subject: [PATCH 08/13] refine: add new RefineToplevel_R to Refine session Includes everything previously included in the ROOT file, except for [Arch]Refine.thy itself, which is included via EmptyFail_H. Signed-off-by: Rafal Kolanski --- proof/ROOT | 17 ++++------------- proof/refine/RefineToplevel_R.thy | 16 ++++++++++++++++ 2 files changed, 20 insertions(+), 13 deletions(-) create mode 100644 proof/refine/RefineToplevel_R.thy diff --git a/proof/ROOT b/proof/ROOT index ebb5e93aaf..1fd4f30109 100644 --- a/proof/ROOT +++ b/proof/ROOT @@ -35,20 +35,11 @@ session Refine in "refine" = BaseRefine + directories "$L4V_ARCH" theories [condition = "REFINE_QUICK_AND_DIRTY", quick_and_dirty] - "$L4V_ARCH/Refine" - "$L4V_ARCH/RAB_FN" - "$L4V_ARCH/EmptyFail_H" - "$L4V_ARCH/ArchInit_R" + "RefineToplevel_R" theories [condition = "SKIP_REFINE_PROOFS", quick_and_dirty, skip_proofs] - "$L4V_ARCH/Refine" - "$L4V_ARCH/RAB_FN" - "$L4V_ARCH/EmptyFail_H" - "$L4V_ARCH/ArchInit_R" - theories - "$L4V_ARCH/Refine" - "$L4V_ARCH/RAB_FN" - "$L4V_ARCH/EmptyFail_H" - "$L4V_ARCH/ArchInit_R" + "RefineToplevel_R" + theories + "RefineToplevel_R" (* * This theory is in a separate session because the proofs currently diff --git a/proof/refine/RefineToplevel_R.thy b/proof/refine/RefineToplevel_R.thy new file mode 100644 index 0000000000..8bdf76fef7 --- /dev/null +++ b/proof/refine/RefineToplevel_R.thy @@ -0,0 +1,16 @@ +(* + * Copyright 2026, Proofcraft Pty Ltd + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +(* This theory serves as a top-level theory for testing Refine. + It should import all theories we want tested as part of building the Refine image. *) + +theory RefineToplevel_R +imports + EmptyFail_H + RAB_FN + ArchInit_R +begin +end From e3959f29023aea39b226fa362b138d079f729f7d Mon Sep 17 00:00:00 2001 From: Rafal Kolanski Date: Thu, 23 Jul 2026 18:39:24 +1000 Subject: [PATCH 09/13] crefine: update includes for Refine arch-split Refine previously contained the entire abstract-to-design refinement theorem, but arch-split resulted in its instantiations being in ArchRefine. Signed-off-by: Rafal Kolanski --- proof/crefine/Move_C.thy | 2 +- proof/crefine/base/Include_C.thy | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/proof/crefine/Move_C.thy b/proof/crefine/Move_C.thy index 10b382b8fc..dff03daf30 100644 --- a/proof/crefine/Move_C.thy +++ b/proof/crefine/Move_C.thy @@ -8,7 +8,7 @@ (* Arch generic lemmas that should be moved into theory files before CRefine *) theory Move_C -imports Refine.Refine +imports Refine.ArchRefine begin lemma dumb_bool_for_all: "(\x. x) = False" diff --git a/proof/crefine/base/Include_C.thy b/proof/crefine/base/Include_C.thy index 4b9347281e..4e52777690 100644 --- a/proof/crefine/base/Include_C.thy +++ b/proof/crefine/base/Include_C.thy @@ -7,7 +7,7 @@ theory Include_C imports "CSpec.KernelInc_C" - "Refine.Refine" + "Refine.ArchRefine" begin end From c42b01c5004deba5f9f08ae26e06fcaf3165e1ea Mon Sep 17 00:00:00 2001 From: Rafal Kolanski Date: Thu, 23 Jul 2026 18:58:58 +1000 Subject: [PATCH 10/13] refine+crefine: make RAB_FN generic The proofs in RAB_FN now work on all architectures and can be made generic. AARCH64 had moved resolveAddressBitsFn_real_cte_at' to Fastpath_Equiv, which is now no longer necessary. Signed-off-by: Rafal Kolanski --- proof/crefine/AARCH64/Fastpath_Equiv.thy | 14 -- proof/refine/AARCH64/RAB_FN.thy | 151 --------------------- proof/refine/ARM_HYP/RAB_FN.thy | 166 ----------------------- proof/refine/{ARM => }/RAB_FN.thy | 20 +-- proof/refine/RISCV64/RAB_FN.thy | 151 --------------------- proof/refine/X64/RAB_FN.thy | 151 --------------------- 6 files changed, 6 insertions(+), 647 deletions(-) delete mode 100644 proof/refine/AARCH64/RAB_FN.thy delete mode 100644 proof/refine/ARM_HYP/RAB_FN.thy rename proof/refine/{ARM => }/RAB_FN.thy (93%) delete mode 100644 proof/refine/RISCV64/RAB_FN.thy delete mode 100644 proof/refine/X64/RAB_FN.thy diff --git a/proof/crefine/AARCH64/Fastpath_Equiv.thy b/proof/crefine/AARCH64/Fastpath_Equiv.thy index cb1936db1a..e1eea23634 100644 --- a/proof/crefine/AARCH64/Fastpath_Equiv.thy +++ b/proof/crefine/AARCH64/Fastpath_Equiv.thy @@ -1483,20 +1483,6 @@ crunch emptySlot for obj_at'_tcbIPCBuffer[wp]: "obj_at' (\tcb. P (tcbIPCBuffer tcb)) t" (wp: crunch_wps) -(* FIXME AARCH64: this was removed since ARM in RAB_FN.thy back in refine *) -lemma resolveAddressBitsFn_real_cte_at': - "resolveAddressBitsFn cap addr depth (only_cnode_caps (ctes_of s)) = Inr rv - \ (isCNodeCap cap \ cte_wp_at' (\cte. cteCap cte = cap) slot s) - \ cnode_caps_gsCNodes (only_cnode_caps (ctes_of s)) (gsCNodes s) - \ valid_objs' s \ valid_cap' cap s - \ real_cte_at' (fst rv) s" - using monadic_rewrite_refine_validE_R[where F=False and P''=\, - OF resolveAddressBitsFn_eq resolveAddressBits_real_cte_at'] - apply (clarsimp simp: valid_def validE_R_def validE_def simpler_gets_def) - apply (cases rv, clarsimp) - apply metis - done - (* FIXME move *) crunch getBoundNotification for (no_fail) no_fail[intro!, wp, simp] diff --git a/proof/refine/AARCH64/RAB_FN.thy b/proof/refine/AARCH64/RAB_FN.thy deleted file mode 100644 index 843d55511b..0000000000 --- a/proof/refine/AARCH64/RAB_FN.thy +++ /dev/null @@ -1,151 +0,0 @@ -(* - * Copyright 2014, General Dynamics C4 Systems - * - * SPDX-License-Identifier: GPL-2.0-only - *) - -theory RAB_FN - -imports - "CSpace1_R" - "Lib.MonadicRewrite" - -begin - -definition - "only_cnode_caps ctes = - option_map ((\x. if isCNodeCap x then x else NullCap) o cteCap) o ctes" - -definition locateSlotFun_def: -"locateSlotFun cnode offset \ cnode + 2 ^ cte_level_bits * offset" - -definition - "cnode_caps_gsCNodes cts cns - = (\cap \ ran cts. isCNodeCap cap - \ cns (capCNodePtr cap) = Some (capCNodeBits cap))" - -abbreviation (input) - "cnode_caps_gsCNodes' s \ cnode_caps_gsCNodes (only_cnode_caps (ctes_of s)) (gsCNodes s)" - -function - resolveAddressBitsFn :: - "capability \ cptr \ nat \ (machine_word \ capability option) - \ (lookup_failure + (machine_word * nat))" -where - "resolveAddressBitsFn a b c = -(\x0 capptr bits caps. (let nodeCap = x0 in - if isCNodeCap nodeCap - then (let - radixBits = capCNodeBits nodeCap; - guardBits = capCNodeGuardSize nodeCap; - levelBits = radixBits + guardBits; - offset = (fromCPtr capptr `~shiftR~` (bits-levelBits)) && - (mask radixBits); - guard = (fromCPtr capptr `~shiftR~` (bits-guardBits)) && - (mask guardBits); - bitsLeft = bits - levelBits; - slot = locateSlotFun (capCNodePtr nodeCap) offset - in - if levelBits = 0 then Inr (0, 0) - else if \ (guardBits \ bits \ guard = capCNodeGuard nodeCap) - then Inl $ GuardMismatch_ \ - guardMismatchBitsLeft= bits, - guardMismatchGuardFound= capCNodeGuard nodeCap, - guardMismatchGuardSize= guardBits \ - else if (levelBits > bits) then Inl $ DepthMismatch_ \ - depthMismatchBitsLeft= bits, - depthMismatchBitsFound= levelBits \ - else if (bitsLeft = 0) - then Inr (slot, 0) - else (case caps slot of Some NullCap - \ Inr (slot, bitsLeft) - | Some nextCap - \ resolveAddressBitsFn nextCap capptr bitsLeft caps - | None \ Inr (0, 0)) - ) - else Inl InvalidRoot - )) - -a b c" - by auto - -termination - apply (relation "measure (snd o snd)") - apply (auto split: if_split_asm) - done - -declare resolveAddressBitsFn.simps[simp del] - -lemma isCNodeCap_capUntypedPtr_capCNodePtr: - "isCNodeCap c \ capUntypedPtr c = capCNodePtr c" - by (clarsimp simp: gen_isCap_simps) - -context begin interpretation Arch . (*FIXME: arch-split*) - -lemma resolveAddressBitsFn_eq: - "monadic_rewrite F E (\s. (isCNodeCap cap \ (\slot. cte_wp_at' (\cte. cteCap cte = cap) slot s)) - \ valid_objs' s \ cnode_caps_gsCNodes' s) - (resolveAddressBits cap capptr bits) - (gets (resolveAddressBitsFn cap capptr bits o only_cnode_caps o ctes_of))" - (is "monadic_rewrite F E (?P cap) (?f cap bits) (?g cap capptr bits)") -proof (induct cap capptr bits rule: resolveAddressBits.induct) - case (1 cap cref depth) - show ?case - apply (subst resolveAddressBits.simps, subst resolveAddressBitsFn.simps) - apply (simp only: Let_def haskell_assertE_def K_bind_def) - apply (rule monadic_rewrite_name_pre) - apply (rule monadic_rewrite_guard_imp) - apply (rule_tac P="(=) s" in monadic_rewrite_trans) - (* step 1, apply the induction hypothesis on the lhs *) - apply (rule monadic_rewrite_named_if monadic_rewrite_named_bindE - monadic_rewrite_refl[THEN monadic_rewrite_guard_imp, where f="returnOk y" for y] - monadic_rewrite_refl[THEN monadic_rewrite_guard_imp, where f="x $ y" for x y] - monadic_rewrite_refl[THEN monadic_rewrite_guard_imp, where f="assertE P" for P s] - TrueI)+ - apply (rule_tac g="case nextCap of CNodeCap a b c d - \ ?g nextCap cref bitsLeft - | _ \ returnOk (slot, bitsLeft)" in monadic_rewrite_guard_imp) - apply (wpc | rule monadic_rewrite_refl "1.hyps" - | simp only: capability.case haskell_assertE_def simp_thms)+ - apply (clarsimp simp: in_monad locateSlot_conv getSlotCap_def - dest!: in_getCTE fst_stateAssertD) - apply (fastforce elim: cte_wp_at_weakenE') - apply (rule monadic_rewrite_refl[THEN monadic_rewrite_guard_imp], simp) - (* step 2, split and match based on the lhs structure *) - apply (simp add: locateSlot_conv liftE_bindE unlessE_def whenE_def - if_to_top_of_bindE assertE_def stateAssert_def bind_assoc - assert_def if_to_top_of_bind getSlotCap_def - split del: if_split cong: if_cong) - apply (rule monadic_rewrite_if_l monadic_rewrite_symb_exec_l'[OF _ get_wp, rotated] - empty_fail_get no_fail_get impI - monadic_rewrite_refl get_wp - | simp add: throwError_def returnOk_def locateSlotFun_def if_not_P - isCNodeCap_capUntypedPtr_capCNodePtr - cong: if_cong split del: if_split)+ - apply (rule monadic_rewrite_symb_exec_l'[OF _ getCTE_inv _ _ getCTE_cte_wp_at, rotated]) - apply simp - apply (rule impI, rule no_fail_getCTE) - apply (simp add: monadic_rewrite_def simpler_gets_def return_def returnOk_def - only_cnode_caps_def cte_wp_at_ctes_of isCap_simps - locateSlotFun_def isCNodeCap_capUntypedPtr_capCNodePtr - split: capability.split) - apply (rule monadic_rewrite_name_pre[where P="\_. False" and f=fail] - monadic_rewrite_refl get_wp - | simp add: throwError_def returnOk_def locateSlotFun_def if_not_P - isCNodeCap_capUntypedPtr_capCNodePtr - cong: if_cong split del: if_split)+ - (* step 3, prove the non-failure conditions *) - apply (clarsimp simp: isCap_simps) - apply (frule(1) cte_wp_at_valid_objs_valid_cap') - apply (clarsimp simp: cte_level_bits_def valid_cap_simps' - real_cte_at' isCap_simps cteSizeBits_def objBits_simps) - apply (clarsimp simp: cte_wp_at_ctes_of only_cnode_caps_def ball_Un - cnode_caps_gsCNodes_def ran_map_option o_def) - apply (drule bspec, rule IntI, erule ranI, simp add: isCap_simps) - apply (simp add: isCap_simps capAligned_def word_bits_def and_mask_less') - done -qed - -end - -end diff --git a/proof/refine/ARM_HYP/RAB_FN.thy b/proof/refine/ARM_HYP/RAB_FN.thy deleted file mode 100644 index 8308048784..0000000000 --- a/proof/refine/ARM_HYP/RAB_FN.thy +++ /dev/null @@ -1,166 +0,0 @@ -(* - * Copyright 2014, General Dynamics C4 Systems - * - * SPDX-License-Identifier: GPL-2.0-only - *) - -theory RAB_FN - -imports - "CSpace1_R" - "Lib.MonadicRewrite" - -begin - -definition - "only_cnode_caps ctes = - option_map ((\x. if isCNodeCap x then x else NullCap) o cteCap) o ctes" - -definition locateSlotFun_def: -"locateSlotFun cnode offset \ cnode + 2 ^ cte_level_bits * offset" - -definition - "cnode_caps_gsCNodes cts cns - = (\cap \ ran cts. isCNodeCap cap - \ cns (capCNodePtr cap) = Some (capCNodeBits cap))" - -abbreviation (input) - "cnode_caps_gsCNodes' s \ cnode_caps_gsCNodes (only_cnode_caps (ctes_of s)) (gsCNodes s)" - -function - resolveAddressBitsFn :: - "capability \ cptr \ nat \ (word32 \ capability option) - \ (lookup_failure + (machine_word * nat))" -where - "resolveAddressBitsFn a b c = -(\x0 capptr bits caps. (let nodeCap = x0 in - if isCNodeCap nodeCap - then (let - radixBits = capCNodeBits nodeCap; - guardBits = capCNodeGuardSize nodeCap; - levelBits = radixBits + guardBits; - offset = (fromCPtr capptr `~shiftR~` (bits-levelBits)) && - (mask radixBits); - guard = (fromCPtr capptr `~shiftR~` (bits-guardBits)) && - (mask guardBits); - bitsLeft = bits - levelBits; - slot = locateSlotFun (capCNodePtr nodeCap) offset - in - if levelBits = 0 then Inr (0, 0) - else if \ (guardBits \ bits \ guard = capCNodeGuard nodeCap) - then Inl $ GuardMismatch_ \ - guardMismatchBitsLeft= bits, - guardMismatchGuardFound= capCNodeGuard nodeCap, - guardMismatchGuardSize= guardBits \ - else if (levelBits > bits) then Inl $ DepthMismatch_ \ - depthMismatchBitsLeft= bits, - depthMismatchBitsFound= levelBits \ - else if (bitsLeft = 0) - then Inr (slot, 0) - else (case caps slot of Some NullCap - \ Inr (slot, bitsLeft) - | Some nextCap - \ resolveAddressBitsFn nextCap capptr bitsLeft caps - | None \ Inr (0, 0)) - ) - else Inl InvalidRoot - )) - -a b c" - by auto - -termination - apply (relation "measure (snd o snd)") - apply (auto split: if_split_asm) - done - -declare resolveAddressBitsFn.simps[simp del] - -lemma isCNodeCap_capUntypedPtr_capCNodePtr: - "isCNodeCap c \ capUntypedPtr c = capCNodePtr c" - by (clarsimp simp: gen_isCap_simps) - -context begin interpretation Arch . (*FIXME: arch-split*) - -lemma resolveAddressBitsFn_eq: - "monadic_rewrite F E (\s. (isCNodeCap cap \ (\slot. cte_wp_at' (\cte. cteCap cte = cap) slot s)) - \ valid_objs' s \ cnode_caps_gsCNodes' s) - (resolveAddressBits cap capptr bits) - (gets (resolveAddressBitsFn cap capptr bits o only_cnode_caps o ctes_of))" - (is "monadic_rewrite F E (?P cap) (?f cap bits) (?g cap capptr bits)") -proof (induct cap capptr bits rule: resolveAddressBits.induct) - case (1 cap cref depth) - note objBits_defs[simp] - - show ?case - apply (subst resolveAddressBits.simps, subst resolveAddressBitsFn.simps) - apply (simp only: Let_def haskell_assertE_def K_bind_def) - apply (rule monadic_rewrite_name_pre) - apply (rule monadic_rewrite_guard_imp) - apply (rule_tac P="(=) s" in monadic_rewrite_trans) - (* step 1, apply the induction hypothesis on the lhs *) - apply (rule monadic_rewrite_named_if monadic_rewrite_named_bindE - monadic_rewrite_refl[THEN monadic_rewrite_guard_imp, where f="returnOk y" for y] - monadic_rewrite_refl[THEN monadic_rewrite_guard_imp, where f="x $ y" for x y] - monadic_rewrite_refl[THEN monadic_rewrite_guard_imp, where f="assertE P" for P s] - TrueI)+ - apply (rule_tac g="case nextCap of CNodeCap a b c d - \ ?g nextCap cref bitsLeft - | _ \ returnOk (slot, bitsLeft)" in monadic_rewrite_guard_imp) - apply (wpc | rule monadic_rewrite_refl "1.hyps" - | simp only: capability.case haskell_assertE_def simp_thms)+ - apply (clarsimp simp: in_monad locateSlot_conv getSlotCap_def - dest!: in_getCTE fst_stateAssertD) - apply (fastforce elim: cte_wp_at_weakenE') - apply (rule monadic_rewrite_refl[THEN monadic_rewrite_guard_imp], simp) - (* step 2, split and match based on the lhs structure *) - apply (simp add: locateSlot_conv liftE_bindE unlessE_def whenE_def - if_to_top_of_bindE assertE_def stateAssert_def bind_assoc - assert_def if_to_top_of_bind getSlotCap_def - split del: if_split cong: if_cong) - apply (rule monadic_rewrite_if_l monadic_rewrite_symb_exec_l'[OF _ get_wp, rotated] - empty_fail_get no_fail_get impI - monadic_rewrite_refl get_wp - | simp add: throwError_def returnOk_def locateSlotFun_def if_not_P - isCNodeCap_capUntypedPtr_capCNodePtr - cong: if_cong split del: if_split)+ - apply (rule monadic_rewrite_symb_exec_l'[OF _ getCTE_inv _ _ getCTE_cte_wp_at, rotated]) - apply simp - apply (rule impI, rule no_fail_getCTE) - apply (simp add: monadic_rewrite_def simpler_gets_def return_def returnOk_def - only_cnode_caps_def cte_wp_at_ctes_of isCap_simps - locateSlotFun_def isCNodeCap_capUntypedPtr_capCNodePtr - split: capability.split) - apply (rule monadic_rewrite_name_pre[where P="\_. False" and f=fail] - monadic_rewrite_refl get_wp - | simp add: throwError_def returnOk_def locateSlotFun_def if_not_P - isCNodeCap_capUntypedPtr_capCNodePtr - cong: if_cong split del: if_split)+ - (* step 3, prove the non-failure conditions *) - apply (clarsimp simp: isCap_simps) - apply (frule(1) cte_wp_at_valid_objs_valid_cap') - apply (clarsimp simp: cte_level_bits_def valid_cap_simps' - real_cte_at' isCap_simps) - apply (clarsimp simp: cte_wp_at_ctes_of only_cnode_caps_def ball_Un - cnode_caps_gsCNodes_def ran_map_option o_def) - apply (drule bspec, rule IntI, erule ranI, simp add: isCap_simps) - apply (simp add: isCap_simps capAligned_def word_bits_def and_mask_less') - done -qed - -lemma resolveAddressBitsFn_real_cte_at': - "resolveAddressBitsFn cap addr depth (only_cnode_caps (ctes_of s)) = Inr rv - \ (isCNodeCap cap \ cte_wp_at' (\cte. cteCap cte = cap) slot s) - \ cnode_caps_gsCNodes (only_cnode_caps (ctes_of s)) (gsCNodes s) - \ valid_objs' s \ valid_cap' cap s - \ real_cte_at' (fst rv) s" - using monadic_rewrite_refine_validE_R[where F=False and P''=\, - OF resolveAddressBitsFn_eq resolveAddressBits_real_cte_at'] - apply (clarsimp simp: valid_def validE_R_def validE_def simpler_gets_def) - apply (cases rv, clarsimp) - apply metis - done - -end - -end diff --git a/proof/refine/ARM/RAB_FN.thy b/proof/refine/RAB_FN.thy similarity index 93% rename from proof/refine/ARM/RAB_FN.thy rename to proof/refine/RAB_FN.thy index 8308048784..7b87c66372 100644 --- a/proof/refine/ARM/RAB_FN.thy +++ b/proof/refine/RAB_FN.thy @@ -9,7 +9,6 @@ theory RAB_FN imports "CSpace1_R" "Lib.MonadicRewrite" - begin definition @@ -29,7 +28,7 @@ abbreviation (input) function resolveAddressBitsFn :: - "capability \ cptr \ nat \ (word32 \ capability option) + "capability \ cptr \ nat \ (machine_word \ capability option) \ (lookup_failure + (machine_word * nat))" where "resolveAddressBitsFn a b c = @@ -80,8 +79,6 @@ lemma isCNodeCap_capUntypedPtr_capCNodePtr: "isCNodeCap c \ capUntypedPtr c = capCNodePtr c" by (clarsimp simp: gen_isCap_simps) -context begin interpretation Arch . (*FIXME: arch-split*) - lemma resolveAddressBitsFn_eq: "monadic_rewrite F E (\s. (isCNodeCap cap \ (\slot. cte_wp_at' (\cte. cteCap cte = cap) slot s)) \ valid_objs' s \ cnode_caps_gsCNodes' s) @@ -90,8 +87,6 @@ lemma resolveAddressBitsFn_eq: (is "monadic_rewrite F E (?P cap) (?f cap bits) (?g cap capptr bits)") proof (induct cap capptr bits rule: resolveAddressBits.induct) case (1 cap cref depth) - note objBits_defs[simp] - show ?case apply (subst resolveAddressBits.simps, subst resolveAddressBitsFn.simps) apply (simp only: Let_def haskell_assertE_def K_bind_def) @@ -128,7 +123,7 @@ proof (induct cap capptr bits rule: resolveAddressBits.induct) apply simp apply (rule impI, rule no_fail_getCTE) apply (simp add: monadic_rewrite_def simpler_gets_def return_def returnOk_def - only_cnode_caps_def cte_wp_at_ctes_of isCap_simps + only_cnode_caps_def cte_wp_at_ctes_of gen_isCap_simps locateSlotFun_def isCNodeCap_capUntypedPtr_capCNodePtr split: capability.split) apply (rule monadic_rewrite_name_pre[where P="\_. False" and f=fail] @@ -137,14 +132,13 @@ proof (induct cap capptr bits rule: resolveAddressBits.induct) isCNodeCap_capUntypedPtr_capCNodePtr cong: if_cong split del: if_split)+ (* step 3, prove the non-failure conditions *) - apply (clarsimp simp: isCap_simps) + apply (clarsimp simp: gen_isCap_simps) apply (frule(1) cte_wp_at_valid_objs_valid_cap') - apply (clarsimp simp: cte_level_bits_def valid_cap_simps' - real_cte_at' isCap_simps) + apply (clarsimp simp: valid_cap_simps' real_cte_at' gen_isCap_simps cteSizeBits_cte_level_bits) apply (clarsimp simp: cte_wp_at_ctes_of only_cnode_caps_def ball_Un cnode_caps_gsCNodes_def ran_map_option o_def) - apply (drule bspec, rule IntI, erule ranI, simp add: isCap_simps) - apply (simp add: isCap_simps capAligned_def word_bits_def and_mask_less') + apply (drule bspec, rule IntI, erule ranI, simp add: gen_isCap_simps) + apply (simp add: mask_eq word_and_less' gen_isCap_simps capAligned_def) done qed @@ -162,5 +156,3 @@ lemma resolveAddressBitsFn_real_cte_at': done end - -end diff --git a/proof/refine/RISCV64/RAB_FN.thy b/proof/refine/RISCV64/RAB_FN.thy deleted file mode 100644 index 843d55511b..0000000000 --- a/proof/refine/RISCV64/RAB_FN.thy +++ /dev/null @@ -1,151 +0,0 @@ -(* - * Copyright 2014, General Dynamics C4 Systems - * - * SPDX-License-Identifier: GPL-2.0-only - *) - -theory RAB_FN - -imports - "CSpace1_R" - "Lib.MonadicRewrite" - -begin - -definition - "only_cnode_caps ctes = - option_map ((\x. if isCNodeCap x then x else NullCap) o cteCap) o ctes" - -definition locateSlotFun_def: -"locateSlotFun cnode offset \ cnode + 2 ^ cte_level_bits * offset" - -definition - "cnode_caps_gsCNodes cts cns - = (\cap \ ran cts. isCNodeCap cap - \ cns (capCNodePtr cap) = Some (capCNodeBits cap))" - -abbreviation (input) - "cnode_caps_gsCNodes' s \ cnode_caps_gsCNodes (only_cnode_caps (ctes_of s)) (gsCNodes s)" - -function - resolveAddressBitsFn :: - "capability \ cptr \ nat \ (machine_word \ capability option) - \ (lookup_failure + (machine_word * nat))" -where - "resolveAddressBitsFn a b c = -(\x0 capptr bits caps. (let nodeCap = x0 in - if isCNodeCap nodeCap - then (let - radixBits = capCNodeBits nodeCap; - guardBits = capCNodeGuardSize nodeCap; - levelBits = radixBits + guardBits; - offset = (fromCPtr capptr `~shiftR~` (bits-levelBits)) && - (mask radixBits); - guard = (fromCPtr capptr `~shiftR~` (bits-guardBits)) && - (mask guardBits); - bitsLeft = bits - levelBits; - slot = locateSlotFun (capCNodePtr nodeCap) offset - in - if levelBits = 0 then Inr (0, 0) - else if \ (guardBits \ bits \ guard = capCNodeGuard nodeCap) - then Inl $ GuardMismatch_ \ - guardMismatchBitsLeft= bits, - guardMismatchGuardFound= capCNodeGuard nodeCap, - guardMismatchGuardSize= guardBits \ - else if (levelBits > bits) then Inl $ DepthMismatch_ \ - depthMismatchBitsLeft= bits, - depthMismatchBitsFound= levelBits \ - else if (bitsLeft = 0) - then Inr (slot, 0) - else (case caps slot of Some NullCap - \ Inr (slot, bitsLeft) - | Some nextCap - \ resolveAddressBitsFn nextCap capptr bitsLeft caps - | None \ Inr (0, 0)) - ) - else Inl InvalidRoot - )) - -a b c" - by auto - -termination - apply (relation "measure (snd o snd)") - apply (auto split: if_split_asm) - done - -declare resolveAddressBitsFn.simps[simp del] - -lemma isCNodeCap_capUntypedPtr_capCNodePtr: - "isCNodeCap c \ capUntypedPtr c = capCNodePtr c" - by (clarsimp simp: gen_isCap_simps) - -context begin interpretation Arch . (*FIXME: arch-split*) - -lemma resolveAddressBitsFn_eq: - "monadic_rewrite F E (\s. (isCNodeCap cap \ (\slot. cte_wp_at' (\cte. cteCap cte = cap) slot s)) - \ valid_objs' s \ cnode_caps_gsCNodes' s) - (resolveAddressBits cap capptr bits) - (gets (resolveAddressBitsFn cap capptr bits o only_cnode_caps o ctes_of))" - (is "monadic_rewrite F E (?P cap) (?f cap bits) (?g cap capptr bits)") -proof (induct cap capptr bits rule: resolveAddressBits.induct) - case (1 cap cref depth) - show ?case - apply (subst resolveAddressBits.simps, subst resolveAddressBitsFn.simps) - apply (simp only: Let_def haskell_assertE_def K_bind_def) - apply (rule monadic_rewrite_name_pre) - apply (rule monadic_rewrite_guard_imp) - apply (rule_tac P="(=) s" in monadic_rewrite_trans) - (* step 1, apply the induction hypothesis on the lhs *) - apply (rule monadic_rewrite_named_if monadic_rewrite_named_bindE - monadic_rewrite_refl[THEN monadic_rewrite_guard_imp, where f="returnOk y" for y] - monadic_rewrite_refl[THEN monadic_rewrite_guard_imp, where f="x $ y" for x y] - monadic_rewrite_refl[THEN monadic_rewrite_guard_imp, where f="assertE P" for P s] - TrueI)+ - apply (rule_tac g="case nextCap of CNodeCap a b c d - \ ?g nextCap cref bitsLeft - | _ \ returnOk (slot, bitsLeft)" in monadic_rewrite_guard_imp) - apply (wpc | rule monadic_rewrite_refl "1.hyps" - | simp only: capability.case haskell_assertE_def simp_thms)+ - apply (clarsimp simp: in_monad locateSlot_conv getSlotCap_def - dest!: in_getCTE fst_stateAssertD) - apply (fastforce elim: cte_wp_at_weakenE') - apply (rule monadic_rewrite_refl[THEN monadic_rewrite_guard_imp], simp) - (* step 2, split and match based on the lhs structure *) - apply (simp add: locateSlot_conv liftE_bindE unlessE_def whenE_def - if_to_top_of_bindE assertE_def stateAssert_def bind_assoc - assert_def if_to_top_of_bind getSlotCap_def - split del: if_split cong: if_cong) - apply (rule monadic_rewrite_if_l monadic_rewrite_symb_exec_l'[OF _ get_wp, rotated] - empty_fail_get no_fail_get impI - monadic_rewrite_refl get_wp - | simp add: throwError_def returnOk_def locateSlotFun_def if_not_P - isCNodeCap_capUntypedPtr_capCNodePtr - cong: if_cong split del: if_split)+ - apply (rule monadic_rewrite_symb_exec_l'[OF _ getCTE_inv _ _ getCTE_cte_wp_at, rotated]) - apply simp - apply (rule impI, rule no_fail_getCTE) - apply (simp add: monadic_rewrite_def simpler_gets_def return_def returnOk_def - only_cnode_caps_def cte_wp_at_ctes_of isCap_simps - locateSlotFun_def isCNodeCap_capUntypedPtr_capCNodePtr - split: capability.split) - apply (rule monadic_rewrite_name_pre[where P="\_. False" and f=fail] - monadic_rewrite_refl get_wp - | simp add: throwError_def returnOk_def locateSlotFun_def if_not_P - isCNodeCap_capUntypedPtr_capCNodePtr - cong: if_cong split del: if_split)+ - (* step 3, prove the non-failure conditions *) - apply (clarsimp simp: isCap_simps) - apply (frule(1) cte_wp_at_valid_objs_valid_cap') - apply (clarsimp simp: cte_level_bits_def valid_cap_simps' - real_cte_at' isCap_simps cteSizeBits_def objBits_simps) - apply (clarsimp simp: cte_wp_at_ctes_of only_cnode_caps_def ball_Un - cnode_caps_gsCNodes_def ran_map_option o_def) - apply (drule bspec, rule IntI, erule ranI, simp add: isCap_simps) - apply (simp add: isCap_simps capAligned_def word_bits_def and_mask_less') - done -qed - -end - -end diff --git a/proof/refine/X64/RAB_FN.thy b/proof/refine/X64/RAB_FN.thy deleted file mode 100644 index 843d55511b..0000000000 --- a/proof/refine/X64/RAB_FN.thy +++ /dev/null @@ -1,151 +0,0 @@ -(* - * Copyright 2014, General Dynamics C4 Systems - * - * SPDX-License-Identifier: GPL-2.0-only - *) - -theory RAB_FN - -imports - "CSpace1_R" - "Lib.MonadicRewrite" - -begin - -definition - "only_cnode_caps ctes = - option_map ((\x. if isCNodeCap x then x else NullCap) o cteCap) o ctes" - -definition locateSlotFun_def: -"locateSlotFun cnode offset \ cnode + 2 ^ cte_level_bits * offset" - -definition - "cnode_caps_gsCNodes cts cns - = (\cap \ ran cts. isCNodeCap cap - \ cns (capCNodePtr cap) = Some (capCNodeBits cap))" - -abbreviation (input) - "cnode_caps_gsCNodes' s \ cnode_caps_gsCNodes (only_cnode_caps (ctes_of s)) (gsCNodes s)" - -function - resolveAddressBitsFn :: - "capability \ cptr \ nat \ (machine_word \ capability option) - \ (lookup_failure + (machine_word * nat))" -where - "resolveAddressBitsFn a b c = -(\x0 capptr bits caps. (let nodeCap = x0 in - if isCNodeCap nodeCap - then (let - radixBits = capCNodeBits nodeCap; - guardBits = capCNodeGuardSize nodeCap; - levelBits = radixBits + guardBits; - offset = (fromCPtr capptr `~shiftR~` (bits-levelBits)) && - (mask radixBits); - guard = (fromCPtr capptr `~shiftR~` (bits-guardBits)) && - (mask guardBits); - bitsLeft = bits - levelBits; - slot = locateSlotFun (capCNodePtr nodeCap) offset - in - if levelBits = 0 then Inr (0, 0) - else if \ (guardBits \ bits \ guard = capCNodeGuard nodeCap) - then Inl $ GuardMismatch_ \ - guardMismatchBitsLeft= bits, - guardMismatchGuardFound= capCNodeGuard nodeCap, - guardMismatchGuardSize= guardBits \ - else if (levelBits > bits) then Inl $ DepthMismatch_ \ - depthMismatchBitsLeft= bits, - depthMismatchBitsFound= levelBits \ - else if (bitsLeft = 0) - then Inr (slot, 0) - else (case caps slot of Some NullCap - \ Inr (slot, bitsLeft) - | Some nextCap - \ resolveAddressBitsFn nextCap capptr bitsLeft caps - | None \ Inr (0, 0)) - ) - else Inl InvalidRoot - )) - -a b c" - by auto - -termination - apply (relation "measure (snd o snd)") - apply (auto split: if_split_asm) - done - -declare resolveAddressBitsFn.simps[simp del] - -lemma isCNodeCap_capUntypedPtr_capCNodePtr: - "isCNodeCap c \ capUntypedPtr c = capCNodePtr c" - by (clarsimp simp: gen_isCap_simps) - -context begin interpretation Arch . (*FIXME: arch-split*) - -lemma resolveAddressBitsFn_eq: - "monadic_rewrite F E (\s. (isCNodeCap cap \ (\slot. cte_wp_at' (\cte. cteCap cte = cap) slot s)) - \ valid_objs' s \ cnode_caps_gsCNodes' s) - (resolveAddressBits cap capptr bits) - (gets (resolveAddressBitsFn cap capptr bits o only_cnode_caps o ctes_of))" - (is "monadic_rewrite F E (?P cap) (?f cap bits) (?g cap capptr bits)") -proof (induct cap capptr bits rule: resolveAddressBits.induct) - case (1 cap cref depth) - show ?case - apply (subst resolveAddressBits.simps, subst resolveAddressBitsFn.simps) - apply (simp only: Let_def haskell_assertE_def K_bind_def) - apply (rule monadic_rewrite_name_pre) - apply (rule monadic_rewrite_guard_imp) - apply (rule_tac P="(=) s" in monadic_rewrite_trans) - (* step 1, apply the induction hypothesis on the lhs *) - apply (rule monadic_rewrite_named_if monadic_rewrite_named_bindE - monadic_rewrite_refl[THEN monadic_rewrite_guard_imp, where f="returnOk y" for y] - monadic_rewrite_refl[THEN monadic_rewrite_guard_imp, where f="x $ y" for x y] - monadic_rewrite_refl[THEN monadic_rewrite_guard_imp, where f="assertE P" for P s] - TrueI)+ - apply (rule_tac g="case nextCap of CNodeCap a b c d - \ ?g nextCap cref bitsLeft - | _ \ returnOk (slot, bitsLeft)" in monadic_rewrite_guard_imp) - apply (wpc | rule monadic_rewrite_refl "1.hyps" - | simp only: capability.case haskell_assertE_def simp_thms)+ - apply (clarsimp simp: in_monad locateSlot_conv getSlotCap_def - dest!: in_getCTE fst_stateAssertD) - apply (fastforce elim: cte_wp_at_weakenE') - apply (rule monadic_rewrite_refl[THEN monadic_rewrite_guard_imp], simp) - (* step 2, split and match based on the lhs structure *) - apply (simp add: locateSlot_conv liftE_bindE unlessE_def whenE_def - if_to_top_of_bindE assertE_def stateAssert_def bind_assoc - assert_def if_to_top_of_bind getSlotCap_def - split del: if_split cong: if_cong) - apply (rule monadic_rewrite_if_l monadic_rewrite_symb_exec_l'[OF _ get_wp, rotated] - empty_fail_get no_fail_get impI - monadic_rewrite_refl get_wp - | simp add: throwError_def returnOk_def locateSlotFun_def if_not_P - isCNodeCap_capUntypedPtr_capCNodePtr - cong: if_cong split del: if_split)+ - apply (rule monadic_rewrite_symb_exec_l'[OF _ getCTE_inv _ _ getCTE_cte_wp_at, rotated]) - apply simp - apply (rule impI, rule no_fail_getCTE) - apply (simp add: monadic_rewrite_def simpler_gets_def return_def returnOk_def - only_cnode_caps_def cte_wp_at_ctes_of isCap_simps - locateSlotFun_def isCNodeCap_capUntypedPtr_capCNodePtr - split: capability.split) - apply (rule monadic_rewrite_name_pre[where P="\_. False" and f=fail] - monadic_rewrite_refl get_wp - | simp add: throwError_def returnOk_def locateSlotFun_def if_not_P - isCNodeCap_capUntypedPtr_capCNodePtr - cong: if_cong split del: if_split)+ - (* step 3, prove the non-failure conditions *) - apply (clarsimp simp: isCap_simps) - apply (frule(1) cte_wp_at_valid_objs_valid_cap') - apply (clarsimp simp: cte_level_bits_def valid_cap_simps' - real_cte_at' isCap_simps cteSizeBits_def objBits_simps) - apply (clarsimp simp: cte_wp_at_ctes_of only_cnode_caps_def ball_Un - cnode_caps_gsCNodes_def ran_map_option o_def) - apply (drule bspec, rule IntI, erule ranI, simp add: isCap_simps) - apply (simp add: isCap_simps capAligned_def word_bits_def and_mask_less') - done -qed - -end - -end From 02796f69ab8851285eac1fbcdac9eef907918426 Mon Sep 17 00:00:00 2001 From: Rafal Kolanski Date: Fri, 24 Jul 2026 06:59:47 +1000 Subject: [PATCH 11/13] refine: EmptyFail_H given arch prefix In preparation for arch-split. Create EmptyFail_H.thy and update import hierarchy. Signed-off-by: Rafal Kolanski --- .../{EmptyFail_H.thy => ArchEmptyFail_H.thy} | 4 ++-- .../ARM/{EmptyFail_H.thy => ArchEmptyFail_H.thy} | 4 ++-- .../{EmptyFail_H.thy => ArchEmptyFail_H.thy} | 4 ++-- proof/refine/EmptyFail_H.thy | 13 +++++++++++++ .../{EmptyFail_H.thy => ArchEmptyFail_H.thy} | 4 ++-- proof/refine/RefineToplevel_R.thy | 2 +- .../X64/{EmptyFail_H.thy => ArchEmptyFail_H.thy} | 4 ++-- 7 files changed, 24 insertions(+), 11 deletions(-) rename proof/refine/AARCH64/{EmptyFail_H.thy => ArchEmptyFail_H.thy} (99%) rename proof/refine/ARM/{EmptyFail_H.thy => ArchEmptyFail_H.thy} (99%) rename proof/refine/ARM_HYP/{EmptyFail_H.thy => ArchEmptyFail_H.thy} (99%) create mode 100644 proof/refine/EmptyFail_H.thy rename proof/refine/RISCV64/{EmptyFail_H.thy => ArchEmptyFail_H.thy} (99%) rename proof/refine/X64/{EmptyFail_H.thy => ArchEmptyFail_H.thy} (99%) diff --git a/proof/refine/AARCH64/EmptyFail_H.thy b/proof/refine/AARCH64/ArchEmptyFail_H.thy similarity index 99% rename from proof/refine/AARCH64/EmptyFail_H.thy rename to proof/refine/AARCH64/ArchEmptyFail_H.thy index 76b436dc93..28b79297ed 100644 --- a/proof/refine/AARCH64/EmptyFail_H.thy +++ b/proof/refine/AARCH64/ArchEmptyFail_H.thy @@ -5,8 +5,8 @@ * SPDX-License-Identifier: GPL-2.0-only *) -theory EmptyFail_H -imports ArchRefine +theory ArchEmptyFail_H +imports EmptyFail_H begin crunch_ignore (empty_fail) diff --git a/proof/refine/ARM/EmptyFail_H.thy b/proof/refine/ARM/ArchEmptyFail_H.thy similarity index 99% rename from proof/refine/ARM/EmptyFail_H.thy rename to proof/refine/ARM/ArchEmptyFail_H.thy index 307c8cf3b0..8b0160f883 100644 --- a/proof/refine/ARM/EmptyFail_H.thy +++ b/proof/refine/ARM/ArchEmptyFail_H.thy @@ -4,8 +4,8 @@ * SPDX-License-Identifier: GPL-2.0-only *) -theory EmptyFail_H -imports ArchRefine +theory ArchEmptyFail_H +imports EmptyFail_H begin crunch_ignore (empty_fail) diff --git a/proof/refine/ARM_HYP/EmptyFail_H.thy b/proof/refine/ARM_HYP/ArchEmptyFail_H.thy similarity index 99% rename from proof/refine/ARM_HYP/EmptyFail_H.thy rename to proof/refine/ARM_HYP/ArchEmptyFail_H.thy index d93d0f3aea..e519cde26d 100644 --- a/proof/refine/ARM_HYP/EmptyFail_H.thy +++ b/proof/refine/ARM_HYP/ArchEmptyFail_H.thy @@ -4,8 +4,8 @@ * SPDX-License-Identifier: GPL-2.0-only *) -theory EmptyFail_H -imports ArchRefine +theory ArchEmptyFail_H +imports EmptyFail_H begin crunch_ignore (empty_fail) diff --git a/proof/refine/EmptyFail_H.thy b/proof/refine/EmptyFail_H.thy new file mode 100644 index 0000000000..00c2b068ea --- /dev/null +++ b/proof/refine/EmptyFail_H.thy @@ -0,0 +1,13 @@ +(* + * Copyright 2014, General Dynamics C4 Systems + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * Copyright 2023, Proofcraft Pty Ltd + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory EmptyFail_H +imports ArchRefine +begin + +end diff --git a/proof/refine/RISCV64/EmptyFail_H.thy b/proof/refine/RISCV64/ArchEmptyFail_H.thy similarity index 99% rename from proof/refine/RISCV64/EmptyFail_H.thy rename to proof/refine/RISCV64/ArchEmptyFail_H.thy index c6ce24d158..92a691c9e6 100644 --- a/proof/refine/RISCV64/EmptyFail_H.thy +++ b/proof/refine/RISCV64/ArchEmptyFail_H.thy @@ -4,8 +4,8 @@ * SPDX-License-Identifier: GPL-2.0-only *) -theory EmptyFail_H -imports ArchRefine +theory ArchEmptyFail_H +imports EmptyFail_H begin crunch_ignore (empty_fail) diff --git a/proof/refine/RefineToplevel_R.thy b/proof/refine/RefineToplevel_R.thy index 8bdf76fef7..222272a069 100644 --- a/proof/refine/RefineToplevel_R.thy +++ b/proof/refine/RefineToplevel_R.thy @@ -9,7 +9,7 @@ theory RefineToplevel_R imports - EmptyFail_H + ArchEmptyFail_H RAB_FN ArchInit_R begin diff --git a/proof/refine/X64/EmptyFail_H.thy b/proof/refine/X64/ArchEmptyFail_H.thy similarity index 99% rename from proof/refine/X64/EmptyFail_H.thy rename to proof/refine/X64/ArchEmptyFail_H.thy index e91d0b7a07..5f33da29a9 100644 --- a/proof/refine/X64/EmptyFail_H.thy +++ b/proof/refine/X64/ArchEmptyFail_H.thy @@ -4,8 +4,8 @@ * SPDX-License-Identifier: GPL-2.0-only *) -theory EmptyFail_H -imports ArchRefine +theory ArchEmptyFail_H +imports EmptyFail_H begin crunch_ignore (empty_fail) From faf5ef1a5be310245f8fb943aafea53ff293e72a Mon Sep 17 00:00:00 2001 From: Rafal Kolanski Date: Tue, 28 Jul 2026 19:08:13 +1000 Subject: [PATCH 12/13] refine: arch-split EmptyFail_H Signed-off-by: Rafal Kolanski --- proof/refine/AARCH64/ArchEmptyFail_H.thy | 297 ++++------------------ proof/refine/ARM/ArchEmptyFail_H.thy | 297 ++++------------------ proof/refine/ARM_HYP/ArchEmptyFail_H.thy | 309 ++++------------------- proof/refine/EmptyFail_H.thy | 302 ++++++++++++++++++++++ proof/refine/RISCV64/ArchEmptyFail_H.thy | 290 ++++----------------- proof/refine/X64/ArchEmptyFail_H.thy | 306 ++++------------------ 6 files changed, 559 insertions(+), 1242 deletions(-) diff --git a/proof/refine/AARCH64/ArchEmptyFail_H.thy b/proof/refine/AARCH64/ArchEmptyFail_H.thy index 28b79297ed..5b8f5fc9dc 100644 --- a/proof/refine/AARCH64/ArchEmptyFail_H.thy +++ b/proof/refine/AARCH64/ArchEmptyFail_H.thy @@ -1,6 +1,6 @@ (* - * Copyright 2023, Proofcraft Pty Ltd * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * Copyright 2023, Proofcraft Pty Ltd * * SPDX-License-Identifier: GPL-2.0-only *) @@ -9,143 +9,24 @@ theory ArchEmptyFail_H imports EmptyFail_H begin -crunch_ignore (empty_fail) - (add: handleE' getCTE getObject updateObject - CSpaceDecls_H.resolveAddressBits - doMachineOp suspend restart schedule) - -context begin interpretation Arch . (*FIXME: arch-split*) - -lemmas forM_empty_fail[intro!, wp, simp] = empty_fail_mapM[simplified forM_def[symmetric]] -lemmas forM_x_empty_fail[intro!, wp, simp] = empty_fail_mapM_x[simplified forM_x_def[symmetric]] -lemmas forME_x_empty_fail[intro!, wp, simp] = empty_fail_mapME_x[simplified forME_x_def[symmetric]] - -lemma withoutPreemption_empty_fail[intro!, wp, simp]: - "empty_fail m \ empty_fail (withoutPreemption m)" - by simp - -lemma withoutFailure_empty_fail[intro!, wp, simp]: - "empty_fail m \ empty_fail (withoutFailure m)" - by simp - -lemma catchFailure_empty_fail[intro!, wp, simp]: - "\ empty_fail f; \x. empty_fail (g x) \ \ empty_fail (catchFailure f g)" - by (simp add: empty_fail_catch) - -lemma emptyOnFailure_empty_fail[intro!, wp, simp]: - "empty_fail m \ empty_fail (emptyOnFailure m)" - by (simp add: emptyOnFailure_def empty_fail_catch) - -lemma rethrowFailure_empty_fail [intro!, wp, simp]: - "empty_fail m \ empty_fail (rethrowFailure f m)" - by (wpsimp simp:rethrowFailure_def o_def) - -lemma unifyFailure_empty_fail [intro!, wp, simp]: - "empty_fail f \ empty_fail (unifyFailure f)" - by (simp add: unifyFailure_def) - -lemma lookupErrorOnFailure_empty_fail [intro!, wp, simp]: - "empty_fail f \ empty_fail (lookupErrorOnFailure isSource f)" - by (simp add: lookupErrorOnFailure_def) - -lemma setObject_empty_fail [intro!, wp, simp]: - assumes x: "(\a b c. empty_fail (updateObject v a x b c))" - shows "empty_fail (setObject x v)" - by (wpsimp simp: setObject_def split_def wp: x) - -lemma asUser_empty_fail [intro!, wp, simp]: - "empty_fail f \ empty_fail (asUser t f)" - unfolding asUser_def - by (wpsimp | simp add: empty_fail_def)+ - -lemma capFaultOnFailure_empty_fail [intro!, wp, simp]: - "empty_fail m \ empty_fail (capFaultOnFailure cptr rp m)" - by (simp add: capFaultOnFailure_def) - -crunch locateSlotCap - for (empty_fail) empty_fail[intro!, wp, simp] - -lemma resolveAddressBits_spec_empty_fail: - notes spec_empty_fail_bindE'[wp_split] - shows - "spec_empty_fail (CSpace_H.resolveAddressBits a b c) s" -proof (induct arbitrary: s rule: resolveAddressBits.induct) - case (1 a b c s) - show ?case - apply (simp add: resolveAddressBits.simps) - apply (wp | simp | wpc | intro impI conjI | rule drop_spec_empty_fail)+ - apply (rule use_spec_empty_fail) - apply (rule 1 | simp add: in_monad | rule drop_spec_empty_fail | force)+ - done - qed +context Arch begin arch_global_naming -lemmas resolveAddressBits_empty_fail[intro!, wp, simp] = - resolveAddressBits_spec_empty_fail[THEN use_spec_empty_fail] +named_theorems EmptyFail_H_assms -declare ef_dmo'[intro!, wp, simp] - -lemma empty_fail_getObject_ep [intro!, wp, simp]: - "empty_fail (getObject p :: endpoint kernel)" - by (simp add: empty_fail_getObject) - -lemma empty_fail_getObject_tcb [intro!, wp, simp]: - shows "empty_fail (getObject x :: tcb kernel)" - by (auto intro: empty_fail_getObject) - -lemma getEndpoint_empty_fail [intro!, wp, simp]: - "empty_fail (getEndpoint ep)" - by (simp add: getEndpoint_def) - -lemma constOnFailure_empty_fail[intro!, wp, simp]: - "empty_fail m \ empty_fail (constOnFailure x m)" - by (simp add: constOnFailure_def const_def empty_fail_catch) - -lemma ArchRetypeDecls_H_deriveCap_empty_fail[intro!, wp, simp]: +lemma arch_deriveCap_empty_fail[EmptyFail_H_assms, intro!, wp, simp]: "empty_fail (Arch.deriveCap x y)" unfolding AARCH64_H.deriveCap_def by (cases y, auto simp: isCap_simps cong: if_cong) -crunch ensureNoChildren - for (empty_fail) empty_fail[intro!, wp, simp] - -lemma deriveCap_empty_fail[intro!, wp, simp]: - "empty_fail (RetypeDecls_H.deriveCap slot y)" - apply (simp add: Retype_H.deriveCap_def) - apply (clarsimp simp: empty_fail_bindE) - done - -crunch setExtraBadge, cteInsert - for (empty_fail) empty_fail[intro!, wp, simp] - -lemma transferCapsToSlots_empty_fail[intro!, wp, simp]: - "empty_fail (transferCapsToSlots ep buffer n caps slots mi)" - apply (induct caps arbitrary: slots n mi) - apply simp - apply (simp add: Let_def split_def - split del: if_split) - apply (simp | wp | wpc | safe)+ - done - -crunch lookupTargetSlot, ensureEmptySlot, lookupSourceSlot, lookupPivotSlot - for (empty_fail) empty_fail[intro!, wp, simp] - -lemma decodeCNodeInvocation_empty_fail[intro!, wp, simp]: - "empty_fail (decodeCNodeInvocation label args cap exs)" - apply (rule_tac label=label and args=args and exs=exs in decode_cnode_cases2) - apply (simp_all add: decodeCNodeInvocation_def - split_def cnode_invok_case_cleanup unlessE_whenE - cong: if_cong bool.case_cong list.case_cong) - by (simp | wp | wpc | safe)+ - -lemma empty_fail_getObject_ap [intro!, wp, simp]: +lemma empty_fail_getObject_ap[intro!, wp, simp]: "empty_fail (getObject p :: asidpool kernel)" by (simp add: empty_fail_getObject) -lemma empty_fail_getObject_pte [intro!, wp, simp]: +lemma empty_fail_getObject_pte[intro!, wp, simp]: "empty_fail (getObject p :: pte kernel)" by (simp add: empty_fail_getObject) -lemma empty_fail_getObject_vcpu [intro!, wp, simp]: +lemma empty_fail_getObject_vcpu[intro!, wp, simp]: "empty_fail (getObject p :: vcpu kernel)" by (simp add: empty_fail_getObject) @@ -175,30 +56,11 @@ lemma empty_fail_pt_type_exhausted: \ False" by (case_tac pt_t; simp) -crunch decodeARMMMUInvocation - for (empty_fail) empty_fail[intro!, wp, simp] +crunch decodeARMMMUInvocation, Arch_postCapDeletion, setRegister, prepareThreadDelete + for (empty_fail) empty_fail[EmptyFail_H_assms, intro!, wp, simp] (simp: Let_def pteAtIndex_def - wp: empty_fail_catch empty_fail_pt_type_exhausted empty_fail_arch_cap_exhausted) - -lemma ignoreFailure_empty_fail[intro!, wp, simp]: - "empty_fail x \ empty_fail (ignoreFailure x)" - by (simp add: ignoreFailure_def empty_fail_catch) - -crunch cancelIPC, setThreadState, tcbSchedDequeue, setupReplyMaster, isStopped, possibleSwitchTo, tcbSchedAppend - for (empty_fail) empty_fail[intro!, wp, simp] -(simp: Let_def setNotification_def setBoundNotification_def wp: empty_fail_getObject) - -crunch "ThreadDecls_H.suspend" - for (empty_fail) "_H_empty_fail"[intro!, wp, simp] - (ignore_del: ThreadDecls_H.suspend) - -lemma ThreadDecls_H_restart_empty_fail[intro!, wp, simp]: - "empty_fail (ThreadDecls_H.restart target)" - by (fastforce simp: restart_def) - -lemma vcpuUpdate_empty_fail[intro!, wp, simp]: - "empty_fail (vcpuUpdate p f)" - by (fastforce simp: vcpuUpdate_def) + wp: empty_fail_catch empty_fail_pt_type_exhausted empty_fail_arch_cap_exhausted + rule: AARCH64_H.postCapDeletion_def) crunch vcpuEnable, vcpuRestore for (empty_fail) empty_fail[intro!, wp, simp] @@ -208,111 +70,46 @@ lemma empty_fail_lookupPTFromLevel[intro!, wp, simp]: "empty_fail (lookupPTFromLevel level ptPtr vPtr target)" by (induct level arbitrary: ptPtr; subst lookupPTFromLevel.simps; simp; wpsimp) -crunch finaliseCap, preemptionPoint, capSwapForDelete - for (empty_fail) empty_fail[intro!, wp, simp] -(wp: empty_fail_catch simp: Let_def ignore: lookupPTFromLevel) - -lemmas finalise_spec_empty_fail_induct = finaliseSlot'.induct[where P= - "\sl exp s. spec_empty_fail (finaliseSlot' sl exp) s"] - -lemma spec_empty_fail_If: - "\ P \ spec_empty_fail f s; \ P \ spec_empty_fail g s \ - \ spec_empty_fail (if P then f else g) s" - by (simp split: if_split) - -lemma spec_empty_whenE': - "\ P \ spec_empty_fail f s \ \ spec_empty_fail (whenE P f) s" - by (simp add: whenE_def spec_empty_returnOk) - -lemma finaliseSlot_spec_empty_fail: - notes spec_empty_fail_bindE'[rotated, wp_split] - shows "spec_empty_fail (finaliseSlot x b) s" -unfolding finaliseSlot_def -proof (induct rule: finalise_spec_empty_fail_induct) - case (1 x b s) - show ?case - apply (subst finaliseSlot'_simps_ext) - apply (simp only: split_def Let_def K_bind_def fun_app_def) - apply (wp spec_empty_whenE' spec_empty_fail_If | wpc - | rule 1[unfolded Let_def K_bind_def split_def fun_app_def, - simplified], (simp | intro conjI)+ - | rule drop_spec_empty_fail | simp)+ - done -qed - -lemmas finaliseSlot_empty_fail[intro!, wp, simp] = - finaliseSlot_spec_empty_fail[THEN use_spec_empty_fail] - -lemma checkCapAt_empty_fail[intro!, wp, simp]: - "empty_fail action \ empty_fail (checkCapAt cap ptr action)" - by (fastforce simp: checkCapAt_def) - -lemma assertDerived_empty_fail[intro!, wp, simp]: - "empty_fail f \ empty_fail (assertDerived src cap f)" - by (fastforce simp: assertDerived_def) +crunch + Arch_finaliseCap, Arch.switchToThread, Arch.switchToIdleThread, prepareNextDomain, getRestartPC, + makeArchFaultMessage + for (empty_fail) empty_fail[EmptyFail_H_assms, intro!, wp, simp] + (rule: AARCH64_H.finaliseCap_def) -crunch cteDelete - for (empty_fail) empty_fail[intro!, wp, simp] +crunch + decodeVCPUInjectIRQ, decodeVCPUWriteReg, decodeVCPUReadReg, doFlush, decodeVCPUAckVPPI, + decodeTransfer, checkValidIPCBuffer, Arch.decodeIRQControlInvocation, Arch.decodeInvocation, + deleteGhost, Arch.createObject, getSanitiseRegisterInfo, + handleArchFaultReply, prepareSetDomain, postModifyRegisters, postSetFlags, + Arch.performIRQControl, Arch.invokeIRQHandler, Arch.performInvocation, handleSpuriousIRQ, + maskIrqSignal, handleVMFault, checkIRQ, prepareThreadDelete, Arch.postCapDeletion + for (empty_fail) empty_fail[EmptyFail_H_assms, intro!, wp, simp] + (simp: Let_def) -lemma spec_empty_fail_unlessE': - "\ \ P \ spec_empty_fail f s \ \ spec_empty_fail (unlessE P f) s" - by (simp add:unlessE_def spec_empty_returnOk) +end (* Arch *) -lemma cteRevoke_spec_empty_fail: - notes spec_empty_fail_bindE'[wp_split] - shows "spec_empty_fail (cteRevoke p) s" -proof (induct rule: cteRevoke.induct) - case (1 p s) - show ?case - apply (simp add: cteRevoke.simps) - apply (wp spec_empty_whenE' spec_empty_fail_unlessE' | rule drop_spec_empty_fail, wp)+ - apply (rule 1, auto simp add: in_monad) - done +interpretation EmptyFail_H?: EmptyFail_H +proof goal_cases + interpret Arch . + case 1 show ?case by (intro_locales; (unfold_locales; (fact EmptyFail_H_assms)?)?) qed -lemmas cteRevoke_empty_fail[intro!, wp, simp] = - cteRevoke_spec_empty_fail[THEN use_spec_empty_fail] +context Arch begin arch_global_naming -lemma Syscall_H_syscall_empty_fail[intro!, wp, simp]: - "\empty_fail a; \x. empty_fail (b x); \x. empty_fail (c x); - \x. empty_fail (d x); \x. empty_fail (e x)\ - \ empty_fail (syscall a b c d e)" - apply (simp add:syscall_def) - apply (wp | wpc | simp)+ - done - -lemma catchError_empty_fail[intro!, wp, simp]: - "\ empty_fail f; \x. empty_fail (g x) \ \ empty_fail (catchError f g)" - by fastforce +named_theorems EmptyFail_H_2_assms crunch - chooseThread, getDomainTime, nextDomain, isHighestPrio, prepareNextDomain - for (empty_fail) empty_fail[intro!, wp, simp] - (wp: empty_fail_catch) - -lemma ThreadDecls_H_schedule_empty_fail[intro!, wp, simp]: - "empty_fail schedule" - supply if_cong[cong] - apply (simp add: schedule_def) - apply (clarsimp simp: scheduleChooseNewThread_def split: if_split | wp | wpc)+ - done - -crunch setMRs, setMessageInfo - for (empty_fail) empty_fail[wp, simp] -(wp: empty_fail_catch simp: const_def Let_def) - -crunch decodeVCPUInjectIRQ, decodeVCPUWriteReg, decodeVCPUReadReg, doFlush, - decodeVCPUAckVPPI - for (empty_fail) empty_fail + handleReservedIRQ, handleHypervisorFault + for (empty_fail) empty_fail[EmptyFail_H_2_assms, intro!, wp, simp] (simp: Let_def) -crunch handleFault - for (empty_fail) empty_fail[wp, simp] +end (* Arch *) -lemma handleHypervisorFault_empty_fail[intro!, wp, simp]: - "empty_fail (handleHypervisorFault t f)" - by (cases f, simp add: handleHypervisorFault_def isFpuEnable_def split del: if_split) - wpsimp +interpretation EmptyFail_H_2?: EmptyFail_H_2 +proof goal_cases + interpret Arch . + case 1 show ?case by (intro_locales; (unfold_locales; (fact EmptyFail_H_2_assms)?)?) +qed crunch callKernel for (empty_fail) empty_fail @@ -320,12 +117,12 @@ crunch callKernel theorem call_kernel_serial: "\ (einvs and (\s. event \ Interrupt \ ct_running s) and (ct_running or ct_idle) and - schact_is_rct and - (\s. 0 < domain_time s \ valid_domain_list s)) s; - \s'. (s, s') \ state_relation \ - (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and - (\s. ksSchedulerAction s = ResumeCurrentThread)) s' \ - \ fst (call_kernel event s) \ {}" + schact_is_rct and (\s. 0 < domain_time s \ valid_domain_list s)) s; + \s'. (s, s') \ state_relation \ + (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and + (\s. ksSchedulerAction s = ResumeCurrentThread) and + (\s. vs_valid_duplicates' (ksPSpace s))) s' \ + \ fst (call_kernel event s) \ {}" apply (cut_tac m = "call_kernel event" in corres_underlying_serial) apply (rule kernel_corres) apply (rule callKernel_empty_fail) @@ -333,5 +130,3 @@ theorem call_kernel_serial: done end - -end diff --git a/proof/refine/ARM/ArchEmptyFail_H.thy b/proof/refine/ARM/ArchEmptyFail_H.thy index 8b0160f883..613094a876 100644 --- a/proof/refine/ARM/ArchEmptyFail_H.thy +++ b/proof/refine/ARM/ArchEmptyFail_H.thy @@ -1,5 +1,6 @@ (* * Copyright 2014, General Dynamics C4 Systems + * Copyright 2023, Proofcraft Pty Ltd * * SPDX-License-Identifier: GPL-2.0-only *) @@ -8,280 +9,86 @@ theory ArchEmptyFail_H imports EmptyFail_H begin -crunch_ignore (empty_fail) - (add: handleE' getCTE getObject updateObject - CSpaceDecls_H.resolveAddressBits - doMachineOp suspend restart schedule) +context Arch begin arch_global_naming -context begin interpretation Arch . (*FIXME: arch-split*) +named_theorems EmptyFail_H_assms -lemmas forM_empty_fail[intro!, wp, simp] = empty_fail_mapM[simplified forM_def[symmetric]] -lemmas forM_x_empty_fail[intro!, wp, simp] = empty_fail_mapM_x[simplified forM_x_def[symmetric]] -lemmas forME_x_empty_fail[intro!, wp, simp] = empty_fail_mapME_x[simplified forME_x_def[symmetric]] +lemma arch_deriveCap_empty_fail[EmptyFail_H_assms, intro!, wp, simp]: + "empty_fail (Arch.deriveCap x y)" + unfolding ARM_H.deriveCap_def + by (cases y, auto simp: isCap_simps cong: if_cong) -lemma withoutPreemption_empty_fail[intro!, wp, simp]: - "empty_fail m \ empty_fail (withoutPreemption m)" - by simp - -lemma withoutFailure_empty_fail[intro!, wp, simp]: - "empty_fail m \ empty_fail (withoutFailure m)" - by simp - -lemma catchFailure_empty_fail[intro!, wp, simp]: - "\ empty_fail f; \x. empty_fail (g x) \ \ empty_fail (catchFailure f g)" - by (simp add: empty_fail_catch) - -lemma emptyOnFailure_empty_fail[intro!, wp, simp]: - "empty_fail m \ empty_fail (emptyOnFailure m)" - by (simp add: emptyOnFailure_def empty_fail_catch) - -lemma rethrowFailure_empty_fail [intro!, wp, simp]: - "empty_fail m \ empty_fail (rethrowFailure f m)" - apply (simp add:rethrowFailure_def o_def) - apply (wp | simp)+ - done - -lemma unifyFailure_empty_fail [intro!, wp, simp]: - "empty_fail f \ empty_fail (unifyFailure f)" - by (simp add: unifyFailure_def) - -lemma lookupErrorOnFailure_empty_fail [intro!, wp, simp]: - "empty_fail f \ empty_fail (lookupErrorOnFailure isSource f)" - by (simp add: lookupErrorOnFailure_def) - -lemma setObject_empty_fail [intro!, wp, simp]: - assumes x: "(\a b c. empty_fail (updateObject v a x b c))" - shows "empty_fail (setObject x v)" - apply (simp add: setObject_def split_def) - apply (wp x | simp)+ - done - -lemma asUser_empty_fail [intro!, wp, simp]: - "empty_fail f \ empty_fail (asUser t f)" - apply (simp add:asUser_def) - apply (wp | wpc | simp | simp add: empty_fail_def)+ - done - -lemma capFaultOnFailure_empty_fail [intro!, wp, simp]: - "empty_fail m \ empty_fail (capFaultOnFailure cptr rp m)" - apply (simp add: capFaultOnFailure_def) - done - -crunch locateSlotCap - for (empty_fail) empty_fail[intro!, wp, simp] - -lemma resolveAddressBits_spec_empty_fail: - notes spec_empty_fail_bindE'[wp_split] - shows - "spec_empty_fail (CSpace_H.resolveAddressBits a b c) s" -proof (induct arbitrary: s rule: resolveAddressBits.induct) - case (1 a b c s) - show ?case - apply (simp add: resolveAddressBits.simps) - apply (wp | simp | wpc | intro impI conjI | rule drop_spec_empty_fail)+ - apply (rule use_spec_empty_fail) - apply (rule 1 | simp add: in_monad | rule drop_spec_empty_fail | force)+ - done - qed - -lemmas resolveAddressBits_empty_fail[intro!, wp, simp] = - resolveAddressBits_spec_empty_fail[THEN use_spec_empty_fail] - -declare ef_dmo'[intro!, wp, simp] - -lemma empty_fail_getObject_ep [intro!, wp, simp]: - "empty_fail (getObject p :: endpoint kernel)" +lemma empty_fail_getObject_ap[intro!, wp, simp]: + "empty_fail (getObject p :: asidpool kernel)" by (simp add: empty_fail_getObject) -lemma getEndpoint_empty_fail [intro!, wp, simp]: - "empty_fail (getEndpoint ep)" - by (simp add: getEndpoint_def) - -lemma constOnFailure_empty_fail[intro!, wp, simp]: - "empty_fail m \ empty_fail (constOnFailure x m)" - by (simp add: constOnFailure_def const_def empty_fail_catch) - -lemma ArchRetypeDecls_H_deriveCap_empty_fail[intro!, wp, simp]: - "isPageTableCap y \ isPageDirectoryCap y \ isPageCap y - \ isASIDControlCap y \ isASIDPoolCap y \ isSGISignalCap y - \ empty_fail (Arch.deriveCap x y)" - by (auto simp: ARM_H.deriveCap_def cong: if_cong) - -crunch ensureNoChildren - for (empty_fail) empty_fail[intro!, wp, simp] - -lemma deriveCap_empty_fail[intro!, wp, simp]: - "empty_fail (RetypeDecls_H.deriveCap slot y)" - apply (simp add: Retype_H.deriveCap_def) - apply (clarsimp simp: empty_fail_bindE) - apply (case_tac "capCap y"; - simp add: isPageTableCap_def isPageDirectoryCap_def isSGISignalCap_def - isPageCap_def isASIDPoolCap_def isASIDControlCap_def) - done - -crunch setExtraBadge, cteInsert - for (empty_fail) empty_fail[intro!, wp, simp] - -lemma transferCapsToSlots_empty_fail[intro!, wp, simp]: - "empty_fail (transferCapsToSlots ep buffer n caps slots mi)" - apply (induct caps arbitrary: slots n mi) - apply simp - apply (simp add: Let_def split_def - split del: if_split) - apply (simp | wp | wpc | safe)+ - done - -crunch lookupTargetSlot, ensureEmptySlot, lookupSourceSlot, lookupPivotSlot - for (empty_fail) empty_fail[intro!, wp, simp] - -lemma decodeCNodeInvocation_empty_fail[intro!, wp, simp]: - "empty_fail (decodeCNodeInvocation label args cap exs)" - apply (rule_tac label=label and args=args and exs=exs in decode_cnode_cases2) - apply (simp_all add: decodeCNodeInvocation_def - split_def cnode_invok_case_cleanup unlessE_whenE - cong: if_cong bool.case_cong list.case_cong) - by (simp | wp | wpc | safe)+ - -lemma empty_fail_getObject_ap [intro!, wp, simp]: - "empty_fail (getObject p :: asidpool kernel)" +lemma empty_fail_getObject_pte[intro!, wp, simp]: + "empty_fail (getObject p :: pte kernel)" by (simp add: empty_fail_getObject) lemma empty_fail_getObject_pde [intro!, wp, simp]: "empty_fail (getObject p :: pde kernel)" by (simp add: empty_fail_getObject) -lemma empty_fail_getObject_pte [intro!, wp, simp]: - "empty_fail (getObject p :: pte kernel)" - by (simp add: empty_fail_getObject) - -crunch decodeARMMMUInvocation - for (empty_fail) empty_fail[intro!, wp, simp] - (simp: Let_def) - -lemma ignoreFailure_empty_fail[intro!, wp, simp]: - "empty_fail x \ empty_fail (ignoreFailure x)" - by (simp add: ignoreFailure_def empty_fail_catch) +crunch decodeARMMMUInvocation, Arch_postCapDeletion, setRegister, prepareThreadDelete + for (empty_fail) empty_fail[EmptyFail_H_assms, intro!, wp, simp] + (simp: Let_def + wp: empty_fail_catch + rule: ARM_H.postCapDeletion_def) -context -notes option.case_cong_weak[cong] -begin crunch - cancelIPC, setThreadState, tcbSchedDequeue, setupReplyMaster, isStopped, - possibleSwitchTo, tcbSchedAppend - for (empty_fail) empty_fail[intro!, wp, simp] - (simp: crunch_simps) -end + Arch_finaliseCap, Arch.switchToThread, Arch.switchToIdleThread, prepareNextDomain, getRestartPC, + makeArchFaultMessage + for (empty_fail) empty_fail[EmptyFail_H_assms, intro!, wp, simp] + (rule: ARM_H.finaliseCap_def) -crunch "ThreadDecls_H.suspend" - for (empty_fail) "_H_empty_fail"[intro!, wp, simp] - (ignore_del: ThreadDecls_H.suspend) - -lemma ThreadDecls_H_restart_empty_fail[intro!, wp, simp]: - "empty_fail (ThreadDecls_H.restart target)" - by (fastforce simp: restart_def) - -crunch finaliseCap, preemptionPoint, capSwapForDelete - for (empty_fail) empty_fail[intro!, wp, simp] - (wp: empty_fail_catch simp: Let_def) - -lemmas finalise_spec_empty_fail_induct = finaliseSlot'.induct[where P= - "\sl exp s. spec_empty_fail (finaliseSlot' sl exp) s"] - -lemma spec_empty_fail_If: - "\ P \ spec_empty_fail f s; \ P \ spec_empty_fail g s \ - \ spec_empty_fail (if P then f else g) s" - by (simp split: if_split) +crunch + doFlush, + decodeTransfer, checkValidIPCBuffer, Arch.decodeIRQControlInvocation, Arch.decodeInvocation, + deleteGhost, Arch.createObject, getSanitiseRegisterInfo, + handleArchFaultReply, prepareSetDomain, postModifyRegisters, postSetFlags, + Arch.performIRQControl, Arch.invokeIRQHandler, Arch.performInvocation, handleSpuriousIRQ, + maskIrqSignal, handleVMFault, checkIRQ, prepareThreadDelete, Arch.postCapDeletion + for (empty_fail) empty_fail[EmptyFail_H_assms, intro!, wp, simp] + (simp: Let_def) -lemma spec_empty_whenE': - "\ P \ spec_empty_fail f s \ \ spec_empty_fail (whenE P f) s" - by (simp add: whenE_def spec_empty_returnOk) +end (* Arch *) -lemma finaliseSlot_spec_empty_fail: - notes spec_empty_fail_bindE'[rotated, wp_split] - shows "spec_empty_fail (finaliseSlot x b) s" -unfolding finaliseSlot_def -proof (induct rule: finalise_spec_empty_fail_induct) - case (1 x b s) - show ?case - apply (subst finaliseSlot'_simps_ext) - apply (simp only: split_def Let_def K_bind_def fun_app_def) - apply (wp spec_empty_whenE' spec_empty_fail_If | wpc - | rule 1[unfolded Let_def K_bind_def split_def fun_app_def, - simplified], (simp | intro conjI)+ - | rule drop_spec_empty_fail | simp)+ - done +interpretation EmptyFail_H?: EmptyFail_H +proof goal_cases + interpret Arch . + case 1 show ?case by (intro_locales; (unfold_locales; (fact EmptyFail_H_assms)?)?) qed -lemmas finaliseSlot_empty_fail[intro!, wp, simp] = - finaliseSlot_spec_empty_fail[THEN use_spec_empty_fail] +context Arch begin arch_global_naming -lemma checkCapAt_empty_fail[intro!, wp, simp]: - "empty_fail action \ empty_fail (checkCapAt cap ptr action)" - by (fastforce simp: checkCapAt_def) +named_theorems EmptyFail_H_2_assms -lemma assertDerived_empty_fail[intro!, wp, simp]: - "empty_fail f \ empty_fail (assertDerived src cap f)" - by (fastforce simp: assertDerived_def) - -crunch cteDelete - for (empty_fail) empty_fail[intro!, wp, simp] +crunch + handleReservedIRQ, handleHypervisorFault + for (empty_fail) empty_fail[EmptyFail_H_2_assms, intro!, wp, simp] + (simp: Let_def) -lemma spec_empty_fail_unlessE': - "\ \ P \ spec_empty_fail f s \ \ spec_empty_fail (unlessE P f) s" - by (simp add:unlessE_def spec_empty_returnOk) +end (* Arch *) -lemma cteRevoke_spec_empty_fail: - notes spec_empty_fail_bindE'[wp_split] - shows "spec_empty_fail (cteRevoke p) s" -proof (induct rule: cteRevoke.induct) - case (1 p s) - show ?case - apply (simp add: cteRevoke.simps) - apply (wp spec_empty_whenE' spec_empty_fail_unlessE' | rule drop_spec_empty_fail, wp)+ - apply (rule 1, auto simp add: in_monad) - done +interpretation EmptyFail_H_2?: EmptyFail_H_2 +proof goal_cases + interpret Arch . + case 1 show ?case by (intro_locales; (unfold_locales; (fact EmptyFail_H_2_assms)?)?) qed -lemmas cteRevoke_empty_fail[intro!, wp, simp] = - cteRevoke_spec_empty_fail[THEN use_spec_empty_fail] - -lemma Syscall_H_syscall_empty_fail[intro!, wp, simp]: - "\empty_fail a; \x. empty_fail (b x); \x. empty_fail (c x); - \x. empty_fail (d x); \x. empty_fail (e x)\ - \ empty_fail (syscall a b c d e)" - apply (simp add:syscall_def) - apply (wp | wpc | simp)+ - done - -lemma catchError_empty_fail[intro!, wp, simp]: - "\ empty_fail f; \x. empty_fail (g x) \ \ empty_fail (catchError f g)" - by fastforce - -crunch - chooseThread, getDomainTime, nextDomain, isHighestPrio, prepareNextDomain - for (empty_fail) empty_fail[intro!, wp, simp] - (wp: empty_fail_catch) - -lemma ThreadDecls_H_schedule_empty_fail[intro!, wp, simp]: - "empty_fail schedule" - supply if_cong[cong] - apply (simp add: schedule_def) - apply (clarsimp simp: scheduleChooseNewThread_def split: if_split | wp | wpc)+ - done - crunch callKernel for (empty_fail) empty_fail (wp: empty_fail_catch) theorem call_kernel_serial: "\ (einvs and (\s. event \ Interrupt \ ct_running s) and (ct_running or ct_idle) and - schact_is_rct and - (\s. 0 < domain_time s \ valid_domain_list s)) s; - \s'. (s, s') \ state_relation \ - (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and - (\s. ksSchedulerAction s = ResumeCurrentThread) and - (\s. vs_valid_duplicates' (ksPSpace s))) s' \ - \ fst (call_kernel event s) \ {}" + schact_is_rct and (\s. 0 < domain_time s \ valid_domain_list s)) s; + \s'. (s, s') \ state_relation \ + (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and + (\s. ksSchedulerAction s = ResumeCurrentThread) and + (\s. vs_valid_duplicates' (ksPSpace s))) s' \ + \ fst (call_kernel event s) \ {}" apply (cut_tac m = "call_kernel event" in corres_underlying_serial) apply (rule kernel_corres) apply (rule callKernel_empty_fail) @@ -289,5 +96,3 @@ theorem call_kernel_serial: done end - -end diff --git a/proof/refine/ARM_HYP/ArchEmptyFail_H.thy b/proof/refine/ARM_HYP/ArchEmptyFail_H.thy index e519cde26d..6f076650bd 100644 --- a/proof/refine/ARM_HYP/ArchEmptyFail_H.thy +++ b/proof/refine/ARM_HYP/ArchEmptyFail_H.thy @@ -1,5 +1,6 @@ (* * Copyright 2014, General Dynamics C4 Systems + * Copyright 2023, Proofcraft Pty Ltd * * SPDX-License-Identifier: GPL-2.0-only *) @@ -8,293 +9,95 @@ theory ArchEmptyFail_H imports EmptyFail_H begin -crunch_ignore (empty_fail) - (add: handleE' getCTE getObject updateObject - CSpaceDecls_H.resolveAddressBits - doMachineOp suspend restart schedule) +context Arch begin arch_global_naming -context begin interpretation Arch . (*FIXME: arch-split*) +named_theorems EmptyFail_H_assms -lemmas forM_empty_fail[intro!, wp, simp] = empty_fail_mapM[simplified forM_def[symmetric]] -lemmas forM_x_empty_fail[intro!, wp, simp] = empty_fail_mapM_x[simplified forM_x_def[symmetric]] -lemmas forME_x_empty_fail[intro!, wp, simp] = empty_fail_mapME_x[simplified forME_x_def[symmetric]] +lemma arch_deriveCap_empty_fail[EmptyFail_H_assms, intro!, wp, simp]: + "empty_fail (Arch.deriveCap x y)" + unfolding ARM_HYP_H.deriveCap_def + by (cases y, auto simp: isCap_simps cong: if_cong) -lemma withoutPreemption_empty_fail[intro!, wp, simp]: - "empty_fail m \ empty_fail (withoutPreemption m)" - by simp - -lemma withoutFailure_empty_fail[intro!, wp, simp]: - "empty_fail m \ empty_fail (withoutFailure m)" - by simp - -lemma catchFailure_empty_fail[intro!, wp, simp]: - "\ empty_fail f; \x. empty_fail (g x) \ \ empty_fail (catchFailure f g)" - by (simp add: empty_fail_catch) - -lemma emptyOnFailure_empty_fail[intro!, wp, simp]: - "empty_fail m \ empty_fail (emptyOnFailure m)" - by (simp add: emptyOnFailure_def empty_fail_catch) - -lemma rethrowFailure_empty_fail [intro!, wp, simp]: - "empty_fail m \ empty_fail (rethrowFailure f m)" - apply (simp add:rethrowFailure_def o_def) - apply (wp | simp)+ - done - -lemma unifyFailure_empty_fail [intro!, wp, simp]: - "empty_fail f \ empty_fail (unifyFailure f)" - by (simp add: unifyFailure_def) - -lemma lookupErrorOnFailure_empty_fail [intro!, wp, simp]: - "empty_fail f \ empty_fail (lookupErrorOnFailure isSource f)" - by (simp add: lookupErrorOnFailure_def) - -lemma setObject_empty_fail [intro!, wp, simp]: - assumes x: "(\a b c. empty_fail (updateObject v a x b c))" - shows "empty_fail (setObject x v)" - apply (simp add: setObject_def split_def) - apply (wp x | simp)+ - done - -lemma asUser_empty_fail [intro!, wp, simp]: - "empty_fail f \ empty_fail (asUser t f)" - apply (simp add:asUser_def) - apply (wp | wpc | simp | simp add: empty_fail_def)+ - done - -lemma capFaultOnFailure_empty_fail [intro!, wp, simp]: - "empty_fail m \ empty_fail (capFaultOnFailure cptr rp m)" - apply (simp add: capFaultOnFailure_def) - done - -crunch locateSlotCap - for (empty_fail) empty_fail[intro!, wp, simp] - -lemma resolveAddressBits_spec_empty_fail: - notes spec_empty_fail_bindE'[wp_split] - shows - "spec_empty_fail (CSpace_H.resolveAddressBits a b c) s" -proof (induct arbitrary: s rule: resolveAddressBits.induct) - case (1 a b c s) - show ?case - apply (simp add: resolveAddressBits.simps) - apply (wp | simp | wpc | intro impI conjI | rule drop_spec_empty_fail)+ - apply (rule use_spec_empty_fail) - apply (rule 1 | simp add: in_monad | rule drop_spec_empty_fail | force)+ - done - qed - -lemmas resolveAddressBits_empty_fail[intro!, wp, simp] = - resolveAddressBits_spec_empty_fail[THEN use_spec_empty_fail] - -declare ef_dmo'[intro!, wp, simp] - -lemma empty_fail_getObject_ep [intro!, wp, simp]: - "empty_fail (getObject p :: endpoint kernel)" +lemma empty_fail_getObject_ap[intro!, wp, simp]: + "empty_fail (getObject p :: asidpool kernel)" by (simp add: empty_fail_getObject) -lemma getEndpoint_empty_fail [intro!, wp, simp]: - "empty_fail (getEndpoint ep)" - by (simp add: getEndpoint_def) - -lemma constOnFailure_empty_fail[intro!, wp, simp]: - "empty_fail m \ empty_fail (constOnFailure x m)" - by (simp add: constOnFailure_def const_def empty_fail_catch) - -lemma ArchRetypeDecls_H_deriveCap_empty_fail[intro!, wp, simp]: - "isPageTableCap y \ isPageDirectoryCap y \ isPageCap y - \ isASIDControlCap y \ isASIDPoolCap y \ isVCPUCap y \ isSGISignalCap y - \ empty_fail (Arch.deriveCap x y)" - by (auto simp: ARM_HYP_H.deriveCap_def cong: if_cong) - -crunch ensureNoChildren - for (empty_fail) empty_fail[intro!, wp, simp] - -lemma deriveCap_empty_fail[intro!, wp, simp]: - "empty_fail (RetypeDecls_H.deriveCap slot y)" - apply (simp add: Retype_H.deriveCap_def) - apply (clarsimp simp: empty_fail_bindE) - apply (cases "capCap y"; simp add: isCap_defs) - done - -crunch setExtraBadge, cteInsert - for (empty_fail) empty_fail[intro!, wp, simp] - -lemma transferCapsToSlots_empty_fail[intro!, wp, simp]: - "empty_fail (transferCapsToSlots ep buffer n caps slots mi)" - apply (induct caps arbitrary: slots n mi) - apply simp - apply (simp add: Let_def split_def - split del: if_split) - apply (simp | wp | wpc | safe)+ - done - -crunch lookupTargetSlot, ensureEmptySlot, lookupSourceSlot, lookupPivotSlot - for (empty_fail) empty_fail[intro!, wp, simp] - -lemma decodeCNodeInvocation_empty_fail[intro!, wp, simp]: - "empty_fail (decodeCNodeInvocation label args cap exs)" - apply (rule_tac label=label and args=args and exs=exs in decode_cnode_cases2) - apply (simp_all add: decodeCNodeInvocation_def - split_def cnode_invok_case_cleanup unlessE_whenE - cong: if_cong bool.case_cong list.case_cong) - by (simp | wp | wpc | safe)+ - -lemma empty_fail_getObject_ap [intro!, wp, simp]: - "empty_fail (getObject p :: asidpool kernel)" +lemma empty_fail_getObject_pte[intro!, wp, simp]: + "empty_fail (getObject p :: pte kernel)" by (simp add: empty_fail_getObject) lemma empty_fail_getObject_pde [intro!, wp, simp]: "empty_fail (getObject p :: pde kernel)" by (simp add: empty_fail_getObject) -lemma empty_fail_getObject_pte [intro!, wp, simp]: - "empty_fail (getObject p :: pte kernel)" - by (simp add: empty_fail_getObject) - -lemma empty_fail_getObject_vcpu [intro!, wp, simp]: +lemma empty_fail_getObject_vcpu[intro!, wp, simp]: "empty_fail (getObject p :: vcpu kernel)" by (simp add: empty_fail_getObject) -crunch decodeARMMMUInvocation - for (empty_fail) empty_fail[intro!, wp, simp] -(simp: Let_def ARMMMU_improve_cases) - -lemma ignoreFailure_empty_fail[intro!, wp, simp]: - "empty_fail x \ empty_fail (ignoreFailure x)" - by (simp add: ignoreFailure_def empty_fail_catch) - -context -notes option.case_cong_weak[cong] -begin -crunch - cancelIPC, setThreadState, tcbSchedDequeue, setupReplyMaster, isStopped, possibleSwitchTo, tcbSchedAppend - for (empty_fail) empty_fail[intro!, wp, simp] - (simp: crunch_simps) -end - -crunch "ThreadDecls_H.suspend" - for (empty_fail) "_H_empty_fail"[intro!, wp, simp] - (ignore_del: ThreadDecls_H.suspend) - -lemma ThreadDecls_H_restart_empty_fail[intro!, wp, simp]: - "empty_fail (ThreadDecls_H.restart target)" - by (fastforce simp: restart_def) - -lemma vcpuUpdate_empty_fail[intro!, wp, simp]: - "empty_fail (vcpuUpdate p f)" - by (fastforce simp: vcpuUpdate_def) +crunch decodeARMMMUInvocation, Arch_postCapDeletion, setRegister, prepareThreadDelete + for (empty_fail) empty_fail[EmptyFail_H_assms, intro!, wp, simp] + (simp: Let_def ARMMMU_improve_cases + wp: empty_fail_catch + rule: ARM_HYP_H.postCapDeletion_def) crunch vcpuEnable, vcpuRestore for (empty_fail) empty_fail[intro!, wp, simp] (simp: uncurry_def) -crunch finaliseCap, preemptionPoint, capSwapForDelete - for (empty_fail) empty_fail[intro!, wp, simp] - (wp: empty_fail_catch simp: Let_def ignore: get_gic_vcpu_ctrl_lr_impl) - -lemmas finalise_spec_empty_fail_induct = finaliseSlot'.induct[where P= - "\sl exp s. spec_empty_fail (finaliseSlot' sl exp) s"] - -lemma spec_empty_fail_If: - "\ P \ spec_empty_fail f s; \ P \ spec_empty_fail g s \ - \ spec_empty_fail (if P then f else g) s" - by (simp split: if_split) - -lemma spec_empty_whenE': - "\ P \ spec_empty_fail f s \ \ spec_empty_fail (whenE P f) s" - by (simp add: whenE_def spec_empty_returnOk) - -lemma finaliseSlot_spec_empty_fail: - notes spec_empty_fail_bindE'[rotated, wp_split] - shows "spec_empty_fail (finaliseSlot x b) s" -unfolding finaliseSlot_def -proof (induct rule: finalise_spec_empty_fail_induct) - case (1 x b s) - show ?case - apply (subst finaliseSlot'_simps_ext) - apply (simp only: split_def Let_def K_bind_def fun_app_def) - apply (wp spec_empty_whenE' spec_empty_fail_If | wpc - | rule 1[unfolded Let_def K_bind_def split_def fun_app_def, - simplified], (simp | intro conjI)+ - | rule drop_spec_empty_fail | simp)+ - done -qed - -lemmas finaliseSlot_empty_fail[intro!, wp, simp] = - finaliseSlot_spec_empty_fail[THEN use_spec_empty_fail] - -lemma checkCapAt_empty_fail[intro!, wp, simp]: - "empty_fail action \ empty_fail (checkCapAt cap ptr action)" - by (fastforce simp: checkCapAt_def) - -lemma assertDerived_empty_fail[intro!, wp, simp]: - "empty_fail f \ empty_fail (assertDerived src cap f)" - by (fastforce simp: assertDerived_def) +crunch + Arch_finaliseCap, Arch.switchToThread, Arch.switchToIdleThread, prepareNextDomain, getRestartPC, + makeArchFaultMessage + for (empty_fail) empty_fail[EmptyFail_H_assms, intro!, wp, simp] + (rule: ARM_HYP_H.finaliseCap_def + ignore: get_gic_vcpu_ctrl_vmcr get_gic_vcpu_ctrl_apr) -crunch cteDelete - for (empty_fail) empty_fail[intro!, wp, simp] +crunch + decodeVCPUInjectIRQ, decodeVCPUWriteReg, decodeVCPUReadReg, doFlush, decodeVCPUAckVPPI, + decodeTransfer, checkValidIPCBuffer, Arch.decodeIRQControlInvocation, Arch.decodeInvocation, + deleteGhost, Arch.createObject, getSanitiseRegisterInfo, + handleArchFaultReply, prepareSetDomain, postModifyRegisters, postSetFlags, + Arch.performIRQControl, Arch.invokeIRQHandler, Arch.performInvocation, handleSpuriousIRQ, + maskIrqSignal, handleVMFault, checkIRQ, prepareThreadDelete, Arch.postCapDeletion + for (empty_fail) empty_fail[EmptyFail_H_assms, intro!, wp, simp] + (simp: Let_def) -lemma spec_empty_fail_unlessE': - "\ \ P \ spec_empty_fail f s \ \ spec_empty_fail (unlessE P f) s" - by (simp add:unlessE_def spec_empty_returnOk) +end (* Arch *) -lemma cteRevoke_spec_empty_fail: - notes spec_empty_fail_bindE'[wp_split] - shows "spec_empty_fail (cteRevoke p) s" -proof (induct rule: cteRevoke.induct) - case (1 p s) - show ?case - apply (simp add: cteRevoke.simps) - apply (wp spec_empty_whenE' spec_empty_fail_unlessE' | rule drop_spec_empty_fail, wp)+ - apply (rule 1, auto simp add: in_monad) - done +interpretation EmptyFail_H?: EmptyFail_H +proof goal_cases + interpret Arch . + case 1 show ?case by (intro_locales; (unfold_locales; (fact EmptyFail_H_assms)?)?) qed -lemmas cteRevoke_empty_fail[intro!, wp, simp] = - cteRevoke_spec_empty_fail[THEN use_spec_empty_fail] - -lemma Syscall_H_syscall_empty_fail[intro!, wp, simp]: - "\empty_fail a; \x. empty_fail (b x); \x. empty_fail (c x); - \x. empty_fail (d x); \x. empty_fail (e x)\ - \ empty_fail (syscall a b c d e)" - apply (simp add:syscall_def) - apply (wp | wpc | simp)+ - done +context Arch begin arch_global_naming -lemma catchError_empty_fail[intro!, wp, simp]: - "\ empty_fail f; \x. empty_fail (g x) \ \ empty_fail (catchError f g)" - by fastforce +named_theorems EmptyFail_H_2_assms crunch - chooseThread, getDomainTime, nextDomain, isHighestPrio, prepareNextDomain - for (empty_fail) empty_fail[intro!, wp, simp] - (wp: empty_fail_catch ignore: get_gic_vcpu_ctrl_apr get_gic_vcpu_ctrl_vmcr) + handleReservedIRQ, handleHypervisorFault + for (empty_fail) empty_fail[EmptyFail_H_2_assms, intro!, wp, simp] + (simp: Let_def) -lemma ThreadDecls_H_schedule_empty_fail[intro!, wp, simp]: - "empty_fail schedule" - supply if_cong[cong] - apply (simp add: schedule_def) - apply (clarsimp simp: scheduleChooseNewThread_def split: if_split | wp | wpc)+ - done +end (* Arch *) -crunch decodeVCPUInjectIRQ, decodeVCPUWriteReg, decodeVCPUReadReg, doFlush - for (empty_fail) empty_fail - (simp: Let_def) +interpretation EmptyFail_H_2?: EmptyFail_H_2 +proof goal_cases + interpret Arch . + case 1 show ?case by (intro_locales; (unfold_locales; (fact EmptyFail_H_2_assms)?)?) +qed crunch callKernel for (empty_fail) empty_fail - (wp: empty_fail_catch simp: Let_def) + (wp: empty_fail_catch) theorem call_kernel_serial: "\ (einvs and (\s. event \ Interrupt \ ct_running s) and (ct_running or ct_idle) and - schact_is_rct and - (\s. 0 < domain_time s \ valid_domain_list s)) s; - \s'. (s, s') \ state_relation \ - (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and - (\s. ksSchedulerAction s = ResumeCurrentThread) and - (\s. vs_valid_duplicates' (ksPSpace s))) s' \ - \ fst (call_kernel event s) \ {}" + schact_is_rct and (\s. 0 < domain_time s \ valid_domain_list s)) s; + \s'. (s, s') \ state_relation \ + (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and + (\s. ksSchedulerAction s = ResumeCurrentThread) and + (\s. vs_valid_duplicates' (ksPSpace s))) s' \ + \ fst (call_kernel event s) \ {}" apply (cut_tac m = "call_kernel event" in corres_underlying_serial) apply (rule kernel_corres) apply (rule callKernel_empty_fail) @@ -302,5 +105,3 @@ theorem call_kernel_serial: done end - -end diff --git a/proof/refine/EmptyFail_H.thy b/proof/refine/EmptyFail_H.thy index 00c2b068ea..826a8941e4 100644 --- a/proof/refine/EmptyFail_H.thy +++ b/proof/refine/EmptyFail_H.thy @@ -10,4 +10,306 @@ theory EmptyFail_H imports ArchRefine begin +arch_requalify_facts (* FIXME arch-split: Machine_AI *) + storeWord_empty_fail setRegister_empty_fail getRestartPC_empty_fail resetTimer_empty_fail + setNextPC_empty_fail +lemmas [intro!, wp, simp] = + storeWord_empty_fail setRegister_empty_fail getRestartPC_empty_fail resetTimer_empty_fail + setNextPC_empty_fail + +arch_requalify_facts (* FIXME arch-split: ArchEmptyFail_AI *) + freeMemory_empty_fail clearMemory_empty_fail +lemmas [intro!, wp, simp] = freeMemory_empty_fail clearMemory_empty_fail + +arch_requalify_consts (H) deleteGhost maskIrqSignal + +crunch_ignore (empty_fail) + (add: handleE' getCTE getObject updateObject + CSpaceDecls_H.resolveAddressBits + doMachineOp suspend restart schedule) + +lemmas forM_empty_fail[intro!, wp, simp] = empty_fail_mapM[simplified forM_def[symmetric]] +lemmas forM_x_empty_fail[intro!, wp, simp] = empty_fail_mapM_x[simplified forM_x_def[symmetric]] +lemmas forME_x_empty_fail[intro!, wp, simp] = empty_fail_mapME_x[simplified forME_x_def[symmetric]] + +lemma withoutPreemption_empty_fail[intro!, wp, simp]: + "empty_fail m \ empty_fail (withoutPreemption m)" + by simp + +lemma withoutFailure_empty_fail[intro!, wp, simp]: + "empty_fail m \ empty_fail (withoutFailure m)" + by simp + +lemma catchFailure_empty_fail[intro!, wp, simp]: + "\ empty_fail f; \x. empty_fail (g x) \ \ empty_fail (catchFailure f g)" + by (simp add: empty_fail_catch) + +lemma emptyOnFailure_empty_fail[intro!, wp, simp]: + "empty_fail m \ empty_fail (emptyOnFailure m)" + by (simp add: emptyOnFailure_def empty_fail_catch) + +lemma rethrowFailure_empty_fail [intro!, wp, simp]: + "empty_fail m \ empty_fail (rethrowFailure f m)" + by (wpsimp simp:rethrowFailure_def o_def) + +lemma unifyFailure_empty_fail [intro!, wp, simp]: + "empty_fail f \ empty_fail (unifyFailure f)" + by (simp add: unifyFailure_def) + +lemma lookupErrorOnFailure_empty_fail [intro!, wp, simp]: + "empty_fail f \ empty_fail (lookupErrorOnFailure isSource f)" + by (simp add: lookupErrorOnFailure_def) + +lemma setObject_empty_fail [intro!, wp, simp]: + assumes x: "(\a b c. empty_fail (updateObject v a x b c))" + shows "empty_fail (setObject x v)" + by (wpsimp simp: setObject_def split_def wp: x) + +lemma asUser_empty_fail [intro!, wp, simp]: + "empty_fail f \ empty_fail (asUser t f)" + unfolding asUser_def + by (wpsimp | simp add: empty_fail_def)+ + +lemma capFaultOnFailure_empty_fail [intro!, wp, simp]: + "empty_fail m \ empty_fail (capFaultOnFailure cptr rp m)" + by (simp add: capFaultOnFailure_def) + +crunch locateSlotCap + for (empty_fail) empty_fail[intro!, wp, simp] + +lemma resolveAddressBits_spec_empty_fail: + notes spec_empty_fail_bindE'[wp_split] + shows + "spec_empty_fail (CSpace_H.resolveAddressBits a b c) s" +proof (induct arbitrary: s rule: resolveAddressBits.induct) + case (1 a b c s) + show ?case + apply (simp add: resolveAddressBits.simps) + apply (wp | simp | wpc | intro impI conjI | rule drop_spec_empty_fail)+ + apply (rule use_spec_empty_fail) + apply (rule 1 | simp add: in_monad | rule drop_spec_empty_fail | force)+ + done + qed + +lemmas resolveAddressBits_empty_fail[intro!, wp, simp] = + resolveAddressBits_spec_empty_fail[THEN use_spec_empty_fail] + +declare ef_dmo'[intro!, wp, simp] + +lemma empty_fail_getObject_ep [intro!, wp, simp]: + "empty_fail (getObject p :: endpoint kernel)" + by (simp add: empty_fail_getObject) + +lemma getEndpoint_empty_fail [intro!, wp, simp]: + "empty_fail (getEndpoint ep)" + by (simp add: getEndpoint_def) + +lemma constOnFailure_empty_fail[intro!, wp, simp]: + "empty_fail m \ empty_fail (constOnFailure x m)" + by (simp add: constOnFailure_def const_def empty_fail_catch) + +crunch ensureNoChildren + for (empty_fail) empty_fail[intro!, wp, simp] + +lemma ignoreFailure_empty_fail[intro!, wp, simp]: + "empty_fail x \ empty_fail (ignoreFailure x)" + by (simp add: ignoreFailure_def empty_fail_catch) + +crunch setExtraBadge, cteInsert + for (empty_fail) empty_fail[intro!, wp, simp] + (ignore: storeWord) + +crunch lookupTargetSlot, ensureEmptySlot, lookupSourceSlot, lookupPivotSlot + for (empty_fail) empty_fail[intro!, wp, simp] + +lemmas finalise_spec_empty_fail_induct = + finaliseSlot'.induct[where P="\sl exp s. spec_empty_fail (finaliseSlot' sl exp) s"] + +lemma spec_empty_fail_If: + "\ P \ spec_empty_fail f s; \ P \ spec_empty_fail g s \ + \ spec_empty_fail (if P then f else g) s" + by (simp split: if_split) + +lemma spec_empty_whenE': + "\ P \ spec_empty_fail f s \ \ spec_empty_fail (whenE P f) s" + by (simp add: whenE_def spec_empty_returnOk) + +lemma checkCapAt_empty_fail[intro!, wp, simp]: + "empty_fail action \ empty_fail (checkCapAt cap ptr action)" + by (fastforce simp: checkCapAt_def) + +lemma assertDerived_empty_fail[intro!, wp, simp]: + "empty_fail f \ empty_fail (assertDerived src cap f)" + by (fastforce simp: assertDerived_def) + +lemma spec_empty_fail_unlessE': + "\ \ P \ spec_empty_fail f s \ \ spec_empty_fail (unlessE P f) s" + by (simp add:unlessE_def spec_empty_returnOk) + +lemma Syscall_H_syscall_empty_fail[intro!, wp, simp]: + "\empty_fail a; \x. empty_fail (b x); \x. empty_fail (c x); + \x. empty_fail (d x); \x. empty_fail (e x)\ + \ empty_fail (syscall a b c d e)" + apply (simp add:syscall_def) + apply (wp | wpc | simp)+ + done + +lemma catchError_empty_fail[intro!, wp, simp]: + "\ empty_fail f; \x. empty_fail (g x) \ \ empty_fail (catchError f g)" + by fastforce + +crunch setMRs, setMessageInfo + for (empty_fail) empty_fail[wp, simp] + (wp: empty_fail_catch simp: const_def Let_def) + +locale EmptyFail_H = + assumes arch_deriveCap_empty_fail[intro!, wp, simp]: + "\x y. empty_fail (Arch.deriveCap x y)" + assumes Arch_postCapDeletion_empty_fail[intro!, wp, simp]: + "\c. empty_fail (Arch.postCapDeletion c)" + assumes prepareThreadDelete_empty_fail[intro!, wp, simp]: + "\t. empty_fail (prepareThreadDelete t)" + assumes arch_finaliseCap_empty_fail[intro!, wp, simp]: + "\x y. empty_fail (Arch.finaliseCap x y)" + assumes arch_switchToThread_empty_fail[intro!, wp, simp]: + "\t. empty_fail (Arch.switchToThread t)" + assumes arch_switchToIdleThread_empty_fail[intro!, wp, simp]: + "empty_fail Arch.switchToIdleThread" + assumes prepareNextDomain_empty_fail[intro!, wp, simp]: + "empty_fail Arch.prepareNextDomain" + assumes makeArchFaultMessage_empty_fail[intro!, wp, simp]: + "\af t. empty_fail (makeArchFaultMessage af t)" + assumes maskIrqSignal_empty_fail[intro!, wp, simp]: + "\irq. empty_fail (Arch.maskIrqSignal irq)" + assumes decodeTransfer_empty_fail[intro!, wp, simp]: + "\arg. empty_fail (decodeTransfer arg)" + assumes checkValidIPCBuffer_empty_fail[intro!, wp, simp]: + "\vptr cap. empty_fail (checkValidIPCBuffer vptr cap)" + assumes Arch_decodeIRQControlInvocation_empty_fail[intro!, wp, simp]: + "\label args srcSlot extraCaps. + empty_fail (Arch.decodeIRQControlInvocation label args srcSlot extraCaps)" + assumes Arch_decodeInvocation_empty_fail[intro!, wp, simp]: + "\label args capIndex slot cap extraCaps. + empty_fail (Arch.decodeInvocation label args capIndex slot cap extraCaps)" + assumes deleteGhost_empty_fail[intro!, wp, simp]: + "\ptr bits. empty_fail (Arch.deleteGhost ptr bits)" + assumes Arch_createObject_empty_fail[intro!, wp, simp]: + "\t regionBase arg isDevice. empty_fail (Arch.createObject t regionBase arg isDevice)" + assumes getSanitiseRegisterInfo_empty_fail[intro!, wp, simp]: + "\t. empty_fail (getSanitiseRegisterInfo t)" + assumes handleArchFaultReply_empty_fail[intro!, wp, simp]: + "\x0 x1 x2 x3. empty_fail (handleArchFaultReply x0 x1 x2 x3)" + assumes prepareSetDomain_empty_fail[intro!, wp, simp]: + "\t newDom. empty_fail (prepareSetDomain t newDom)" + assumes postModifyRegisters_empty_fail[intro!, wp, simp]: + "\arg1 arg2. empty_fail (postModifyRegisters arg1 arg2)" + assumes postSetFlags_empty_fail[intro!, wp, simp]: + "\t flags. empty_fail (postSetFlags t flags)" + assumes Arch_performIRQControl_empty_fail[intro!, wp, simp]: + "\irq_inv. empty_fail (Arch.performIRQControl irq_inv)" + assumes Arch_invokeIRQHandler_empty_fail[intro!, wp, simp]: + "\irq_inv. empty_fail (Arch.invokeIRQHandler irq_inv)" + assumes Arch_performInvocation_empty_fail[intro!, wp, simp]: + "\i. empty_fail (Arch.performInvocation i)" + assumes handleSpuriousIRQ_empty_fail[intro!, wp, simp]: + "empty_fail handleSpuriousIRQ" + assumes handleVMFault_empty_fail[intro!, wp, simp]: + "\t vmfault. empty_fail (handleVMFault t vmfault)" + assumes checkIRQ_empty_fail[intro!, wp, simp]: + "\irq. empty_fail (checkIRQ irq)" +begin + +lemma deriveCap_empty_fail[intro!, wp, simp]: + "empty_fail (RetypeDecls_H.deriveCap slot y)" + by (clarsimp simp: empty_fail_bindE deriveCap_def) + +lemma transferCapsToSlots_empty_fail[intro!, wp, simp]: + "empty_fail (transferCapsToSlots ep buffer n caps slots mi)" + by (induct caps arbitrary: slots n mi; + wpsimp simp: Let_def split_def split_del: if_split) + +lemma decodeCNodeInvocation_empty_fail[intro!, wp, simp]: + "empty_fail (decodeCNodeInvocation label args cap exs)" + apply (rule_tac label=label and args=args and exs=exs in decode_cnode_cases2) + apply (simp_all add: decodeCNodeInvocation_def + split_def cnode_invok_case_cleanup unlessE_whenE + cong: if_cong bool.case_cong list.case_cong) + by (simp | wp | wpc | safe)+ (* slow *) + +crunch cancelIPC, setThreadState, tcbSchedDequeue, setupReplyMaster, isStopped, possibleSwitchTo, tcbSchedAppend + for (empty_fail) empty_fail[intro!, wp, simp] + (simp: Let_def setNotification_def setBoundNotification_def wp: empty_fail_getObject) + +crunch ThreadDecls_H.suspend + for (empty_fail) "_H_empty_fail"[intro!, wp, simp] + (ignore_del: ThreadDecls_H.suspend) + +lemma ThreadDecls_H_restart_empty_fail[intro!, wp, simp]: + "empty_fail (ThreadDecls_H.restart target)" + by (fastforce simp: restart_def) + +crunch finaliseCap, preemptionPoint, capSwapForDelete + for (empty_fail) empty_fail[intro!, wp, simp] + (wp: empty_fail_catch simp: Let_def) + +lemma finaliseSlot_spec_empty_fail: + notes spec_empty_fail_bindE'[rotated, wp_split] + shows "spec_empty_fail (finaliseSlot x b) s" +unfolding finaliseSlot_def +proof (induct rule: finalise_spec_empty_fail_induct) + case (1 x b s) + show ?case + apply (subst finaliseSlot'_simps_ext) + apply (simp only: split_def Let_def K_bind_def fun_app_def) + apply (wp spec_empty_whenE' spec_empty_fail_If | wpc + | rule 1[unfolded Let_def K_bind_def split_def fun_app_def, + simplified], (simp | intro conjI)+ + | rule drop_spec_empty_fail | simp)+ + done +qed + +lemmas finaliseSlot_empty_fail[intro!, wp, simp] = + finaliseSlot_spec_empty_fail[THEN use_spec_empty_fail] + +crunch cteDelete + for (empty_fail) empty_fail[intro!, wp, simp] + +lemma cteRevoke_spec_empty_fail: + notes spec_empty_fail_bindE'[wp_split] + shows "spec_empty_fail (cteRevoke p) s" +proof (induct rule: cteRevoke.induct) + case (1 p s) + show ?case + apply (simp add: cteRevoke.simps) + apply (wp spec_empty_whenE' spec_empty_fail_unlessE' | rule drop_spec_empty_fail, wp)+ + apply (rule 1, auto simp add: in_monad) + done +qed + +lemmas cteRevoke_empty_fail[intro!, wp, simp] = + cteRevoke_spec_empty_fail[THEN use_spec_empty_fail] + +crunch + chooseThread, getDomainTime, nextDomain, isHighestPrio + for (empty_fail) empty_fail[intro!, wp, simp] + (wp: empty_fail_catch) + +lemma ThreadDecls_H_schedule_empty_fail[intro!, wp, simp]: + "empty_fail schedule" + supply if_cong[cong] + apply (simp add: schedule_def) + apply (clarsimp simp: scheduleChooseNewThread_def split: if_split | wp | wpc)+ + done + +crunch handleFault + for (empty_fail) empty_fail[wp, simp] + +end (* EmptyFail_H *) + +locale EmptyFail_H_2 = EmptyFail_H + + assumes handleReservedIRQ_empty_fail[intro!, wp, simp]: + "\irq. empty_fail (handleReservedIRQ irq)" + assumes handleHypervisorFault_empty_fail[intro!, wp, simp]: + "\thread fault. empty_fail (handleHypervisorFault thread fault)" + end diff --git a/proof/refine/RISCV64/ArchEmptyFail_H.thy b/proof/refine/RISCV64/ArchEmptyFail_H.thy index 92a691c9e6..892a44efcc 100644 --- a/proof/refine/RISCV64/ArchEmptyFail_H.thy +++ b/proof/refine/RISCV64/ArchEmptyFail_H.thy @@ -1,5 +1,6 @@ (* * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * Copyright 2023, Proofcraft Pty Ltd * * SPDX-License-Identifier: GPL-2.0-only *) @@ -8,137 +9,20 @@ theory ArchEmptyFail_H imports EmptyFail_H begin -crunch_ignore (empty_fail) - (add: handleE' getCTE getObject updateObject - CSpaceDecls_H.resolveAddressBits - doMachineOp suspend restart schedule) +context Arch begin arch_global_naming -context begin interpretation Arch . (*FIXME: arch-split*) +named_theorems EmptyFail_H_assms -lemmas forM_empty_fail[intro!, wp, simp] = empty_fail_mapM[simplified forM_def[symmetric]] -lemmas forM_x_empty_fail[intro!, wp, simp] = empty_fail_mapM_x[simplified forM_x_def[symmetric]] -lemmas forME_x_empty_fail[intro!, wp, simp] = empty_fail_mapME_x[simplified forME_x_def[symmetric]] +lemma arch_deriveCap_empty_fail[EmptyFail_H_assms, intro!, wp, simp]: + "empty_fail (Arch.deriveCap x y)" + unfolding RISCV64_H.deriveCap_def + by (cases y, auto simp: isCap_simps cong: if_cong) -lemma withoutPreemption_empty_fail[intro!, wp, simp]: - "empty_fail m \ empty_fail (withoutPreemption m)" - by simp - -lemma withoutFailure_empty_fail[intro!, wp, simp]: - "empty_fail m \ empty_fail (withoutFailure m)" - by simp - -lemma catchFailure_empty_fail[intro!, wp, simp]: - "\ empty_fail f; \x. empty_fail (g x) \ \ empty_fail (catchFailure f g)" - by (simp add: empty_fail_catch) - -lemma emptyOnFailure_empty_fail[intro!, wp, simp]: - "empty_fail m \ empty_fail (emptyOnFailure m)" - by (simp add: emptyOnFailure_def empty_fail_catch) - -lemma rethrowFailure_empty_fail [intro!, wp, simp]: - "empty_fail m \ empty_fail (rethrowFailure f m)" - by (wpsimp simp:rethrowFailure_def o_def) - -lemma unifyFailure_empty_fail [intro!, wp, simp]: - "empty_fail f \ empty_fail (unifyFailure f)" - by (simp add: unifyFailure_def) - -lemma lookupErrorOnFailure_empty_fail [intro!, wp, simp]: - "empty_fail f \ empty_fail (lookupErrorOnFailure isSource f)" - by (simp add: lookupErrorOnFailure_def) - -lemma setObject_empty_fail [intro!, wp, simp]: - assumes x: "(\a b c. empty_fail (updateObject v a x b c))" - shows "empty_fail (setObject x v)" - by (wpsimp simp: setObject_def split_def wp: x) - -lemma asUser_empty_fail [intro!, wp, simp]: - "empty_fail f \ empty_fail (asUser t f)" - unfolding asUser_def - by (wpsimp | simp add: empty_fail_def)+ - -lemma capFaultOnFailure_empty_fail [intro!, wp, simp]: - "empty_fail m \ empty_fail (capFaultOnFailure cptr rp m)" - by (simp add: capFaultOnFailure_def) - -crunch locateSlotCap - for (empty_fail) empty_fail[intro!, wp, simp] - -lemma resolveAddressBits_spec_empty_fail: - notes spec_empty_fail_bindE'[wp_split] - shows - "spec_empty_fail (CSpace_H.resolveAddressBits a b c) s" -proof (induct arbitrary: s rule: resolveAddressBits.induct) - case (1 a b c s) - show ?case - apply (simp add: resolveAddressBits.simps) - apply (wp | simp | wpc | intro impI conjI | rule drop_spec_empty_fail)+ - apply (rule use_spec_empty_fail) - apply (rule 1 | simp add: in_monad | rule drop_spec_empty_fail | force)+ - done - qed - -lemmas resolveAddressBits_empty_fail[intro!, wp, simp] = - resolveAddressBits_spec_empty_fail[THEN use_spec_empty_fail] - -declare ef_dmo'[intro!, wp, simp] - -lemma empty_fail_getObject_ep [intro!, wp, simp]: - "empty_fail (getObject p :: endpoint kernel)" - by (simp add: empty_fail_getObject) - -lemma getEndpoint_empty_fail [intro!, wp, simp]: - "empty_fail (getEndpoint ep)" - by (simp add: getEndpoint_def) - -lemma constOnFailure_empty_fail[intro!, wp, simp]: - "empty_fail m \ empty_fail (constOnFailure x m)" - by (simp add: constOnFailure_def const_def empty_fail_catch) - -lemma ArchRetypeDecls_H_deriveCap_empty_fail[intro!, wp, simp]: - "isPageTableCap y \ isFrameCap y \ isASIDControlCap y \ isASIDPoolCap y - \ empty_fail (Arch.deriveCap x y)" - by (auto simp: isCap_simps RISCV64_H.deriveCap_def cong: if_cong) - -crunch ensureNoChildren - for (empty_fail) empty_fail[intro!, wp, simp] - -lemma deriveCap_empty_fail[intro!, wp, simp]: - "empty_fail (RetypeDecls_H.deriveCap slot y)" - apply (simp add: Retype_H.deriveCap_def) - apply (clarsimp simp: empty_fail_bindE) - apply (case_tac "capCap y") - apply (simp_all add: isCap_simps) - done - -crunch setExtraBadge, cteInsert - for (empty_fail) empty_fail[intro!, wp, simp] - -lemma transferCapsToSlots_empty_fail[intro!, wp, simp]: - "empty_fail (transferCapsToSlots ep buffer n caps slots mi)" - apply (induct caps arbitrary: slots n mi) - apply simp - apply (simp add: Let_def split_def - split del: if_split) - apply (simp | wp | wpc | safe)+ - done - -crunch lookupTargetSlot, ensureEmptySlot, lookupSourceSlot, lookupPivotSlot - for (empty_fail) empty_fail[intro!, wp, simp] - -lemma decodeCNodeInvocation_empty_fail[intro!, wp, simp]: - "empty_fail (decodeCNodeInvocation label args cap exs)" - apply (rule_tac label=label and args=args and exs=exs in decode_cnode_cases2) - apply (simp_all add: decodeCNodeInvocation_def - split_def cnode_invok_case_cleanup unlessE_whenE - cong: if_cong bool.case_cong list.case_cong) - by (simp | wp | wpc | safe)+ - -lemma empty_fail_getObject_ap [intro!, wp, simp]: +lemma empty_fail_getObject_ap[intro!, wp, simp]: "empty_fail (getObject p :: asidpool kernel)" by (simp add: empty_fail_getObject) -lemma empty_fail_getObject_pte [intro!, wp, simp]: +lemma empty_fail_getObject_pte[intro!, wp, simp]: "empty_fail (getObject p :: pte kernel)" by (simp add: empty_fail_getObject) @@ -158,125 +42,55 @@ lemma empty_fail_arch_cap_exhausted: \ empty_fail undefined" by (cases cap; simp add: isCap_simps) -crunch decodeRISCVMMUInvocation - for (empty_fail) empty_fail[intro!, wp, simp] - (simp: Let_def pteAtIndex_def wp: empty_fail_catch empty_fail_arch_cap_exhausted) - -lemma ignoreFailure_empty_fail[intro!, wp, simp]: - "empty_fail x \ empty_fail (ignoreFailure x)" - by (simp add: ignoreFailure_def empty_fail_catch) - -crunch cancelIPC, setThreadState, tcbSchedDequeue, setupReplyMaster, isStopped, possibleSwitchTo, tcbSchedAppend - for (empty_fail) empty_fail[intro!, wp, simp] -(simp: Let_def setNotification_def setBoundNotification_def wp: empty_fail_getObject) - -crunch "ThreadDecls_H.suspend" - for (empty_fail) "_H_empty_fail"[intro!, wp, simp] - (ignore_del: ThreadDecls_H.suspend) - -lemma ThreadDecls_H_restart_empty_fail[intro!, wp, simp]: - "empty_fail (ThreadDecls_H.restart target)" - by (fastforce simp: restart_def) +crunch decodeRISCVMMUInvocation, Arch_postCapDeletion, setRegister, prepareThreadDelete + for (empty_fail) empty_fail[EmptyFail_H_assms, intro!, wp, simp] + (simp: Let_def pteAtIndex_def + wp: empty_fail_catch empty_fail_arch_cap_exhausted + rule: RISCV64_H.postCapDeletion_def) lemma empty_fail_lookupPTFromLevel[intro!, wp, simp]: "empty_fail (lookupPTFromLevel level ptPtr vPtr target)" by (induct level arbitrary: ptPtr; subst lookupPTFromLevel.simps; simp; wpsimp) -crunch setBoundNotification - for (empty_fail) empty_fail[intro!, wp, simp] - -crunch finaliseCap, preemptionPoint, capSwapForDelete - for (empty_fail) empty_fail[intro!, wp, simp] -(wp: empty_fail_catch simp: Let_def ignore: lookupPTFromLevel) - -lemmas finalise_spec_empty_fail_induct = finaliseSlot'.induct[where P= - "\sl exp s. spec_empty_fail (finaliseSlot' sl exp) s"] - -lemma spec_empty_fail_If: - "\ P \ spec_empty_fail f s; \ P \ spec_empty_fail g s \ - \ spec_empty_fail (if P then f else g) s" - by (simp split: if_split) - -lemma spec_empty_whenE': - "\ P \ spec_empty_fail f s \ \ spec_empty_fail (whenE P f) s" - by (simp add: whenE_def spec_empty_returnOk) - -lemma finaliseSlot_spec_empty_fail: - notes spec_empty_fail_bindE'[rotated, wp_split] - shows "spec_empty_fail (finaliseSlot x b) s" -unfolding finaliseSlot_def -proof (induct rule: finalise_spec_empty_fail_induct) - case (1 x b s) - show ?case - apply (subst finaliseSlot'_simps_ext) - apply (simp only: split_def Let_def K_bind_def fun_app_def) - apply (wp spec_empty_whenE' spec_empty_fail_If | wpc - | rule 1[unfolded Let_def K_bind_def split_def fun_app_def, - simplified], (simp | intro conjI)+ - | rule drop_spec_empty_fail | simp)+ - done -qed - -lemmas finaliseSlot_empty_fail[intro!, wp, simp] = - finaliseSlot_spec_empty_fail[THEN use_spec_empty_fail] - -lemma checkCapAt_empty_fail[intro!, wp, simp]: - "empty_fail action \ empty_fail (checkCapAt cap ptr action)" - by (fastforce simp: checkCapAt_def) - -lemma assertDerived_empty_fail[intro!, wp, simp]: - "empty_fail f \ empty_fail (assertDerived src cap f)" - by (fastforce simp: assertDerived_def) - -crunch cteDelete - for (empty_fail) empty_fail[intro!, wp, simp] - -lemma spec_empty_fail_unlessE': - "\ \ P \ spec_empty_fail f s \ \ spec_empty_fail (unlessE P f) s" - by (simp add:unlessE_def spec_empty_returnOk) +crunch + Arch_finaliseCap, Arch.switchToThread, Arch.switchToIdleThread, prepareNextDomain, getRestartPC, + makeArchFaultMessage + for (empty_fail) empty_fail[EmptyFail_H_assms, intro!, wp, simp] + (rule: RISCV64_H.finaliseCap_def) -lemma cteRevoke_spec_empty_fail: - notes spec_empty_fail_bindE'[wp_split] - shows "spec_empty_fail (cteRevoke p) s" -proof (induct rule: cteRevoke.induct) - case (1 p s) - show ?case - apply (simp add: cteRevoke.simps) - apply (wp spec_empty_whenE' spec_empty_fail_unlessE' | rule drop_spec_empty_fail, wp)+ - apply (rule 1, auto simp add: in_monad) - done +crunch + decodeTransfer, checkValidIPCBuffer, Arch.decodeIRQControlInvocation, Arch.decodeInvocation, + deleteGhost, Arch.createObject, getSanitiseRegisterInfo, + handleArchFaultReply, prepareSetDomain, postModifyRegisters, postSetFlags, + Arch.performIRQControl, Arch.invokeIRQHandler, Arch.performInvocation, handleSpuriousIRQ, + maskIrqSignal, handleVMFault, checkIRQ, prepareThreadDelete, Arch.postCapDeletion + for (empty_fail) empty_fail[EmptyFail_H_assms, intro!, wp, simp] + (simp: Let_def) + +end (* Arch *) + +interpretation EmptyFail_H?: EmptyFail_H +proof goal_cases + interpret Arch . + case 1 show ?case by (intro_locales; (unfold_locales; (fact EmptyFail_H_assms)?)?) qed -lemmas cteRevoke_empty_fail[intro!, wp, simp] = - cteRevoke_spec_empty_fail[THEN use_spec_empty_fail] +context Arch begin arch_global_naming -lemma Syscall_H_syscall_empty_fail[intro!, wp, simp]: - "\empty_fail a; \x. empty_fail (b x); \x. empty_fail (c x); - \x. empty_fail (d x); \x. empty_fail (e x)\ - \ empty_fail (syscall a b c d e)" - apply (simp add:syscall_def) - apply (wp | wpc | simp)+ - done - -lemma catchError_empty_fail[intro!, wp, simp]: - "\ empty_fail f; \x. empty_fail (g x) \ \ empty_fail (catchError f g)" - by fastforce +named_theorems EmptyFail_H_2_assms crunch - chooseThread, getDomainTime, nextDomain, isHighestPrio, prepareNextDomain - for (empty_fail) empty_fail[intro!, wp, simp] - (wp: empty_fail_catch) + handleReservedIRQ, handleHypervisorFault + for (empty_fail) empty_fail[EmptyFail_H_2_assms, intro!, wp, simp] + (simp: Let_def) -lemma ThreadDecls_H_schedule_empty_fail[intro!, wp, simp]: - "empty_fail schedule" - supply if_cong[cong] - apply (simp add: schedule_def) - apply (clarsimp simp: scheduleChooseNewThread_def split: if_split | wp | wpc)+ - done +end (* Arch *) -crunch setMRs, setMessageInfo - for (empty_fail) empty_fail[wp, simp] -(wp: empty_fail_catch simp: const_def Let_def) +interpretation EmptyFail_H_2?: EmptyFail_H_2 +proof goal_cases + interpret Arch . + case 1 show ?case by (intro_locales; (unfold_locales; (fact EmptyFail_H_2_assms)?)?) +qed crunch callKernel for (empty_fail) empty_fail @@ -284,12 +98,12 @@ crunch callKernel theorem call_kernel_serial: "\ (einvs and (\s. event \ Interrupt \ ct_running s) and (ct_running or ct_idle) and - schact_is_rct and - (\s. 0 < domain_time s \ valid_domain_list s)) s; - \s'. (s, s') \ state_relation \ - (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and - (\s. ksSchedulerAction s = ResumeCurrentThread)) s' \ - \ fst (call_kernel event s) \ {}" + schact_is_rct and (\s. 0 < domain_time s \ valid_domain_list s)) s; + \s'. (s, s') \ state_relation \ + (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and + (\s. ksSchedulerAction s = ResumeCurrentThread) and + (\s. vs_valid_duplicates' (ksPSpace s))) s' \ + \ fst (call_kernel event s) \ {}" apply (cut_tac m = "call_kernel event" in corres_underlying_serial) apply (rule kernel_corres) apply (rule callKernel_empty_fail) @@ -297,5 +111,3 @@ theorem call_kernel_serial: done end - -end diff --git a/proof/refine/X64/ArchEmptyFail_H.thy b/proof/refine/X64/ArchEmptyFail_H.thy index 5f33da29a9..4ca32c58bc 100644 --- a/proof/refine/X64/ArchEmptyFail_H.thy +++ b/proof/refine/X64/ArchEmptyFail_H.thy @@ -1,5 +1,6 @@ (* * Copyright 2014, General Dynamics C4 Systems + * Copyright 2023, Proofcraft Pty Ltd * * SPDX-License-Identifier: GPL-2.0-only *) @@ -8,151 +9,27 @@ theory ArchEmptyFail_H imports EmptyFail_H begin -crunch_ignore (empty_fail) - (add: handleE' getCTE getObject updateObject - CSpaceDecls_H.resolveAddressBits - doMachineOp suspend restart schedule) +context Arch begin arch_global_naming -context begin interpretation Arch . (*FIXME: arch-split*) +named_theorems EmptyFail_H_assms -lemmas forM_empty_fail[intro!, wp, simp] = empty_fail_mapM[simplified forM_def[symmetric]] -lemmas forM_x_empty_fail[intro!, wp, simp] = empty_fail_mapM_x[simplified forM_x_def[symmetric]] -lemmas forME_x_empty_fail[intro!, wp, simp] = empty_fail_mapME_x[simplified forME_x_def[symmetric]] +lemma arch_deriveCap_empty_fail[EmptyFail_H_assms, intro!, wp, simp]: + "empty_fail (Arch.deriveCap x y)" + unfolding X64_H.deriveCap_def + by (cases y, auto simp: isCap_simps cong: if_cong) -lemma withoutPreemption_empty_fail[intro!, wp, simp]: - "empty_fail m \ empty_fail (withoutPreemption m)" - by simp - -lemma withoutFailure_empty_fail[intro!, wp, simp]: - "empty_fail m \ empty_fail (withoutFailure m)" - by simp - -lemma catchFailure_empty_fail[intro!, wp, simp]: - "\ empty_fail f; \x. empty_fail (g x) \ \ empty_fail (catchFailure f g)" - by (simp add: empty_fail_catch) - -lemma emptyOnFailure_empty_fail[intro!, wp, simp]: - "empty_fail m \ empty_fail (emptyOnFailure m)" - by (simp add: emptyOnFailure_def empty_fail_catch) - -lemma rethrowFailure_empty_fail [intro!, wp, simp]: - "empty_fail m \ empty_fail (rethrowFailure f m)" - apply (simp add:rethrowFailure_def o_def) - apply (wp | simp)+ - done - -lemma unifyFailure_empty_fail [intro!, wp, simp]: - "empty_fail f \ empty_fail (unifyFailure f)" - by (simp add: unifyFailure_def) - -lemma lookupErrorOnFailure_empty_fail [intro!, wp, simp]: - "empty_fail f \ empty_fail (lookupErrorOnFailure isSource f)" - by (simp add: lookupErrorOnFailure_def) - -lemma setObject_empty_fail [intro!, wp, simp]: - assumes x: "(\a b c. empty_fail (updateObject v a x b c))" - shows "empty_fail (setObject x v)" - apply (simp add: setObject_def split_def) - apply (wp x | simp)+ - done - -lemma asUser_empty_fail [intro!, wp, simp]: - "empty_fail f \ empty_fail (asUser t f)" - apply (simp add:asUser_def) - apply (wp | wpc | simp | simp add: empty_fail_def)+ - done - -lemma capFaultOnFailure_empty_fail [intro!, wp, simp]: - "empty_fail m \ empty_fail (capFaultOnFailure cptr rp m)" - apply (simp add: capFaultOnFailure_def) - done - -crunch locateSlotCap - for (empty_fail) empty_fail[intro!, wp, simp] - -lemma resolveAddressBits_spec_empty_fail: - notes spec_empty_fail_bindE'[wp_split] - shows - "spec_empty_fail (CSpace_H.resolveAddressBits a b c) s" -proof (induct arbitrary: s rule: resolveAddressBits.induct) - case (1 a b c s) - show ?case - apply (simp add: resolveAddressBits.simps) - apply (wp | simp | wpc | intro impI conjI | rule drop_spec_empty_fail)+ - apply (rule use_spec_empty_fail) - apply (rule 1 | simp add: in_monad | rule drop_spec_empty_fail | force)+ - done - qed - -lemmas resolveAddressBits_empty_fail[intro!, wp, simp] = - resolveAddressBits_spec_empty_fail[THEN use_spec_empty_fail] - -declare ef_dmo'[intro!, wp, simp] - -lemma empty_fail_getObject_ep [intro!, wp, simp]: - "empty_fail (getObject p :: endpoint kernel)" +lemma empty_fail_getObject_ap[intro!, wp, simp]: + "empty_fail (getObject p :: asidpool kernel)" by (simp add: empty_fail_getObject) -lemma getEndpoint_empty_fail [intro!, wp, simp]: - "empty_fail (getEndpoint ep)" - by (simp add: getEndpoint_def) - -lemma constOnFailure_empty_fail[intro!, wp, simp]: - "empty_fail m \ empty_fail (constOnFailure x m)" - by (simp add: constOnFailure_def const_def empty_fail_catch) - -lemma ArchRetypeDecls_H_deriveCap_empty_fail[intro!, wp, simp]: - "isPageTableCap y \ isPageDirectoryCap y \ isPageCap y \ isIOPortControlCap y - \ isASIDControlCap y \ isASIDPoolCap y \ isPDPointerTableCap y \ isPML4Cap y \ isIOPortCap y - \ empty_fail (Arch.deriveCap x y)" - by (auto simp: X64_H.deriveCap_def cong: if_cong) - -crunch ensureNoChildren - for (empty_fail) empty_fail[intro!, wp, simp] - -lemma deriveCap_empty_fail[intro!, wp, simp]: - "empty_fail (RetypeDecls_H.deriveCap slot y)" - apply (simp add: Retype_H.deriveCap_def) - apply (clarsimp simp: empty_fail_bindE) - apply (case_tac "capCap y") - apply (simp_all add: isCap_simps) - done - -crunch setExtraBadge, cteInsert - for (empty_fail) empty_fail[intro!, wp, simp] - -lemma transferCapsToSlots_empty_fail[intro!, wp, simp]: - "empty_fail (transferCapsToSlots ep buffer n caps slots mi)" - apply (induct caps arbitrary: slots n mi) - apply simp - apply (simp add: Let_def split_def - split del: if_split) - apply (simp | wp | wpc | safe)+ - done - -crunch lookupTargetSlot, ensureEmptySlot, lookupSourceSlot, lookupPivotSlot - for (empty_fail) empty_fail[intro!, wp, simp] - -lemma decodeCNodeInvocation_empty_fail[intro!, wp, simp]: - "empty_fail (decodeCNodeInvocation label args cap exs)" - apply (rule_tac label=label and args=args and exs=exs in decode_cnode_cases2) - apply (simp_all add: decodeCNodeInvocation_def - split_def cnode_invok_case_cleanup unlessE_whenE - cong: if_cong bool.case_cong list.case_cong) - by (simp | wp | wpc | safe)+ - -lemma empty_fail_getObject_ap [intro!, wp, simp]: - "empty_fail (getObject p :: asidpool kernel)" +lemma empty_fail_getObject_pte[intro!, wp, simp]: + "empty_fail (getObject p :: pte kernel)" by (simp add: empty_fail_getObject) lemma empty_fail_getObject_pde [intro!, wp, simp]: "empty_fail (getObject p :: pde kernel)" by (simp add: empty_fail_getObject) -lemma empty_fail_getObject_pte [intro!, wp, simp]: - "empty_fail (getObject p :: pte kernel)" - by (simp add: empty_fail_getObject) - lemma empty_fail_getObject_pdpte [intro!, wp, simp]: "empty_fail (getObject p :: pdpte kernel)" by (simp add: empty_fail_getObject) @@ -163,128 +40,55 @@ lemma empty_fail_getObject_pml4e [intro!, wp, simp]: crunch decodeX64MMUInvocation, decodeX64PortInvocation for (empty_fail) empty_fail[intro!, wp, simp] -(simp: Let_def ) - -lemma ignoreFailure_empty_fail[intro!, wp, simp]: - "empty_fail x \ empty_fail (ignoreFailure x)" - by (simp add: ignoreFailure_def empty_fail_catch) - -crunch setBoundNotification, setNotification - for (empty_fail) empty_fail[intro!, wp, simp] + (simp: Let_def ) crunch - cancelIPC, setThreadState, tcbSchedDequeue, setupReplyMaster, isStopped, possibleSwitchTo, tcbSchedAppend - for (empty_fail) empty_fail[intro!, wp, simp] - (simp: Let_def wp: empty_fail_getObject) - -crunch "ThreadDecls_H.suspend" - for (empty_fail) "_H_empty_fail"[intro!, wp, simp] - (ignore_del: ThreadDecls_H.suspend) - -lemma ThreadDecls_H_restart_empty_fail[intro!, wp, simp]: - "empty_fail (ThreadDecls_H.restart target)" - by (fastforce simp: restart_def) - -crunch finaliseCap, preemptionPoint, capSwapForDelete - for (empty_fail) empty_fail[intro!, wp, simp] - (wp: empty_fail_catch simp: Let_def) - -lemmas finalise_spec_empty_fail_induct = finaliseSlot'.induct[where P= - "\sl exp s. spec_empty_fail (finaliseSlot' sl exp) s"] - -lemma spec_empty_fail_If: - "\ P \ spec_empty_fail f s; \ P \ spec_empty_fail g s \ - \ spec_empty_fail (if P then f else g) s" - by (simp split: if_split) - -lemma spec_empty_whenE': - "\ P \ spec_empty_fail f s \ \ spec_empty_fail (whenE P f) s" - by (simp add: whenE_def spec_empty_returnOk) - -lemma finaliseSlot_spec_empty_fail: - notes spec_empty_fail_bindE'[rotated, wp_split] - shows "spec_empty_fail (finaliseSlot x b) s" -unfolding finaliseSlot_def -proof (induct rule: finalise_spec_empty_fail_induct) - case (1 x b s) - show ?case - apply (subst finaliseSlot'_simps_ext) - apply (simp only: split_def Let_def K_bind_def fun_app_def) - apply (wp spec_empty_whenE' spec_empty_fail_If | wpc - | rule 1[unfolded Let_def K_bind_def split_def fun_app_def, - simplified], (simp | intro conjI)+ - | rule drop_spec_empty_fail | simp)+ - done -qed - -lemmas finaliseSlot_empty_fail[intro!, wp, simp] = - finaliseSlot_spec_empty_fail[THEN use_spec_empty_fail] - -lemma checkCapAt_empty_fail[intro!, wp, simp]: - "empty_fail action \ empty_fail (checkCapAt cap ptr action)" - by (fastforce simp: checkCapAt_def) - -lemma assertDerived_empty_fail[intro!, wp, simp]: - "empty_fail f \ empty_fail (assertDerived src cap f)" - by (fastforce simp: assertDerived_def) + Arch_finaliseCap, Arch.switchToThread, Arch.switchToIdleThread, prepareNextDomain, getRestartPC, + makeArchFaultMessage + for (empty_fail) empty_fail[EmptyFail_H_assms, intro!, wp, simp] + (rule: X64_H.finaliseCap_def) -crunch cteDelete - for (empty_fail) empty_fail[intro!, wp, simp] +lemma empty_fail_portIn[intro!, wp, simp]: + "empty_fail a \ empty_fail (portIn a)" + by (fastforce simp: portIn_def) -lemma spec_empty_fail_unlessE': - "\ \ P \ spec_empty_fail f s \ \ spec_empty_fail (unlessE P f) s" - by (simp add:unlessE_def spec_empty_returnOk) +lemma empty_fail_portOut[intro!, wp, simp]: + "empty_fail (w a) \ empty_fail (portOut w a)" + by (fastforce simp: portOut_def) -lemma cteRevoke_spec_empty_fail: - notes spec_empty_fail_bindE'[wp_split] - shows "spec_empty_fail (cteRevoke p) s" -proof (induct rule: cteRevoke.induct) - case (1 p s) - show ?case - apply (simp add: cteRevoke.simps) - apply (wp spec_empty_whenE' spec_empty_fail_unlessE' | rule drop_spec_empty_fail, wp)+ - apply (rule 1, auto simp add: in_monad) - done +crunch + decodeTransfer, checkValidIPCBuffer, Arch.decodeIRQControlInvocation, Arch.decodeInvocation, + deleteGhost, Arch.createObject, getSanitiseRegisterInfo, + handleArchFaultReply, prepareSetDomain, postModifyRegisters, postSetFlags, + Arch.performIRQControl, Arch.invokeIRQHandler, Arch.performInvocation, handleSpuriousIRQ, + maskIrqSignal, handleVMFault, checkIRQ, prepareThreadDelete, Arch.postCapDeletion + for (empty_fail) empty_fail[EmptyFail_H_assms, intro!, wp, simp] + (simp: Let_def) + +end (* Arch *) + +interpretation EmptyFail_H?: EmptyFail_H +proof goal_cases + interpret Arch . + case 1 show ?case by (intro_locales; (unfold_locales; (fact EmptyFail_H_assms)?)?) qed -lemmas cteRevoke_empty_fail[intro!, wp, simp] = - cteRevoke_spec_empty_fail[THEN use_spec_empty_fail] - -lemma Syscall_H_syscall_empty_fail[intro!, wp, simp]: - "\empty_fail a; \x. empty_fail (b x); \x. empty_fail (c x); - \x. empty_fail (d x); \x. empty_fail (e x)\ - \ empty_fail (syscall a b c d e)" - apply (simp add:syscall_def) - apply (wp | wpc | simp)+ - done +context Arch begin arch_global_naming -lemma catchError_empty_fail[intro!, wp, simp]: - "\ empty_fail f; \x. empty_fail (g x) \ \ empty_fail (catchError f g)" - by fastforce +named_theorems EmptyFail_H_2_assms crunch - chooseThread, getDomainTime, nextDomain, isHighestPrio, prepareNextDomain - for (empty_fail) empty_fail[intro!, wp, simp] - (wp: empty_fail_catch) - -lemma ThreadDecls_H_schedule_empty_fail[intro!, wp, simp]: - "empty_fail schedule" - supply if_cong[cong] - apply (simp add: schedule_def) - apply (clarsimp simp: scheduleChooseNewThread_def split: if_split | wp | wpc)+ - done + handleReservedIRQ, handleHypervisorFault + for (empty_fail) empty_fail[EmptyFail_H_2_assms, intro!, wp, simp] + (simp: Let_def) -crunch setMRs, setMessageInfo - for (empty_fail) empty_fail[wp, simp] -(wp: empty_fail_catch simp: const_def Let_def ignore: portIn portOut) +end (* Arch *) -lemma empty_fail_portIn[intro!, wp, simp]: - "empty_fail a \ empty_fail (portIn a)" - by (fastforce simp: portIn_def) - -lemma empty_fail_portOut[intro!, wp, simp]: - "empty_fail (w a) \ empty_fail (portOut w a)" - by (fastforce simp: portOut_def) +interpretation EmptyFail_H_2?: EmptyFail_H_2 +proof goal_cases + interpret Arch . + case 1 show ?case by (intro_locales; (unfold_locales; (fact EmptyFail_H_2_assms)?)?) +qed crunch callKernel for (empty_fail) empty_fail @@ -292,12 +96,12 @@ crunch callKernel theorem call_kernel_serial: "\ (einvs and (\s. event \ Interrupt \ ct_running s) and (ct_running or ct_idle) and - schact_is_rct and - (\s. 0 < domain_time s \ valid_domain_list s)) s; - \s'. (s, s') \ state_relation \ - (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and - (\s. ksSchedulerAction s = ResumeCurrentThread)) s' \ - \ fst (call_kernel event s) \ {}" + schact_is_rct and (\s. 0 < domain_time s \ valid_domain_list s)) s; + \s'. (s, s') \ state_relation \ + (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and + (\s. ksSchedulerAction s = ResumeCurrentThread) and + (\s. vs_valid_duplicates' (ksPSpace s))) s' \ + \ fst (call_kernel event s) \ {}" apply (cut_tac m = "call_kernel event" in corres_underlying_serial) apply (rule kernel_corres) apply (rule callKernel_empty_fail) @@ -305,5 +109,3 @@ theorem call_kernel_serial: done end - -end From a4158d3e6d0c29e1cc051178ccfc1d9d40ab8a8b Mon Sep 17 00:00:00 2001 From: Rafal Kolanski Date: Fri, 24 Jul 2026 11:37:40 +1000 Subject: [PATCH 13/13] infoflow refine: update imports for EmptyFail_H arch-split Signed-off-by: Rafal Kolanski --- proof/infoflow/refine/ADT_IF_Refine.thy | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/proof/infoflow/refine/ADT_IF_Refine.thy b/proof/infoflow/refine/ADT_IF_Refine.thy index 7abb4127bd..973429862a 100644 --- a/proof/infoflow/refine/ADT_IF_Refine.thy +++ b/proof/infoflow/refine/ADT_IF_Refine.thy @@ -5,7 +5,7 @@ *) theory ADT_IF_Refine -imports "InfoFlow.ArchADT_IF" "Refine.EmptyFail_H" +imports "InfoFlow.ArchADT_IF" "Refine.ArchEmptyFail_H" begin definition kernelEntry_if where