diff --git a/.github/workflows/proof-deploy.yml b/.github/workflows/proof-deploy.yml index 74fdbf0ab4..66ab7d2f44 100644 --- a/.github/workflows/proof-deploy.yml +++ b/.github/workflows/proof-deploy.yml @@ -152,39 +152,13 @@ jobs: env: GH_SSH: ${{ secrets.CI_SSH }} -# Automatically rebase platform branches on pushes to master. -# This workflow here on the master branch attempts a git rebase of the platform -# branches listed in the build matrix below. If the rebase succeeds, the rebased -# branch is pushed under the name `-rebased`. This triggers the build -# workflow on the `-rebased` branch, which will run the proofs. If the -# proofs succeed, the `-rebased` branch is force-pushed over -# ``, becoming the new platform branch. - rebase: - name: Rebase platform branches + # Automatically rebase platform branches on pushes to master. + trigger-rebase: + name: Trigger platform branch rebase if: github.ref == 'refs/heads/master' runs-on: ubuntu-latest - strategy: - fail-fast: false - matrix: - branch: [imx8-fpu-ver] steps: - - name: Checkout - uses: actions/checkout@v4 + - name: Trigger rebase + uses: peter-evans/repository-dispatch@v3 with: - ref: ${{ matrix.branch }} - path: l4v-${{ matrix.branch }} - fetch-depth: 0 - # needed to trigger push actions on the -rebased branch - # (implict GITHUB_TOKEN does not trigger further push actions). - token: ${{ secrets.PRIV_REPO_TOKEN }} - - name: Rebase - run: | - cd l4v-${{ matrix.branch }} - git config --global user.name "seL4 CI" - git config --global user.email "ci@sel4.systems" - git rebase origin/master - git status - - name: Push - run: | - cd l4v-${{ matrix.branch }} - git push -f origin HEAD:${{ matrix.branch }}-rebased + event-type: rebase diff --git a/.github/workflows/rebase.yml b/.github/workflows/rebase.yml new file mode 100644 index 0000000000..fbbbcc5536 --- /dev/null +++ b/.github/workflows/rebase.yml @@ -0,0 +1,50 @@ +# Copyright 2024 Proofcraft Pty Ltd +# +# SPDX-License-Identifier: BSD-2-Clause + +# On repository dispatch event rebase platform branches. + +name: Rebase + +on: + repository_dispatch: + types: + - rebase + # for testing: + workflow_dispatch: + +# This workflow here on the master branch attempts a git rebase of the platform +# branches listed in the build matrix below. If the rebase succeeds, the rebased +# branch is pushed under the name `-rebased`. This triggers the build +# workflow on the `-rebased` branch, which will run the proofs. If the +# proofs succeed, the `-rebased` branch is force-pushed over +# ``, becoming the new platform branch. +jobs: + rebase: + name: Rebase platform branches + runs-on: ubuntu-latest + strategy: + fail-fast: false + matrix: + branch: [imx8-fpu-ver] + steps: + - name: Checkout + uses: actions/checkout@v4 + with: + ref: ${{ matrix.branch }} + path: l4v-${{ matrix.branch }} + fetch-depth: 0 + # needed to trigger push actions on the -rebased branch + # (implict GITHUB_TOKEN does not trigger further push actions). + token: ${{ secrets.PRIV_REPO_TOKEN }} + - name: Rebase + run: | + cd l4v-${{ matrix.branch }} + git config --global user.name "seL4 CI" + git config --global user.email "ci@sel4.systems" + git rebase origin/master + git status + - name: Push + run: | + cd l4v-${{ matrix.branch }} + git push -f origin HEAD:${{ matrix.branch }}-rebased diff --git a/README.md b/README.md index 8fa990f058..03421c4b7d 100644 --- a/README.md +++ b/README.md @@ -6,13 +6,13 @@ [![DOI][0]](http://dx.doi.org/10.5281/zenodo.591732) [![CI](https://github.com/seL4/l4v/actions/workflows/push.yml/badge.svg)](https://github.com/seL4/l4v/actions/workflows/push.yml) -[![Proofs](https://github.com/seL4/l4v/actions/workflows/proof-deploy.yml/badge.svg)](https://github.com/seL4/l4v/actions/workflows/proof-deploy.yml) +[![Proofs](https://github.com/seL4/l4v/actions/workflows/proof-deploy.yml/badge.svg?branch=master)](https://github.com/seL4/l4v/actions/workflows/proof-deploy.yml?query=branch%3Amaster) [![Weekly Clean](https://github.com/seL4/l4v/actions/workflows/weekly-clean.yml/badge.svg)](https://github.com/seL4/l4v/actions/workflows/weekly-clean.yml) [![External](https://github.com/seL4/l4v/actions/workflows/external.yml/badge.svg)](https://github.com/seL4/l4v/actions/workflows/external.yml) MCS:\ [![CI](https://github.com/seL4/l4v/actions/workflows/push.yml/badge.svg?branch=rt)](https://github.com/seL4/l4v/actions/workflows/push.yml) -[![RT Proofs](https://github.com/seL4/l4v/actions/workflows/proof.yml/badge.svg?branch=rt)](https://github.com/seL4/l4v/actions/workflows/proof.yml) +[![MCS Proofs](https://github.com/seL4/l4v/actions/workflows/proof-deploy.yml/badge.svg?branch=rt)](https://github.com/seL4/l4v/actions/workflows/proof-deploy.yml?query=branch%3Art) [0]: https://zenodo.org/badge/doi/10.5281/zenodo.591732.svg diff --git a/camkes/cdl-refine/Eval_CAMKES_CDL.thy b/camkes/cdl-refine/Eval_CAMKES_CDL.thy index 1a1347223d..83be8b8482 100644 --- a/camkes/cdl-refine/Eval_CAMKES_CDL.thy +++ b/camkes/cdl-refine/Eval_CAMKES_CDL.thy @@ -169,7 +169,7 @@ lemma Collect_asid_high__eval_helper: apply (subst arg_cong[where f="(<) _"]) prefer 2 apply (rule unat_lt2p) - apply (simp add: asid_high_bits_def) + apply (simp add: MiscMachine_A.asid_high_bits_def) apply (simp add: transform_asid_def asid_high_bits_of_def[abs_def]) apply (rule set_eqI) apply (rule iffI) @@ -177,34 +177,35 @@ lemma Collect_asid_high__eval_helper: apply (clarsimp simp: Collect_conj_eq image_iff) apply (rule_tac x="(of_nat asid_high << asid_low_bits) + 1" in bexI) apply (subst add.commute, subst shiftr_irrelevant) - apply (clarsimp simp: asid_low_bits_def asid_high_bits_def) - apply (clarsimp simp: is_aligned_shift) - apply (subst shiftl_shiftr_id) - apply (clarsimp simp: asid_low_bits_def asid_high_bits_def) - apply (clarsimp simp: asid_low_bits_def asid_high_bits_def word_of_nat_less) + apply (clarsimp simp: MiscMachine_A.asid_low_bits_def) + apply (clarsimp simp: is_aligned_shift MiscMachine_A.asid_low_bits_def) + apply (clarsimp simp: MiscMachine_A.asid_low_bits_def) + apply (subst shiftl_shiftr_id, simp) + apply (clarsimp simp: MiscMachine_A.asid_high_bits_def word_of_nat_less) apply (subst ucast_of_nat_small) - apply (clarsimp simp: asid_high_bits_def) + apply (clarsimp simp: MiscMachine_A.asid_high_bits_def) apply simp apply clarsimp apply (rule conjI) apply (clarsimp simp: unat_ucast_eq_unat_and_mask) apply (subst add.commute, subst shiftr_irrelevant) - apply (clarsimp simp: asid_low_bits_def asid_high_bits_def) + apply (clarsimp simp: MiscMachine_A.asid_low_bits_def MiscMachine_A.asid_high_bits_def) apply (clarsimp simp: is_aligned_shift) apply (subst shiftl_shiftr_id) - apply (clarsimp simp: asid_low_bits_def asid_high_bits_def) - apply (clarsimp simp: asid_low_bits_def asid_high_bits_def word_of_nat_less) + apply (clarsimp simp: MiscMachine_A.asid_low_bits_def) + apply (clarsimp simp: MiscMachine_A.asid_low_bits_def MiscMachine_A.asid_high_bits_def + word_of_nat_less) apply (fold asid_high_bits_def) apply (subst less_mask_eq) - apply (clarsimp simp: asid_high_bits_def word_of_nat_less) + apply (clarsimp simp: MiscMachine_A.asid_high_bits_def word_of_nat_less) apply (rule unat_of_nat_eq) - apply (clarsimp simp: asid_high_bits_def) + apply (clarsimp simp: MiscMachine_A.asid_high_bits_def) apply (rule less_is_non_zero_p1[where k="2^asid_high_bits << asid_low_bits"]) - apply (simp only: shiftl_t2n) + apply (simp add: shiftl_t2n) apply (subst mult.commute, subst mult.commute, rule word_mult_less_mono1) - apply (clarsimp simp: asid_high_bits_def word_of_nat_less) - apply (clarsimp simp: asid_low_bits_def) - apply (clarsimp simp: asid_low_bits_def asid_high_bits_def) + apply (clarsimp simp: MiscMachine_A.asid_high_bits_def word_of_nat_less) + apply (clarsimp simp: MiscMachine_A.asid_low_bits_def) + apply (clarsimp simp: MiscMachine_A.asid_low_bits_def MiscMachine_A.asid_high_bits_def) done diff --git a/docs/arch-split.md b/docs/arch-split.md index 39705dd083..c2e2064fbc 100644 --- a/docs/arch-split.md +++ b/docs/arch-split.md @@ -111,7 +111,7 @@ theory Retype_R imports VSpace_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma placeNewObject_def2: "placeNewObject ptr val gb = createObjects' ptr 1 (injectKO val) gb" @@ -151,11 +151,12 @@ want to prevent, however, inadvertent references to types, constants and facts which are only internal to a particular architecture (e.g. definitions of constants). -To help achieve this hiding, we provide a custom command, **global_naming**, -that modifies the way qualified names are generated. The primary use of -`global_naming` is in architecture-specific theories, to ensure that by default, -types, constants and lemmas are given an architecture-specific qualified name, -even though they are part of the Arch locale. +To help achieve this hiding, we provide the custom commands **global_naming** +and **arch_global_naming**, which modify the way qualified names are generated. +The primary use of these commands is in architecture-specific theories, to +ensure that by default, types, constants and lemmas are given an +architecture-specific qualified name, even though they are part of the Arch +locale. - `l4v/proof/invariant-abstract/ARM/ArchADT_AI.thy` @@ -171,6 +172,12 @@ context Arch begin global_naming ARM definition "get_pd_of_thread ≡ ..." end +(* the more convenient and preferred way to achieve the above when L4V_ARCH=ARM + is to use arch_global_naming, spiritually equivalent to `global_naming $L4V_ARCH` *) +context Arch begin arch_global_naming +(* ... *) +end + (* Back in the global context, we can't refer to these names without naming a particular architecture! *) term get_pd_of_thread (* Free variable *) term Arch.get_pd_of_thread (* Free variable *) @@ -192,8 +199,8 @@ architecture. If we saw such a reference in a generic theory, we would immediately recognise that something was wrong. The convention is that in architecture-specific theories, we initially -give *all* types, constants and lemmas with an architecture-specific -`global_naming` scheme. Then, in generic theories, we use +give *all* types, constants and lemmas the architecture-specific +`arch_global_naming` scheme. Then, in generic theories, we use *requalification* to selectively extract just those types, constants and facts which are expected to exist on all architectures. @@ -204,8 +211,13 @@ We provide three custom commands for giving existing names new bindings in the global namespace: **requalify_types**, **requalify_consts**, **requalify_facts**, for types, constants and facts respectively. The new name is based on the context in which the requalification command is -executed. We use requalification in various ways, depending on the -situation. +executed. As with `global_naming`, we provide `L4V_ARCH`-aware versions of +these commands: **arch_requalify_types**, **arch_requalify_consts** and +**arch_requalify_types**. + +To understand how these commands function, see `lib/test/Requalify_Test.thy`. + +We use requalification in various ways, depending on the situation. The most basic use is to take a name from the Arch context and make it available in the global context without qualification. This should be @@ -220,7 +232,73 @@ done for any type, constant or fact: type, constant or fact, so that the unqualified name unambiguously denotes the architecture-specific concept for the current architecture. -We do this in a generic theory: +Note: the `[arch_]requalify_*` commands will warn when the unqualified name is +already available in the global context (see: Dealing with name clashes). To +suppress this warning, pass `(aliasing)` as the first parameter. + + +### Requalifying in practice + +Let's use the generic theory `l4v/proof/invariant-abstract/ADT_AI.thy` as an +example: + +```isabelle +theory ADT_AI +imports + "./$L4V_ARCH/ArchADT_AI" +begin + +term empty_context (* Free variable. *) +``` + +The constant `empty_context` is not visible in the theory scope, as it was +defined inside the Arch locale, likely with `arch_global_naming`, thus visible +as (for example) `ARM.empty_context`. We want to make this constant available +to generic proofs. The obvious way to do this is: + +```isabelle +requalify_consts ARM.empty_context (* avoid: can only be done in Arch theories *) +``` + +Unfortunately, on another platforms such as RISCV64, the constant will have a +different qualified name. We can instead appeal to `L4V_ARCH` again, since we +already rely on it to select the correct theories for the current architecture: + +```isabelle +arch_requalify_consts empty_context (* preferred *) + +(* The requalified constant is now available unqualified in the global context. *) +term empty_context + +(* However, its definition is not. *) +thm empty_context_def (* ERROR *) +``` + +In some cases, consts/types/facts may be thrown into the `Arch` context without +further qualification. In such cases, normal requalification may be used: + +```isabelle +requalify_consts Arch.empty_context (* standard locale version, likely due to missing global_naming *) +``` + + +### Requalifying inside "Arch" theories + +While requalifying inside `Arch*` theories is possible, as seen above, it +requires duplicating the requalify command(s) on every architecture, and so +should be avoided. However, it is not always possible to conveniently do so, +particularly when defining constants inside `Arch`, then having to use those +constants to instantiate locales, before heading back into the `Arch` context. + + +### Requalifying via interpretation (slow) + +Using `arch_requalify_*` commands still implicitly appeals to the name of the +architecture while in a generic theory. This has the advantage of being fast and +thus is preferred, but we describe the old interpretation method here for +reference (for dealing with older theories or older repository versions). + +We can do this in a generic theory: - `l4v/proof/invariant-abstract/ADT_AI.thy` @@ -261,41 +339,51 @@ available unqualified until the end of the context block. Indeed, in this case, the only purpose of the anonymous context block is to limit the scope of this `interpretation`. -Note: It is critical to the success of arch_split that we *never* interpret the +Note: It is critical to the success of arch-split that we *never* interpret the Arch locale, *except* inside an appropriate context block. -In a generic theory, we typically only interpret the Arch locale: +In a generic theory, we typically only interpret the Arch locale to keep +existing proofs checking until we find time to factor out the +architecture-dependent parts. The `.` in `context begin interpretation Arch .` +in the middle of AInvs takes 7.5s, so repeated use of this technique should be +avoided when possible. -- to requalify names with no qualifier, or -- to keep existing proofs checking until we find time to factor out the - architecture-dependent parts. +### Requalifying into the Arch locale -### Unconventional requalification shortcut - -While the expected convention is to perform requalify commands in the generic -theory as described above, there exists a shortcut for doing so in -architecture-specific theories when outside the Arch context: +The `requalify` commands support a target parameter, e.g. ```isabelle -requalify_facts - ARM.user_mem_dom_cong +requalify_facts (in Arch) user_mem_dom_cong +``` -thm user_mem_dom_cong (* ok *) +Which prevents exporting the name into the global theory context, exporting it +under `Arch.` instead: + +```isabelle +thm user_mem_dom_cong (* ERROR *) thm ARM.user_mem_dom_cong (* ok *) -thm Arch.user_mem_dom_cong (* ERROR *) +thm Arch.user_mem_dom_cong (* ok *) ``` -This immediately makes the fact available in the global context. While it is a -violation of expected conventions and needs to be repeated in every -arch-specific theory file, there is one important difference: -* the `.` in `context begin interpretation Arch .` in the middle of AInvs takes 7.5s -* `requalify_facts` in the global context is nearly instant (even for -multiple facts). +Generally, we want to avoid unprefixed names in the Arch locale, preferring to +use a `global_naming` to generate a prefix instead. However, when the generic +and arch-specific short names are identical, this functionality allows giving +an architecture-specific constant/type/fact a generic name while not mixing it +with generic namespace (see also "Dealing with name clashes", as this affects +lookup order inside interpretations). + +One can target any locale in this fashion, although the usefulness to arch-split +is then decreased, since short names might not be visible past a naming prefix: + +```isabelle +requalify_facts (in Some_Locale) ARM.user_mem_dom_cong -This disparity will only get worse as the Arch context grows bigger, and -might indicate the need for some alternative functionality. +thm user_mem_dom_cong (* ERROR *) +thm ARM.user_mem_dom_cong (* ok *) +thm Some_Locale.user_mem_dom_cong (* ok *) +``` ### Dealing with name clashes @@ -327,7 +415,7 @@ term deriveCap (* In the Arch context, this is the deriveCap funct term RetypeDecls_H.deriveCap (* This is the arch-generic deriveCap function. *) (* The following makes Arch.deriveCap refer to the architecture-specific constant. *) -requalify_consts deriveCap +requalify_consts deriveCap (* Warning: Name "deriveCap" already exists in theory context *) (* Unfortunately, the above also means that in a context in which Arch is interpreted, `deriveCap` unqualified would refer to the arch-specific constant, which may break existing proofs. @@ -406,7 +494,16 @@ Haskell specs. We use `ARM` everywhere else. This means that the arch-specific references only require either an `ARM_A` or `ARM_H` qualifier. No theory qualifier is required, and the result is more robust to theory reorganisation. -In the future, when we are properly splitting the refinement proofs, we will may +Requalification of consts/types/facts from these prefixes should be done as +follows: + +```isabelle +arch_requalify_const some_const (* requalifies ARM.some_const *) +arch_requalify_const (A) some_const (* requalifies ARM_A.some_const *) +arch_requalify_const (H) some_const (* requalifies ARM_H.some_const *) +``` + +In the future, when we are properly splitting the refinement proofs, we may want to extend this approach by introducing `Arch_A` and `Arch_H` `global_naming` schemes to disambiguate overloaded requalified names. @@ -649,6 +746,39 @@ generates limited duplication: a fact from `Foo_AI_1` will be duplicated in `Foo_AI_2`, but not in `Foo_AI_3+`. +### Temporarily proving a fact in the Arch locale + +The concept of "generic consequences of architecture-specific properties" shows +up in a few places. Normally, as outlined above, we prefer either exporting +enough facts to prove the property in the generic context or requiring the +property as a locale assumption. However, sometimes we end up in a situation +where the same proof will work on all architectures and spelling it out with +locale assumptions is inconvenient. For example (from `Invariants_AI`): + +```isabelle +(* generic consequence of architecture-specific details *) +lemma (in Arch) valid_arch_cap_pspaceI: + "⟦ valid_arch_cap acap s; kheap s = kheap s' ⟧ ⟹ valid_arch_cap acap s'" + unfolding valid_arch_cap_def + by (auto intro: obj_at_pspaceI split: arch_cap.split) + +requalify_facts Arch.valid_arch_cap_pspaceI +``` + +In this case, no matter what the architecture, the `valid_arch_cap` function +will only ever look at the heap, so this proof will always work. + +There are some considerations when using this strategy: + +1. We use the Arch locale without `global_naming`, as its performance is better + than entering the Arch locale and proving the lemma there. This means its + qualified name will be `Arch.valid_arch_cap_pspaceI`, but this is acceptable + since: +2. The lemma is immediately requalified into the generic context, so we never + really want to use its qualified name again. +3. This technique is rarely used, *use sparingly*! + + ## Qualifying non-locale-compatible commands Generally speaking, architecture-specific definitions and lemmas should @@ -739,7 +869,7 @@ The workflow: intra-theory dependencies" above. - Look in the generic theory for a block of the form - `context Arch begin (* FIXME: arch_split *) ... end`. + `context Arch begin (* FIXME: arch-split *) ... end`. - These indicate things that we've previously classified as belonging in an arch-specific theory. @@ -751,7 +881,7 @@ The workflow: - Look for subsequent breakage in the generic theory. - If this is in a subsequent Arch block (`context Arch begin (* FIXME: - arch_split *) ... end`), just move that block. + arch-split *) ... end`), just move that block. - Otherwise, if it's not obvious what to do, have a conversation with someone. We'll add more tips here as the process becomes clearer. diff --git a/docs/conventions.md b/docs/conventions.md index 9a4e95d059..dc6c34e7d8 100644 --- a/docs/conventions.md +++ b/docs/conventions.md @@ -41,7 +41,7 @@ correct material in here! circumstances will be transformed into `?x2.0` which is harder to work with), but don't overuse `'`, i.e. `x'''` is not a good name. -[1]: https://isabelle.systems/conventions/naming.html +[1]: https://web.archive.org/web/20220810201813/https://isabelle.systems/conventions/naming.html ## Directories diff --git a/lib/Monad_Commute.thy b/lib/Monad_Commute.thy index a5bbf317bf..c42431d281 100644 --- a/lib/Monad_Commute.thy +++ b/lib/Monad_Commute.thy @@ -140,6 +140,21 @@ lemma mapM_x_commute: apply auto done +(* Proof needs to be different from mapM_x_commute, to eliminate "distinct" *) +lemma mapM_x_commute_T: + assumes commute: "\r. monad_commute \ (b r) a" + shows "monad_commute \ (mapM_x b xs) a" + apply (induct xs) + apply (clarsimp simp: mapM_x_Nil return_def bind_def monad_commute_def) + apply (clarsimp simp: mapM_x_Cons) + apply (rule monad_commute_guard_imp) + apply (rule commute_commute, rule monad_commute_split) + apply (rule commute_commute, assumption) + apply (rule commute_commute, rule commute) + apply wp + apply clarsimp + done + lemma commute_name_pre_state: assumes "\s. P s \ monad_commute ((=) s) f g" shows "monad_commute P f g" diff --git a/lib/ROOT b/lib/ROOT index 10c3726175..84a5431195 100644 --- a/lib/ROOT +++ b/lib/ROOT @@ -127,6 +127,7 @@ session LibTest (lib) in test = Refine + Named_Eta_Test Rules_Tac_Test MonadicRewrite_Test + Requalify_Test (* use virtual memory function as an example, only makes sense on ARM: *) theories [condition = "L4V_ARCH_IS_ARM"] CorresK_Test diff --git a/lib/Requalify.thy b/lib/Requalify.thy index b06fdb3719..6230ec2964 100644 --- a/lib/Requalify.thy +++ b/lib/Requalify.thy @@ -1,82 +1,139 @@ (* + * Copyright 2024, Proofcraft Pty Ltd * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) * * SPDX-License-Identifier: BSD-2-Clause *) (* - Requalify constants, types and facts into the current naming + Requalify constants, types and facts into the current naming. + Includes command variants that support implicitly using the L4V_ARCH environment variable. *) +text \See theory @{text "test/Requalify_Test.thy"} for commented examples and usage scenarios.\ + theory Requalify imports Main -keywords "requalify_facts" :: thy_decl and "requalify_types" :: thy_decl and "requalify_consts" :: thy_decl and - "global_naming" :: thy_decl +keywords "requalify_facts" :: thy_decl + and "requalify_types" :: thy_decl + and "requalify_consts" :: thy_decl + and "global_naming" :: thy_decl + and "arch_requalify_facts" :: thy_decl + and "arch_requalify_types" :: thy_decl + and "arch_requalify_consts" :: thy_decl + and "arch_global_naming" :: thy_decl begin ML \ local - fun all_facts_of ctxt = - let - val thy = Proof_Context.theory_of ctxt; - val global_facts = Global_Theory.facts_of thy; - in - Facts.dest_static false [] global_facts - end; + Proof_Context.theory_of ctxt + |> Global_Theory.facts_of + |> Facts.dest_static false []; + +fun tl' (_ :: xs) = xs + | tl' _ = [] + +(* Alias binding to fully-qualified name "name" in both global and local context *) +fun bind_alias global_alias_fn local_alias_fn binding (name : string) = + Local_Theory.declaration {syntax = false, pos = Position.none, pervasive = true} (fn phi => + let val binding' = Morphism.binding phi binding; + in Context.mapping (global_alias_fn binding' name) (local_alias_fn binding' name) end); +(* Instantiate global and local aliasing functions for consts, types and facts *) +val const_alias = bind_alias Sign.const_alias Proof_Context.const_alias; +val type_alias = bind_alias Sign.type_alias Proof_Context.type_alias; +val alias_fact = bind_alias Global_Theory.alias_fact Proof_Context.alias_fact; + +(* Locate global fact matching supplied name. + When we specify a fact name that resolves to a global name, return the normal fact lookup result. + Note: Locale_Name.fact_name outside the locale resolves to a global name. + + When we are inside a locale, the lookup is more interesting. Supplying "short_name" will result + in "local.short_name", which we then need to match to some name in the global context. We do + this by going through *all* the fact names in the current context, searching for matches + of the form "X.Y.short_name", where we hope X is some theory, and Y is some locale. + + Since "X.Y.short_name" is not sufficiently unique, we must also check that the theorems under + the discovered name match the ones under "local.short_name". *) fun global_fact ctxt nm = let val facts = Proof_Context.facts_of ctxt; val {name, thms, ...} = (Facts.retrieve (Context.Proof ctxt) facts (nm, Position.none)); - fun tl' (_ :: xs) = xs - | tl' _ = [] - - fun matches suf (gnm, gthms) = - let - val gsuf = Long_Name.explode gnm |> tl' |> tl' |> Long_Name.implode; - - in suf = gsuf andalso eq_list (Thm.equiv_thm (Proof_Context.theory_of ctxt)) (thms, gthms) - end + fun matches suffix (global_name, global_thms) = + suffix = (Long_Name.explode global_name |> tl' |> tl' |> Long_Name.implode) + andalso eq_list (Thm.equiv_thm (Proof_Context.theory_of ctxt)) (thms, global_thms) in - case Long_Name.dest_local name of NONE => (name, thms) | SOME suf => - (case (find_first (matches suf) (all_facts_of ctxt)) of - SOME x => x - | NONE => raise Fail ("Couldn't find global equivalent of local fact: " ^ nm)) + case Long_Name.dest_local name of + NONE => (name, thms) + | SOME suffix => + (case (find_first (matches suffix) (all_facts_of ctxt)) of + SOME x => x + | NONE => raise Fail ("Couldn't find global equivalent of local fact: " ^ nm)) end -fun syntax_alias global_alias local_alias b (name : string) = - Local_Theory.declaration {syntax = false, pos = Position.none, pervasive = true} (fn phi => - let val b' = Morphism.binding phi b - in Context.mapping (global_alias b' name) (local_alias b' name) end); - -val alias_fact = syntax_alias Global_Theory.alias_fact Proof_Context.alias_fact; -val const_alias = syntax_alias Sign.const_alias Proof_Context.const_alias; -val type_alias = syntax_alias Sign.type_alias Proof_Context.type_alias; +val alias = Parse.reserved "aliasing" >> K true +val alias_default = false -in +(* (aliasing) only *) +val generic_options = Scan.optional (Args.parens alias >> (fn x => (x, ""))) (alias_default, "") -fun gen_requalify get_proper_nm parse_nm check_nm alias = - (Parse.opt_target -- Scan.repeat1 (Parse.position (Scan.ahead parse_nm -- Parse.name)) - >> (fn (target,bs) => - Toplevel.local_theory NONE target (fn lthy => - let +(* e.g. ARM, ARM_A, ARM_H *) +val arch_suffix = ((Parse.reserved "A" || Parse.reserved "H") >> (fn s => "_" ^ s)) +fun arch_prefix suffix = getenv_strict "L4V_ARCH" ^ suffix - fun read_entry ((entry, t), pos) lthy = - let - val local_nm = get_proper_nm lthy t; - val _ = check_nm lthy (entry, (local_nm, pos)); - val b = Binding.make (Long_Name.base_name t, pos) +(* ([aliasing][,] [A|H]) in that order *) +val arch_options = + Scan.optional ( + Args.parens ( + (alias --| Parse.$$$ "," -- arch_suffix) + || (alias >> (fn x => (x, ""))) + || (arch_suffix >> (fn x => (alias_default, x))) + )) (alias_default, "") - val lthy' = lthy - |> alias b local_nm +val arch_global_opts = Scan.optional (Args.parens arch_suffix) "" - in lthy' end +in - in fold read_entry bs lthy end))) +fun gen_requalify get_proper_nm check_parsed_nm alias_fn arch = +let + val options = if arch then arch_options else generic_options +in + (Parse.opt_target -- options -- Scan.repeat1 (Parse.position Parse.name) + >> (fn ((target, (aliasing, arch_suffix)), names) => + Toplevel.local_theory NONE target (fn lthy => + let + val global_ctxt = Proof_Context.theory_of lthy |> Proof_Context.init_global + + fun requalify_entry (orig_name, pos) lthy = + let + val name = if arch then arch_prefix arch_suffix ^ "." ^ orig_name else orig_name + val local_name = get_proper_nm lthy name; + (* Look up name again for purposes of document markup (i.e. ctrl+click on names). + Do not use the resolved qualified local_name, because while it is somehow possible to + create aliases/bindings to consts/type names that have been hidden with + hide_const/hide_type, attempting to use them with check_const/check_type_name will + fail with "Inaccessible" errors. *) + val _ = check_parsed_nm lthy (name, pos); + + (* Check whether the short (base) name is already available in theory context if no + locale target is supplied and the "aliasing" option is not supplied. + Note: currently no name collision warning when exporting into locale *) + val base_name = Long_Name.base_name name; + val global_base = try (get_proper_nm global_ctxt) (Long_Name.base_name name); + val _ = (case (global_base, target, aliasing) of + (SOME _, NONE, false) => warning ("Name \"" ^ base_name + ^ "\" already exists in theory context") + | _ => ()) + + val b = Binding.make (base_name, pos) + val lthy' = lthy |> alias_fn b local_name + in lthy' end + in fold requalify_entry names lthy end))) +end local @@ -84,142 +141,91 @@ val get_const_nm = ((fst o dest_Const) oo (Proof_Context.read_const {proper = tr val get_type_nm = ((fst o dest_Type) oo (Proof_Context.read_type_name {proper = true, strict = false})) val get_fact_nm = (fst oo global_fact) -fun check_fact lthy (_, (nm, pos)) = Proof_Context.get_fact lthy (Facts.Named ((nm,pos), NONE)) +(* For the arch_requalify commands, we prefix the const/type name based on L4V_ARCH and A/H option. + This means we have to be careful when resolving names and marking up the document. + + What is completely non-obvious is that Proof_Context.read_const and Proof_Context.read_type_name + are sensitive to YXML markup information embedded in the supplied string. When such information + is available, they will use it to mark up the document. However, in the process they will invoke + Input.source_content, which will make sure that the position information conforms to the content + length. This is *bad news* for arch_requalify, because when the user asks for "name", we treat it + as something like "ARM_A.name". + So if we use Parse.const/Parse.typ we'll get an annotated string: + name + If we tweak "name" to become "ARM_A.name" instead, the read_const/read_type_name functions will + sync the length and attempt to annotate it as: + name + which is a larger range than the user gave us, leading to errors about overlapping ranges. + This means that the nice option of using Parse.const + Proof_Context.read_const can't be used + here. + + Instead, we use Proof_Context.check_const/check_type_name on user-supplied names along with the + position from Parse.position to get markup reports which we apply manually. + + For theorems, document annotation appears to be included in Proof_context.get_fact. *) + +fun check_const lthy (nm, pos) = + Proof_Context.check_const {proper = true, strict = false} lthy (nm, [pos]) + |> #2 |> Context_Position.reports @{context} + +fun check_type_name lthy (nm, pos) = + Proof_Context.check_type_name {proper = true, strict = false} lthy (nm, pos) + |> #2 |> Context_Position.reports @{context} + +fun check_fact lthy (nm, pos) = Proof_Context.get_fact lthy (Facts.Named ((nm, pos), NONE)) in val _ = Outer_Syntax.command @{command_keyword requalify_consts} "alias const with current naming" - (gen_requalify get_const_nm Parse.const (fn lthy => fn (e, _) => get_const_nm lthy e) const_alias) + (gen_requalify get_const_nm check_const const_alias false) val _ = Outer_Syntax.command @{command_keyword requalify_types} "alias type with current naming" - (gen_requalify get_type_nm Parse.typ (fn lthy => fn (e, _) => get_type_nm lthy e) type_alias) + (gen_requalify get_type_nm check_type_name type_alias false) val _ = Outer_Syntax.command @{command_keyword requalify_facts} "alias fact with current naming" - (gen_requalify get_fact_nm Parse.thm check_fact alias_fact) + (gen_requalify get_fact_nm check_fact alias_fact false) val _ = Outer_Syntax.command @{command_keyword global_naming} "change global naming of context block" (Parse.binding >> (fn naming => Toplevel.local_theory NONE NONE - (Local_Theory.map_background_naming (Name_Space.parent_path #> Name_Space.qualified_path true naming)))) - -end - -end -\ - -(*Tests and examples *) - -locale Requalify_Locale -begin - -typedecl requalify_type - -definition "requalify_const == (undefined :: requalify_type)" + (Local_Theory.map_background_naming (Name_Space.parent_path + #> Name_Space.qualified_path true naming)))) +(* Arch variants use the L4V_ARCH variable and an additional A/H option, so that when L4V_ARCH=ARM + "arch_requalify_consts (H) const" becomes "requalify_consts ARM_H.const" + This allows them to be used in a architecture-generic theory. *) -end - -typedecl requalify_type -definition "requalify_const == (undefined :: requalify_type)" - -context Requalify_Locale begin global_naming Requalify_Locale2 - -requalify_consts requalify_const -requalify_types requalify_type -requalify_facts requalify_const_def - -end - -term "requalify_const :: requalify_type" -term "Requalify_Locale2.requalify_const :: Requalify_Locale2.requalify_type" -lemma "Requalify_Locale2.requalify_const = (undefined :: Requalify_Locale2.requalify_type)" - by (simp add: Requalify_Locale2.requalify_const_def) - -consts requalify_test_f :: "'a \ 'b \ bool" - -lemma - assumes f1: "requalify_test_f requalify_const Requalify_Locale2.requalify_const" - and f2: "requalify_test_f Requalify_Locale2.requalify_const Requalify.requalify_const" - shows "requalify_test_f Requalify_Locale2.requalify_const requalify_const" "requalify_const = undefined" - apply (rule f1)? - apply (rule f2) - apply (simp add: requalify_const_def) - done - -context Requalify_Locale begin - -lemma - assumes f1: "requalify_test_f requalify_const Requalify_Locale2.requalify_const" - and f2: "requalify_test_f Requalify_Locale2.requalify_const Requalify.requalify_const" - shows "requalify_test_f Requalify_Locale2.requalify_const requalify_const" "requalify_const = undefined" - apply (rule f2)? - apply (rule f1) - apply (simp add: requalify_const_def) - done - -end - -context Requalify_Locale begin global_naming global - -requalify_consts Requalify.requalify_const -requalify_types Requalify.requalify_type -requalify_facts Requalify.requalify_const_def - -end - -context Requalify_Locale begin - -lemma - assumes f1: "requalify_test_f requalify_const Requalify_Locale2.requalify_const" - and f2: "requalify_test_f Requalify_Locale2.requalify_const global.requalify_const" - shows "requalify_test_f Requalify_Locale2.requalify_const requalify_const" "requalify_const = undefined" - apply (rule f1)? - apply (rule f2) - apply (simp add: requalify_const_def) - done -end - -context begin interpretation Requalify_Locale . - -lemma - assumes f1: "requalify_test_f requalify_const Requalify_Locale2.requalify_const" - and f2: "requalify_test_f Requalify_Locale2.requalify_const global.requalify_const" - shows "requalify_test_f Requalify_Locale2.requalify_const requalify_const" "requalify_const = undefined" - apply (rule f1)? - apply (rule f2) - apply (simp add: requalify_const_def) - done -end - -locale Requalify_Locale3 -begin - -typedecl requalify_type2 -definition "requalify_const2 == (undefined :: requalify_type2)" +val _ = + Outer_Syntax.command @{command_keyword arch_requalify_consts} + "alias const with current naming, but prepend \"($L4V_ARCH)_[A|H].\" using env. variable" + (gen_requalify get_const_nm check_const const_alias true) -end +val _ = + Outer_Syntax.command @{command_keyword arch_requalify_types} + "alias type with current naming, but prepend \"($L4V_ARCH)_[A|H].\" using env. variable" + (gen_requalify get_type_nm check_type_name type_alias true) -context begin interpretation Requalify_Locale3 . +val _ = + Outer_Syntax.command @{command_keyword arch_requalify_facts} + "alias fact with current naming, but prepend \"($L4V_ARCH)_[A|H].\" using env. variable" + (gen_requalify get_fact_nm check_fact alias_fact true) -requalify_consts requalify_const2 -requalify_types requalify_type2 -requalify_facts requalify_const2_def +val _ = + Outer_Syntax.command @{command_keyword arch_global_naming} + "change global naming of context block to \"($L4V_ARCH)_[A|H]\" using env. variable" + (arch_global_opts >> (fn arch_suffix => + Toplevel.local_theory NONE NONE + (Local_Theory.map_background_naming + (Name_Space.parent_path + #> Name_Space.qualified_path true (Binding.make (arch_prefix arch_suffix, @{here})))))) end -lemma "(requalify_const2 :: requalify_type2) = undefined" - by (simp add: requalify_const2_def) - -context Requalify_Locale3 begin - -lemma "(requalify_const2 :: requalify_type2) = undefined" - by (simp add: requalify_const2_def) - end - +\ end diff --git a/lib/Word_Lib/Word_Lemmas_Internal.thy b/lib/Word_Lib/Word_Lemmas_Internal.thy index 79fc351c7f..8b7a0187cd 100644 --- a/lib/Word_Lib/Word_Lemmas_Internal.thy +++ b/lib/Word_Lib/Word_Lemmas_Internal.thy @@ -979,6 +979,11 @@ lemma shiftr_not_max_word: "0 < n \ w >> n \ max_word" by (metis and_mask_eq_iff_shiftr_0 and_mask_not_max_word diff_less len_gt_0 shiftr_le_0 word_shiftr_lt) +lemma shiftr_less_max_mask: + "0 < n \ x >> n < mask LENGTH('a)" for x :: "'a::len word" + using not_max_word_iff_less shiftr_not_max_word + by auto + lemma word_sandwich1: fixes a b c :: "'a::len word" assumes "a < b" diff --git a/lib/test/Requalify_Test.thy b/lib/test/Requalify_Test.thy new file mode 100644 index 0000000000..a3eda0fe83 --- /dev/null +++ b/lib/test/Requalify_Test.thy @@ -0,0 +1,429 @@ +(* + * Copyright 2024, Proofcraft Pty Ltd + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: BSD-2-Clause + *) + +theory Requalify_Test +imports Lib.Requalify +begin + +section \Tests and examples for requalify commands\ + +subsection \Generic\ + +subsubsection \Exporting types, constants and facts from a locale into the theory context\ + +locale Requalify_Example1 + +context Requalify_Example1 begin +typedecl ex1_type +definition "ex1_const \ undefined :: ex1_type" +end + +(* these will all generate errors: +typ ex1_type +term "ex1_const :: ex1_type" +thm ex1_const_def +*) + +typ Requalify_Example1.ex1_type +term "Requalify_Example1.ex1_const :: Requalify_Example1.ex1_type" +thm Requalify_Example1.ex1_const_def + +(* exporting will make types/consts/facts available *) + +requalify_types Requalify_Example1.ex1_type +typ ex1_type + +requalify_consts Requalify_Example1.ex1_const +term "ex1_const :: ex1_type" + +requalify_facts Requalify_Example1.ex1_const_def +thm ex1_const_def + +(* trying to export into theory context that already has that name will result in warnings *) +requalify_types Requalify_Example1.ex1_type +requalify_consts Requalify_Example1.ex1_const +requalify_facts Requalify_Example1.ex1_const_def + +(* warnings can be suppressed if naming collision is on purpose, but see caveats in next sections *) +requalify_types (aliasing) Requalify_Example1.ex1_type +requalify_consts (aliasing) Requalify_Example1.ex1_const +requalify_facts (aliasing) Requalify_Example1.ex1_const_def + +(* requalification can also occur via interpretation, using internal names, but this is slower *) +context begin interpretation Requalify_Example1 . +requalify_types ex1_type +requalify_consts ex1_const +requalify_facts ex1_const_def +end + + +subsubsection \Exporting types, constants and facts from a locale into a locale context\ + +locale Requalify_Example2 + +(* the target of the export can be a locale (this mode cannot be used from an interpretation) *) + +requalify_types (in Requalify_Example2) Requalify_Example1.ex1_type +requalify_consts (in Requalify_Example2) Requalify_Example1.ex1_const +requalify_facts (in Requalify_Example2) Requalify_Example1.ex1_const_def + +(* this is equivalent to doing the requalifications in the original locale context *) +context Requalify_Example1 begin +requalify_types (in Requalify_Example2) ex1_type +requalify_consts (in Requalify_Example2) ex1_const +requalify_facts (in Requalify_Example2) ex1_const_def +end + +typ Requalify_Example2.ex1_type +term "Requalify_Example2.ex1_const :: Requalify_Example2.ex1_type" +thm Requalify_Example2.ex1_const_def + +(* unfortunately, there is currently no warning on name collisions into locales *) +requalify_types (in Requalify_Example2) Requalify_Example1.ex1_type (* no warning *) +requalify_consts (in Requalify_Example2) Requalify_Example1.ex1_const (* no warning *) +requalify_facts (in Requalify_Example2) Requalify_Example1.ex1_const_def (* no warning *) + + +subsubsection \Using global naming to ensure a name prefix within a locale\ + +locale Requalify_Example_G + +context Requalify_Example_G begin global_naming EXAMPLE1 +typedecl ex_g_type +definition "ex_g_const \ undefined :: ex_g_type" +end + +(* note the prefixed names in the global context *) +typ EXAMPLE1.ex_g_type +term "EXAMPLE1.ex_g_const :: EXAMPLE1.ex_g_type" +thm EXAMPLE1.ex_g_const_def + +(* the locale names will not work, these will all generate errors: +typ Requalify_Example_G.ex_g_type +term "Requalify_Example_G.ex_g_const :: Requalify_Example_G.ex_g_type" +thm Requalify_Example_G.ex_g_const_def +*) + +(* Looking up the local unprefixed name inside the locale will work as expected *) +context Requalify_Example_G begin +thm ex_g_const_def +end + +(* using the new name, we can export as usual: *) +requalify_types EXAMPLE1.ex_g_type +requalify_consts EXAMPLE1.ex_g_const +requalify_facts EXAMPLE1.ex_g_const_def + +(* inside a locale interpretation, the names can be accessed without a prefix *) +context begin interpretation Requalify_Example_G . +requalify_types ex_g_type +requalify_consts ex_g_const +requalify_facts ex_g_const_def +end + +(* We can also re-export the name to the same locale in order to make an un-prefixed alias *) +requalify_types (in Requalify_Example_G) EXAMPLE1.ex_g_type +requalify_consts (in Requalify_Example_G) EXAMPLE1.ex_g_const +requalify_facts (in Requalify_Example_G) EXAMPLE1.ex_g_const_def + +(* This makes the names available via the locale name as well *) +typ Requalify_Example_G.ex_g_type +term "Requalify_Example_G.ex_g_const :: Requalify_Example_G.ex_g_type" +thm Requalify_Example_G.ex_g_const_def + + +subsubsection \Managing collisions and global naming\ + +(* In previous sections we generated collisions by repeatedly exporting the same thing. + Generally, exporting the same name from a locale into the global context is not advised, + as it will only cause confusion. + + However, a more realistic example is when global_naming is involved. Let's say we have a + Arch locale that's supposed to hide some architecture-specific details, and a name + prefix of BOARD for a specific architecture. It makes more sense with constants and types, + but those are harder to tell apart in a demo. +*) + +lemma requalify_collision: + "False = False" + by simp + +locale Arch + +context Arch begin global_naming BOARD +lemma requalify_collision: + "True = True" + by simp +end + +(* If we access the name, we get what we expect: *) +thm requalify_collision (* False = False *) + +(* Exporting requalify_collision to the theory context would now be ill-advised, as it would + make the global name inconvenient to access. What makes more sense is to export it such + that we can access the architecture specific name under Fake_Arch (and not talk about the + specific board), while maintaining access to the global name. Let's try: *) + +requalify_facts (in Arch) BOARD.requalify_collision + +(* global context: good *) +thm requalify_collision (* False = False *) +thm Arch.requalify_collision (* True = True *) + +(* context post-interpretation: we don't have convenient access to the global name anymore *) +context begin interpretation Arch . +thm requalify_collision (* True = True *) +thm Arch.requalify_collision (* True = True *) +end + +(* This is because whatever name was last interpreted takes precedence. If we want to fix this, we + need to re-export the global name *from* the Fake_Arch locale. + By convention we also give it a "global." prefix: *) +context Arch begin + context begin global_naming global + requalify_facts (aliasing) Requalify_Test.requalify_collision + end +end + +(* After this convolution, the names are now consistently available: *) + +(* globally *) +thm requalify_collision (* False = False *) +thm global.requalify_collision (* False = False *) +thm Arch.requalify_collision (* True = True *) + +(* when interpreted *) +context begin interpretation Arch . +thm requalify_collision (* False = False *) +thm global.requalify_collision (* False = False *) +thm Arch.requalify_collision (* True = True *) +end + +(* and in the locale context *) +context Arch begin +thm requalify_collision (* False = False *) +thm global.requalify_collision (* False = False *) +thm Arch.requalify_collision (* True = True *) +end + + +subsection \Architecture-specific (requires L4V_ARCH environment variable set to work)\ + +(* The above documentation and examples attempted to be somewhat generic. In the seL4 verification + repository, we have a specific setup: + + * A number of architectures (e.g. ARM, ARM_HYP, RISCV64, X64, AARCH64) parametrised by the + L4V_ARCH environment variable. + * An Arch locale for containing architecture-specific definitions, types and proofs, wherein + global naming wraps the architecture as follows: + * ($L4V_ARCH)_A for the Abstract spec (e.g. ARM_A) + * ($L4V_ARCH)_H for the Haskell spec (e.g. ARM_H) + * as per L4V_ARCH for everything else (e.g. ARM) (though other namespaces may appear in future) + + The arch_requalify and arch_global_naming variants lean on this, by being able to generically + say something about a requirement each specific architecture needs to fulfill. +*) + +context Arch begin + arch_global_naming (* equivalent to "global_naming ARM" on ARM *) + typedecl arch_specific_type + definition "arch_specific_const \ undefined :: arch_specific_type" + lemma arch_specific_lemma: "arch_specific_const = arch_specific_const" by simp + + arch_global_naming (A) (* equivalent to "global_naming ARM_A" on ARM *) + definition "arch_specific_const_a \ undefined :: arch_specific_type" + + arch_global_naming (H) (* equivalent to "global_naming ARM_A" on ARM *) + definition "arch_specific_const_h \ undefined :: arch_specific_type" +end + +(* confirm these are the ARM, ARM_A, and ARM_H prefixes respectively: *) +find_theorems name:arch_specific_const + +(* we requalify these prefixed constants without knowing what arch we are on: *) +arch_requalify_types arch_specific_type +arch_requalify_consts arch_specific_const +arch_requalify_facts arch_specific_lemma +arch_requalify_consts (A) arch_specific_const_a +arch_requalify_consts (H) arch_specific_const_h +arch_requalify_consts (H) arch_specific_const_h (* warnings work as usual *) +arch_requalify_consts (aliasing, H) arch_specific_const_h (* warnings suppression *) + +(* this has placed all names into the global context *) +typ arch_specific_type +thm arch_specific_lemma +term "arch_specific_const :: arch_specific_type" +term "arch_specific_const_a :: arch_specific_type" +term "arch_specific_const_h :: arch_specific_type" + +(* If we wish to create a generic name that does not compete with a global name, we need to export + into the Arch locale, then fix up the interpretation order of any collisions as described in + "Managing collisions and global naming" *) +arch_requalify_consts (in Arch) (A) arch_specific_const_a + +(* this now works *) +term Arch.arch_specific_const_a + + +section "Specific tests" + +subsection \Temporary requalification of, hiding of, and re-exposing of constants\ + +(* This kind of approach can be used for tools such at the C Parser, which are not aware of the Arch + locale and might need to refer to constants directly in internal annotations. *) + +context Arch begin arch_global_naming +datatype vmpage_size = + ARCHSmallPage +end +arch_requalify_types vmpage_size + +context Arch begin global_naming vmpage_size +requalify_consts ARCHSmallPage +end + +(* both now visible in generic context *) +typ vmpage_size +term vmpage_size.ARCHSmallPage +term ARCHSmallPage (* note: the direct constructor name is not accessible due to qualified export *) + +(* temporary global exposure is done, hide vmpage sizes again *) +hide_const + vmpage_size.ARCHSmallPage + +find_consts name:ARCHSmallPage +(* finds one constant (despite it being hidden), e.g. on ARM: + Requalify.ARM.vmpage_size.ARMSmallPage :: "vmpage_size" + but note that this constant is inaccessible from theory scope: + term Requalify_Test.AARCH64.vmpage_size.ARCHSmallPage + will result in Inaccessible constant: "Requalify_Test.ARM.vmpage_size.ARCHSmallPage" *) + +(* Arch-specific, in actual use replace ARCH with actual architecture such as ARM *) +context Arch begin +term vmpage_size.ARCHSmallPage (* despite being hidden in theory scope, it's still visible in Arch *) +global_naming "ARCH.vmpage_size" requalify_consts ARCHSmallPage +global_naming "ARCH" requalify_consts ARCHSmallPage +end + +term ARCH.ARCHSmallPage (* now accessible under specific qualified name *) +term ARCH.vmpage_size.ARCHSmallPage (* now accessible under specific qualified name *) +term Requalify_Test.ARCH.vmpage_size.ARCHSmallPage (* fully qualified name *) +(* but be aware, these are only aliases to the original constant! *) +find_consts name:ARCHSmallPage (* still only Requalify_Test.ARM.vmpage_size.ARCHSmallPage *) + + +section "Misc tests / usage examples" + +locale Requalify_Locale +begin + +typedecl requalify_type + +definition "requalify_const == (undefined :: requalify_type)" + + +end + +typedecl requalify_type +definition "requalify_const == (undefined :: requalify_type)" + +context Requalify_Locale begin global_naming Requalify_Locale2 + +requalify_consts requalify_const +requalify_types requalify_type +requalify_facts requalify_const_def + +end + +term "requalify_const :: requalify_type" +term "Requalify_Locale2.requalify_const :: Requalify_Locale2.requalify_type" +lemma "Requalify_Locale2.requalify_const = (undefined :: Requalify_Locale2.requalify_type)" + by (simp add: Requalify_Locale2.requalify_const_def) + +consts requalify_test_f :: "'a \ 'b \ bool" + +lemma + assumes f1: "requalify_test_f requalify_const Requalify_Locale2.requalify_const" + and f2: "requalify_test_f Requalify_Locale2.requalify_const Requalify_Test.requalify_const" + shows "requalify_test_f Requalify_Locale2.requalify_const requalify_const" "requalify_const = undefined" + apply (rule f1)? + apply (rule f2) + apply (simp add: requalify_const_def) + done + +context Requalify_Locale begin + +lemma + assumes f1: "requalify_test_f requalify_const Requalify_Locale2.requalify_const" + and f2: "requalify_test_f Requalify_Locale2.requalify_const Requalify_Test.requalify_const" + shows "requalify_test_f Requalify_Locale2.requalify_const requalify_const" "requalify_const = undefined" + apply (rule f2)? + apply (rule f1) + apply (simp add: requalify_const_def) + done + +end + +context Requalify_Locale begin global_naming global + +requalify_consts Requalify_Test.requalify_const +requalify_types Requalify_Test.requalify_type +requalify_facts Requalify_Test.requalify_const_def + +end + +context Requalify_Locale begin + +lemma + assumes f1: "requalify_test_f requalify_const Requalify_Locale2.requalify_const" + and f2: "requalify_test_f Requalify_Locale2.requalify_const global.requalify_const" + shows "requalify_test_f Requalify_Locale2.requalify_const requalify_const" "requalify_const = undefined" + apply (rule f1)? + apply (rule f2) + apply (simp add: requalify_const_def) + done +end + +context begin interpretation Requalify_Locale . + +lemma + assumes f1: "requalify_test_f requalify_const Requalify_Locale2.requalify_const" + and f2: "requalify_test_f Requalify_Locale2.requalify_const global.requalify_const" + shows "requalify_test_f Requalify_Locale2.requalify_const requalify_const" "requalify_const = undefined" + apply (rule f1)? + apply (rule f2) + apply (simp add: requalify_const_def) + done +end + +locale Requalify_Locale3 +begin + +typedecl requalify_type2 +definition "requalify_const2 == (undefined :: requalify_type2)" + +end + +context begin interpretation Requalify_Locale3 . + +requalify_consts requalify_const2 +requalify_types requalify_type2 +requalify_facts requalify_const2_def + +end + +lemma "(requalify_const2 :: requalify_type2) = undefined" + by (simp add: requalify_const2_def) + +context Requalify_Locale3 begin + +lemma "(requalify_const2 :: requalify_type2) = undefined" + by (simp add: requalify_const2_def) + +end + +end diff --git a/misc/scripts/thydeps b/misc/scripts/thydeps index b0cc667613..f2fab83403 100755 --- a/misc/scripts/thydeps +++ b/misc/scripts/thydeps @@ -51,7 +51,7 @@ def session_theory_deps(isabelle_dir, ROOT_dirs, sessions): isabelle_dir, cmdline, ignore_exit_code=True).splitlines(): l = l.decode('utf-8') # 'Session HOL/HOL-Library (main timing)' - m = re.match(r'Session (' + session_name_re + ')/(' + session_name_re + ')(?: \(.*\))?', l) + m = re.match(r'Session (' + session_name_re + ')/(' + session_name_re + r')(?: \(.*\))?', l) if m: # start processing next session _, session = m.groups() diff --git a/proof/access-control/ARM/ArchIpc_AC.thy b/proof/access-control/ARM/ArchIpc_AC.thy index 45fabb1356..4f2b49cd9d 100644 --- a/proof/access-control/ARM/ArchIpc_AC.thy +++ b/proof/access-control/ARM/ArchIpc_AC.thy @@ -192,7 +192,7 @@ declare arch_get_sanitise_register_info_inv[Ipc_AC_assms] end -context is_extended begin interpretation Arch . (*FIXME: arch_split*) +context is_extended begin interpretation Arch . (*FIXME: arch-split*) lemma list_integ_lift_in_ipc[Ipc_AC_assms]: assumes li: diff --git a/proof/access-control/ARM/ArchRetype_AC.thy b/proof/access-control/ARM/ArchRetype_AC.thy index 63deb8b9a8..5b2f637b27 100644 --- a/proof/access-control/ARM/ArchRetype_AC.thy +++ b/proof/access-control/ARM/ArchRetype_AC.thy @@ -209,25 +209,21 @@ lemma copy_global_invs_mappings_restricted': lemma init_arch_objects_pas_refined[Retype_AC_assms]: "\pas_refined aag and post_retype_invs tp refs and (\s. \ x\set refs. x \ global_refs s) and K (\ref \ set refs. is_aligned ref (obj_bits_api tp obj_sz))\ - init_arch_objects tp ptr bits obj_sz refs + init_arch_objects tp dev ptr bits obj_sz refs \\_. pas_refined aag\" + supply if_split[split del] apply (rule hoare_gen_asm) - apply (cases tp) - apply (simp_all add: init_arch_objects_def) - apply (wp | simp)+ - apply (rename_tac aobject_type) - apply (case_tac aobject_type, simp_all) - apply ((simp | wp)+)[5] - apply wp - apply (rule_tac Q'="\rv. pas_refined aag and + apply (cases tp; + (wpsimp simp: init_arch_objects_def + wp: mapM_x_wp'[where f="\r. do_machine_op (m r)" for m])) + apply (rule_tac Q'="\rv. pas_refined aag and all_invs_but_equal_kernel_mappings_restricted (set refs) and (\s. \x \ set refs. x \ global_refs s)" in hoare_strengthen_post) - apply (wp mapM_x_wp[OF _ subset_refl]) - apply ((wp copy_global_mappings_pas_refined copy_global_invs_mappings_restricted' - copy_global_mappings_global_refs_inv copy_global_invs_mappings_restricted' - | fastforce simp: obj_bits_api_def default_arch_object_def pd_bits_def pageBits_def)+)[2] - apply (wp dmo_invs hoare_vcg_const_Ball_lift valid_irq_node_typ - | fastforce simp: post_retype_invs_def)+ + apply (wp mapM_x_wp[OF _ subset_refl]) + apply ((wp copy_global_mappings_pas_refined copy_global_invs_mappings_restricted' + copy_global_mappings_global_refs_inv copy_global_invs_mappings_restricted' + | fastforce simp: obj_bits_api_def default_arch_object_def pd_bits_def pageBits_def)+)[2] + apply (fastforce simp: post_retype_invs_def split: if_split) done lemma region_in_kernel_window_preserved: @@ -287,7 +283,7 @@ crunch delete_objects (ignore: do_machine_op freeMemory) lemma init_arch_objects_pas_cur_domain[Retype_AC_assms, wp]: - "init_arch_objects tp ptr n us refs \pas_cur_domain aag\" + "init_arch_objects tp dev ptr n us refs \pas_cur_domain aag\" by wp lemma retype_region_pas_cur_domain[Retype_AC_assms, wp]: @@ -366,13 +362,12 @@ lemma dmo_clearMemory_respects'[Retype_AC_assms]: \\_. integrity aag X st\" unfolding do_machine_op_def clearMemory_def apply (simp add: split_def cleanCacheRange_PoU_def) - apply wp - apply clarsimp + apply wpsimp apply (erule use_valid) - apply wp - apply (simp add: cleanCacheRange_RAM_def cleanCacheRange_PoC_def cacheRangeOp_def cleanL2Range_def - cleanByVA_def split_def dsb_def) - apply (wp mol_respects mapM_x_wp' storeWord_respects)+ + apply (wp mapM_x_wp') + apply (simp add: cleanCacheRange_RAM_def cleanCacheRange_PoC_def cacheRangeOp_def cleanL2Range_def + cleanByVA_def split_def dsb_def) + apply (wp mol_respects mapM_x_wp' storeWord_respects)+ apply (simp add: word_size_bits_def) apply (clarsimp simp: word_size_def word_bits_def upto_enum_step_shift_red[where us=2, simplified]) apply (erule bspec) @@ -396,6 +391,12 @@ lemma dmo_cleanCacheRange_PoU_respects [wp]: "do_machine_op (cleanCacheRange_PoU vstart vend pstart) \integrity aag X st\" by (wpsimp wp: dmo_cacheRangeOp_lift simp: cleanCacheRange_PoU_def cleanByVA_PoU_def) +lemma dmo_cleanCacheRange_RAM_respects [wp]: + "do_machine_op (cleanCacheRange_RAM vstart vend pstart) \integrity aag X st\" + by (wpsimp wp: dmo_cacheRangeOp_lift + simp: dmo_bind_valid cleanCacheRange_RAM_def cleanCacheRange_PoC_def + cleanL2Range_def dsb_def cleanByVA_def) + lemma dmo_mapM_x_cleanCacheRange_PoU_integrity: "do_machine_op (mapM_x (\x. cleanCacheRange_PoU (f x) (g x) (h x)) refs) \integrity aag X st\" by (wp dmo_mapM_x_wp_inv) @@ -403,7 +404,7 @@ lemma dmo_mapM_x_cleanCacheRange_PoU_integrity: lemma init_arch_objects_integrity[Retype_AC_assms]: "\integrity aag X st and K (\x\set refs. is_subject aag x) and K (\ref \ set refs. is_aligned ref (obj_bits_api new_type obj_sz))\ - init_arch_objects new_type ptr num_objects obj_sz refs + init_arch_objects new_type dev ptr num_objects obj_sz refs \\_. integrity aag X st\" apply (rule hoare_gen_asm)+ apply (cases new_type; simp add: init_arch_objects_def split del: if_split) diff --git a/proof/access-control/ARM/ExampleSystem.thy b/proof/access-control/ARM/ExampleSystem.thy index 9c983d64dc..6282d5ef13 100644 --- a/proof/access-control/ARM/ExampleSystem.thy +++ b/proof/access-control/ARM/ExampleSystem.thy @@ -8,7 +8,7 @@ theory ExampleSystem imports ArchAccess_AC begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition nat_to_bl :: "nat \ nat \ bool list option" diff --git a/proof/access-control/DomainSepInv.thy b/proof/access-control/DomainSepInv.thy index 6f33d347fd..7d2c2c6421 100644 --- a/proof/access-control/DomainSepInv.thy +++ b/proof/access-control/DomainSepInv.thy @@ -315,7 +315,7 @@ locale DomainSepInv_1 = and arch_post_cap_deletion_domain_sep_inv[wp]: "arch_post_cap_deletion acap \\s :: det_ext state. domain_sep_inv irqs st s\" and init_arch_objects_domain_sep_inv[wp]: - "init_arch_objects typ ptr n sz refs \\s :: det_ext state. domain_sep_inv irqs st s\" + "init_arch_objects typ dev ptr n sz refs \\s :: det_ext state. domain_sep_inv irqs st s\" and prepare_thread_delete_domain_sep_inv[wp]: "prepare_thread_delete t \\s :: det_ext state. domain_sep_inv irqs st s\" and arch_finalise_cap_rv: diff --git a/proof/access-control/RISCV64/ArchRetype_AC.thy b/proof/access-control/RISCV64/ArchRetype_AC.thy index f9b731c133..93b34a9022 100644 --- a/proof/access-control/RISCV64/ArchRetype_AC.thy +++ b/proof/access-control/RISCV64/ArchRetype_AC.thy @@ -250,7 +250,7 @@ crunch delete_objects (ignore: do_machine_op freeMemory) lemma init_arch_objects_pas_cur_domain[Retype_AC_assms, wp]: - "init_arch_objects tp ptr n us refs \pas_cur_domain aag\" + "init_arch_objects tp dev ptr n us refs \pas_cur_domain aag\" by wp lemma retype_region_pas_cur_domain[Retype_AC_assms, wp]: diff --git a/proof/access-control/RISCV64/ExampleSystem.thy b/proof/access-control/RISCV64/ExampleSystem.thy index 1c2fd36088..2f1980177f 100644 --- a/proof/access-control/RISCV64/ExampleSystem.thy +++ b/proof/access-control/RISCV64/ExampleSystem.thy @@ -8,7 +8,7 @@ theory ExampleSystem imports ArchAccess_AC begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition nat_to_bl :: "nat \ nat \ bool list option" diff --git a/proof/access-control/Retype_AC.thy b/proof/access-control/Retype_AC.thy index dbda41be06..b81ad611ab 100644 --- a/proof/access-control/Retype_AC.thy +++ b/proof/access-control/Retype_AC.thy @@ -184,15 +184,15 @@ locale Retype_AC_1 = "\tp. is_aligned p (obj_bits_api (ArchObject tp) n) \ aobj_ref' (arch_default_cap tp p n dev) \ ptr_range p (obj_bits_api (ArchObject tp) n)" and init_arch_objects_pas_refined: - "\tp. \pas_refined aag and post_retype_invs tp refs + "\tp dev. \pas_refined aag and post_retype_invs tp refs and (\s. \x\set refs. x \ global_refs s) and K (\ref \ set refs. is_aligned ref (obj_bits_api tp obj_sz))\ - init_arch_objects tp ptr bits obj_sz refs - \\_. pas_refined aag\" + init_arch_objects tp dev ptr bits obj_sz refs + \\_. pas_refined aag\" and dmo_freeMemory_invs: "do_machine_op (freeMemory ptr bits) \\s :: det_ext state. invs s\" and init_arch_objects_pas_cur_domain[wp]: - "\tp. init_arch_objects tp ptr n us refs \pas_cur_domain aag\" + "\tp dev. init_arch_objects tp dev ptr n us refs \pas_cur_domain aag\" and retype_region_pas_cur_domain[wp]: "\tp. retype_region ptr n us tp dev \pas_cur_domain aag\" and reset_untyped_cap_pas_cur_domain[wp]: @@ -222,7 +222,7 @@ locale Retype_AC_1 = and init_arch_objects_integrity: "\integrity aag X st and K (\x\set refs. is_subject aag x) and K (\ref \ set refs. is_aligned ref (obj_bits_api new_type obj_sz))\ - init_arch_objects new_type ptr num_objects obj_sz refs + init_arch_objects new_type dev ptr num_objects obj_sz refs \\_. integrity aag X st\" and integrity_asids_detype: "\r \ R. pasObjectAbs aag r \ subjects diff --git a/proof/access-control/Syscall_AC.thy b/proof/access-control/Syscall_AC.thy index b505d09d9c..ad13ff9fb8 100644 --- a/proof/access-control/Syscall_AC.thy +++ b/proof/access-control/Syscall_AC.thy @@ -504,7 +504,7 @@ locale Syscall_AC_1 = and handle_reserved_irq_arch_state[wp]: "\P. handle_reserved_irq irq \\s :: det_ext state. P (arch_state s)\" and init_arch_objects_arch_state[wp]: - "\P. init_arch_objects new_type ptr n sz refs \\s :: det_ext state. P (arch_state s)\" + "\P. init_arch_objects new_type dev ptr n sz refs \\s :: det_ext state. P (arch_state s)\" and getActiveIRQ_inv: "\P. \f s. P s \ P (irq_state_update f s) \ \P\ getActiveIRQ in_kernel \\rv. P\" diff --git a/proof/bisim/Syscall_S.thy b/proof/bisim/Syscall_S.thy index 06907304b2..0785444dad 100644 --- a/proof/bisim/Syscall_S.thy +++ b/proof/bisim/Syscall_S.thy @@ -8,7 +8,7 @@ theory Syscall_S imports Separation begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma syscall_bisim: assumes bs: diff --git a/proof/crefine/AARCH64/ADT_C.thy b/proof/crefine/AARCH64/ADT_C.thy index 660bfeff8c..96ce1bd238 100644 --- a/proof/crefine/AARCH64/ADT_C.thy +++ b/proof/crefine/AARCH64/ADT_C.thy @@ -220,7 +220,7 @@ end consts Init_C' :: "unit observable \ cstate global_state set" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "Init_C \ \((tc,s),m,e). Init_C' ((tc, truncate_state s),m,e)" @@ -345,7 +345,7 @@ lemma cint_rel_to_H: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "cstate_to_machine_H s \ @@ -630,7 +630,7 @@ lemma carch_state_to_H_correct: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma tcb_queue_rel_unique: "hp NULL = None \ diff --git a/proof/crefine/AARCH64/Arch_C.thy b/proof/crefine/AARCH64/Arch_C.thy index be910a494d..8b7b1c02da 100644 --- a/proof/crefine/AARCH64/Arch_C.thy +++ b/proof/crefine/AARCH64/Arch_C.thy @@ -12,7 +12,7 @@ begin unbundle l4v_word_context -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch unmapPageTable for gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" @@ -92,7 +92,7 @@ lemma clearMemory_PT_setObject_PTE_ccorres: apply (clarsimp simp: guard_is_UNIV_def bit_simps split: if_split) apply clarsimp apply (frule is_aligned_addrFromPPtr_n, simp) - apply (simp add: is_aligned_no_overflow' addrFromPPtr_mask_cacheLineSize) + apply (simp add: is_aligned_no_overflow' addrFromPPtr_mask_cacheLineBits) apply (rule conjI) apply (simp add: unat_mask_eq flip: mask_2pm1) apply (simp add: mask_eq_exp_minus_1) @@ -1604,7 +1604,7 @@ definition flushtype_relation :: "flush_type \ machine_word \ scast ` {Kernel_C.ARMPageUnify_Instruction, Kernel_C.ARMVSpaceUnify_Instruction}" lemma doFlush_ccorres: - "ccorres dc xfdc (\s. vs \ ve \ ps \ ps + (ve - vs) \ vs && mask cacheLineSize = ps && mask cacheLineSize + "ccorres dc xfdc (\s. vs \ ve \ ps \ ps + (ve - vs) \ vs && mask cacheLineBits = ps && mask cacheLineBits \ ptrFromPAddr ps \ ptrFromPAddr ps + (ve - vs) \ unat (ve - vs) \ gsMaxObjectSize s) (\flushtype_relation t \invLabel\ \ \\start = vs\ \ \\end = ve\ \ \\pstart = ps\) [] diff --git a/proof/crefine/AARCH64/CLevityCatch.thy b/proof/crefine/AARCH64/CLevityCatch.thy index 0f30569422..192cfe3bad 100644 --- a/proof/crefine/AARCH64/CLevityCatch.thy +++ b/proof/crefine/AARCH64/CLevityCatch.thy @@ -73,7 +73,7 @@ qed (* end holding area *) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* Short-hand for unfolding cumbersome machine constants *) (* FIXME MOVE these should be in refine, and the _eq forms should NOT be declared [simp]! *) diff --git a/proof/crefine/AARCH64/DetWP.thy b/proof/crefine/AARCH64/DetWP.thy index 200baa7eaf..9e52e6058c 100644 --- a/proof/crefine/AARCH64/DetWP.thy +++ b/proof/crefine/AARCH64/DetWP.thy @@ -9,7 +9,7 @@ theory DetWP imports "Lib.DetWPLib" "CBaseRefine.Include_C" begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma det_wp_doMachineOp [wp]: "det_wp (\_. P) f \ det_wp (\_. P) (doMachineOp f)" diff --git a/proof/crefine/AARCH64/Fastpath_C.thy b/proof/crefine/AARCH64/Fastpath_C.thy index 47eac532e3..18fe506b69 100644 --- a/proof/crefine/AARCH64/Fastpath_C.thy +++ b/proof/crefine/AARCH64/Fastpath_C.thy @@ -17,7 +17,7 @@ imports "CLib.MonadicRewrite_C" begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setCTE_obj_at'_queued: "\obj_at' (\tcb. P (tcbQueued tcb)) t\ setCTE p v \\rv. obj_at' (\tcb. P (tcbQueued tcb)) t\" diff --git a/proof/crefine/AARCH64/Fastpath_Defs.thy b/proof/crefine/AARCH64/Fastpath_Defs.thy index 39399599b0..99c03234a1 100644 --- a/proof/crefine/AARCH64/Fastpath_Defs.thy +++ b/proof/crefine/AARCH64/Fastpath_Defs.thy @@ -15,7 +15,7 @@ theory Fastpath_Defs imports ArchMove_C begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "fastpaths sysc \ case sysc of diff --git a/proof/crefine/AARCH64/Fastpath_Equiv.thy b/proof/crefine/AARCH64/Fastpath_Equiv.thy index e68c67d1be..d07a04c45e 100644 --- a/proof/crefine/AARCH64/Fastpath_Equiv.thy +++ b/proof/crefine/AARCH64/Fastpath_Equiv.thy @@ -45,7 +45,7 @@ lemma setCTE_tcbContext: apply (rule setObject_cte_obj_at_tcb', simp_all) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setThreadState_tcbContext: "setThreadState st tptr \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" diff --git a/proof/crefine/AARCH64/Invoke_C.thy b/proof/crefine/AARCH64/Invoke_C.thy index 3a9fbeed08..08815fe4e4 100644 --- a/proof/crefine/AARCH64/Invoke_C.thy +++ b/proof/crefine/AARCH64/Invoke_C.thy @@ -1382,7 +1382,7 @@ lemma decodeCNodeInvocation_ccorres: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas setCTE_def3 = setCTE_def2[THEN eq_reflection] @@ -1649,43 +1649,34 @@ lemma clearMemory_untyped_ccorres: apply (cinit' lift: bits_' ptr___ptr_to_unsigned_long_') apply (rule_tac P="ptr \ 0 \ sz < word_bits" in ccorres_gen_asm) apply (simp add: clearMemory_def) - apply (simp add: doMachineOp_bind storeWord_empty_fail) - apply (rule ccorres_split_nothrow_novcg_dc) - apply (rule_tac P="?P" and P'="{s. region_actually_is_bytes ptr (2 ^ sz) s}" in ccorres_from_vcg) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (rule conjI; clarsimp) - apply (simp add: word_less_nat_alt unat_of_nat word_bits_def) - apply (clarsimp simp: isCap_simps valid_cap'_def capAligned_def - is_aligned_no_wrap'[OF _ word64_power_less_1] - unat_of_nat_eq word_bits_def) - apply (simp add: is_aligned_weaken is_aligned_triv[THEN is_aligned_weaken]) - apply (clarsimp simp: ghost_assertion_size_logic[unfolded o_def] region_actually_is_bytes_dom_s) - apply (clarsimp simp: field_simps word_size_def mapM_x_storeWord_step - word_bits_def cte_wp_at_ctes_of) - apply (frule ctes_of_valid', clarify+) - apply (simp add: doMachineOp_def split_def exec_gets) - apply (simp add: select_f_def simpler_modify_def bind_def valid_cap_simps' capAligned_def) - apply (subst pspace_no_overlap_underlying_zero_update; simp?) - apply (case_tac sz, simp_all)[1] - apply (case_tac nat, simp_all)[1] - apply (case_tac nata, simp_all)[1] - apply (clarsimp dest!: region_actually_is_bytes) - apply (drule(1) rf_sr_rep0) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def) - apply csymbr - apply (ctac add: cleanCacheRange_RAM_ccorres) - apply wp - apply (simp add: guard_is_UNIV_def unat_of_nat - word_bits_def capAligned_def word_of_nat_less) + apply (rule_tac P="?P" and P'="{s. region_actually_is_bytes ptr (2 ^ sz) s}" in ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (rule conjI; clarsimp) + apply (simp add: word_less_nat_alt unat_of_nat word_bits_def) + apply (clarsimp simp: isCap_simps valid_cap'_def capAligned_def + is_aligned_no_wrap'[OF _ word64_power_less_1] + unat_of_nat_eq word_bits_def) + apply (simp add: is_aligned_weaken is_aligned_triv[THEN is_aligned_weaken]) + apply (clarsimp simp: ghost_assertion_size_logic[unfolded o_def] region_actually_is_bytes_dom_s) + apply (clarsimp simp: field_simps word_size_def mapM_x_storeWord_step + word_bits_def cte_wp_at_ctes_of) + apply (frule ctes_of_valid', clarify+) + apply (simp add: doMachineOp_def split_def exec_gets) + apply (simp add: select_f_def simpler_modify_def bind_def valid_cap_simps' capAligned_def) + apply (subst pspace_no_overlap_underlying_zero_update; simp?) + apply (case_tac sz, simp_all)[1] + apply (case_tac nat, simp_all)[1] + apply (case_tac nata, simp_all)[1] + apply (clarsimp dest!: region_actually_is_bytes) + apply (drule(1) rf_sr_rep0) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def + carch_state_relation_def cmachine_state_relation_def) apply (clarsimp simp: cte_wp_at_ctes_of) apply (frule ctes_of_valid'; clarify?) apply (clarsimp simp: isCap_simps valid_cap_simps' capAligned_def word_of_nat_less Kernel_Config.resetChunkBits_def word_bits_def unat_2p_sub_1) - apply (strengthen is_aligned_no_wrap'[where sz=sz] is_aligned_addrFromPPtr_n)+ - apply (simp add: addrFromPPtr_mask_cacheLineSize pptrBaseOffset_alignment_def) apply (cases "ptr = 0"; simp) apply (drule subsetD, rule intvl_self, simp) apply simp @@ -2812,10 +2803,10 @@ lemma ctes_of_ex_cte_cap_to': lemma Arch_isFrameType_spec: - "\s. \ \ \s. unat \type \ fromEnum (maxBound::ArchTypes_H.object_type)\ + "\s. \ \ \s. unat \type \ fromEnum (maxBound::object_type)\ Call Arch_isFrameType_'proc \ \ret__unsigned_long = - from_bool (isFrameType ((toEnum (unat \<^bsup>s\<^esup> type))::ArchTypes_H.object_type))\" + from_bool (isFrameType ((toEnum (unat \<^bsup>s\<^esup> type))::object_type))\" apply vcg apply (simp add: toEnum_object_type_to_H) apply (frule object_type_from_to_H) diff --git a/proof/crefine/AARCH64/Ipc_C.thy b/proof/crefine/AARCH64/Ipc_C.thy index 3c5a995444..1b8ff37839 100644 --- a/proof/crefine/AARCH64/Ipc_C.thy +++ b/proof/crefine/AARCH64/Ipc_C.thy @@ -14,7 +14,7 @@ imports IsolatedThreadAction begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "replyFromKernel_success_empty thread \ do @@ -292,7 +292,7 @@ lemma ccap_relation_reply_helpers: cap_reply_cap_lift_def word_size elim!: ccap_relationE) -(*FIXME: arch_split: C kernel names hidden by Haskell names *) +(*FIXME: arch-split: C kernel names hidden by Haskell names *) (*FIXME: fupdate simplification issues for 2D arrays *) abbreviation "syscallMessageC \ kernel_all_global_addresses.fault_messages.[unat MessageID_Syscall]" lemmas syscallMessageC_def = kernel_all_substitute.fault_messages_def @@ -315,7 +315,7 @@ lemma syscallMessage_ccorres: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "handleArchFaultReply' f sender receiver tag \ @@ -1041,7 +1041,7 @@ lemma setMR_ccorres_dc: end (* FIXME: move *) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch setMR for valid_pspace'[wp]: "valid_pspace'" crunch setMR diff --git a/proof/crefine/AARCH64/IsolatedThreadAction.thy b/proof/crefine/AARCH64/IsolatedThreadAction.thy index d8c1d0cf50..b11ec605d4 100644 --- a/proof/crefine/AARCH64/IsolatedThreadAction.thy +++ b/proof/crefine/AARCH64/IsolatedThreadAction.thy @@ -156,7 +156,7 @@ lemma partial_overwrite_fun_upd: apply (clarsimp split: if_split) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma get_tcb_state_regs_ko_at': "ko_at' ko p s \ get_tcb_state_regs (ksPSpace s p) @@ -1349,7 +1349,7 @@ lemma bind_assoc: = do x \ m; y \ f x; g y od" by (rule bind_assoc) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setObject_modify_assert: "\ updateObject v = updateObject_default v \ diff --git a/proof/crefine/AARCH64/Machine_C.thy b/proof/crefine/AARCH64/Machine_C.thy index 1e02ad82ad..573d0fdb75 100644 --- a/proof/crefine/AARCH64/Machine_C.thy +++ b/proof/crefine/AARCH64/Machine_C.thy @@ -156,7 +156,7 @@ assumes cleanByVA_PoU_ccorres: assumes cleanCacheRange_RAM_ccorres: "ccorres dc xfdc (\s. w1 \ w2 \ w3 \ w3 + (w2 - w1) - \ w1 && mask cacheLineSize = w3 && mask cacheLineSize + \ w1 && mask cacheLineBits = w3 && mask cacheLineBits \ unat (w2 - w1) \ gsMaxObjectSize s) (\\start = w1\ \ \\end = w2\ \ \\pstart = w3\) [] (doMachineOp (cleanCacheRange_RAM w1 w2 w3)) @@ -165,7 +165,7 @@ assumes cleanCacheRange_RAM_ccorres: assumes cleanCacheRange_PoU_ccorres: "ccorres dc xfdc (\s. unat (w2 - w1) \ gsMaxObjectSize s \ w1 \ w2 \ w3 \ w3 + (w2 - w1) - \ w1 && mask cacheLineSize = w3 && mask cacheLineSize) + \ w1 && mask cacheLineBits = w3 && mask cacheLineBits) (\\start = w1\ \ \\end = w2\ \ \\pstart = w3\) [] (doMachineOp (cleanCacheRange_PoU w1 w2 w3)) (Call cleanCacheRange_PoU_'proc)" @@ -173,7 +173,7 @@ assumes cleanCacheRange_PoU_ccorres: assumes cleanInvalidateCacheRange_RAM_ccorres: "ccorres dc xfdc (\s. unat (w2 - w1) \ gsMaxObjectSize s \ w1 \ w2 \ w3 \ w3 + (w2 - w1) - \ w1 && mask cacheLineSize = w3 && mask cacheLineSize) + \ w1 && mask cacheLineBits = w3 && mask cacheLineBits) (\\start = w1\ \ \\end = w2\ \ \\pstart = w3\) [] (doMachineOp (cleanInvalidateCacheRange_RAM w1 w2 w3)) (Call cleanInvalidateCacheRange_RAM_'proc)" @@ -181,14 +181,14 @@ assumes cleanInvalidateCacheRange_RAM_ccorres: assumes invalidateCacheRange_RAM_ccorres: "ccorres dc xfdc ((\s. unat (w2 - w1) \ gsMaxObjectSize s) and (\_. w1 \ w2 \ w3 \ w3 + (w2 - w1) - \ w1 && mask cacheLineSize = w3 && mask cacheLineSize)) + \ w1 && mask cacheLineBits = w3 && mask cacheLineBits)) (\\start = w1\ \ \\end = w2\ \ \\pstart = w3\) [] (doMachineOp (invalidateCacheRange_RAM w1 w2 w3)) (Call invalidateCacheRange_RAM_'proc)" assumes invalidateCacheRange_I_ccorres: "ccorres dc xfdc (\_. w1 \ w2 \ w3 \ w3 + (w2 - w1) - \ w1 && mask cacheLineSize = w3 && mask cacheLineSize) + \ w1 && mask cacheLineBits = w3 && mask cacheLineBits) (\\start = w1\ \ \\end = w2\ \ \\pstart = w3\) [] (doMachineOp (invalidateCacheRange_I w1 w2 w3)) (Call invalidateCacheRange_I_'proc)" @@ -199,6 +199,13 @@ assumes cleanCacheRange_RAM_preserves_kernel_bytes: \ (\x. snd (hrs_htd (t_hrs_' (globals s)) x) 0 \ None \ hrs_mem (t_hrs_' (globals t)) x = hrs_mem (t_hrs_' (globals s)) x)}" +assumes cleanCacheRange_PoU_preserves_kernel_bytes: + "\s. \\\<^bsub>/UNIV\<^esub> {s} Call cleanCacheRange_PoU_'proc + {t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s)) + \ (\x. snd (hrs_htd (t_hrs_' (globals s)) x) 0 \ None + \ hrs_mem (t_hrs_' (globals t)) x = hrs_mem (t_hrs_' (globals s)) x)}" + + (* Hypervisor-related machine ops *) (* ARM Hypervisor hardware register getters and setters *) diff --git a/proof/crefine/AARCH64/Recycle_C.thy b/proof/crefine/AARCH64/Recycle_C.thy index ae30cd2b4e..ec167b9566 100644 --- a/proof/crefine/AARCH64/Recycle_C.thy +++ b/proof/crefine/AARCH64/Recycle_C.thy @@ -252,8 +252,6 @@ lemma range_cover_nca_neg: "\x p (off :: 9 word). apply (simp add: pageBits_def objBits_simps) done -lemmas unat_of_nat32' = unat_of_nat_eq[where 'a=32] - lemma clearMemory_PageCap_ccorres: "ccorres dc xfdc (invs' and valid_cap' (ArchObjectCap (FrameCap ptr undefined sz False None)) and (\s. 2 ^ pageBitsForSize sz \ gsMaxObjectSize s) @@ -268,30 +266,27 @@ lemma clearMemory_PageCap_ccorres: apply (cinit' lift: bits_' ptr___ptr_to_unsigned_long_') apply (rule_tac P="capAligned (ArchObjectCap (FrameCap ptr undefined sz False None))" in ccorres_gen_asm) - apply (rule ccorres_Guard_Seq) + apply (rule ccorres_Guard) apply (simp add: clearMemory_def) - apply (simp add: doMachineOp_bind) - apply (rule ccorres_split_nothrow_novcg_dc) - apply (rule_tac P="?P" in ccorres_from_vcg[where P'=UNIV]) - apply (rule allI, rule conseqPre, vcg) - apply (clarsimp simp: valid_cap'_def capAligned_def - is_aligned_no_wrap'[OF _ word64_power_less_1]) - apply (prop_tac "ptr \ 0") - subgoal - apply (simp add: frame_at'_def) - apply (drule_tac x=0 in spec) - apply (clarsimp simp: pageBitsForSize_def bit_simps split: vmpage_size.splits) - done - apply simp - apply (prop_tac "3 \ pageBitsForSize sz") - apply (simp add: pageBitsForSize_def bit_simps split: vmpage_size.split) - apply (rule conjI) - apply (erule is_aligned_weaken) - apply (clarsimp simp: pageBitsForSize_def split: vmpage_size.splits) - apply (rule conjI) - apply (rule is_aligned_power2) - apply (clarsimp simp: pageBitsForSize_def split: vmpage_size.splits) - apply (clarsimp simp: ghost_assertion_size_logic[unfolded o_def]) + apply (rule_tac P="?P" in ccorres_from_vcg[where P'=UNIV]) + apply (rule allI, rule conseqPre, vcg) + apply (clarsimp simp: valid_cap'_def capAligned_def + is_aligned_no_wrap'[OF _ word64_power_less_1]) + apply (prop_tac "ptr \ 0") + subgoal + apply (simp add: frame_at'_def) + apply (drule_tac x=0 in spec) + apply (clarsimp simp: pageBitsForSize_def bit_simps split: vmpage_size.splits) + done + apply simp + apply (prop_tac "3 \ pageBitsForSize sz") + apply (simp add: pageBitsForSize_def bit_simps split: vmpage_size.split) + apply (rule conjI) + apply (erule is_aligned_weaken) + apply (clarsimp simp: pageBitsForSize_def split: vmpage_size.splits) + apply (rule conjI) + apply (rule is_aligned_power2) + apply (clarsimp simp: pageBitsForSize_def split: vmpage_size.splits) apply (clarsimp simp: ghost_assertion_size_logic[unfolded o_def] frame_at'_def) apply (simp add: flex_user_data_at_rf_sr_dom_s bit_simps) apply (clarsimp simp: field_simps word_size_def mapM_x_storeWord_step) @@ -308,7 +303,7 @@ lemma clearMemory_PageCap_ccorres: apply (erule allfEI[where f=of_nat]) apply (clarsimp simp: bit_simps) apply (subst(asm) of_nat_power, assumption) - apply simp + apply simp apply (insert pageBitsForSize_64 [of sz])[1] apply (erule order_le_less_trans [rotated]) apply simp @@ -376,25 +371,8 @@ lemma clearMemory_PageCap_ccorres: apply (simp add: bit_simps) apply (simp add: of_nat_power[where 'a=64, folded word_bits_def]) apply (simp add: pageBits_def ko_at_projectKO_opt[OF user_data_at_ko]) - (* FIXME AARCH64 indentation *) apply (rule inj_Ptr) - apply csymbr - apply (ctac add: cleanCacheRange_RAM_ccorres) - apply wp - apply (simp add: guard_is_UNIV_def unat_of_nat - word_bits_def capAligned_def word_of_nat_less) - apply (clarsimp simp: word_bits_def valid_cap'_def - capAligned_def word_of_nat_less) - apply (frule is_aligned_addrFromPPtr_n, simp add: pageBitsForSize_def split: vmpage_size.splits) - apply (simp add: bit_simps pptrBaseOffset_alignment_def)+ - apply (simp add: is_aligned_no_overflow') - apply (rule conjI) - subgoal - apply (prop_tac "cacheLineSize \ pageBitsForSize sz") - apply (simp add: pageBitsForSize_def bit_simps cacheLineSize_def split: vmpage_size.splits) - apply (simp add: is_aligned_mask[THEN iffD1] is_aligned_weaken) - done - apply (simp add: pageBitsForSize_def bit_simps split: vmpage_size.splits) + apply (clarsimp simp: word_bits_def valid_cap'_def capAligned_def word_of_nat_less) done declare replicate_numeral [simp] @@ -533,7 +511,7 @@ lemma heap_to_user_data_in_user_mem'[simp]: apply simp+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setObject_asidpool_gs[wp]: "setObject ptr (vcpu::asidpool) \\s. P (gsMaxObjectSize s)\" diff --git a/proof/crefine/AARCH64/Retype_C.thy b/proof/crefine/AARCH64/Retype_C.thy index 448703ed1e..0916051c60 100644 --- a/proof/crefine/AARCH64/Retype_C.thy +++ b/proof/crefine/AARCH64/Retype_C.thy @@ -41,7 +41,7 @@ lemma zero_le_sint: "\ 0 \ (a :: machine_word); a < 0x80000000000000 apply simp done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma map_option_byte_to_word_heap: assumes disj: "\(off :: 9 word) x. x<8 \ p + ucast off * 8 + x \ S " (*9=page table index*) @@ -5047,7 +5047,7 @@ lemma placeNewObject_user_data: done definition - createObject_hs_preconds :: "machine_word \ ArchTypes_H.object_type \ nat \ bool \ kernel_state \ bool" + createObject_hs_preconds :: "machine_word \ object_type \ nat \ bool \ kernel_state \ bool" where "createObject_hs_preconds regionBase newType userSize d \ (invs' and pspace_no_overlap' regionBase (getObjectSize newType userSize) @@ -5070,14 +5070,14 @@ abbreviation (* these preconds actually used throughout the proof *) abbreviation(input) - createObject_c_preconds1 :: "machine_word \ ArchTypes_H.object_type \ nat \ bool \ (globals myvars) set" + createObject_c_preconds1 :: "machine_word \ object_type \ nat \ bool \ (globals myvars) set" where "createObject_c_preconds1 regionBase newType userSize deviceMemory \ {s. region_actually_is_dev_bytes regionBase (2 ^ getObjectSize newType userSize) deviceMemory s}" (* these preconds used at start of proof *) definition - createObject_c_preconds :: "machine_word \ ArchTypes_H.object_type \ nat \ bool \ (globals myvars) set" + createObject_c_preconds :: "machine_word \ object_type \ nat \ bool \ (globals myvars) set" where "createObject_c_preconds regionBase newType userSize deviceMemory \ (createObject_c_preconds1 regionBase newType userSize deviceMemory @@ -5818,6 +5818,40 @@ lemma updatePTType_ccorres: apply (clarsimp simp: cvariable_array_map_relation_def split: if_splits) done +lemma placeNewDataObject_dev_ccorres: + "ccorresG rf_sr \ dc xfdc + (createObject_hs_preconds regionBase newType us True + and K (APIType_capBits newType us = pageBits + us)) + ({s. region_actually_is_bytes regionBase (2 ^ (pageBits + us)) s}) + hs + (placeNewDataObject regionBase us True) + (global_htd_update (\s. (ptr_retyps (2^us) (Ptr regionBase :: user_data_device_C ptr))))" + apply (simp add: placeNewDataObject_def ccorres_cond_univ_iff) + apply (rule ccorres_guard_imp, rule placeNewObject_user_data_device, simp_all) + apply (clarsimp simp: createObject_hs_preconds_def invs'_def + valid_state'_def valid_pspace'_def) + done + +lemma placeNewDataObject_no_dev_ccorres: + "ccorresG rf_sr \ dc xfdc + (createObject_hs_preconds regionBase newType us False + and K (APIType_capBits newType us = pageBits + us)) + ({s. region_actually_is_bytes regionBase (2 ^ (pageBits + us)) s + \ (heap_list_is_zero (hrs_mem (t_hrs_' (globals s))) regionBase (2 ^ (pageBits + us)))}) + hs + (placeNewDataObject regionBase us False) + (global_htd_update (\s. (ptr_retyps (2^us) (Ptr regionBase :: user_data_C ptr))))" + apply (simp add: placeNewDataObject_def ccorres_cond_empty_iff) + apply (rule ccorres_guard_imp, rule placeNewObject_user_data, simp_all) + apply (clarsimp simp: createObject_hs_preconds_def invs'_def + valid_state'_def valid_pspace'_def) + apply (frule range_cover.sz(1), simp add: word_bits_def) + done + +crunch placeNewDataObject, updatePTType + for gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" + (simp: crunch_simps) + lemma Arch_createObject_ccorres: assumes t: "toAPIType newType = None" shows "ccorres (\a b. ccap_relation (ArchObjectCap a) b) ret__struct_cap_C_' @@ -5866,31 +5900,62 @@ proof - canonical_address_and_maskD) done - apply (in_case "HugePageObject") -subgoal - apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') - apply (simp add: object_type_from_H_def Kernel_C_defs) - apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - asidInvalid_def APIType_capBits_def shiftL_nat objBits_simps - ptBits_def pageBits_def word_sle_def word_sless_def fold_eq_0_to_bool) - apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps - AARCH64_H.createObject_def pageBits_def ptTranslationBits_def - cond_second_eq_seq_ccorres modify_gsUserPages_update - intro!: ccorres_rhs_assoc) - apply ((rule ccorres_return_C | simp | wp | vcg - | (rule match_ccorres, ctac add: - placeNewDataObject_ccorres[where us=18 and newType=newType, simplified] - gsUserPages_update_ccorres[folded modify_gsUserPages_update]) - | (rule match_ccorres, csymbr))+)[1] - apply (intro conjI) + subgoal + apply (in_case "HugePageObject") + apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') + apply (simp add: object_type_from_H_def Kernel_C_defs) + apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff + asidInvalid_def APIType_capBits_def shiftL_nat objBits_simps + ptBits_def pageBits_def word_sle_def word_sless_def fold_eq_0_to_bool) + apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps + AARCH64_H.createObject_def pageBits_def ptTranslationBits_def + cond_second_eq_seq_ccorres modify_gsUserPages_update + intro!: ccorres_rhs_assoc) + apply (rule ccorres_cases[where P=deviceMemory]) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_dev_ccorres[where us=18 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vm_page_size_defs ptTranslationBits_def + canonical_address_and_maskD[unfolded mask_def, simplified] + vmrights_to_H_def mask_def vm_rights_defs c_valid_cap_def cl_valid_cap_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_no_dev_ccorres[where us=18 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr+ + apply (rule ccorres_Guard_Seq) + apply (ctac (no_vcg) add: cleanCacheRange_RAM_ccorres) + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vm_page_size_defs ptTranslationBits_def + canonical_address_and_maskD[unfolded mask_def, simplified] + vmrights_to_H_def mask_def vm_rights_defs c_valid_cap_def cl_valid_cap_def) + apply wpsimp + apply (simp add: guard_is_UNIV_def) apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs ptTranslationBits_def - APIType_capBits_def pageBits_def) - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_frame_cap_lift - vm_page_size_defs ptTranslationBits_def - canonical_address_and_maskD[unfolded mask_def, simplified] - vmrights_to_H_def mask_def vm_rights_defs c_valid_cap_def cl_valid_cap_def) - done + APIType_capBits_def pageBits_def is_aligned_no_overflow_mask + addrFromPPtr_mask_cacheLineBits) + apply (rule conjI) + apply (drule is_aligned_addrFromPPtr_n, simp add: pptrBaseOffset_alignment_def) + apply (simp add: is_aligned_no_overflow_mask) + apply (simp add: mask_def) + done apply (in_case "VSpaceObject") subgoal apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') @@ -5902,25 +5967,30 @@ subgoal apply (clarsimp simp: hrs_htd_update bitSimps objBits_simps AARCH64_H.createObject_def pt_bits_minus_pte_bits) apply (ctac pre only: add: placeNewObject_pte_vs[simplified]) - apply (ctac only: add: updatePTType_ccorres) + apply (ctac (no_vcg) only: add: updatePTType_ccorres) apply csymbr - apply (rule ccorres_return_C) - apply simp - apply simp - apply simp - apply wp - apply vcg + apply (ctac (no_vcg) only: add: cleanCacheRange_PoU_ccorres) + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wpsimp + apply clarsimp + apply (rule conjI) + apply (solves \simp add: bit_simps Kernel_Config.config_ARM_PA_SIZE_BITS_40_def mask_def\) + apply (clarsimp simp: ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_vspace_cap_lift + vmrights_to_H_def isFrameType_def canonical_address_and_maskD) apply wp apply vcg apply clarify apply (intro conjI) apply (clarsimp simp: invs_pspace_aligned' invs_pspace_distinct' invs_valid_global' APIType_capBits_def invs_valid_objs' - invs_urz) - apply clarsimp - apply (clarsimp simp: ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_vspace_cap_lift - vmrights_to_H_def isFrameType_def canonical_address_and_maskD) + invs_urz is_aligned_no_overflow_mask) + apply (rule conjI, solves \clarsimp simp: bit_simps mask_def split: if_splits\) + apply (drule is_aligned_addrFromPPtr_n, simp add: pptrBaseOffset_alignment_def bit_simps split: if_splits) + apply (simp add: is_aligned_no_overflow_mask addrFromPPtr_mask_cacheLineBits) + apply (clarsimp simp: APIType_capBits_def isFrameType_def) apply (prop_tac "c_guard (vs_Ptr regionBase)") apply (rule is_aligned_c_guard[where m=pte_bits], simp, simp) apply (simp add: align_of_array) @@ -5945,18 +6015,50 @@ subgoal AARCH64_H.createObject_def pageBits_def cond_second_eq_seq_ccorres modify_gsUserPages_update intro!: ccorres_rhs_assoc) - apply ((rule ccorres_return_C | simp | wp | vcg - | (rule match_ccorres, ctac add: - placeNewDataObject_ccorres[where us=0 and newType=newType, simplified] - gsUserPages_update_ccorres[folded modify_gsUserPages_update]) - | (rule match_ccorres, csymbr))+)[1] - apply (intro conjI) - apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs - APIType_capBits_def pageBits_def) - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def cl_valid_cap_def - framesize_to_H_def cap_to_H_simps cap_frame_cap_lift vm_page_size_defs - canonical_address_and_maskD[unfolded mask_def, simplified] - vmrights_to_H_def mask_def vm_rights_defs c_valid_cap_def) + apply (rule ccorres_cases[where P=deviceMemory]) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_dev_ccorres[where us=0 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vm_page_size_defs ptTranslationBits_def + canonical_address_and_maskD[unfolded mask_def, simplified] + vmrights_to_H_def mask_def vm_rights_defs c_valid_cap_def cl_valid_cap_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_no_dev_ccorres[where us=0 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr+ + apply (rule ccorres_Guard_Seq) + apply (ctac (no_vcg) add: cleanCacheRange_RAM_ccorres) + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vm_page_size_defs ptTranslationBits_def + canonical_address_and_maskD[unfolded mask_def, simplified] + vmrights_to_H_def mask_def vm_rights_defs c_valid_cap_def cl_valid_cap_def) + apply wpsimp + apply (simp add: guard_is_UNIV_def) + apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs ptTranslationBits_def + APIType_capBits_def pageBits_def is_aligned_no_overflow_mask + addrFromPPtr_mask_cacheLineBits) + apply (rule conjI) + apply (drule is_aligned_addrFromPPtr_n, simp add: pptrBaseOffset_alignment_def) + apply (simp add: is_aligned_no_overflow_mask) + apply (simp add: mask_def) done apply (in_case "LargePageObject") subgoal @@ -5969,25 +6071,56 @@ subgoal pageBits_def ptTranslationBits_def cond_second_eq_seq_ccorres modify_gsUserPages_update intro!: ccorres_rhs_assoc) - apply ((rule ccorres_return_C | simp | wp | vcg - | (rule match_ccorres, ctac add: - placeNewDataObject_ccorres[where us=9 and newType=newType, simplified] - gsUserPages_update_ccorres[folded modify_gsUserPages_update]) - | (rule match_ccorres, csymbr))+)[1] - apply (intro conjI) - apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs ptTranslationBits_def - APIType_capBits_def pageBits_def) - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_frame_cap_lift - ptTranslationBits_def vm_page_size_defs vmrights_to_H_def - canonical_address_and_maskD[unfolded mask_def, simplified] - mask_def vm_rights_defs c_valid_cap_def cl_valid_cap_def) + apply (rule ccorres_cases[where P=deviceMemory]) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_dev_ccorres[where us=9 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vm_page_size_defs ptTranslationBits_def + canonical_address_and_maskD[unfolded mask_def, simplified] + vmrights_to_H_def mask_def vm_rights_defs c_valid_cap_def cl_valid_cap_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_no_dev_ccorres[where us=9 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr+ + apply (rule ccorres_Guard_Seq) + apply (ctac (no_vcg) add: cleanCacheRange_RAM_ccorres) + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vm_page_size_defs ptTranslationBits_def + canonical_address_and_maskD[unfolded mask_def, simplified] + vmrights_to_H_def mask_def vm_rights_defs c_valid_cap_def cl_valid_cap_def) + apply wpsimp + apply (simp add: guard_is_UNIV_def) + apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs ptTranslationBits_def + APIType_capBits_def pageBits_def is_aligned_no_overflow_mask + addrFromPPtr_mask_cacheLineBits) + apply (rule conjI) + apply (drule is_aligned_addrFromPPtr_n, simp add: pptrBaseOffset_alignment_def) + apply (simp add: is_aligned_no_overflow_mask) + apply (simp add: mask_def) done apply (in_case "PageTableObject") (* FIXME AARCH64: goal here shows a vs_Ptr, but that is only because pt_Ptr and vs_Ptr are the same type in this config. Probably should get a comment at def of vs_Ptr *) -subgoal + subgoal apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff asidInvalid_def @@ -5998,25 +6131,30 @@ subgoal AARCH64_H.createObject_def pageBits_def pt_bits_def table_size pte_bits_def) apply (ctac pre only: add: placeNewObject_pte_pt[simplified ptTranslationBits_def, simplified]) - apply (ctac only: add: updatePTType_ccorres) + apply (ctac (no_vcg) only: add: updatePTType_ccorres) apply csymbr - apply (rule ccorres_return_C) - apply simp - apply simp - apply simp - apply wp - apply vcg + apply (ctac (no_vcg) only: add: cleanCacheRange_PoU_ccorres) + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wpsimp + apply clarsimp + apply (rule conjI) + apply (solves \simp add: bit_simps Kernel_Config.config_ARM_PA_SIZE_BITS_40_def mask_def\) + apply (clarsimp simp: bit_simps ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_page_table_cap_lift + vmrights_to_H_def isFrameType_def canonical_address_and_maskD) apply wp apply vcg apply clarify apply (intro conjI) apply (clarsimp simp: invs_pspace_aligned' invs_pspace_distinct' invs_valid_global' - APIType_capBits_def invs_valid_objs' - invs_urz bit_simps) - apply clarsimp - apply (clarsimp simp: bit_simps ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_page_table_cap_lift - vmrights_to_H_def isFrameType_def canonical_address_and_maskD) + APIType_capBits_def invs_valid_objs' bit_simps + invs_urz is_aligned_no_overflow_mask) + apply (rule conjI, solves \clarsimp simp: bit_simps mask_def split: if_splits\) + apply (drule is_aligned_addrFromPPtr_n, simp add: pptrBaseOffset_alignment_def split: if_splits) + apply (simp add: is_aligned_no_overflow_mask addrFromPPtr_mask_cacheLineBits) + apply (clarsimp simp: APIType_capBits_def isFrameType_def bit_simps) apply (prop_tac "c_guard (pt_Ptr regionBase)") apply (rule is_aligned_c_guard[where m=pte_bits], simp, simp) apply (simp add: align_of_array) @@ -7833,7 +7971,7 @@ lemma APIType_capBits_min: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma createNewCaps_1_gsCNodes_p: "\\s. P (gsCNodes s p) \ p \ ptr\ createNewCaps newType ptr 1 n dev\\rv s. P (gsCNodes s p)\" @@ -7956,14 +8094,18 @@ lemma Arch_createObject_preserves_bytes: exspec=cap_page_table_cap_new_modifies exspec=addrFromPPtr_modifies exspec=cap_vcpu_cap_new_modifies + exspec=cleanCacheRange_RAM_preserves_kernel_bytes + exspec=cleanCacheRange_PoU_preserves_kernel_bytes ) + apply (clarsimp simp: vm_page_size_defs) apply (safe intro!: byte_regions_unmodified_hrs_mem_update, - (simp_all add: h_t_valid_field hrs_htd_update)+) - apply (safe intro!: ptr_retyp_d ptr_retyps_out) - apply (simp_all add: object_type_from_H_def Kernel_C_defs APIType_capBits_def - bit_simps - split: object_type.split_asm ArchTypes_H.apiobject_type.split_asm) - apply (simp add: Kernel_Config.config_ARM_PA_SIZE_BITS_40_def) (* FIXME AARCH64: from bit_simps above *) + simp_all add: h_t_valid_field hrs_htd_update) + apply (safe intro!: ptr_retyp_d ptr_retyps_out) + apply (simp_all add: object_type_from_H_def Kernel_C_defs APIType_capBits_def + bit_simps + split: object_type.split_asm ArchTypes_H.apiobject_type.split_asm) + apply (all \(solves \simp add: byte_regions_unmodified_def\)?\) + apply (simp add: Kernel_Config.config_ARM_PA_SIZE_BITS_40_def) (* from bit_simps above, matches guard *) apply (drule intvlD) apply clarsimp apply (erule notE, rule intvlI) @@ -8156,6 +8298,14 @@ lemma insertNewCap_ccorres: apply (simp add: untypedZeroRange_def Let_def) done +lemma Arch_createObject_not_untyped: + "\s. \\\<^bsub>/UNIV\<^esub> + {s} Call Arch_createObject_'proc {t. cap_get_tag (ret__struct_cap_C_' t) \ scast cap_untyped_cap}" + apply (rule allI, rule conseqPre) + apply (vcg exspec=cleanCacheRange_PoU_modifies exspec=cleanCacheRange_RAM_modifies) + apply (clarsimp simp: cap_tag_defs vm_page_size_defs) + done + lemma createObject_untyped_region_is_zero_bytes: "\\. \\\<^bsub>/UNIV\<^esub> {s. let tp = (object_type_to_H (t_' s)); sz = APIType_capBits tp (unat (userSize_' s)) @@ -8167,7 +8317,7 @@ lemma createObject_untyped_region_is_zero_bytes: {t. cap_get_tag (ret__struct_cap_C_' t) = scast cap_untyped_cap \ (case untypedZeroRange (cap_to_H (the (cap_lift (ret__struct_cap_C_' t)))) of None \ True | Some (a, b) \ region_actually_is_zero_bytes a (unat ((b + 1) - a)) t)}" - apply (rule allI, rule conseqPre, vcg exspec=Arch_initContext_modifies) + apply (rule allI, rule conseqPre, vcg exspec=Arch_initContext_modifies exspec=Arch_createObject_not_untyped) apply (clarsimp simp: cap_tag_defs Let_def) apply (simp add: cap_lift_untyped_cap cap_tag_defs cap_to_H_simps cap_untyped_cap_lift_def object_type_from_H_def) diff --git a/proof/crefine/AARCH64/SR_lemmas_C.thy b/proof/crefine/AARCH64/SR_lemmas_C.thy index b8bb8899fe..68f335e40f 100644 --- a/proof/crefine/AARCH64/SR_lemmas_C.thy +++ b/proof/crefine/AARCH64/SR_lemmas_C.thy @@ -12,7 +12,7 @@ imports "Refine.Invariants_H" begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) section "vm rights" diff --git a/proof/crefine/AARCH64/Schedule_C.thy b/proof/crefine/AARCH64/Schedule_C.thy index 1f613ac14a..33c8cc464d 100644 --- a/proof/crefine/AARCH64/Schedule_C.thy +++ b/proof/crefine/AARCH64/Schedule_C.thy @@ -12,7 +12,7 @@ begin instance tcb :: no_vcpu by intro_classes auto -(*FIXME: arch_split: move up?*) +(*FIXME: arch-split: move up?*) context Arch begin context begin global_naming global requalify_facts diff --git a/proof/crefine/AARCH64/StateRelation_C.thy b/proof/crefine/AARCH64/StateRelation_C.thy index e0b8b4658a..1e25d3ef45 100644 --- a/proof/crefine/AARCH64/StateRelation_C.thy +++ b/proof/crefine/AARCH64/StateRelation_C.thy @@ -10,7 +10,7 @@ theory StateRelation_C imports Wellformed_C begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "lifth p s \ the (clift (t_hrs_' s) p)" @@ -81,7 +81,7 @@ text \ which can subsequently be instantiated for @{text kernel_all_global_addresses} as well as @{text kernel_all_substitute}. \ -locale state_rel = Arch + substitute_pre + (*FIXME: arch_split*) +locale state_rel = Arch + substitute_pre + (*FIXME: arch-split*) fixes armKSKernelVSpace_C :: "machine_word \ arm_vspace_region_use" locale kernel = kernel_all_substitute + state_rel @@ -133,7 +133,7 @@ definition carch_state_relation :: "Arch.kernel_state \ globals \ globals \ bool" @@ -709,7 +709,7 @@ where ((\ (d \ maxDomain \ i < l2BitmapSize)) \ abitmap2 (d, i) = 0)" -end (* interpretation Arch . (*FIXME: arch_split*) *) +end (* interpretation Arch . (*FIXME: arch-split*) *) definition region_is_bytes' :: "machine_word \ nat \ heap_typ_desc \ bool" diff --git a/proof/crefine/AARCH64/SyscallArgs_C.thy b/proof/crefine/AARCH64/SyscallArgs_C.thy index daec411010..662dab61a6 100644 --- a/proof/crefine/AARCH64/SyscallArgs_C.thy +++ b/proof/crefine/AARCH64/SyscallArgs_C.thy @@ -13,13 +13,13 @@ imports StoreWord_C DetWP begin -(*FIXME: arch_split: C kernel names hidden by Haskell names *) +(*FIXME: arch-split: C kernel names hidden by Haskell names *) context kernel_m begin abbreviation "msgRegistersC \ kernel_all_substitute.msgRegisters" lemmas msgRegistersC_def = kernel_all_substitute.msgRegisters_def end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare word_neq_0_conv[simp del] @@ -1201,7 +1201,7 @@ lemma getSyscallArg_ccorres_foo: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma invocation_eq_use_type: "\ value \ (value' :: 32 signed word); diff --git a/proof/crefine/AARCH64/Syscall_C.thy b/proof/crefine/AARCH64/Syscall_C.thy index aa8f96bf94..199592009c 100644 --- a/proof/crefine/AARCH64/Syscall_C.thy +++ b/proof/crefine/AARCH64/Syscall_C.thy @@ -15,7 +15,7 @@ imports Arch_C begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch replyFromKernel for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" end diff --git a/proof/crefine/AARCH64/Tcb_C.thy b/proof/crefine/AARCH64/Tcb_C.thy index bc4b2fb7ba..6d4b307a22 100644 --- a/proof/crefine/AARCH64/Tcb_C.thy +++ b/proof/crefine/AARCH64/Tcb_C.thy @@ -59,7 +59,7 @@ lemma doMachineOp_sched: apply fastforce done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch restart for curThread[wp]: "\s. P (ksCurThread s)" (wp: crunch_wps simp: crunch_simps) @@ -1105,7 +1105,7 @@ lemma Arch_performTransfer_ccorres: apply simp+ done -(*FIXME: arch_split: C kernel names hidden by Haskell names *) +(*FIXME: arch-split: C kernel names hidden by Haskell names *) abbreviation "frameRegistersC \ kernel_all_substitute.frameRegisters" lemmas frameRegistersC_def = kernel_all_substitute.frameRegisters_def abbreviation "gpRegistersC \ kernel_all_substitute.gpRegisters" diff --git a/proof/crefine/AARCH64/VSpace_C.thy b/proof/crefine/AARCH64/VSpace_C.thy index ad5c870cc5..8381d5c75c 100644 --- a/proof/crefine/AARCH64/VSpace_C.thy +++ b/proof/crefine/AARCH64/VSpace_C.thy @@ -19,7 +19,7 @@ autocorres c_locale = kernel_all_substitute ] "../c/build/$L4V_ARCH/kernel_all.c_pp" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ccorres_name_pre_C: "(\s. s \ P' \ ccorres_underlying sr \ r xf arrel axf P {s} hs f g) @@ -2744,7 +2744,7 @@ lemma vcpu_enable_ccorres: apply (rule_tac Q'="\_. vcpu_at' v" in hoare_post_imp, fastforce) apply wpsimp apply (clarsimp simp: typ_heap_simps' Collect_const_mem cvcpu_relation_def - cvcpu_regs_relation_def Let_def cvgic_relation_def hcrVCPU_def + cvcpu_regs_relation_def Let_def cvgic_relation_def hcrVCPU_val | rule conjI | simp)+ apply (drule (1) vcpu_at_rf_sr) apply (clarsimp simp: typ_heap_simps' cvcpu_relation_def cvgic_relation_def) diff --git a/proof/crefine/AARCH64/Wellformed_C.thy b/proof/crefine/AARCH64/Wellformed_C.thy index ed72235d2a..9517cab4bf 100644 --- a/proof/crefine/AARCH64/Wellformed_C.thy +++ b/proof/crefine/AARCH64/Wellformed_C.thy @@ -15,7 +15,7 @@ imports "CSpec.Substitute" begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* Takes an address and ensures it can be given to a function expecting a canonical address. Canonical addresses on 64-bit machines aren't really 64-bit, due to bus sizes. Hence, structures @@ -303,7 +303,7 @@ record cte_CL = cap_CL :: cap_CL cteMDBNode_CL :: mdb_node_CL -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition cte_lift :: "cte_C \ cte_CL" @@ -562,6 +562,63 @@ lemma ucast_irq_array_guard[unfolded irq_array_size_val, simplified]: done +text \cacheLineBits interface\ + +lemmas cacheLineBits_val = + cacheLineBits_def[unfolded Kernel_Config.CONFIG_L1_CACHE_LINE_SIZE_BITS_def] + +lemma cacheLineBits_leq_pageBits: + "cacheLineBits \ pageBits" + using cacheLineBits_sanity + by (simp add: pageBits_def) + +lemma pageBits_leq_pptrBaseOffset_alignment: + "pageBits \ pptrBaseOffset_alignment" + by (simp add: pageBits_def pptrBaseOffset_alignment_def) + +lemma cacheLineBits_leq_pptrBaseOffset_alignment: + "cacheLineBits \ pptrBaseOffset_alignment" + by (rule order.trans, rule cacheLineBits_leq_pageBits, rule pageBits_leq_pptrBaseOffset_alignment) + +lemma cacheLineBits_leq_pbfs: + "cacheLineBits \ pageBitsForSize sz" + by (rule order.trans, rule cacheLineBits_leq_pageBits, rule pbfs_atleast_pageBits) + +lemma addrFromPPtr_mask_pptrBaseOffset_alignment: + "n \ pptrBaseOffset_alignment + \ addrFromPPtr ptr && mask n = ptr && mask n" + unfolding addrFromPPtr_def + by (metis is_aligned_weaken mask_add_aligned pptrBaseOffset_aligned zadd_diff_inverse) + +lemma addrFromPPtr_mask_cacheLineBits: + "addrFromPPtr ptr && mask cacheLineBits = ptr && mask cacheLineBits" + by (rule addrFromPPtr_mask_pptrBaseOffset_alignment, + rule cacheLineBits_leq_pptrBaseOffset_alignment) + +lemma pptrBaseOffset_cacheLineBits_aligned[simp]: + "pptrBaseOffset && mask cacheLineBits = 0" + unfolding is_aligned_mask[symmetric] + by (rule is_aligned_weaken[OF pptrBaseOffset_aligned cacheLineBits_leq_pptrBaseOffset_alignment]) + +lemma ptrFromPAddr_mask_cacheLineBits[simp]: + "ptrFromPAddr v && mask cacheLineBits = v && mask cacheLineBits" + by (simp add: ptrFromPAddr_def add_mask_ignore) + + +text \hcrVCPU interface\ + +arch_requalify_facts hcrCommon_def hcrTWE_def hcrTWI_def + +(* hcrVCPU can have two values, based on configuration. We only need need the numerical value + to match with C, no other computations depend on it *) +schematic_goal hcrVCPU_val: + "hcrVCPU = ?val" + by (simp add: hcrVCPU_def hcrCommon_def hcrTWE_def hcrTWI_def + Kernel_Config.config_DISABLE_WFI_WFE_TRAPS_def) + +(* end of Kernel_Config interface section *) + + (* Input abbreviations for API object types *) (* disambiguates names *) @@ -645,26 +702,6 @@ abbreviation(input) where "prioInvalid == seL4_InvalidPrio" -(* caches *) - -definition cacheLineSize :: nat where - "cacheLineSize \ 6" - -lemma addrFromPPtr_mask_cacheLineSize: - "addrFromPPtr ptr && mask cacheLineSize = ptr && mask cacheLineSize" - apply (simp add: addrFromPPtr_def AARCH64.pptrBase_def pptrBaseOffset_def canonical_bit_def - paddrBase_def cacheLineSize_def mask_def) - apply word_bitwise - done - -lemma pptrBaseOffset_cacheLineSize_aligned[simp]: - "pptrBaseOffset && mask cacheLineSize = 0" - by (simp add: pptrBaseOffset_def paddrBase_def pptrBase_def cacheLineSize_def mask_def) - -lemma ptrFromPAddr_mask_cacheLineSize[simp]: - "ptrFromPAddr v && mask cacheLineSize = v && mask cacheLineSize" - by (simp add: ptrFromPAddr_def add_mask_ignore) - (* The magic 4 comes out of the bitfield generator -- this applies to all versions of the kernel. *) lemma ThreadState_Restart_mask[simp]: "(scast ThreadState_Restart::machine_word) && mask 4 = scast ThreadState_Restart" diff --git a/proof/crefine/ARM/ADT_C.thy b/proof/crefine/ARM/ADT_C.thy index 6be4828c54..9358e49fc1 100644 --- a/proof/crefine/ARM/ADT_C.thy +++ b/proof/crefine/ARM/ADT_C.thy @@ -193,7 +193,7 @@ end consts Init_C' :: "unit observable \ cstate global_state set" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "Init_C \ \((tc,s),m,e). Init_C' ((tc, truncate_state s),m,e)" @@ -320,7 +320,7 @@ lemma cint_rel_to_H: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "cstate_to_machine_H s \ @@ -625,7 +625,7 @@ lemma (in kernel_m) carch_state_to_H_correct: apply (fastforce simp: valid_asid_table'_def) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma tcb_queue_rel_unique: "hp NULL = None \ diff --git a/proof/crefine/ARM/ArchMove_C.thy b/proof/crefine/ARM/ArchMove_C.thy index b692ea8857..fb22ca37cb 100644 --- a/proof/crefine/ARM/ArchMove_C.thy +++ b/proof/crefine/ARM/ArchMove_C.thy @@ -233,7 +233,7 @@ crunch insertNewCap, Arch_createNewCaps, threadSet, Arch.createObject, setThread simp: unless_def updateObject_default_def crunch_simps ignore_del: preemptionPoint) -lemma addrFromPPtr_mask[simplified ARM.pageBitsForSize_simps]: +lemma addrFromPPtr_mask_ARMSuperSection: "n \ pageBitsForSize ARMSuperSection \ addrFromPPtr ptr && mask n = ptr && mask n" apply (simp add: addrFromPPtr_def) @@ -242,13 +242,6 @@ lemma addrFromPPtr_mask[simplified ARM.pageBitsForSize_simps]: apply (simp flip: mask_eqs(8)) done -(* this could be done as - lemmas addrFromPPtr_mask_5 = addrFromPPtr_mask[where n=5, simplified] - but that wouldn't give a sanity check of the n \ ... assumption disappearing *) -lemma addrFromPPtr_mask_5: - "addrFromPPtr ptr && mask 5 = ptr && mask 5" - by (rule addrFromPPtr_mask[where n=5, simplified]) - end end diff --git a/proof/crefine/ARM/Arch_C.thy b/proof/crefine/ARM/Arch_C.thy index a1ae08610c..167279e00d 100644 --- a/proof/crefine/ARM/Arch_C.thy +++ b/proof/crefine/ARM/Arch_C.thy @@ -9,7 +9,7 @@ theory Arch_C imports Recycle_C begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch unmapPageTable for ctes_of[wp]: "\s. P (ctes_of s)" (wp: crunch_wps simp: crunch_simps) @@ -1598,9 +1598,8 @@ lemma performPageInvocationMapPTE_ccorres: apply simp apply (subst is_aligned_no_wrap', assumption, fastforce) apply (subst add_diff_eq [symmetric], subst is_aligned_no_wrap', assumption, fastforce) - apply (simp add:addrFromPPtr_mask_5) - apply (clarsimp simp:pte_range_relation_def ptr_add_def ptr_range_to_list_def - addrFromPPtr_mask_5) + apply simp + apply (clarsimp simp: pte_range_relation_def ptr_add_def ptr_range_to_list_def) apply (auto simp: valid_pte_slots'2_def upt_conv_Cons[where i=0])[1] apply (clarsimp simp: guard_is_UNIV_def hd_conv_nth last_conv_nth ucast_minus) apply (clarsimp simp: pte_range_relation_def ptr_range_to_list_def objBits_simps archObjSize_def) @@ -1848,9 +1847,9 @@ lemma performPageInvocationMapPDE_ccorres: apply (simp add: hd_conv_nth last_conv_nth) apply (rule conj_assoc[where Q="a \ b" for a b, THEN iffD1])+ apply (rule conjI) - (* the inequality first *) - apply (clarsimp simp:valid_pde_slots'2_def pdeBits_def - objBits_simps archObjSize_def hd_conv_nth) + (* the inequality first *) + apply (clarsimp simp: valid_pde_slots'2_def pdeBits_def + objBits_simps archObjSize_def hd_conv_nth) apply (clarsimp simp:pde_range_relation_def ptr_range_to_list_def ptr_add_def) apply (frule is_aligned_addrFromPPtr_n,simp) apply (cut_tac n = "sz+2" in power_not_zero[where 'a="32"]) @@ -1858,9 +1857,9 @@ lemma performPageInvocationMapPDE_ccorres: apply (subst is_aligned_no_wrap', assumption, fastforce) apply (subst add_diff_eq [symmetric]) apply (subst is_aligned_no_wrap', assumption, fastforce) - apply (simp add:addrFromPPtr_mask_5) + apply simp apply (clarsimp simp: pde_range_relation_def ptr_range_to_list_def CTypesDefs.ptr_add_def - valid_pde_slots'2_def addrFromPPtr_mask_5) + valid_pde_slots'2_def) apply (auto simp: upt_conv_Cons[where i=0])[1] apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem hd_conv_nth last_conv_nth) apply (clarsimp simp: pde_range_relation_def ptr_range_to_list_def pdeBits_def) @@ -2787,10 +2786,9 @@ lemma decodeARMFrameInvocation_ccorres: erule is_aligned_no_wrap', clarsimp\ | solves \frule vmsz_aligned_addrFromPPtr(3)[THEN iffD2], (subst mask_add_aligned mask_add_aligned_right, erule is_aligned_weaken, - rule order_trans[OF _ pbfs_atleast_pageBits[simplified pageBits_def]], simp)+, + rule cacheLineBits_leq_pbfs)+, simp\)+)[1] (* 20s *) done - (* C side *) apply (clarsimp simp: rf_sr_ksCurThread ThreadState_defs mask_eq_iff_w2p word_size word_less_nat_alt from_bool_0 excaps_map_def cte_wp_at_ctes_of) @@ -3146,13 +3144,12 @@ lemma decodeARMPageDirectoryInvocation_ccorres: apply (simp add:linorder_not_le) apply (erule word_less_sub_1) apply (simp add:mask_add_aligned mask_twice) - apply (subgoal_tac "5 \ pageBitsForSize a") - apply (frule(1) is_aligned_weaken) - apply (simp add:mask_add_aligned mask_twice) - apply (erule order_trans[rotated]) - apply (erule flush_range_le1, simp add: linorder_not_le) - apply (erule word_less_sub_1) - apply (case_tac a,simp+)[1] + apply (cut_tac cacheLineBits_leq_pbfs) + apply (frule(1) is_aligned_weaken) + apply (simp add:mask_add_aligned mask_twice) + apply (erule order_trans[rotated]) + apply (erule flush_range_le1, simp add: linorder_not_le) + apply (erule word_less_sub_1) apply simp apply (vcg exspec=resolveVAddr_modifies) apply (rule_tac P'="{s. errstate s = find_ret}" diff --git a/proof/crefine/ARM/CLevityCatch.thy b/proof/crefine/ARM/CLevityCatch.thy index be093e2817..ebc9d0450b 100644 --- a/proof/crefine/ARM/CLevityCatch.thy +++ b/proof/crefine/ARM/CLevityCatch.thy @@ -14,7 +14,7 @@ imports Boolean_C begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* Rule previously in the simpset, now not. *) declare ptr_add_def' [simp] diff --git a/proof/crefine/ARM/DetWP.thy b/proof/crefine/ARM/DetWP.thy index 82163aafb2..57e376c2fb 100644 --- a/proof/crefine/ARM/DetWP.thy +++ b/proof/crefine/ARM/DetWP.thy @@ -8,7 +8,7 @@ theory DetWP imports "Lib.DetWPLib" "CBaseRefine.Include_C" begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma det_wp_doMachineOp [wp]: "det_wp (\_. P) f \ det_wp (\_. P) (doMachineOp f)" diff --git a/proof/crefine/ARM/Fastpath_C.thy b/proof/crefine/ARM/Fastpath_C.thy index 76f516b983..74c1566d46 100644 --- a/proof/crefine/ARM/Fastpath_C.thy +++ b/proof/crefine/ARM/Fastpath_C.thy @@ -17,7 +17,7 @@ imports "CLib.MonadicRewrite_C" begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setCTE_obj_at'_queued: "\obj_at' (\tcb. P (tcbQueued tcb)) t\ setCTE p v \\rv. obj_at' (\tcb. P (tcbQueued tcb)) t\" diff --git a/proof/crefine/ARM/Fastpath_Defs.thy b/proof/crefine/ARM/Fastpath_Defs.thy index 6326c34838..a08a031b81 100644 --- a/proof/crefine/ARM/Fastpath_Defs.thy +++ b/proof/crefine/ARM/Fastpath_Defs.thy @@ -15,7 +15,7 @@ theory Fastpath_Defs imports ArchMove_C begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "fastpaths sysc \ case sysc of diff --git a/proof/crefine/ARM/Fastpath_Equiv.thy b/proof/crefine/ARM/Fastpath_Equiv.thy index 0d2e4b88a2..bd2847d0c2 100644 --- a/proof/crefine/ARM/Fastpath_Equiv.thy +++ b/proof/crefine/ARM/Fastpath_Equiv.thy @@ -45,7 +45,7 @@ lemma setCTE_tcbContext: apply (rule setObject_cte_obj_at_tcb', simp_all) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setThreadState_tcbContext: "setThreadState st tptr \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" diff --git a/proof/crefine/ARM/Finalise_C.thy b/proof/crefine/ARM/Finalise_C.thy index 63181b8ae0..1ed3e81b87 100644 --- a/proof/crefine/ARM/Finalise_C.thy +++ b/proof/crefine/ARM/Finalise_C.thy @@ -1097,7 +1097,7 @@ lemma offset_xf_for_sequence: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch invalidateHWASIDEntry for pde_mappings'[wp]: "valid_pde_mappings'" end @@ -1140,7 +1140,7 @@ lemma invalidateASIDEntry_ccorres: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch invalidateASIDEntry for obj_at'[wp]: "obj_at' P p" crunch flushSpace diff --git a/proof/crefine/ARM/Invoke_C.thy b/proof/crefine/ARM/Invoke_C.thy index 34ac785154..442e779a55 100644 --- a/proof/crefine/ARM/Invoke_C.thy +++ b/proof/crefine/ARM/Invoke_C.thy @@ -1371,7 +1371,7 @@ lemma decodeCNodeInvocation_ccorres: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setCTE_sch_act_wf[wp]: "\ \s. sch_act_wf (ksSchedulerAction s) s \ @@ -1517,45 +1517,37 @@ lemma clearMemory_untyped_ccorres: apply (cinit' lift: bits_' ptr___ptr_to_unsigned_long_') apply (rule_tac P="ptr \ 0 \ sz < word_bits" in ccorres_gen_asm) - apply (rule ccorres_Guard_Seq) + apply (rule ccorres_Guard) apply (simp add: clearMemory_def) - apply (simp add: doMachineOp_bind ef_storeWord) - apply (rule ccorres_split_nothrow_novcg_dc) - apply (rule_tac P="?P" and P'="{s. region_actually_is_bytes ptr (2 ^ sz) s}" - in ccorres_from_vcg) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (clarsimp simp: isCap_simps valid_cap'_def capAligned_def - is_aligned_no_wrap'[OF _ word32_power_less_1] - unat_of_nat_eq word_bits_def) - apply (simp add: is_aligned_weaken is_aligned_triv[THEN is_aligned_weaken]) - apply (clarsimp simp: ghost_assertion_size_logic[unfolded o_def] - region_actually_is_bytes_dom_s) - apply (clarsimp simp: field_simps word_size_def mapM_x_storeWord_step - word_bits_def cte_wp_at_ctes_of) - apply (frule ctes_of_valid', clarify+) - apply (simp add: doMachineOp_def split_def exec_gets) - apply (simp add: select_f_def simpler_modify_def bind_def - valid_cap_simps' capAligned_def) - apply (subst pspace_no_overlap_underlying_zero_update, simp+) - apply (case_tac sz, simp_all)[1] - apply (case_tac nat, simp_all)[1] - apply (clarsimp dest!: region_actually_is_bytes) - apply (drule(1) rf_sr_rep0) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def) - apply csymbr - apply (ctac add: cleanCacheRange_RAM_ccorres) - apply wp - apply (simp add: guard_is_UNIV_def unat_of_nat - word_bits_def capAligned_def word_of_nat_less) + apply (rule_tac P="?P" and P'="{s. region_actually_is_bytes ptr (2 ^ sz) s}" in ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (clarsimp simp: isCap_simps valid_cap'_def capAligned_def + is_aligned_no_wrap'[OF _ word32_power_less_1] + unat_of_nat_eq word_bits_def) + apply (simp add: is_aligned_weaken is_aligned_triv[THEN is_aligned_weaken]) + apply (clarsimp simp: ghost_assertion_size_logic[unfolded o_def] + region_actually_is_bytes_dom_s) + apply (clarsimp simp: field_simps word_size_def mapM_x_storeWord_step + word_bits_def cte_wp_at_ctes_of) + apply (frule ctes_of_valid', clarify+) + apply (simp add: doMachineOp_def split_def exec_gets) + apply (simp add: select_f_def simpler_modify_def bind_def + valid_cap_simps' capAligned_def) + apply (subst pspace_no_overlap_underlying_zero_update, simp+) + apply (case_tac sz, simp_all)[1] + apply (case_tac nat, simp_all)[1] + apply (clarsimp dest!: region_actually_is_bytes) + apply (drule(1) rf_sr_rep0) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def + carch_state_relation_def cmachine_state_relation_def) + apply (simp add: guard_is_UNIV_def unat_of_nat + word_bits_def capAligned_def word_of_nat_less) apply (clarsimp simp: cte_wp_at_ctes_of) apply (frule ctes_of_valid', clarify+) apply (clarsimp simp: isCap_simps valid_cap_simps' capAligned_def word_of_nat_less Kernel_Config.resetChunkBits_def word_bits_def unat_2p_sub_1) - apply (strengthen is_aligned_no_wrap'[where sz=sz] is_aligned_addrFromPPtr_n)+ - apply (simp add: addrFromPPtr_mask) apply (cases "ptr = 0") apply (drule subsetD, rule intvl_self, simp) apply (simp split: if_split_asm) @@ -2623,10 +2615,10 @@ lemma ctes_of_ex_cte_cap_to': lemma Arch_isFrameType_spec: - "\s. \ \ \s. unat \type \ fromEnum (maxBound::ArchTypes_H.object_type)\ + "\s. \ \ \s. unat \type \ fromEnum (maxBound::object_type)\ Call Arch_isFrameType_'proc \ \ret__unsigned_long = - from_bool (isFrameType ((toEnum (unat \<^bsup>s\<^esup> type))::ArchTypes_H.object_type))\" + from_bool (isFrameType ((toEnum (unat \<^bsup>s\<^esup> type))::object_type))\" apply vcg apply (simp add: toEnum_object_type_to_H) apply (frule object_type_from_to_H) diff --git a/proof/crefine/ARM/Ipc_C.thy b/proof/crefine/ARM/Ipc_C.thy index e484a4a691..92e4276445 100644 --- a/proof/crefine/ARM/Ipc_C.thy +++ b/proof/crefine/ARM/Ipc_C.thy @@ -13,7 +13,7 @@ imports IsolatedThreadAction begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "replyFromKernel_success_empty thread \ do @@ -275,7 +275,7 @@ lemma ccap_relation_reply_helpers: cap_reply_cap_lift_def word_size elim!: ccap_relationE) -(*FIXME: arch_split: C kernel names hidden by Haskell names *) +(*FIXME: arch-split: C kernel names hidden by Haskell names *) (*FIXME: fupdate simplification issues for 2D arrays *) abbreviation "syscallMessageC \ kernel_all_global_addresses.fault_messages.[unat MessageID_Syscall]" lemmas syscallMessageC_def = kernel_all_substitute.fault_messages_def @@ -298,7 +298,7 @@ lemma syscallMessage_ccorres: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "handleArchFaultReply' f sender receiver tag \ do @@ -883,7 +883,7 @@ lemma setMR_ccorres_dc: end (* FIXME: move *) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch setMR for valid_pspace'[wp]: "valid_pspace'" crunch setMR diff --git a/proof/crefine/ARM/IsolatedThreadAction.thy b/proof/crefine/ARM/IsolatedThreadAction.thy index d8e5757393..8d25b7b1bc 100644 --- a/proof/crefine/ARM/IsolatedThreadAction.thy +++ b/proof/crefine/ARM/IsolatedThreadAction.thy @@ -9,7 +9,7 @@ theory IsolatedThreadAction imports ArchMove_C begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) datatype tcb_state_regs = TCBStateRegs (tsrState : thread_state) (tsrContext : "MachineTypes.register \ machine_word") @@ -960,7 +960,7 @@ lemma bind_assoc: = do x \ m; y \ f x; g y od" by (rule bind_assoc) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setObject_modify_assert: "\ updateObject v = updateObject_default v \ diff --git a/proof/crefine/ARM/Machine_C.thy b/proof/crefine/ARM/Machine_C.thy index f77622bbb7..1dccec1e1d 100644 --- a/proof/crefine/ARM/Machine_C.thy +++ b/proof/crefine/ARM/Machine_C.thy @@ -260,33 +260,33 @@ lemma index_xf_for_sequence: lemma lineStart_le_mono: "x \ y \ lineStart x \ lineStart y" - by (clarsimp simp: lineStart_def cacheLineBits_def shiftr_shiftl1 neg_mask_mono_le) + by (clarsimp simp: lineStart_def shiftr_shiftl1 neg_mask_mono_le) lemma lineStart_sub: - "\ x && mask 5 = y && mask 5\ \ lineStart (x - y) = lineStart x - lineStart y" - apply (clarsimp simp: lineStart_def cacheLineBits_def shiftr_shiftl1) + "\ x && mask cacheLineBits = y && mask cacheLineBits\ \ lineStart (x - y) = lineStart x - lineStart y" + apply (clarsimp simp: lineStart_def shiftr_shiftl1) apply (clarsimp simp: mask_out_sub_mask) apply (clarsimp simp: mask_eqs(8)[symmetric]) done lemma lineStart_mask: - "lineStart x && mask 5 = 0" - by (clarsimp simp: lineStart_def cacheLineBits_def shiftr_shiftl1 mask_AND_NOT_mask) + "lineStart x && mask cacheLineBits = 0" + by (clarsimp simp: lineStart_def shiftr_shiftl1 mask_AND_NOT_mask) lemma cachRangeOp_corres_helper: - "\w1 \ w2; w3 \ w3 + (w2 - w1); w1 && mask 5 = w3 && mask 5\ - \ unat (lineStart w2 - lineStart w1) div 32 = - unat (lineStart (w3 + (w2 - w1)) - lineStart w3) div 32" + "\w1 \ w2; w3 \ w3 + (w2 - w1); w1 && mask cacheLineBits = w3 && mask cacheLineBits\ + \ unat (lineStart w2 - lineStart w1) div (2^cacheLineBits) = + unat (lineStart (w3 + (w2 - w1)) - lineStart w3) div (2^cacheLineBits)" apply (subst dvd_div_div_eq_mult, simp) - apply (clarsimp simp: and_mask_dvd_nat[where n=5, simplified]) - apply (clarsimp simp: lineStart_def cacheLineBits_def shiftr_shiftl1) + apply (clarsimp simp: and_mask_dvd_nat[where n=cacheLineBits, simplified]) + apply (clarsimp simp: lineStart_def shiftr_shiftl1) apply (subst mask_eqs(8)[symmetric]) apply (clarsimp simp: mask_AND_NOT_mask) - apply (clarsimp simp: and_mask_dvd_nat[where n=5, simplified]) + apply (clarsimp simp: and_mask_dvd_nat[where n=cacheLineBits, simplified]) apply (subst mask_eqs(8)[symmetric]) apply (clarsimp simp: lineStart_mask) - apply (subgoal_tac "w3 + (w2 - w1) && mask 5 = w2 && mask 5") + apply (subgoal_tac "w3 + (w2 - w1) && mask cacheLineBits = w2 && mask cacheLineBits") apply clarsimp apply (rule_tac x=w1 and y=w3 in linorder_le_cases) apply (subgoal_tac "lineStart (w3 + (w2 - w1)) - lineStart w2 = lineStart w3 - lineStart w1") @@ -332,31 +332,35 @@ lemma lineIndex_def2: lemma lineIndex_le_mono: "x \ y \ lineIndex x \ lineIndex y" - by (clarsimp simp: lineIndex_def2 cacheLineBits_def le_shiftr) + by (clarsimp simp: lineIndex_def2 le_shiftr) lemma lineIndex_lineStart_diff: - "w1 \ w2 \ (unat (lineStart w2 - lineStart w1) div 32) = unat (lineIndex w2 - lineIndex w1)" - apply (subst shiftr_div_2n'[symmetric, where n=5, simplified]) + "w1 \ w2 \ + unat (lineStart w2 - lineStart w1) div (2^cacheLineBits) = unat (lineIndex w2 - lineIndex w1)" + apply (subst shiftr_div_2n'[symmetric, where n=cacheLineBits, simplified]) apply (drule lineStart_le_mono) apply (drule sub_right_shift[OF lineStart_mask lineStart_mask]) - apply (simp add: lineIndex_def cacheLineBits_def) + apply (simp add: lineIndex_def) done +lemma unat_cacheLine_machine_word[simp]: + "unat ((2::machine_word)^cacheLineBits) = 2^cacheLineBits" + by (rule unat_p2, rule cacheLineBits_le_machine_word) + lemma cacheRangeOp_ccorres: "\\x y. empty_fail (oper x y); \n. ccorres dc xfdc \ (\\index = lineIndex w1 + of_nat n\) hs - (doMachineOp (oper (lineStart w1 + of_nat n * 0x20) - (lineStart w3 + of_nat n * 0x20))) + (doMachineOp (oper (lineStart w1 + of_nat n * (2^cacheLineBits)) + (lineStart w3 + of_nat n * (2^cacheLineBits)))) f; \s. \\\<^bsub>/UNIV\<^esub> {s} f ({t. index_' t = index_' s}) \ \ ccorres dc xfdc (\_. w1 \ w2 \ w3 \ w3 + (w2 - w1) - \ w1 && mask 5 = w3 && mask 5) - (\\index = w1 >> 5\) hs + \ w1 && mask cacheLineBits = w3 && mask cacheLineBits) + (\\index = w1 >> cacheLineBits\) hs (doMachineOp (cacheRangeOp oper w1 w2 w3)) - (While \\index < (w2 >> 5) + 1\ + (While \\index < (w2 >> cacheLineBits) + 1\ (f;; \index :== \index + 1))" - apply (clarsimp simp: cacheRangeOp_def doMachineOp_mapM_x split_def - cacheLine_def cacheLineBits_def) + apply (clarsimp simp: cacheRangeOp_def doMachineOp_mapM_x split_def cacheLine_def) apply (rule ccorres_gen_asm[where G=\, simplified]) apply (rule ccorres_guard_imp) apply (rule ccorres_rel_imp) @@ -370,7 +374,7 @@ lemma cacheRangeOp_ccorres: apply (subst min_absorb1[OF order_eq_refl]) apply (erule (2) cachRangeOp_corres_helper) apply (simp add: lineIndex_lineStart_diff) - apply (simp add: lineIndex_def2 cacheLineBits_def) + apply (simp add: lineIndex_def2) apply unat_arith apply wp apply (clarsimp simp: length_upto_enum_step lineStart_le_mono unat_div) @@ -379,37 +383,39 @@ lemma cacheRangeOp_ccorres: apply (simp add: lineIndex_lineStart_diff unat_sub[OF lineIndex_le_mono]) apply (subst le_add_diff_inverse) apply (simp add: lineIndex_le_mono word_le_nat_alt[symmetric]) - apply (simp add: lineIndex_def2 cacheLineBits_def) - apply (rule unat_mono[where 'a=32 and b="0xFFFFFFFF", simplified]) - apply word_bitwise - apply (simp add: lineIndex_def cacheLineBits_def lineStart_def) + apply (simp add: lineIndex_def2) + apply (rule less_le_trans) + apply (rule unat_mono[where 'a=machine_word_len and b="mask word_bits"]) + apply (rule shiftr_cacheLineBits_less_mask_word_bits) + apply (simp add: mask_def word_bits_def unat_max_word) + apply (simp add: lineIndex_def lineStart_def) done - lemma lineStart_eq_minus_mask: - "lineStart w1 = w1 - (w1 && mask 5)" - by (simp add: lineStart_def cacheLineBits_def mask_out_sub_mask[symmetric] and_not_mask) + "lineStart w1 = w1 - (w1 && mask cacheLineBits)" + by (simp add: lineStart_def mask_out_sub_mask[symmetric] and_not_mask) lemma lineStart_idem[simp]: "lineStart (lineStart x) = lineStart x" - by (simp add: lineStart_def cacheLineBits_def) - + by (simp add: lineStart_def) lemma cache_range_lineIndex_helper: - "lineIndex w1 + of_nat n << 5 = w1 - (w1 && mask 5) + of_nat n * 0x20" - apply (clarsimp simp: lineIndex_def cacheLineBits_def word_shiftl_add_distrib lineStart_def[symmetric, unfolded cacheLineBits_def] lineStart_eq_minus_mask[symmetric]) + "lineIndex w1 + of_nat n << cacheLineBits = + w1 - (w1 && mask cacheLineBits) + of_nat n * (2^cacheLineBits)" + apply (clarsimp simp: lineIndex_def word_shiftl_add_distrib lineStart_def[symmetric] + lineStart_eq_minus_mask[symmetric]) apply (simp add: shiftl_t2n) done - lemma cleanCacheRange_PoC_ccorres: "ccorres dc xfdc (\_. w1 \ w2 \ w3 \ w3 + (w2 - w1) - \ w1 && mask 5 = w3 && mask 5) + \ w1 && mask cacheLineBits = w3 && mask cacheLineBits) (\\start = w1\ \ \\end = w2\ \ \\pstart = w3\) [] (doMachineOp (cleanCacheRange_PoC w1 w2 w3)) (Call cleanCacheRange_PoC_'proc)" apply (rule ccorres_gen_asm[where G=\, simplified]) apply (cinit' lift: start_' end_' pstart_') + apply (fold cacheLineBits_val) (* make CACHE_LINE_SIZE_BITS value symbolic *) apply (clarsimp simp: cleanCacheRange_PoC_def word_sle_def whileAnno_def) apply (ccorres_remove_UNIV_guard) apply csymbr @@ -420,22 +426,24 @@ lemma cleanCacheRange_PoC_ccorres: apply (rule ccorres_guard_imp2) apply csymbr apply (ctac add: cleanByVA_ccorres) - apply (clarsimp simp: lineStart_def cacheLineBits_def shiftr_shiftl1 - mask_out_sub_mask) - apply (drule_tac s="w1 && mask 5" in sym, simp add: cache_range_lineIndex_helper) + apply (clarsimp simp: lineStart_def shiftr_shiftl1 mask_out_sub_mask) + apply (drule_tac s="w1 && mask cacheLineBits" in sym, simp add: cache_range_lineIndex_helper) apply (vcg exspec=cleanByVA_modifies) apply clarsimp done lemma cleanInvalidateCacheRange_RAM_ccorres: - "ccorres dc xfdc ((\s. unat (w2 - w1) \ gsMaxObjectSize s) - and (\_. w1 \ w2 \ w3 \ w3 + (w2 - w1) - \ w1 && mask 5 = w3 && mask 5 \ unat (w2 - w2) \ gsMaxObjectSize s)) - (\\start = w1\ \ \\end = w2\ \ \\pstart = w3\) [] + "ccorres dc xfdc + ((\s. unat (w2 - w1) \ gsMaxObjectSize s) and + (\_. w1 \ w2 \ w3 \ w3 + (w2 - w1) \ + w1 && mask cacheLineBits = w3 && mask cacheLineBits \ + unat (w2 - w2) \ gsMaxObjectSize s)) + (\\start = w1\ \ \\end = w2\ \ \\pstart = w3\) [] (doMachineOp (cleanInvalidateCacheRange_RAM w1 w2 w3)) (Call cleanInvalidateCacheRange_RAM_'proc)" apply (rule ccorres_gen_asm) apply (cinit' lift: start_' end_' pstart_') + apply (fold cacheLineBits_val) (* make CACHE_LINE_SIZE_BITS value symbolic *) apply (clarsimp simp: word_sle_def whileAnno_def) apply (ccorres_remove_UNIV_guard) apply (rule ccorres_Guard_Seq) @@ -455,9 +463,8 @@ lemma cleanInvalidateCacheRange_RAM_ccorres: apply (rule ccorres_guard_imp2) apply csymbr apply (ctac add: cleanInvalByVA_ccorres) - apply (clarsimp simp: lineStart_def cacheLineBits_def shiftr_shiftl1 - mask_out_sub_mask) - apply (drule_tac s="w1 && mask 5" in sym, simp add: cache_range_lineIndex_helper) + apply (clarsimp simp: lineStart_def shiftr_shiftl1 mask_out_sub_mask) + apply (drule_tac s="w1 && mask cacheLineBits" in sym, simp add: cache_range_lineIndex_helper) apply (vcg exspec=cleanInvalByVA_modifies) apply (rule ceqv_refl) apply (ctac (no_vcg) add: dsb_ccorres) @@ -468,7 +475,7 @@ lemma cleanInvalidateCacheRange_RAM_ccorres: lemma cleanCacheRange_RAM_ccorres: "ccorres dc xfdc (\s. w1 \ w2 \ w3 \ w3 + (w2 - w1) - \ w1 && mask 5 = w3 && mask 5 + \ w1 && mask cacheLineBits = w3 && mask cacheLineBits \ unat (w2 - w1) \ gsMaxObjectSize s) (\\start = w1\ \ \\end = w2\ \ \\pstart = w3\) [] (doMachineOp (cleanCacheRange_RAM w1 w2 w3)) @@ -493,12 +500,13 @@ lemma cleanCacheRange_RAM_ccorres: lemma cleanCacheRange_PoU_ccorres: "ccorres dc xfdc ((\s. unat (w2 - w1) \ gsMaxObjectSize s) and (\_. w1 \ w2 \ w3 \ w3 + (w2 - w1) - \ w1 && mask 5 = w3 && mask 5)) + \ w1 && mask cacheLineBits = w3 && mask cacheLineBits)) (\\start = w1\ \ \\end = w2\ \ \\pstart = w3\) [] (doMachineOp (cleanCacheRange_PoU w1 w2 w3)) (Call cleanCacheRange_PoU_'proc)" apply (rule ccorres_gen_asm) apply (cinit' lift: start_' end_' pstart_') + apply (fold cacheLineBits_val) (* make CACHE_LINE_SIZE_BITS value symbolic *) apply (clarsimp simp: word_sle_def whileAnno_def) apply (ccorres_remove_UNIV_guard) apply (rule ccorres_Guard_Seq) @@ -512,9 +520,8 @@ lemma cleanCacheRange_PoU_ccorres: apply (rule ccorres_guard_imp2) apply csymbr apply (ctac add: cleanByVA_PoU_ccorres) - apply (clarsimp simp: lineStart_def cacheLineBits_def shiftr_shiftl1 - mask_out_sub_mask) - apply (drule_tac s="w1 && mask 5" in sym, simp add: cache_range_lineIndex_helper) + apply (clarsimp simp: lineStart_def shiftr_shiftl1 mask_out_sub_mask) + apply (drule_tac s="w1 && mask cacheLineBits" in sym, simp add: cache_range_lineIndex_helper) apply (vcg exspec=cleanByVA_PoU_modifies) apply clarsimp apply (frule(1) ghost_assertion_size_logic) @@ -528,12 +535,13 @@ lemma dmo_if: lemma invalidateCacheRange_RAM_ccorres: "ccorres dc xfdc ((\s. unat (w2 - w1) \ gsMaxObjectSize s) and (\_. w1 \ w2 \ w3 \ w3 + (w2 - w1) - \ w1 && mask 5 = w3 && mask 5)) + \ w1 && mask cacheLineBits = w3 && mask cacheLineBits)) (\\start = w1\ \ \\end = w2\ \ \\pstart = w3\) [] (doMachineOp (invalidateCacheRange_RAM w1 w2 w3)) (Call invalidateCacheRange_RAM_'proc)" apply (rule ccorres_gen_asm) apply (cinit' lift: start_' end_' pstart_') + apply (fold cacheLineBits_val) (* make CACHE_LINE_SIZE_BITS value symbolic *) apply (clarsimp simp: word_sle_def whileAnno_def split del: if_split) apply (ccorres_remove_UNIV_guard) apply (simp add: invalidateCacheRange_RAM_def doMachineOp_bind when_def @@ -542,19 +550,18 @@ lemma invalidateCacheRange_RAM_ccorres: split del: if_split) apply (rule ccorres_split_nothrow_novcg) apply (rule ccorres_cond[where R=\]) - apply (clarsimp simp: lineStart_def cacheLineBits_def) + apply (clarsimp simp: lineStart_def) apply (rule ccorres_call[OF cleanCacheRange_RAM_ccorres, where xf'=xfdc], (clarsimp)+) apply (rule ccorres_return_Skip) apply ceqv apply (rule ccorres_split_nothrow_novcg) apply (rule ccorres_cond[where R=\]) - apply (clarsimp simp: lineStart_def cacheLineBits_def) + apply (clarsimp simp: lineStart_def) apply csymbr apply (rule ccorres_call[OF cleanCacheRange_RAM_ccorres, where xf'=xfdc], (clarsimp)+) apply (rule ccorres_return_Skip) apply ceqv - apply (rule_tac P="\s. unat (w2 - w1) \ gsMaxObjectSize s" - in ccorres_cross_over_guard) + apply (rule_tac P="\s. unat (w2 - w1) \ gsMaxObjectSize s" in ccorres_cross_over_guard) apply (rule ccorres_Guard_Seq) apply (rule ccorres_basic_srnoop2, simp) apply (ctac add: invalidateL2Range_ccorres) @@ -569,9 +576,8 @@ lemma invalidateCacheRange_RAM_ccorres: apply (rule ccorres_guard_imp2) apply csymbr apply (ctac add: invalidateByVA_ccorres) - apply (clarsimp simp: lineStart_def cacheLineBits_def shiftr_shiftl1 - mask_out_sub_mask) - apply (drule_tac s="w1 && mask 5" in sym, simp add: cache_range_lineIndex_helper) + apply (clarsimp simp: lineStart_def shiftr_shiftl1 mask_out_sub_mask) + apply (drule_tac s="w1 && mask cacheLineBits" in sym, simp add: cache_range_lineIndex_helper) apply (vcg exspec=invalidateByVA_modifies) apply ceqv apply (ctac add: dsb_ccorres) @@ -583,7 +589,7 @@ lemma invalidateCacheRange_RAM_ccorres: apply (simp add: guard_is_UNIV_def) apply (auto dest: ghost_assertion_size_logic simp: o_def)[1] apply (wp | clarsimp split: if_split)+ - apply (clarsimp simp: lineStart_def cacheLineBits_def guard_is_UNIV_def) + apply (clarsimp simp: lineStart_def guard_is_UNIV_def) apply (clarsimp simp: lineStart_mask) apply (subst mask_eqs(7)[symmetric]) apply (subst mask_eqs(8)[symmetric]) @@ -592,13 +598,14 @@ lemma invalidateCacheRange_RAM_ccorres: lemma invalidateCacheRange_I_ccorres: "ccorres dc xfdc (\_. w1 \ w2 \ w3 \ w3 + (w2 - w1) - \ w1 && mask 5 = w3 && mask 5) + \ w1 && mask cacheLineBits = w3 && mask cacheLineBits) (\\start = w1\ \ \\end = w2\ \ \\pstart = w3\) [] (doMachineOp (invalidateCacheRange_I w1 w2 w3)) (Call invalidateCacheRange_I_'proc)" apply (rule ccorres_gen_asm[where G=\, simplified]) apply (cinit' lift: start_' end_' pstart_') apply (clarsimp simp: word_sle_def whileAnno_def) + apply (fold cacheLineBits_val) (* make CACHE_LINE_SIZE_BITS value symbolic *) apply (ccorres_remove_UNIV_guard) apply (simp add: invalidateCacheRange_I_def) apply csymbr @@ -609,21 +616,21 @@ lemma invalidateCacheRange_I_ccorres: apply (rule ccorres_guard_imp2) apply csymbr apply (ctac add: invalidateByVA_I_ccorres) - apply (clarsimp simp: lineStart_def cacheLineBits_def shiftr_shiftl1 - mask_out_sub_mask) - apply (drule_tac s="w1 && mask 5" in sym, simp add: cache_range_lineIndex_helper) + apply (clarsimp simp: lineStart_def shiftr_shiftl1 mask_out_sub_mask) + apply (drule_tac s="w1 && mask cacheLineBits" in sym, simp add: cache_range_lineIndex_helper) apply (vcg exspec=invalidateByVA_I_modifies) apply clarsimp done lemma branchFlushRange_ccorres: "ccorres dc xfdc (\_. w1 \ w2 \ w3 \ w3 + (w2 - w1) - \ w1 && mask 5 = w3 && mask 5) + \ w1 && mask cacheLineBits = w3 && mask cacheLineBits) (\\start = w1\ \ \\end = w2\ \ \\pstart = w3\) [] (doMachineOp (branchFlushRange w1 w2 w3)) (Call branchFlushRange_'proc)" apply (rule ccorres_gen_asm[where G=\, simplified]) apply (cinit' lift: start_' end_' pstart_') + apply (fold cacheLineBits_val) (* make CACHE_LINE_SIZE_BITS value symbolic *) apply (clarsimp simp: word_sle_def whileAnno_def) apply (ccorres_remove_UNIV_guard) apply (simp add: branchFlushRange_def) @@ -635,9 +642,8 @@ lemma branchFlushRange_ccorres: apply (rule ccorres_guard_imp2) apply csymbr apply (ctac add: branchFlush_ccorres) - apply (clarsimp simp: lineStart_def cacheLineBits_def shiftr_shiftl1 - mask_out_sub_mask) - apply (drule_tac s="w1 && mask 5" in sym, simp add: cache_range_lineIndex_helper) + apply (clarsimp simp: lineStart_def shiftr_shiftl1 mask_out_sub_mask) + apply (drule_tac s="w1 && mask cacheLineBits" in sym, simp add: cache_range_lineIndex_helper) apply (vcg exspec=branchFlush_modifies) apply clarsimp done diff --git a/proof/crefine/ARM/PSpace_C.thy b/proof/crefine/ARM/PSpace_C.thy index 8fc97ce5d7..1fa45d4f6a 100644 --- a/proof/crefine/ARM/PSpace_C.thy +++ b/proof/crefine/ARM/PSpace_C.thy @@ -9,7 +9,7 @@ theory PSpace_C imports Ctac_lemmas_C begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setObject_obj_at_pre: "\ updateObject ko = updateObject_default ko; diff --git a/proof/crefine/ARM/Recycle_C.thy b/proof/crefine/ARM/Recycle_C.thy index 65ab347cfc..a1d0464c86 100644 --- a/proof/crefine/ARM/Recycle_C.thy +++ b/proof/crefine/ARM/Recycle_C.thy @@ -351,7 +351,7 @@ lemma heap_to_user_data_in_user_mem'[simp]: apply simp+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch invalidateTLBByASID for pde_mappings'[wp]: "valid_pde_mappings'" @@ -445,7 +445,8 @@ lemma clearMemory_PT_setObject_PTE_ccorres: apply (clarsimp simp: ptBits_def pageBits_def pteBits_def) apply (frule is_aligned_addrFromPPtr_n, simp) apply (clarsimp simp: is_aligned_no_overflow'[where n=10, simplified] pageBits_def - field_simps is_aligned_mask[symmetric] mask_AND_less_0) + field_simps is_aligned_mask[symmetric] mask_AND_less_0 + cacheLineBits_le_ptBits[unfolded ptBits_def pteBits_def, simplified]) done lemma modify_gets_helper: diff --git a/proof/crefine/ARM/Refine_C.thy b/proof/crefine/ARM/Refine_C.thy index 52a222783e..0567d1a930 100644 --- a/proof/crefine/ARM/Refine_C.thy +++ b/proof/crefine/ARM/Refine_C.thy @@ -11,7 +11,7 @@ theory Refine_C imports Init_C Fastpath_Equiv Fastpath_C CToCRefine begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch handleVMFault for ksQ[wp]: "\s. P (ksReadyQueues s)" (ignore: getFAR getDFSR getIFSR) diff --git a/proof/crefine/ARM/Retype_C.thy b/proof/crefine/ARM/Retype_C.thy index 688272dac9..8fb637600a 100644 --- a/proof/crefine/ARM/Retype_C.thy +++ b/proof/crefine/ARM/Retype_C.thy @@ -17,7 +17,7 @@ declare word_neq_0_conv [simp del] instance cte_C :: array_outer_max_size by intro_classes simp -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma map_option_byte_to_word_heap: assumes disj: "\(off :: 10 word) x. x<4 \ p + ucast off * 4 + x \ S " @@ -4141,7 +4141,7 @@ lemma placeNewObject_pde: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) end lemma dom_disj_union: @@ -4350,7 +4350,7 @@ lemma placeNewObject_user_data: definition - createObject_hs_preconds :: "word32 \ ArchTypes_H.object_type \ nat \ bool \ kernel_state \ bool" + createObject_hs_preconds :: "word32 \ object_type \ nat \ bool \ kernel_state \ bool" where "createObject_hs_preconds regionBase newType userSize d \ (invs' and pspace_no_overlap' regionBase (getObjectSize newType userSize) @@ -4373,14 +4373,14 @@ abbreviation (* these preconds actually used throughout the proof *) abbreviation(input) - createObject_c_preconds1 :: "word32 \ ArchTypes_H.object_type \ nat \ bool \ (globals myvars) set" + createObject_c_preconds1 :: "word32 \ object_type \ nat \ bool \ (globals myvars) set" where "createObject_c_preconds1 regionBase newType userSize deviceMemory \ {s. region_actually_is_dev_bytes regionBase (2 ^ getObjectSize newType userSize) deviceMemory s}" (* these preconds used at start of proof *) definition - createObject_c_preconds :: "word32 \ ArchTypes_H.object_type \ nat \ bool \ (globals myvars) set" + createObject_c_preconds :: "word32 \ object_type \ nat \ bool \ (globals myvars) set" where "createObject_c_preconds regionBase newType userSize deviceMemory \ (createObject_c_preconds1 regionBase newType userSize deviceMemory @@ -4533,6 +4533,40 @@ lemma cond_second_eq_seq_ccorres: apply (auto elim!: exec_Normal_elim_cases intro: exec.Seq exec.CondTrue exec.CondFalse) done +lemma placeNewDataObject_dev_ccorres: + "ccorresG rf_sr \ dc xfdc + (createObject_hs_preconds regionBase newType us True + and K (APIType_capBits newType us = pageBits + us)) + ({s. region_actually_is_bytes regionBase (2 ^ (pageBits + us)) s}) + hs + (placeNewDataObject regionBase us True) + (global_htd_update (\s. (ptr_retyps (2^us) (Ptr regionBase :: user_data_device_C ptr))))" + apply (simp add: placeNewDataObject_def ccorres_cond_univ_iff) + apply (rule ccorres_guard_imp, rule placeNewObject_user_data_device, simp_all) + apply (clarsimp simp: createObject_hs_preconds_def invs'_def + valid_state'_def valid_pspace'_def) + done + +lemma placeNewDataObject_no_dev_ccorres: + "ccorresG rf_sr \ dc xfdc + (createObject_hs_preconds regionBase newType us False + and K (APIType_capBits newType us = pageBits + us)) + ({s. region_actually_is_bytes regionBase (2 ^ (pageBits + us)) s + \ (heap_list_is_zero (hrs_mem (t_hrs_' (globals s))) regionBase (2 ^ (pageBits + us)))}) + hs + (placeNewDataObject regionBase us False) + (global_htd_update (\s. (ptr_retyps (2^us) (Ptr regionBase :: user_data_C ptr))))" + apply (simp add: placeNewDataObject_def ccorres_cond_empty_iff) + apply (rule ccorres_guard_imp, rule placeNewObject_user_data, simp_all) + apply (clarsimp simp: createObject_hs_preconds_def invs'_def + valid_state'_def valid_pspace'_def) + apply (frule range_cover.sz(1), simp add: word_bits_def) + done + +crunch placeNewDataObject + for gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" + (simp: crunch_simps) + lemma Arch_createObject_ccorres: assumes t: "toAPIType newType = None" shows "ccorres (\a b. ccap_relation (ArchObjectCap a) b) ret__struct_cap_C_' @@ -4552,179 +4586,284 @@ proof - apply (frule range_cover.aligned) apply (cut_tac t) apply (case_tac newType, - simp_all add: toAPIType_def - bind_assoc - ARMLargePageBits_def) + simp_all add: toAPIType_def bind_assoc ARMLargePageBits_def) + apply (in_case "SmallPageObject") apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - ARMLargePageBits_def ARMSmallPageBits_def - ARMSectionBits_def ARMSuperSectionBits_def asidInvalid_def - sle_positive APIType_capBits_def shiftL_nat objBits_simps - ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def - fold_eq_0_to_bool) - apply (ccorres_remove_UNIV_guard) - apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def - ARM_H.createObject_def pageBits_def - cond_second_eq_seq_ccorres modify_gsUserPages_update - intro!: ccorres_rhs_assoc) - apply ((rule ccorres_return_C | simp | wp | vcg - | (rule match_ccorres, ctac add: - placeNewDataObject_ccorres[where us=0 and newType=newType, simplified] - gsUserPages_update_ccorres[folded modify_gsUserPages_update]) - | (rule match_ccorres, csymbr))+)[1] - apply (intro conjI) - apply (clarsimp simp: createObject_hs_preconds_def - APIType_capBits_def pageBits_def) - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_small_frame_cap_lift - vmrights_to_H_def mask_def vm_rights_defs) - - \ \Page objects: could possibly fix the duplication here\ + asidInvalid_def APIType_capBits_def shiftL_nat objBits_simps + ptBits_def pageBits_def word_sle_def word_sless_def fold_eq_0_to_bool) + apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps + ARM_H.createObject_def pageBits_def + cond_second_eq_seq_ccorres modify_gsUserPages_update + intro!: ccorres_rhs_assoc) + apply (rule ccorres_cases[where P=deviceMemory]) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_dev_ccorres[where us=0 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_small_frame_cap_lift + vmrights_to_H_def vm_rights_defs, + simp add: mask_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_no_dev_ccorres[where us=0 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr+ + apply (rule ccorres_Guard_Seq) + apply (ctac (no_vcg) add: cleanCacheRange_RAM_ccorres) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_small_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + vm_page_size_defs) + apply (simp add: mask_def) + apply wpsimp + apply (simp add: guard_is_UNIV_def) + apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs + APIType_capBits_def pageBits_def is_aligned_no_overflow_mask) + apply (rule conjI) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply (simp add: mask_def) + + apply (in_case "LargePageObject") apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - ARMLargePageBits_def ARMSmallPageBits_def - ARMSectionBits_def ARMSuperSectionBits_def asidInvalid_def - sle_positive APIType_capBits_def shiftL_nat objBits_simps - ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def - fold_eq_0_to_bool) - apply (ccorres_remove_UNIV_guard) - apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def - ARM_H.createObject_def pageBits_def - cond_second_eq_seq_ccorres modify_gsUserPages_update - intro!: ccorres_rhs_assoc) - apply ((rule ccorres_return_C | simp | wp | vcg - | (rule match_ccorres, ctac add: - placeNewDataObject_ccorres[where us=4 and newType=newType, simplified] - gsUserPages_update_ccorres[folded modify_gsUserPages_update]) - | (rule match_ccorres, csymbr))+)[1] - apply (intro conjI) - apply (clarsimp simp: createObject_hs_preconds_def - APIType_capBits_def pageBits_def) - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_frame_cap_lift - vmrights_to_H_def mask_def vm_rights_defs vm_page_size_defs - cl_valid_cap_def c_valid_cap_def - is_aligned_neg_mask_eq_concrete[THEN sym]) - + asidInvalid_def APIType_capBits_def shiftL_nat objBits_simps + ptBits_def pageBits_def word_sle_def word_sless_def fold_eq_0_to_bool) + apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps + ARM_H.createObject_def pageBits_def + cond_second_eq_seq_ccorres modify_gsUserPages_update + intro!: ccorres_rhs_assoc) + apply (rule ccorres_cases[where P=deviceMemory]) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_dev_ccorres[where us=4 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_no_dev_ccorres[where us=4 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr+ + apply (rule ccorres_Guard_Seq) + apply (ctac (no_vcg) add: cleanCacheRange_RAM_ccorres) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wpsimp + apply (simp add: guard_is_UNIV_def) + apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs + APIType_capBits_def pageBits_def is_aligned_no_overflow_mask) + apply (rule conjI) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply (simp add: mask_def) + + apply (in_case "SectionObject") apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - ARMLargePageBits_def ARMSmallPageBits_def - ARMSectionBits_def ARMSuperSectionBits_def asidInvalid_def - sle_positive APIType_capBits_def shiftL_nat objBits_simps - ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def - fold_eq_0_to_bool) - apply (ccorres_remove_UNIV_guard) - apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def - ARM_H.createObject_def pageBits_def - cond_second_eq_seq_ccorres modify_gsUserPages_update - intro!: ccorres_rhs_assoc) - apply ((rule ccorres_return_C | simp | wp | vcg - | (rule match_ccorres, ctac add: - placeNewDataObject_ccorres[where us=8 and newType=newType, simplified] - gsUserPages_update_ccorres[folded modify_gsUserPages_update]) - | (rule match_ccorres, csymbr))+)[1] - apply (intro conjI) - apply (clarsimp simp: createObject_hs_preconds_def - APIType_capBits_def pageBits_def) - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_frame_cap_lift - vmrights_to_H_def mask_def vm_rights_defs vm_page_size_defs - cl_valid_cap_def c_valid_cap_def - is_aligned_neg_mask_eq_concrete[THEN sym]) + asidInvalid_def APIType_capBits_def shiftL_nat objBits_simps + ptBits_def pageBits_def word_sle_def word_sless_def fold_eq_0_to_bool) + apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps + ARM_H.createObject_def pageBits_def + cond_second_eq_seq_ccorres modify_gsUserPages_update + intro!: ccorres_rhs_assoc) + apply (rule ccorres_cases[where P=deviceMemory]) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_dev_ccorres[where us=8 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_no_dev_ccorres[where us=8 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr+ + apply (rule ccorres_Guard_Seq) + apply (ctac (no_vcg) add: cleanCacheRange_RAM_ccorres) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wpsimp + apply (simp add: guard_is_UNIV_def) + apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs + APIType_capBits_def pageBits_def is_aligned_no_overflow_mask) + apply (rule conjI) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply (simp add: mask_def) + apply (in_case "SuperSectionObject") apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - ARMLargePageBits_def ARMSmallPageBits_def - ARMSectionBits_def ARMSuperSectionBits_def asidInvalid_def - sle_positive APIType_capBits_def shiftL_nat objBits_simps - ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def - fold_eq_0_to_bool) - apply (ccorres_remove_UNIV_guard) - apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def - ARM_H.createObject_def pageBits_def - cond_second_eq_seq_ccorres modify_gsUserPages_update - intro!: ccorres_rhs_assoc) - apply ((rule ccorres_return_C | simp | wp | vcg - | (rule match_ccorres, ctac add: - placeNewDataObject_ccorres[where us=12 and newType=newType, simplified] - gsUserPages_update_ccorres[folded modify_gsUserPages_update]) - | (rule match_ccorres, csymbr))+)[1] - apply (intro conjI) - apply (clarsimp simp: createObject_hs_preconds_def - APIType_capBits_def pageBits_def) - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_frame_cap_lift - vmrights_to_H_def mask_def vm_rights_defs vm_page_size_defs - cl_valid_cap_def c_valid_cap_def - is_aligned_neg_mask_eq_concrete[THEN sym]) - - \ \PageTableObject\ + asidInvalid_def APIType_capBits_def shiftL_nat objBits_simps + ptBits_def pageBits_def word_sle_def word_sless_def fold_eq_0_to_bool) + apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps + ARM_H.createObject_def pageBits_def + cond_second_eq_seq_ccorres modify_gsUserPages_update + intro!: ccorres_rhs_assoc) + apply (rule ccorres_cases[where P=deviceMemory]) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_dev_ccorres[where us=12 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_no_dev_ccorres[where us=12 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr+ + apply (rule ccorres_Guard_Seq) + apply (ctac (no_vcg) add: cleanCacheRange_RAM_ccorres) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wpsimp + apply (simp add: guard_is_UNIV_def) + apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs + APIType_capBits_def pageBits_def is_aligned_no_overflow_mask) + apply (rule conjI) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply (simp add: mask_def) + + apply (in_case "PageTableObject") apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) - apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - ARMLargePageBits_def ARMSmallPageBits_def - ARMSectionBits_def ARMSuperSectionBits_def asidInvalid_def - sle_positive APIType_capBits_def shiftL_nat objBits_simps - ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def) - apply (ccorres_remove_UNIV_guard) + apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff asidInvalid_def + APIType_capBits_def shiftL_nat objBits_simps + ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def) apply (rule ccorres_rhs_assoc)+ apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def - ARM_H.createObject_def pageBits_def) + ARM_H.createObject_def pageBits_def pt_bits_def) apply (ctac pre only: add: placeNewObject_pte[simplified]) apply csymbr - apply (rule ccorres_return_C) - apply simp - apply simp - apply simp + apply (ctac (no_vcg) add: cleanCacheRange_PoU_ccorres) + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp apply wp apply vcg apply clarify apply (intro conjI) apply (clarsimp simp: invs_pspace_aligned' invs_pspace_distinct' invs_valid_global' - APIType_capBits_def invs_valid_objs' - invs_urz) - apply clarsimp - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_page_table_cap_lift - is_aligned_neg_mask_eq vmrights_to_H_def - Kernel_C.VMReadWrite_def Kernel_C.VMNoAccess_def - Kernel_C.VMKernelOnly_def Kernel_C.VMReadOnly_def) - apply (simp add: isFrameType_def) - - \ \PageDirectoryObject\ + APIType_capBits_def invs_valid_objs' is_aligned_no_overflow_mask + invs_urz pteBits_def) + apply (rule conjI, simp add: mask_def) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply (clarsimp simp: ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_page_table_cap_lift + vmrights_to_H_def pteBits_def vmrights_defs) + apply (clarsimp simp: isFrameType_def mask_def is_aligned_neg_mask_eq_concrete[THEN sym]) + + apply (in_case "PageDirectoryObject") apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - asidInvalid_def sle_positive APIType_capBits_def shiftL_nat - objBits_simps archObjSize_def - ptBits_def pageBits_def pdBits_def word_sle_def word_sless_def) - apply (ccorres_remove_UNIV_guard) + asidInvalid_def APIType_capBits_def shiftL_nat + objBits_simps archObjSize_def isFrameType_def + ptBits_def pageBits_def pdBits_def word_sle_def word_sless_def) apply (rule ccorres_rhs_assoc)+ apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def - ARM_H.createObject_def pageBits_def pdBits_def) + ARM_H.createObject_def pageBits_def pdBits_def pd_bits_def) apply (ctac pre only: add: placeNewObject_pde[simplified]) apply (ctac add: copyGlobalMappings_ccorres) apply csymbr apply (ctac add: cleanCacheRange_PoU_ccorres) apply csymbr - apply (rule ccorres_return_C) - apply simp - apply simp - apply simp + apply (rule ccorres_return_C; simp) apply wp apply clarsimp apply vcg apply wp apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_page_directory_cap_lift - is_aligned_neg_mask_eq vmrights_to_H_def - Kernel_C.VMReadWrite_def Kernel_C.VMNoAccess_def - Kernel_C.VMKernelOnly_def Kernel_C.VMReadOnly_def) + framesize_to_H_def cap_to_H_simps cap_page_directory_cap_lift + vmrights_to_H_def vm_rights_defs) apply (vcg exspec=copyGlobalMappings_modifies) apply (clarsimp simp:placeNewObject_def2) apply (wp createObjects'_pde_mappings' createObjects'_page_directory_at_global[where sz=pdBits] @@ -4732,20 +4871,23 @@ proof - apply clarsimp apply vcg apply (clarsimp simp: invs_pspace_aligned' invs_pspace_distinct' - archObjSize_def invs_valid_global' makeObject_pde pdBits_def - pageBits_def range_cover.aligned projectKOs APIType_capBits_def - object_type_from_H_def objBits_simps pdeBits_def - invs_valid_objs' isFrameType_def) + archObjSize_def invs_valid_global' makeObject_pde pdBits_def + pageBits_def range_cover.aligned projectKOs APIType_capBits_def + object_type_from_H_def objBits_simps pdeBits_def + invs_valid_objs' isFrameType_def) apply (frule invs_arch_state') apply (frule range_cover.aligned) apply (frule is_aligned_addrFromPPtr_n, simp) apply (intro conjI, simp_all) - apply fastforce - apply fastforce - apply (clarsimp simp: pageBits_def pdeBits_def - valid_arch_state'_def page_directory_at'_def pdBits_def) - apply (clarsimp simp: is_aligned_no_overflow'[where n=14, simplified] pdeBits_def - field_simps is_aligned_mask[symmetric] mask_AND_less_0)+ + apply fastforce + apply fastforce + apply (clarsimp simp: valid_arch_state'_def page_directory_at'_def) + apply (simp add: mask_def) + apply (simp add: is_aligned_no_overflow_mask) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply (clarsimp simp: is_aligned_mask[symmetric] mask_AND_less_0) + apply (clarsimp simp: mask_def) done qed @@ -6356,7 +6498,7 @@ lemma APIType_capBits_min: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma createNewCaps_1_gsCNodes_p: "\\s. P (gsCNodes s p) \ p \ ptr\ createNewCaps newType ptr 1 n dev\\rv s. P (gsCNodes s p)\" @@ -6470,6 +6612,43 @@ lemma cleanCacheRange_PoU_preserves_bytes: elim!: byte_regions_unmodified_trans byte_regions_unmodified_trans[rotated], (simp_all add: h_t_valid_field)+) +lemma cleanByVA_preserves_bytes: + "\s. \\\<^bsub>/UNIV\<^esub> {s} Call cleanByVA_'proc + {t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s)) + \ byte_regions_unmodified' s t}" + apply (rule allI, rule conseqPost, rule cleanByVA_preserves_kernel_bytes[rule_format]) + apply simp_all + apply (clarsimp simp: byte_regions_unmodified_def) + done + +lemma cleanCacheRange_PoC_preserves_bytes: + "\s. \\\<^bsub>/UNIV\<^esub> {s} Call cleanCacheRange_PoC_'proc + {t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s)) + \ byte_regions_unmodified' s t}" + apply (hoare_rule HoarePartial.ProcNoRec1) + apply (clarsimp simp only: whileAnno_def) + apply (subst whileAnno_def[symmetric, where V=undefined + and I="{t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s)) + \ byte_regions_unmodified' s t}" for s]) + apply (rule conseqPre, vcg exspec=cleanByVA_preserves_bytes) + by (safe intro!: byte_regions_unmodified_hrs_mem_update + elim!: byte_regions_unmodified_trans byte_regions_unmodified_trans[rotated], + (simp_all add: h_t_valid_field)+) + +lemma cleanCacheRange_RAM_preserves_bytes: + "\s. \\\<^bsub>/UNIV\<^esub> {s} Call cleanCacheRange_RAM_'proc + {t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s)) + \ byte_regions_unmodified' s t}" + apply (hoare_rule HoarePartial.ProcNoRec1, rule allI) + apply (rule conseqPre, vcg exspec=cleanCacheRange_PoC_preserves_bytes + exspec=cleanL2Range_preserves_kernel_bytes + exspec=dsb_preserves_kernel_bytes) + apply (safe intro!: byte_regions_unmodified_hrs_mem_update + elim!: byte_regions_unmodified_trans byte_regions_unmodified_trans[rotated], + (simp_all add: h_t_valid_field)+) + apply (clarsimp simp: byte_regions_unmodified_def) + done + lemma hrs_htd_update_canon: "hrs_htd_update (\_. f (hrs_htd hrs)) hrs = hrs_htd_update f hrs" by (cases hrs, simp add: hrs_htd_update_def hrs_htd_def) @@ -6488,15 +6667,18 @@ lemma Arch_createObject_preserves_bytes: exspec=copyGlobalMappings_preserves_bytes exspec=addrFromPPtr_modifies exspec=cleanCacheRange_PoU_preserves_bytes - exspec=cap_page_directory_cap_new_modifies) + exspec=cleanCacheRange_RAM_preserves_bytes + exspec=cap_page_directory_cap_new_modifies) find_names ARMSmallPage_def apply (safe intro!: byte_regions_unmodified_hrs_mem_update, (simp_all add: h_t_valid_field hrs_htd_update)+) - apply (safe intro!: ptr_retyp_d ptr_retyps_out) - apply (simp_all add: object_type_from_H_def Kernel_C_defs APIType_capBits_def - split: object_type.split_asm apiobject_type.split_asm) - apply (rule byte_regions_unmodified_flip, simp) - apply (rule byte_regions_unmodified_trans[rotated], - assumption, simp_all add: hrs_htd_update_canon hrs_htd_update) + apply (safe intro!: ptr_retyp_d ptr_retyps_out) + apply (simp_all add: object_type_from_H_def Kernel_C_defs APIType_capBits_def + vm_page_size_defs + split: object_type.split_asm apiobject_type.split_asm) + apply (all \(solves \simp add: mask_def\)?\) + apply (rule byte_regions_unmodified_flip, simp, + rule byte_regions_unmodified_trans[rotated], assumption; + simp add: hrs_htd_update_canon hrs_htd_update)+ done lemma ptr_arr_retyps_eq_outside_dom: @@ -6646,6 +6828,16 @@ lemma insertNewCap_ccorres: apply (simp add: untypedZeroRange_def Let_def) done +lemma Arch_createObject_not_untyped: + "\s. \\\<^bsub>/UNIV\<^esub> + {s} Call Arch_createObject_'proc {t. cap_get_tag (ret__struct_cap_C_' t) \ scast cap_untyped_cap}" + apply (rule allI, rule conseqPre) + apply (vcg exspec=cleanCacheRange_PoU_modifies + exspec=cleanCacheRange_RAM_modifies + exspec=copyGlobalMappings_modifies) + apply (clarsimp simp: cap_tag_defs vm_page_size_defs mask_def) + done + lemma createObject_untyped_region_is_zero_bytes: "\\. \\\<^bsub>/UNIV\<^esub> {s. let tp = (object_type_to_H (t_' s)); sz = APIType_capBits tp (unat (userSize_' s)) @@ -6657,9 +6849,8 @@ lemma createObject_untyped_region_is_zero_bytes: {t. cap_get_tag (ret__struct_cap_C_' t) = scast cap_untyped_cap \ (case untypedZeroRange (cap_to_H (the (cap_lift (ret__struct_cap_C_' t)))) of None \ True | Some (a, b) \ region_actually_is_zero_bytes a (unat ((b + 1) - a)) t)}" - apply (rule allI, rule conseqPre, vcg exspec=copyGlobalMappings_modifies - exspec=Arch_initContext_modifies - exspec=cleanCacheRange_PoU_modifies) + apply (rule allI, rule conseqPre, + vcg exspec=Arch_createObject_not_untyped exspec=Arch_initContext_modifies) apply (clarsimp simp: cap_tag_defs) apply (simp add: cap_lift_untyped_cap cap_tag_defs cap_to_H_simps cap_untyped_cap_lift_def object_type_from_H_def) diff --git a/proof/crefine/ARM/SR_lemmas_C.thy b/proof/crefine/ARM/SR_lemmas_C.thy index ddcb8c6ea9..c848920b8d 100644 --- a/proof/crefine/ARM/SR_lemmas_C.thy +++ b/proof/crefine/ARM/SR_lemmas_C.thy @@ -11,7 +11,7 @@ imports "Refine.Invariants_H" begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) section "ctes" diff --git a/proof/crefine/ARM/Schedule_C.thy b/proof/crefine/ARM/Schedule_C.thy index 4e3aac750b..006c0d8acf 100644 --- a/proof/crefine/ARM/Schedule_C.thy +++ b/proof/crefine/ARM/Schedule_C.thy @@ -9,7 +9,7 @@ theory Schedule_C imports Tcb_C Detype_C begin -(*FIXME: arch_split: move up?*) +(*FIXME: arch-split: move up?*) context Arch begin context begin global_naming global requalify_facts diff --git a/proof/crefine/ARM/StateRelation_C.thy b/proof/crefine/ARM/StateRelation_C.thy index 497e268881..857103992d 100644 --- a/proof/crefine/ARM/StateRelation_C.thy +++ b/proof/crefine/ARM/StateRelation_C.thy @@ -8,7 +8,7 @@ theory StateRelation_C imports Wellformed_C begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "lifth p s \ the (clift (t_hrs_' s) p)" @@ -100,7 +100,7 @@ text \ which can subsequently be instantiated for @{text kernel_all_global_addresses} as well as @{text kernel_all_substitute}. \ -locale state_rel = Arch + substitute_pre + (*FIXME: arch_split*) +locale state_rel = Arch + substitute_pre + (*FIXME: arch-split*) fixes armKSKernelVSpace_C :: "machine_word \ arm_vspace_region_use" locale kernel = kernel_all_substitute + state_rel @@ -134,7 +134,7 @@ where end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition cmachine_state_relation :: "machine_state \ globals \ bool" diff --git a/proof/crefine/ARM/SyscallArgs_C.thy b/proof/crefine/ARM/SyscallArgs_C.thy index 2cac960a08..1aabd59eac 100644 --- a/proof/crefine/ARM/SyscallArgs_C.thy +++ b/proof/crefine/ARM/SyscallArgs_C.thy @@ -12,13 +12,13 @@ imports StoreWord_C DetWP begin -(*FIXME: arch_split: C kernel names hidden by Haskell names *) +(*FIXME: arch-split: C kernel names hidden by Haskell names *) context kernel_m begin abbreviation "msgRegistersC \ kernel_all_substitute.msgRegisters" lemmas msgRegistersC_def = kernel_all_substitute.msgRegisters_def end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare word_neq_0_conv[simp del] @@ -1256,7 +1256,7 @@ lemma getSyscallArg_ccorres_foo: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma invocation_eq_use_type: "\ value \ (value' :: 32 signed word); diff --git a/proof/crefine/ARM/Syscall_C.thy b/proof/crefine/ARM/Syscall_C.thy index 801b4c6ceb..1b7e214e52 100644 --- a/proof/crefine/ARM/Syscall_C.thy +++ b/proof/crefine/ARM/Syscall_C.thy @@ -14,7 +14,7 @@ imports Arch_C begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch replyFromKernel for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" end diff --git a/proof/crefine/ARM/Tcb_C.thy b/proof/crefine/ARM/Tcb_C.thy index 264da21d5b..82c5be1e8c 100644 --- a/proof/crefine/ARM/Tcb_C.thy +++ b/proof/crefine/ARM/Tcb_C.thy @@ -58,7 +58,7 @@ lemma doMachineOp_sched: apply fastforce done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch restart for curThread[wp]: "\s. P (ksCurThread s)" @@ -1029,7 +1029,7 @@ lemma Arch_performTransfer_ccorres: apply simp+ done -(*FIXME: arch_split: C kernel names hidden by Haskell names *) +(*FIXME: arch-split: C kernel names hidden by Haskell names *) abbreviation "frameRegistersC \ kernel_all_substitute.frameRegisters" lemmas frameRegistersC_def = kernel_all_substitute.frameRegisters_def abbreviation "gpRegistersC \ kernel_all_substitute.gpRegisters" diff --git a/proof/crefine/ARM/VSpace_C.thy b/proof/crefine/ARM/VSpace_C.thy index 03bea4c91a..407b485ab9 100644 --- a/proof/crefine/ARM/VSpace_C.thy +++ b/proof/crefine/ARM/VSpace_C.thy @@ -1141,7 +1141,7 @@ lemma rf_sr_armKSNextASID: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch invalidateASID for armKSNextASID[wp]: "\s. P (armKSNextASID (ksArchState s))" @@ -1563,8 +1563,10 @@ definition | ARM_H.flush_type.Unify \ (label = Kernel_C.ARMPageUnify_Instruction \ label = Kernel_C.ARMPDUnify_Instruction)" lemma doFlush_ccorres: - "ccorres dc xfdc (\s. vs \ ve \ ps \ ps + (ve - vs) \ vs && mask 5 = ps && mask 5 - \ unat (ve - vs) \ gsMaxObjectSize s) + "ccorres dc xfdc + (\s. vs \ ve \ ps \ ps + (ve - vs) \ + vs && mask cacheLineBits = ps && mask cacheLineBits \ + unat (ve - vs) \ gsMaxObjectSize s) (\flushtype_relation t \invLabel___int\ \ \\start = vs\ \ \\end = ve\ \ \\pstart = ps\) [] (doMachineOp (doFlush t vs ve ps)) (Call doFlush_'proc)" apply (cinit' lift: pstart_') @@ -1615,7 +1617,7 @@ lemma doFlush_ccorres: done end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch setVMRootForFlush for gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" (wp: crunch_wps) @@ -1626,7 +1628,7 @@ context kernel_m begin lemma performPageFlush_ccorres: "ccorres (K (K \) \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (invs' and K (asid \ mask asid_bits) - and (\s. ps \ ps + (ve - vs) \ vs && mask 5 = ps && mask 5 + and (\s. ps \ ps + (ve - vs) \ vs && mask cacheLineBits = ps && mask cacheLineBits \ unat (ve - vs) \ gsMaxObjectSize s)) (\\pd = Ptr pd\ \ \\asid = asid\ \ \\start = vs\ \ \\end = ve\ \ \\pstart = ps\ \ \flushtype_relation typ \invLabel___int \) @@ -1757,7 +1759,7 @@ lemma setMessageInfo_ccorres: lemma performPageDirectoryInvocationFlush_ccorres: "ccorres (K (K \) \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (invs' and K (asid \ mask asid_bits) - and (\s. ps \ ps + (ve - vs) \ vs && mask 5 = ps && mask 5 + and (\s. ps \ ps + (ve - vs) \ vs && mask cacheLineBits = ps && mask cacheLineBits \ unat (ve - vs) \ gsMaxObjectSize s)) (\\pd = Ptr pd\ \ \\asid = asid\ \ \\start = vs\ \ \\end = ve\ \ \\pstart = ps\ \ \flushtype_relation typ \invLabel___int \) @@ -1860,7 +1862,7 @@ lemma flushPage_ccorres: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch flushPage for no_0_obj'[wp]: "no_0_obj'" end @@ -1948,18 +1950,13 @@ lemma ccorres_return_void_C': done lemma is_aligned_cache_preconds: - "\is_aligned rva n; n \ 6\ \ rva \ rva + 0x3F \ - addrFromPPtr rva \ addrFromPPtr rva + 0x3F \ rva && mask 5 = addrFromPPtr rva && mask 5" + "\ is_aligned rva n; n \ 6 \ \ rva \ rva + 0x3F \ addrFromPPtr rva \ addrFromPPtr rva + 0x3F" supply if_cong[cong] apply (drule is_aligned_weaken, simp) apply (rule conjI) apply (drule is_aligned_no_overflow, simp, unat_arith)[1] - apply (rule conjI) - apply (drule is_aligned_addrFromPPtr_n, simp) - apply (drule is_aligned_no_overflow, unat_arith) - apply (frule is_aligned_addrFromPPtr_n, simp) - apply (drule_tac x=6 and y=5 in is_aligned_weaken, simp)+ - apply (simp add: is_aligned_mask) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (drule is_aligned_no_overflow, unat_arith) done lemma pte_pte_invalid_new_spec: @@ -2219,7 +2216,7 @@ lemma unmapPage_ccorres: subgoal by (simp add: upto_enum_step_def upto_enum_word take_bit_Suc hd_map last_map typ_at_to_obj_at_arches field_simps objBits_simps archObjSize_def, - clarsimp dest!: is_aligned_cache_preconds) + drule is_aligned_cache_preconds; clarsimp) apply (simp add: upto_enum_step_def upto_enum_word) apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem) apply (simp add: hd_map last_map upto_enum_step_def objBits_simps archObjSize_def diff --git a/proof/crefine/ARM/Wellformed_C.thy b/proof/crefine/ARM/Wellformed_C.thy index b1a9671ef3..caa878d9bf 100644 --- a/proof/crefine/ARM/Wellformed_C.thy +++ b/proof/crefine/ARM/Wellformed_C.thy @@ -14,7 +14,7 @@ imports "CSpec.Substitute" begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) abbreviation cte_Ptr :: "word32 \ cte_C ptr" where "cte_Ptr == Ptr" @@ -232,7 +232,7 @@ record cte_CL = cap_CL :: cap_CL cteMDBNode_CL :: mdb_node_CL -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition cte_lift :: "cte_C \ cte_CL" @@ -495,6 +495,63 @@ lemma ucast_irq_array_guard[unfolded irq_array_size_val, simplified]: done +text \cacheLineBits interface\ + +(* only use this inside cache op functions; see Arch_Kernel_Config_Lemmas.cacheLineBits_sanity *) +lemmas cacheLineBits_val = + cacheLineBits_def[unfolded Kernel_Config.CONFIG_L1_CACHE_LINE_SIZE_BITS_def] + +lemma cacheLineBits_le_ptBits: + "cacheLineBits \ ptBits" + using cacheLineBits_sanity + by (simp add: ptBits_def pteBits_def) + +lemma ptBits_leq_pageBits: + "ptBits \ pageBits" + by (simp add: ptBits_def pageBits_def pteBits_def) + +lemma ptBits_leq_pdBits: + "ptBits \ pdBits" + by (simp add: ptBits_def pdBits_def pteBits_def) + +lemma cacheLineBits_leq_pageBits: + "cacheLineBits \ pageBits" + using ptBits_leq_pageBits cacheLineBits_le_ptBits + by simp + +lemma cacheLineBits_leq_pdBits: + "cacheLineBits \ pdBits" + using ptBits_leq_pdBits cacheLineBits_le_ptBits + by simp + +lemma cacheLineBits_le_machine_word: + "cacheLineBits < LENGTH(machine_word_len)" + using pt_bits_stuff cacheLineBits_le_ptBits + by (simp add: word_bits_def) + +lemma APIType_capBits_PageDirectoryObject_pdBits: + "APIType_capBits PageDirectoryObject us = pdBits" + by (simp add: pdBits_def APIType_capBits_def pdeBits_def) + +lemma cacheLineBits_le_PageDirectoryObject_sz: + "cacheLineBits \ APIType_capBits PageDirectoryObject us" + by (simp add: APIType_capBits_PageDirectoryObject_pdBits cacheLineBits_leq_pdBits) + +lemma cacheLineBits_leq_pbfs: + "cacheLineBits \ pageBitsForSize sz" + by (rule order.trans, rule cacheLineBits_leq_pageBits, rule pbfs_atleast_pageBits) + +lemma addrFromPPtr_mask_cacheLineBits[simp]: + "addrFromPPtr ptr && mask cacheLineBits = ptr && mask cacheLineBits" + by (rule addrFromPPtr_mask_ARMSuperSection, rule cacheLineBits_leq_pbfs) + +lemma shiftr_cacheLineBits_less_mask_word_bits: + "x >> cacheLineBits < mask word_bits" for x :: machine_word + using shiftr_less_max_mask[where n=cacheLineBits and x=x] cacheLineBits_sanity + by (simp add: word_bits_def) + +(* end of Kernel_Config interface section *) + abbreviation(input) NotificationObject :: sword32 where diff --git a/proof/crefine/ARM_HYP/ADT_C.thy b/proof/crefine/ARM_HYP/ADT_C.thy index 485cd6df4e..0ca2bcd27d 100644 --- a/proof/crefine/ARM_HYP/ADT_C.thy +++ b/proof/crefine/ARM_HYP/ADT_C.thy @@ -213,7 +213,7 @@ end consts Init_C' :: "unit observable \ cstate global_state set" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "Init_C \ \((tc,s),m,e). Init_C' ((tc, truncate_state s),m,e)" @@ -634,7 +634,7 @@ lemma (in kernel_m) carch_state_to_H_correct: apply (fastforce simp: valid_asid_table'_def) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma tcb_queue_rel_unique: "hp NULL = None \ diff --git a/proof/crefine/ARM_HYP/ArchMove_C.thy b/proof/crefine/ARM_HYP/ArchMove_C.thy index 9d898f404a..31054c9437 100644 --- a/proof/crefine/ARM_HYP/ArchMove_C.thy +++ b/proof/crefine/ARM_HYP/ArchMove_C.thy @@ -617,17 +617,6 @@ crunch insertNewCap, Arch_createNewCaps, threadSet, Arch.createObject, setThread simp: unless_def updateObject_default_def crunch_simps ignore_del: preemptionPoint) -(* this could be done as - lemmas addrFromPPtr_mask_6 = addrFromPPtr_mask[where n=6, simplified] - but that wouldn't give a sanity check of the n \ ... assumption disappearing *) -lemma addrFromPPtr_mask_6: - "addrFromPPtr ptr && mask 6 = ptr && mask 6" - by (rule addrFromPPtr_mask[where n=6, simplified]) - -lemma ptrFromPAddr_mask_6: - "ptrFromPAddr ps && mask 6 = ps && mask 6" - by (rule ptrFromPAddr_mask[where n=6, simplified]) - end end diff --git a/proof/crefine/ARM_HYP/Arch_C.thy b/proof/crefine/ARM_HYP/Arch_C.thy index a464729ab9..0ead82e81a 100644 --- a/proof/crefine/ARM_HYP/Arch_C.thy +++ b/proof/crefine/ARM_HYP/Arch_C.thy @@ -11,7 +11,7 @@ begin unbundle l4v_word_context -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch unmapPageTable for ctes_of[wp]: "\s. P (ctes_of s)" (wp: crunch_wps simp: crunch_simps) @@ -1742,8 +1742,7 @@ lemma performPageInvocationMapPTE_ccorres: apply (subst is_aligned_no_wrap', assumption, fastforce simp: field_simps) apply (subst add_diff_eq [symmetric], subst is_aligned_no_wrap', assumption, fastforce simp: field_simps) apply simp - apply (clarsimp simp: pte_range_relation_def ptr_add_def ptr_range_to_list_def - addrFromPPtr_mask_6) + apply (clarsimp simp: pte_range_relation_def ptr_add_def ptr_range_to_list_def) apply (auto simp: valid_pte_slots'2_def upt_conv_Cons[where i=0])[1] apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem hd_conv_nth last_conv_nth ucast_minus) apply (clarsimp simp: pte_range_relation_def ptr_range_to_list_def objBits_simps @@ -2122,8 +2121,7 @@ lemma performPageInvocationMapPDE_ccorres: apply (subst is_aligned_no_wrap', assumption, fastforce simp: field_simps) apply (subst add_diff_eq [symmetric], subst is_aligned_no_wrap', assumption, fastforce simp: field_simps) apply simp - apply (clarsimp simp: pde_range_relation_def ptr_add_def ptr_range_to_list_def - addrFromPPtr_mask_6) + apply (clarsimp simp: pde_range_relation_def ptr_add_def ptr_range_to_list_def) apply (auto simp: valid_pde_slots'2_def upt_conv_Cons[where i=0])[1] apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem hd_conv_nth last_conv_nth ucast_minus) apply (clarsimp simp: pde_range_relation_def ptr_range_to_list_def objBits_simps @@ -3149,7 +3147,7 @@ lemma decodeARMFrameInvocation_ccorres: intro conjI, (solves \frule vmsz_aligned_addrFromPPtr(3)[THEN iffD2], (subst mask_add_aligned mask_add_aligned_right, erule is_aligned_weaken, - rule order_trans[OF _ pbfs_atleast_pageBits[simplified pageBits_def]], simp)+, + rule cacheLineBits_leq_pbfs)+, simp\), fastforce simp add: ptrFromPAddr_add_left is_aligned_no_overflow3[rotated -1])+ apply (local_method simplify_and_expand)+ @@ -3513,15 +3511,14 @@ lemma decodeARMPageDirectoryInvocation_ccorres: \ \cache flush constraints\ subgoal for _ _ _ _ _ _ sz p - using pbfs_atleast_pageBits[simplified pageBits_def, of sz] + using pbfs_atleast_pageBits[of sz] cacheLineBits_leq_pageBits apply (intro conjI) apply (erule flush_range_le) apply (simp add:linorder_not_le) apply (erule word_less_sub_1) apply (simp add:mask_add_aligned mask_twice) apply (fastforce simp: mask_twice - mask_add_aligned[OF is_aligned_pageBitsForSize_minimum, - simplified pageBits_def]) + mask_add_aligned[OF is_aligned_pageBitsForSize_minimum]) apply (simp add: ptrFromPAddr_add_left) apply (erule flush_range_le) apply (simp add:linorder_not_le) diff --git a/proof/crefine/ARM_HYP/CLevityCatch.thy b/proof/crefine/ARM_HYP/CLevityCatch.thy index 251ef4abeb..93ecc49fd6 100644 --- a/proof/crefine/ARM_HYP/CLevityCatch.thy +++ b/proof/crefine/ARM_HYP/CLevityCatch.thy @@ -14,7 +14,7 @@ imports Boolean_C begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare word_neq_0_conv [simp del] diff --git a/proof/crefine/ARM_HYP/DetWP.thy b/proof/crefine/ARM_HYP/DetWP.thy index 82163aafb2..57e376c2fb 100644 --- a/proof/crefine/ARM_HYP/DetWP.thy +++ b/proof/crefine/ARM_HYP/DetWP.thy @@ -8,7 +8,7 @@ theory DetWP imports "Lib.DetWPLib" "CBaseRefine.Include_C" begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma det_wp_doMachineOp [wp]: "det_wp (\_. P) f \ det_wp (\_. P) (doMachineOp f)" diff --git a/proof/crefine/ARM_HYP/Fastpath_C.thy b/proof/crefine/ARM_HYP/Fastpath_C.thy index 6052add3d7..1402c6eb42 100644 --- a/proof/crefine/ARM_HYP/Fastpath_C.thy +++ b/proof/crefine/ARM_HYP/Fastpath_C.thy @@ -17,7 +17,7 @@ imports "CLib.MonadicRewrite_C" begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setCTE_obj_at'_queued: "\obj_at' (\tcb. P (tcbQueued tcb)) t\ setCTE p v \\rv. obj_at' (\tcb. P (tcbQueued tcb)) t\" diff --git a/proof/crefine/ARM_HYP/Fastpath_Defs.thy b/proof/crefine/ARM_HYP/Fastpath_Defs.thy index 6326c34838..a08a031b81 100644 --- a/proof/crefine/ARM_HYP/Fastpath_Defs.thy +++ b/proof/crefine/ARM_HYP/Fastpath_Defs.thy @@ -15,7 +15,7 @@ theory Fastpath_Defs imports ArchMove_C begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "fastpaths sysc \ case sysc of diff --git a/proof/crefine/ARM_HYP/Fastpath_Equiv.thy b/proof/crefine/ARM_HYP/Fastpath_Equiv.thy index 99b1e043df..b62ef16970 100644 --- a/proof/crefine/ARM_HYP/Fastpath_Equiv.thy +++ b/proof/crefine/ARM_HYP/Fastpath_Equiv.thy @@ -45,7 +45,7 @@ lemma setCTE_tcbContext: apply (rule setObject_cte_obj_at_tcb', simp_all) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setThreadState_tcbContext: "setThreadState st tptr \obj_at' (\tcb. P ((atcbContextGet o tcbArch) tcb)) t\" diff --git a/proof/crefine/ARM_HYP/Finalise_C.thy b/proof/crefine/ARM_HYP/Finalise_C.thy index e72c634003..24322083b4 100644 --- a/proof/crefine/ARM_HYP/Finalise_C.thy +++ b/proof/crefine/ARM_HYP/Finalise_C.thy @@ -1131,7 +1131,7 @@ lemma offset_xf_for_sequence: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch invalidateHWASIDEntry for pde_mappings'[wp]: "valid_pde_mappings'" end @@ -1174,7 +1174,7 @@ lemma invalidateASIDEntry_ccorres: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch invalidateASIDEntry for obj_at'[wp]: "obj_at' P p" crunch flushSpace diff --git a/proof/crefine/ARM_HYP/Invoke_C.thy b/proof/crefine/ARM_HYP/Invoke_C.thy index 78502779c2..f482be0709 100644 --- a/proof/crefine/ARM_HYP/Invoke_C.thy +++ b/proof/crefine/ARM_HYP/Invoke_C.thy @@ -1390,7 +1390,7 @@ lemma decodeCNodeInvocation_ccorres: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas setCTE_def3 = setCTE_def2[THEN eq_reflection] @@ -1677,45 +1677,37 @@ lemma clearMemory_untyped_ccorres: apply (cinit' lift: bits_' ptr___ptr_to_unsigned_long_') apply (rule_tac P="ptr \ 0 \ sz < word_bits" in ccorres_gen_asm) - apply (rule ccorres_Guard_Seq) + apply (rule ccorres_Guard) apply (simp add: clearMemory_def) - apply (simp add: doMachineOp_bind ef_storeWord) - apply (rule ccorres_split_nothrow_novcg_dc) - apply (rule_tac P="?P" and P'="{s. region_actually_is_bytes ptr (2 ^ sz) s}" - in ccorres_from_vcg) - apply (rule allI, rule conseqPre, vcg) - apply clarsimp - apply (clarsimp simp: isCap_simps valid_cap'_def capAligned_def - is_aligned_no_wrap'[OF _ word32_power_less_1] - unat_of_nat_eq word_bits_def) - apply (simp add: is_aligned_weaken is_aligned_triv[THEN is_aligned_weaken]) - apply (clarsimp simp: ghost_assertion_size_logic[unfolded o_def] - region_actually_is_bytes_dom_s) - apply (clarsimp simp: field_simps word_size_def mapM_x_storeWord_step - word_bits_def cte_wp_at_ctes_of) - apply (frule ctes_of_valid', clarify+) - apply (simp add: doMachineOp_def split_def exec_gets) - apply (simp add: select_f_def simpler_modify_def bind_def - valid_cap_simps' capAligned_def) - apply (subst pspace_no_overlap_underlying_zero_update, simp+) - apply (case_tac sz, simp_all)[1] - apply (case_tac nat, simp_all)[1] - apply (clarsimp dest!: region_actually_is_bytes) - apply (drule(1) rf_sr_rep0) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def - carch_state_relation_def cmachine_state_relation_def) - apply csymbr - apply (ctac add: cleanCacheRange_RAM_ccorres) - apply wp - apply (simp add: guard_is_UNIV_def unat_of_nat - word_bits_def capAligned_def word_of_nat_less) + apply (rule_tac P="?P" and P'="{s. region_actually_is_bytes ptr (2 ^ sz) s}" in ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply clarsimp + apply (clarsimp simp: isCap_simps valid_cap'_def capAligned_def + is_aligned_no_wrap'[OF _ word32_power_less_1] + unat_of_nat_eq word_bits_def) + apply (simp add: is_aligned_weaken is_aligned_triv[THEN is_aligned_weaken]) + apply (clarsimp simp: ghost_assertion_size_logic[unfolded o_def] + region_actually_is_bytes_dom_s) + apply (clarsimp simp: field_simps word_size_def mapM_x_storeWord_step + word_bits_def cte_wp_at_ctes_of) + apply (frule ctes_of_valid', clarify+) + apply (simp add: doMachineOp_def split_def exec_gets) + apply (simp add: select_f_def simpler_modify_def bind_def + valid_cap_simps' capAligned_def) + apply (subst pspace_no_overlap_underlying_zero_update, simp+) + apply (case_tac sz, simp_all)[1] + apply (case_tac nat, simp_all)[1] + apply (clarsimp dest!: region_actually_is_bytes) + apply (drule(1) rf_sr_rep0) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def + carch_state_relation_def cmachine_state_relation_def) + apply (simp add: guard_is_UNIV_def unat_of_nat + word_bits_def capAligned_def word_of_nat_less) apply (clarsimp simp: cte_wp_at_ctes_of) apply (frule ctes_of_valid', clarify+) apply (clarsimp simp: isCap_simps valid_cap_simps' capAligned_def word_of_nat_less Kernel_Config.resetChunkBits_def word_bits_def unat_2p_sub_1) - apply (strengthen is_aligned_no_wrap'[where sz=sz] is_aligned_addrFromPPtr_n)+ - apply (simp add: addrFromPPtr_mask) apply (cases "ptr = 0") apply (drule subsetD, rule intvl_self, simp) apply (simp split: if_split_asm) @@ -2828,10 +2820,10 @@ lemma ctes_of_ex_cte_cap_to': lemma Arch_isFrameType_spec: - "\s. \ \ \s. unat \type \ fromEnum (maxBound::ArchTypes_H.object_type)\ + "\s. \ \ \s. unat \type \ fromEnum (maxBound::object_type)\ Call Arch_isFrameType_'proc \ \ret__unsigned_long = - from_bool (isFrameType ((toEnum (unat \<^bsup>s\<^esup> type))::ArchTypes_H.object_type))\" + from_bool (isFrameType ((toEnum (unat \<^bsup>s\<^esup> type))::object_type))\" apply vcg apply (simp add: toEnum_object_type_to_H) apply (frule object_type_from_to_H) diff --git a/proof/crefine/ARM_HYP/Ipc_C.thy b/proof/crefine/ARM_HYP/Ipc_C.thy index 376139a7dc..8777d9b3c6 100644 --- a/proof/crefine/ARM_HYP/Ipc_C.thy +++ b/proof/crefine/ARM_HYP/Ipc_C.thy @@ -13,7 +13,7 @@ imports IsolatedThreadAction begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "replyFromKernel_success_empty thread \ do @@ -346,7 +346,7 @@ lemma ccap_relation_reply_helpers: cap_reply_cap_lift_def word_size elim!: ccap_relationE) -(*FIXME: arch_split: C kernel names hidden by Haskell names *) +(*FIXME: arch-split: C kernel names hidden by Haskell names *) (*FIXME: fupdate simplification issues for 2D arrays *) abbreviation "syscallMessageC \ kernel_all_global_addresses.fault_messages.[unat MessageID_Syscall]" lemmas syscallMessageC_def = kernel_all_substitute.fault_messages_def @@ -369,7 +369,7 @@ lemma syscallMessage_ccorres: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "handleArchFaultReply' f sender receiver tag \ @@ -1088,7 +1088,7 @@ lemma setMR_ccorres_dc: end (* FIXME: move *) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch setMR for valid_pspace'[wp]: "valid_pspace'" crunch setMR diff --git a/proof/crefine/ARM_HYP/IsolatedThreadAction.thy b/proof/crefine/ARM_HYP/IsolatedThreadAction.thy index 4fad3331b4..4e0d5d49fd 100644 --- a/proof/crefine/ARM_HYP/IsolatedThreadAction.thy +++ b/proof/crefine/ARM_HYP/IsolatedThreadAction.thy @@ -9,7 +9,7 @@ theory IsolatedThreadAction imports ArchMove_C begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) datatype tcb_state_regs = TCBStateRegs (tsrState : thread_state) (tsrContext : "MachineTypes.register \ machine_word") @@ -1235,7 +1235,7 @@ lemma bind_assoc: = do x \ m; y \ f x; g y od" by (rule bind_assoc) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setObject_modify_assert: "\ updateObject v = updateObject_default v \ diff --git a/proof/crefine/ARM_HYP/Machine_C.thy b/proof/crefine/ARM_HYP/Machine_C.thy index 2ad8e55adf..00e6f8edee 100644 --- a/proof/crefine/ARM_HYP/Machine_C.thy +++ b/proof/crefine/ARM_HYP/Machine_C.thy @@ -224,7 +224,7 @@ assumes getFAR_ccorres: (doMachineOp getFAR) (Call getFAR_'proc)" -(* FIXME ARMHYP double-check this, assumption is ccorres holds regardless of in_kernel *) +(* assumption is ccorres holds regardless of in_kernel *) assumes getActiveIRQ_ccorres: "\in_kernel. ccorres (\(a::irq option) c::machine_word. @@ -402,39 +402,38 @@ lemma index_xf_for_sequence: (* FIXME CLEANUP on all arches: this entire cache (section) has: - a number of useful word lemmas that can go into WordLib - - a ton of hardcoded "mask 6" and "64", which on sabre is "mask 5" and "32" respectively. - The proofs themselves are extremely similar. This can be much more generic! *) lemma lineStart_le_mono: "x \ y \ lineStart x \ lineStart y" - by (clarsimp simp: lineStart_def cacheLineBits_def shiftr_shiftl1 neg_mask_mono_le) + by (clarsimp simp: lineStart_def shiftr_shiftl1 neg_mask_mono_le) lemma lineStart_sub: - "\ x && mask 6 = y && mask 6\ \ lineStart (x - y) = lineStart x - lineStart y" - apply (clarsimp simp: lineStart_def cacheLineBits_def shiftr_shiftl1) + "\ x && mask cacheLineBits = y && mask cacheLineBits\ \ lineStart (x - y) = lineStart x - lineStart y" + apply (clarsimp simp: lineStart_def shiftr_shiftl1) apply (clarsimp simp: mask_out_sub_mask) apply (clarsimp simp: mask_eqs(8)[symmetric]) done lemma lineStart_mask: - "lineStart x && mask 6 = 0" - by (clarsimp simp: lineStart_def cacheLineBits_def shiftr_shiftl1 mask_AND_NOT_mask) + "lineStart x && mask cacheLineBits = 0" + by (clarsimp simp: lineStart_def shiftr_shiftl1 mask_AND_NOT_mask) lemma cachRangeOp_corres_helper: - "\w1 \ w2; w3 \ w3 + (w2 - w1); w1 && mask 6 = w3 && mask 6\ - \ unat (lineStart w2 - lineStart w1) div 64 = - unat (lineStart (w3 + (w2 - w1)) - lineStart w3) div 64" + "\w1 \ w2; w3 \ w3 + (w2 - w1); w1 && mask cacheLineBits = w3 && mask cacheLineBits\ + \ unat (lineStart w2 - lineStart w1) div (2^cacheLineBits) = + unat (lineStart (w3 + (w2 - w1)) - lineStart w3) div (2^cacheLineBits)" apply (subst dvd_div_div_eq_mult, simp) - apply (clarsimp simp: and_mask_dvd_nat[where n=6, simplified]) - apply (clarsimp simp: lineStart_def cacheLineBits_def shiftr_shiftl1) + apply (clarsimp simp: and_mask_dvd_nat[where n=cacheLineBits, simplified]) + apply (clarsimp simp: lineStart_def shiftr_shiftl1) apply (subst mask_eqs(8)[symmetric]) apply (clarsimp simp: mask_AND_NOT_mask) - apply (clarsimp simp: and_mask_dvd_nat[where n=6, simplified]) + apply (clarsimp simp: and_mask_dvd_nat[where n=cacheLineBits, simplified]) apply (subst mask_eqs(8)[symmetric]) apply (clarsimp simp: lineStart_mask) - apply (subgoal_tac "w3 + (w2 - w1) && mask 6 = w2 && mask 6") + apply (subgoal_tac "w3 + (w2 - w1) && mask cacheLineBits = w2 && mask cacheLineBits") apply clarsimp apply (rule_tac x=w1 and y=w3 in linorder_le_cases) apply (subgoal_tac "lineStart (w3 + (w2 - w1)) - lineStart w2 = lineStart w3 - lineStart w1") @@ -482,31 +481,35 @@ lemma lineIndex_def2: lemma lineIndex_le_mono: "x \ y \ lineIndex x \ lineIndex y" - by (clarsimp simp: lineIndex_def2 cacheLineBits_def le_shiftr) + by (clarsimp simp: lineIndex_def2 le_shiftr) lemma lineIndex_lineStart_diff: - "w1 \ w2 \ (unat (lineStart w2 - lineStart w1) div 64) = unat (lineIndex w2 - lineIndex w1)" - apply (subst shiftr_div_2n'[symmetric, where n=6, simplified]) + "w1 \ w2 \ + unat (lineStart w2 - lineStart w1) div (2^cacheLineBits) = unat (lineIndex w2 - lineIndex w1)" + apply (subst shiftr_div_2n'[symmetric, where n=cacheLineBits, simplified]) apply (drule lineStart_le_mono) apply (drule sub_right_shift[OF lineStart_mask lineStart_mask]) - apply (simp add: lineIndex_def cacheLineBits_def) + apply (simp add: lineIndex_def) done +lemma unat_cacheLine_machine_word[simp]: + "unat ((2::machine_word)^cacheLineBits) = 2^cacheLineBits" + by (rule unat_p2, rule cacheLineBits_le_machine_word) + lemma cacheRangeOp_ccorres: "\\x y. empty_fail (oper x y); \n. ccorres dc xfdc \ (\\index = lineIndex w1 + of_nat n\) hs - (doMachineOp (oper (lineStart w1 + of_nat n * 0x40) - (lineStart w3 + of_nat n * 0x40))) + (doMachineOp (oper (lineStart w1 + of_nat n * (2^cacheLineBits)) + (lineStart w3 + of_nat n * (2^cacheLineBits)))) f; \s. \\\<^bsub>/UNIV\<^esub> {s} f ({t. index_' t = index_' s}) \ \ ccorres dc xfdc (\_. w1 \ w2 \ w3 \ w3 + (w2 - w1) - \ w1 && mask 6 = w3 && mask 6) - (\\index = w1 >> 6\) hs + \ w1 && mask cacheLineBits = w3 && mask cacheLineBits) + (\\index = w1 >> cacheLineBits\) hs (doMachineOp (cacheRangeOp oper w1 w2 w3)) - (While \\index < (w2 >> 6) + 1\ + (While \\index < (w2 >> cacheLineBits) + 1\ (f;; \index :== \index + 1))" - apply (clarsimp simp: cacheRangeOp_def doMachineOp_mapM_x split_def - cacheLine_def cacheLineBits_def) + apply (clarsimp simp: cacheRangeOp_def doMachineOp_mapM_x split_def cacheLine_def) apply (rule ccorres_gen_asm[where G=\, simplified]) apply (rule ccorres_guard_imp) apply (rule ccorres_rel_imp) @@ -520,7 +523,7 @@ lemma cacheRangeOp_ccorres: apply (subst min_absorb1[OF order_eq_refl]) apply (erule (2) cachRangeOp_corres_helper) apply (simp add: lineIndex_lineStart_diff) - apply (simp add: lineIndex_def2 cacheLineBits_def) + apply (simp add: lineIndex_def2) apply unat_arith apply wp apply (clarsimp simp: length_upto_enum_step lineStart_le_mono unat_div) @@ -529,36 +532,41 @@ lemma cacheRangeOp_ccorres: apply (simp add: lineIndex_lineStart_diff unat_sub[OF lineIndex_le_mono]) apply (subst le_add_diff_inverse) apply (simp add: lineIndex_le_mono word_le_nat_alt[symmetric]) - apply (simp add: lineIndex_def2 cacheLineBits_def) - apply (rule unat_mono[where 'a=32 and b="0xFFFFFFFF", simplified]) - apply word_bitwise - apply (simp add: lineIndex_def cacheLineBits_def lineStart_def) + apply (simp add: lineIndex_def2) + apply (rule less_le_trans) + apply (rule unat_mono[where 'a=machine_word_len and b="mask word_bits"]) + apply (rule shiftr_cacheLineBits_less_mask_word_bits) + apply (simp add: mask_def word_bits_def unat_max_word) + apply (simp add: lineIndex_def lineStart_def) done lemma lineStart_eq_minus_mask: - "lineStart w1 = w1 - (w1 && mask 6)" - by (simp add: lineStart_def cacheLineBits_def mask_out_sub_mask[symmetric] and_not_mask) + "lineStart w1 = w1 - (w1 && mask cacheLineBits)" + by (simp add: lineStart_def mask_out_sub_mask[symmetric] and_not_mask) lemma lineStart_idem[simp]: "lineStart (lineStart x) = lineStart x" - by (simp add: lineStart_def cacheLineBits_def) + by (simp add: lineStart_def) lemma cache_range_lineIndex_helper: - "lineIndex w1 + of_nat n << 6 = w1 - (w1 && mask 6) + of_nat n * 0x40" - apply (clarsimp simp: lineIndex_def cacheLineBits_def word_shiftl_add_distrib lineStart_def[symmetric, unfolded cacheLineBits_def] lineStart_eq_minus_mask[symmetric]) + "lineIndex w1 + of_nat n << cacheLineBits = + w1 - (w1 && mask cacheLineBits) + of_nat n * (2^cacheLineBits)" + apply (clarsimp simp: lineIndex_def word_shiftl_add_distrib lineStart_def[symmetric] + lineStart_eq_minus_mask[symmetric]) apply (simp add: shiftl_t2n) done lemma cleanCacheRange_PoC_ccorres: "ccorres dc xfdc (\_. w1 \ w2 \ w3 \ w3 + (w2 - w1) - \ w1 && mask 6 = w3 && mask 6) + \ w1 && mask cacheLineBits = w3 && mask cacheLineBits) (\\start = w1\ \ \\end = w2\ \ \\pstart = w3\) [] (doMachineOp (cleanCacheRange_PoC w1 w2 w3)) (Call cleanCacheRange_PoC_'proc)" apply (rule ccorres_gen_asm[where G=\, simplified]) apply (cinit' lift: start_' end_' pstart_') + apply (fold cacheLineBits_val) (* make CACHE_LINE_SIZE_BITS value symbolic *) apply (clarsimp simp: cleanCacheRange_PoC_def word_sle_def whileAnno_def) apply csymbr apply (rule cacheRangeOp_ccorres) @@ -568,22 +576,24 @@ lemma cleanCacheRange_PoC_ccorres: apply (rule ccorres_guard_imp2) apply csymbr apply (ctac add: cleanByVA_ccorres) - apply (clarsimp simp: lineStart_def cacheLineBits_def shiftr_shiftl1 - mask_out_sub_mask) - apply (drule_tac s="w1 && mask 6" in sym, simp add: cache_range_lineIndex_helper) + apply (clarsimp simp: lineStart_def shiftr_shiftl1 mask_out_sub_mask) + apply (drule_tac s="w1 && mask cacheLineBits" in sym, simp add: cache_range_lineIndex_helper) apply (vcg exspec=cleanByVA_modifies) apply clarsimp done lemma cleanInvalidateCacheRange_RAM_ccorres: - "ccorres dc xfdc ((\s. unat (w2 - w1) \ gsMaxObjectSize s) - and (\_. w1 \ w2 \ w3 \ w3 + (w2 - w1) - \ w1 && mask 6 = w3 && mask 6 \ unat (w2 - w2) \ gsMaxObjectSize s)) - (\\start = w1\ \ \\end = w2\ \ \\pstart = w3\) [] + "ccorres dc xfdc + ((\s. unat (w2 - w1) \ gsMaxObjectSize s) and + (\_. w1 \ w2 \ w3 \ w3 + (w2 - w1) \ + w1 && mask cacheLineBits = w3 && mask cacheLineBits \ + unat (w2 - w2) \ gsMaxObjectSize s)) + (\\start = w1\ \ \\end = w2\ \ \\pstart = w3\) [] (doMachineOp (cleanInvalidateCacheRange_RAM w1 w2 w3)) (Call cleanInvalidateCacheRange_RAM_'proc)" apply (rule ccorres_gen_asm) apply (cinit' lift: start_' end_' pstart_') + apply (fold cacheLineBits_val) (* make CACHE_LINE_SIZE_BITS value symbolic *) apply (clarsimp simp: word_sle_def whileAnno_def) apply (rule ccorres_Guard_Seq) apply (rule ccorres_basic_srnoop) @@ -602,9 +612,8 @@ lemma cleanInvalidateCacheRange_RAM_ccorres: apply (rule ccorres_guard_imp2) apply csymbr apply (ctac add: cleanInvalByVA_ccorres) - apply (clarsimp simp: lineStart_def cacheLineBits_def shiftr_shiftl1 - mask_out_sub_mask) - apply (drule_tac s="w1 && mask 6" in sym, simp add: cache_range_lineIndex_helper) + apply (clarsimp simp: lineStart_def shiftr_shiftl1 mask_out_sub_mask) + apply (drule_tac s="w1 && mask cacheLineBits" in sym, simp add: cache_range_lineIndex_helper) apply (vcg exspec=cleanInvalByVA_modifies) apply (rule ceqv_refl) apply (ctac (no_vcg) add: dsb_ccorres) @@ -615,7 +624,7 @@ lemma cleanInvalidateCacheRange_RAM_ccorres: lemma cleanCacheRange_RAM_ccorres: "ccorres dc xfdc (\s. w1 \ w2 \ w3 \ w3 + (w2 - w1) - \ w1 && mask 6 = w3 && mask 6 + \ w1 && mask cacheLineBits = w3 && mask cacheLineBits \ unat (w2 - w1) \ gsMaxObjectSize s) (\\start = w1\ \ \\end = w2\ \ \\pstart = w3\) [] (doMachineOp (cleanCacheRange_RAM w1 w2 w3)) @@ -640,12 +649,13 @@ lemma cleanCacheRange_RAM_ccorres: lemma cleanCacheRange_PoU_ccorres: "ccorres dc xfdc ((\s. unat (w2 - w1) \ gsMaxObjectSize s) and (\_. w1 \ w2 \ w3 \ w3 + (w2 - w1) - \ w1 && mask 6 = w3 && mask 6)) + \ w1 && mask cacheLineBits = w3 && mask cacheLineBits)) (\\start = w1\ \ \\end = w2\ \ \\pstart = w3\) [] (doMachineOp (cleanCacheRange_PoU w1 w2 w3)) (Call cleanCacheRange_PoU_'proc)" apply (rule ccorres_gen_asm) apply (cinit' lift: start_' end_' pstart_') + apply (fold cacheLineBits_val) (* make CACHE_LINE_SIZE_BITS value symbolic *) apply (clarsimp simp: word_sle_def whileAnno_def) apply (rule ccorres_Guard_Seq) apply (rule ccorres_basic_srnoop2, simp) @@ -658,9 +668,8 @@ lemma cleanCacheRange_PoU_ccorres: apply (rule ccorres_guard_imp2) apply csymbr apply (ctac add: cleanByVA_PoU_ccorres) - apply (clarsimp simp: lineStart_def cacheLineBits_def shiftr_shiftl1 - mask_out_sub_mask) - apply (drule_tac s="w1 && mask 6" in sym, simp add: cache_range_lineIndex_helper) + apply (clarsimp simp: lineStart_def shiftr_shiftl1 mask_out_sub_mask) + apply (drule_tac s="w1 && mask cacheLineBits" in sym, simp add: cache_range_lineIndex_helper) apply (vcg exspec=cleanByVA_PoU_modifies) apply clarsimp apply (frule(1) ghost_assertion_size_logic) @@ -674,12 +683,13 @@ lemma dmo_if: lemma invalidateCacheRange_RAM_ccorres: "ccorres dc xfdc ((\s. unat (w2 - w1) \ gsMaxObjectSize s) and (\_. w1 \ w2 \ w3 \ w3 + (w2 - w1) - \ w1 && mask 6 = w3 && mask 6)) + \ w1 && mask cacheLineBits = w3 && mask cacheLineBits)) (\\start = w1\ \ \\end = w2\ \ \\pstart = w3\) [] (doMachineOp (invalidateCacheRange_RAM w1 w2 w3)) (Call invalidateCacheRange_RAM_'proc)" apply (rule ccorres_gen_asm) apply (cinit' lift: start_' end_' pstart_') + apply (fold cacheLineBits_val) (* make CACHE_LINE_SIZE_BITS value symbolic *) apply (clarsimp simp: word_sle_def whileAnno_def split del: if_split) apply (simp add: invalidateCacheRange_RAM_def doMachineOp_bind when_def empty_fail_invalidateL2Range empty_fail_invalidateByVA @@ -687,19 +697,18 @@ lemma invalidateCacheRange_RAM_ccorres: split del: if_split) apply (rule ccorres_split_nothrow_novcg) apply (rule ccorres_cond[where R=\]) - apply (clarsimp simp: lineStart_def cacheLineBits_def) + apply (clarsimp simp: lineStart_def) apply (rule ccorres_call[OF cleanCacheRange_RAM_ccorres, where xf'=xfdc], (clarsimp)+) apply (rule ccorres_return_Skip) apply ceqv apply (rule ccorres_split_nothrow_novcg) apply (rule ccorres_cond[where R=\]) - apply (clarsimp simp: lineStart_def cacheLineBits_def) + apply (clarsimp simp: lineStart_def) apply csymbr apply (rule ccorres_call[OF cleanCacheRange_RAM_ccorres, where xf'=xfdc], (clarsimp)+) apply (rule ccorres_return_Skip) apply ceqv - apply (rule_tac P="\s. unat (w2 - w1) \ gsMaxObjectSize s" - in ccorres_cross_over_guard) + apply (rule_tac P="\s. unat (w2 - w1) \ gsMaxObjectSize s" in ccorres_cross_over_guard) apply (rule ccorres_Guard_Seq) apply (rule ccorres_basic_srnoop2, simp) apply (ctac add: plat_invalidateL2Range_ccorres) @@ -714,9 +723,8 @@ lemma invalidateCacheRange_RAM_ccorres: apply (rule ccorres_guard_imp2) apply csymbr apply (ctac add: invalidateByVA_ccorres) - apply (clarsimp simp: lineStart_def cacheLineBits_def shiftr_shiftl1 - mask_out_sub_mask) - apply (drule_tac s="w1 && mask 6" in sym, simp add: cache_range_lineIndex_helper) + apply (clarsimp simp: lineStart_def shiftr_shiftl1 mask_out_sub_mask) + apply (drule_tac s="w1 && mask cacheLineBits" in sym, simp add: cache_range_lineIndex_helper) apply (vcg exspec=invalidateByVA_modifies) apply ceqv apply (ctac add: dsb_ccorres) @@ -728,7 +736,7 @@ lemma invalidateCacheRange_RAM_ccorres: apply (simp add: guard_is_UNIV_def) apply (auto dest: ghost_assertion_size_logic simp: o_def)[1] apply (wp | clarsimp split: if_split)+ - apply (clarsimp simp: lineStart_def cacheLineBits_def guard_is_UNIV_def) + apply (clarsimp simp: lineStart_def guard_is_UNIV_def) apply (clarsimp simp: lineStart_mask) apply (subst mask_eqs(7)[symmetric]) apply (subst mask_eqs(8)[symmetric]) @@ -737,7 +745,7 @@ lemma invalidateCacheRange_RAM_ccorres: lemma invalidateCacheRange_I_ccorres: "ccorres dc xfdc (\_. w1 \ w2 \ w3 \ w3 + (w2 - w1) - \ w1 && mask 6 = w3 && mask 6) + \ w1 && mask cacheLineBits = w3 && mask cacheLineBits) (\\start = w1\ \ \\end = w2\ \ \\pstart = w3\) [] (doMachineOp (invalidateCacheRange_I w1 w2 w3)) (Call invalidateCacheRange_I_'proc)" @@ -750,12 +758,13 @@ lemma invalidateCacheRange_I_ccorres: lemma branchFlushRange_ccorres: "ccorres dc xfdc (\_. w1 \ w2 \ w3 \ w3 + (w2 - w1) - \ w1 && mask 6 = w3 && mask 6) + \ w1 && mask cacheLineBits = w3 && mask cacheLineBits) (\\start = w1\ \ \\end = w2\ \ \\pstart = w3\) [] (doMachineOp (branchFlushRange w1 w2 w3)) (Call branchFlushRange_'proc)" apply (rule ccorres_gen_asm[where G=\, simplified]) apply (cinit' lift: start_' end_' pstart_') + apply (fold cacheLineBits_val) (* make CACHE_LINE_SIZE_BITS value symbolic *) apply (clarsimp simp: word_sle_def whileAnno_def) apply (simp add: branchFlushRange_def) apply csymbr @@ -766,9 +775,8 @@ lemma branchFlushRange_ccorres: apply (rule ccorres_guard_imp2) apply csymbr apply (ctac add: branchFlush_ccorres) - apply (clarsimp simp: lineStart_def cacheLineBits_def shiftr_shiftl1 - mask_out_sub_mask) - apply (drule_tac s="w1 && mask 6" in sym, simp add: cache_range_lineIndex_helper) + apply (clarsimp simp: lineStart_def shiftr_shiftl1 mask_out_sub_mask) + apply (drule_tac s="w1 && mask cacheLineBits" in sym, simp add: cache_range_lineIndex_helper) apply (vcg exspec=branchFlush_modifies) apply clarsimp done diff --git a/proof/crefine/ARM_HYP/Recycle_C.thy b/proof/crefine/ARM_HYP/Recycle_C.thy index cfec03c6fe..d911af5641 100644 --- a/proof/crefine/ARM_HYP/Recycle_C.thy +++ b/proof/crefine/ARM_HYP/Recycle_C.thy @@ -265,121 +265,109 @@ lemma clearMemory_PageCap_ccorres: apply (cinit' lift: bits_' ptr___ptr_to_unsigned_long_') apply (rule_tac P="capAligned (ArchObjectCap (PageCap False ptr undefined sz None))" in ccorres_gen_asm) - apply (rule ccorres_Guard_Seq) + apply (rule ccorres_Guard) apply (simp add: clearMemory_def) - apply (simp add: doMachineOp_bind ef_storeWord) - apply (rule ccorres_split_nothrow_novcg_dc) - apply (rule_tac P="?P" in ccorres_from_vcg[where P'=UNIV]) - apply (rule allI, rule conseqPre, vcg) - apply (clarsimp simp: valid_cap'_def capAligned_def - is_aligned_no_wrap'[OF _ word32_power_less_1]) - apply (subgoal_tac "2 \ pageBitsForSize sz") - prefer 2 - apply (simp add: pageBitsForSize_def split: vmpage_size.split) - apply (rule conjI) - apply (erule is_aligned_weaken) - apply (clarsimp simp: pageBitsForSize_def split: vmpage_size.splits) - apply (rule conjI) - apply (rule is_aligned_power2) - apply (clarsimp simp: pageBitsForSize_def split: vmpage_size.splits) - apply (clarsimp simp: ghost_assertion_size_logic[unfolded o_def]) - apply (simp add: flex_user_data_at_rf_sr_dom_s) - apply (clarsimp simp: field_simps word_size_def mapM_x_storeWord_step) - apply (simp add: doMachineOp_def split_def exec_gets) - apply (simp add: select_f_def simpler_modify_def bind_def) - apply (fold replicateHider_def)[1] - apply (subst coerce_heap_update_to_heap_updates' - [where chunk=4096 and m="2 ^ (pageBitsForSize sz - pageBits)"]) - apply (simp add: pageBitsForSize_def pageBits_def - split: vmpage_size.split) - apply (subst coerce_memset_to_heap_update_user_data) - apply (subgoal_tac "\p<2 ^ (pageBitsForSize sz - pageBits). - x \\<^sub>c (Ptr (ptr + of_nat p * 0x1000) :: user_data_C ptr)") - prefer 2 - apply (erule allfEI[where f=of_nat]) - apply clarsimp - apply (subst(asm) of_nat_power, assumption) - apply simp - apply (insert pageBitsForSize_32 [of sz])[1] - apply (erule order_le_less_trans [rotated]) - apply simp - apply (simp, drule ko_at_projectKO_opt[OF user_data_at_ko]) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def cpspace_relation_def) - apply (erule cmap_relationE1, simp(no_asm) add: heap_to_user_data_def Let_def) - apply fastforce - subgoal by (simp add: pageBits_def typ_heap_simps) - apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def) - apply (clarsimp simp: cpspace_relation_def typ_heap_simps - clift_foldl_hrs_mem_update foldl_id - carch_state_relation_def - cmachine_state_relation_def - foldl_fun_upd_const[unfolded fun_upd_def] - power_user_page_foldl_zero_ranges - dom_heap_to_device_data) - apply (rule conjI[rotated]) - apply (simp add:pageBitsForSize_mess_multi) - apply (rule cmap_relationI) - apply (clarsimp simp: dom_heap_to_device_data cmap_relation_def) - apply (simp add:cuser_user_data_device_relation_def) - apply (subst help_force_intvl_range_conv, assumption) - subgoal by (simp add: pageBitsForSize_def split: vmpage_size.split) - apply assumption - apply (subst heap_to_user_data_update_region) - apply (drule map_to_user_data_aligned, clarsimp) - apply (rule aligned_range_offset_mem[where m=pageBits], simp_all)[1] - apply (rule pbfs_atleast_pageBits) - apply (erule cmap_relation_If_upd) - apply (clarsimp simp: cuser_user_data_relation_def order_less_le_trans[OF unat_lt2p]) - apply (simp add: update_ti_t_word32_0s) - apply (rule image_cong[OF _ refl]) - apply (rule set_eqI, rule iffI) - apply (clarsimp simp del: atLeastAtMost_iff) - apply (drule map_to_user_data_aligned, clarsimp) - apply (simp only: mask_in_range[symmetric]) - apply (rule_tac x="unat ((xa && mask (pageBitsForSize sz)) >> pageBits)" in image_eqI) - apply (simp add: subtract_mask(2)[symmetric]) - apply (cut_tac w="xa - ptr" and n=pageBits in and_not_mask[symmetric]) - apply (simp add: shiftl_t2n field_simps pageBits_def) - apply (subst is_aligned_neg_mask_eq, simp_all)[1] - apply (erule aligned_sub_aligned, simp_all add: word_bits_def)[1] - apply (erule is_aligned_weaken) - apply (rule pbfs_atleast_pageBits[unfolded pageBits_def]) - apply simp - apply (rule unat_less_power) - apply (fold word_bits_def, simp) - apply (rule shiftr_less_t2n) - apply (simp add: pbfs_atleast_pageBits) - apply (rule and_mask_less_size) - apply (simp add: word_bits_def word_size) - apply (rule IntI) - apply (clarsimp simp del: atLeastAtMost_iff) - apply (subst aligned_range_offset_mem, assumption, simp_all)[1] - apply (rule order_le_less_trans[rotated], erule shiftl_less_t2n [OF of_nat_power], - simp_all add: word_bits_def)[1] - apply (insert pageBitsForSize_32 [of sz])[1] - apply (erule order_le_less_trans [rotated]) - subgoal by simp - subgoal by (simp add: pageBits_def shiftl_t2n field_simps) - apply clarsimp - apply (drule_tac x="of_nat n" in spec) - apply (simp add: of_nat_power[where 'a=32, folded word_bits_def]) - apply (rule exI) - subgoal by (simp add: pageBits_def ko_at_projectKO_opt[OF user_data_at_ko]) + apply (rule_tac P="?P" in ccorres_from_vcg[where P'=UNIV]) + apply (rule allI, rule conseqPre, vcg) + apply (clarsimp simp: valid_cap'_def capAligned_def + is_aligned_no_wrap'[OF _ word32_power_less_1]) + apply (prop_tac "ptr \ 0", simp) + apply simp + apply (prop_tac "2 \ pageBitsForSize sz") + apply (simp add: pageBitsForSize_def split: vmpage_size.split) + apply (rule conjI) + apply (erule is_aligned_weaken, simp) + apply (rule conjI) + apply (rule is_aligned_power2, simp) + apply (clarsimp simp: ghost_assertion_size_logic[unfolded o_def]) + apply (simp add: flex_user_data_at_rf_sr_dom_s) + apply (clarsimp simp: field_simps word_size_def mapM_x_storeWord_step) + apply (simp add: doMachineOp_def split_def exec_gets) + apply (simp add: select_f_def simpler_modify_def bind_def) + apply (fold replicateHider_def)[1] + apply (subst coerce_heap_update_to_heap_updates' + [where chunk=4096 and m="2 ^ (pageBitsForSize sz - pageBits)"]) + apply (simp add: pageBitsForSize_def pageBits_def + split: vmpage_size.split) + apply (subst coerce_memset_to_heap_update_user_data) + apply (subgoal_tac "\p<2 ^ (pageBitsForSize sz - pageBits). + x \\<^sub>c (Ptr (ptr + of_nat p * 0x1000) :: user_data_C ptr)") + prefer 2 + apply (erule allfEI[where f=of_nat]) + apply clarsimp + apply (subst(asm) of_nat_power, assumption) + apply simp + apply (insert pageBitsForSize_32 [of sz])[1] + apply (erule order_le_less_trans [rotated]) + apply simp + apply (simp, drule ko_at_projectKO_opt[OF user_data_at_ko]) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def cpspace_relation_def) + apply (erule cmap_relationE1, simp(no_asm) add: heap_to_user_data_def Let_def) + apply fastforce + subgoal by (simp add: pageBits_def typ_heap_simps) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def) + apply (clarsimp simp: cpspace_relation_def typ_heap_simps + clift_foldl_hrs_mem_update foldl_id + carch_state_relation_def + cmachine_state_relation_def + foldl_fun_upd_const[unfolded fun_upd_def] + power_user_page_foldl_zero_ranges + dom_heap_to_device_data) + apply (rule conjI[rotated]) + apply (simp add:pageBitsForSize_mess_multi) + apply (rule cmap_relationI) + apply (clarsimp simp: dom_heap_to_device_data cmap_relation_def) + apply (simp add:cuser_user_data_device_relation_def) + apply (subst help_force_intvl_range_conv, assumption) + subgoal by (simp add: pageBitsForSize_def split: vmpage_size.split) + apply assumption + apply (subst heap_to_user_data_update_region) + apply (drule map_to_user_data_aligned, clarsimp) + apply (rule aligned_range_offset_mem[where m=pageBits], simp_all)[1] + apply (rule pbfs_atleast_pageBits) + apply (erule cmap_relation_If_upd) + apply (clarsimp simp: cuser_user_data_relation_def order_less_le_trans[OF unat_lt2p]) + apply (simp add: update_ti_t_word32_0s) + apply (rule image_cong[OF _ refl]) + apply (rule set_eqI, rule iffI) + apply (clarsimp simp del: atLeastAtMost_iff) + apply (drule map_to_user_data_aligned, clarsimp) + apply (simp only: mask_in_range[symmetric]) + apply (rule_tac x="unat ((xa && mask (pageBitsForSize sz)) >> pageBits)" in image_eqI) + apply (simp add: subtract_mask(2)[symmetric]) + apply (cut_tac w="xa - ptr" and n=pageBits in and_not_mask[symmetric]) + apply (simp add: shiftl_t2n field_simps pageBits_def) + apply (subst is_aligned_neg_mask_eq, simp_all)[1] + apply (erule aligned_sub_aligned, simp_all add: word_bits_def)[1] + apply (erule is_aligned_weaken) + apply (rule pbfs_atleast_pageBits[unfolded pageBits_def]) + apply simp + apply (rule unat_less_power) + apply (fold word_bits_def, simp) + apply (rule shiftr_less_t2n) + apply (simp add: pbfs_atleast_pageBits) + apply (rule and_mask_less_size) + apply (simp add: word_bits_def word_size) + apply (rule IntI) + apply (clarsimp simp del: atLeastAtMost_iff) + apply (subst aligned_range_offset_mem, assumption, simp_all)[1] + apply (rule order_le_less_trans[rotated], erule shiftl_less_t2n [OF of_nat_power], + simp_all add: word_bits_def)[1] + apply (insert pageBitsForSize_32 [of sz])[1] + apply (erule order_le_less_trans [rotated]) subgoal by simp - apply csymbr - apply (ctac add: cleanCacheRange_RAM_ccorres) - apply wp - apply (simp add: guard_is_UNIV_def unat_of_nat - word_bits_def capAligned_def word_of_nat_less) + subgoal by (simp add: pageBits_def shiftl_t2n field_simps) + apply clarsimp + apply (drule_tac x="of_nat n" in spec) + apply (simp add: of_nat_power[where 'a=32, folded word_bits_def]) + apply (rule exI) + subgoal by (simp add: pageBits_def ko_at_projectKO_opt[OF user_data_at_ko]) + subgoal by simp + apply (simp add: guard_is_UNIV_def unat_of_nat + word_bits_def capAligned_def word_of_nat_less) apply (clarsimp simp: word_bits_def valid_cap'_def capAligned_def word_of_nat_less) - apply (frule is_aligned_addrFromPPtr_n, simp add: pageBitsForSize_def split: vmpage_size.splits) - by (clarsimp simp: is_aligned_no_overflow'[where n=12, simplified] - is_aligned_no_overflow'[where n=16, simplified] - is_aligned_no_overflow'[where n=21, simplified] - is_aligned_no_overflow'[where n=25, simplified] pageBits_def - is_aligned_mask[symmetric] mask_AND_less_0 - pageBitsForSize_def split: vmpage_size.splits) + done lemma coerce_memset_to_heap_update_asidpool: "heap_update_list x (replicateHider 4096 0) @@ -577,7 +565,7 @@ lemma heap_to_user_data_in_user_mem'[simp]: apply simp+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch invalidateTLBByASID for pde_mappings'[wp]: "valid_pde_mappings'" diff --git a/proof/crefine/ARM_HYP/Retype_C.thy b/proof/crefine/ARM_HYP/Retype_C.thy index 53b9ab7c7a..a960eb388c 100644 --- a/proof/crefine/ARM_HYP/Retype_C.thy +++ b/proof/crefine/ARM_HYP/Retype_C.thy @@ -20,7 +20,7 @@ instance cte_C :: array_outer_max_size instance virq_C :: array_inner_packed by intro_classes simp -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma map_option_byte_to_word_heap: @@ -4713,7 +4713,7 @@ lemma placeNewObject_pde: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) end lemma dom_disj_union: @@ -4919,7 +4919,7 @@ lemma placeNewObject_user_data: definition - createObject_hs_preconds :: "word32 \ ArchTypes_H.object_type \ nat \ bool \ kernel_state \ bool" + createObject_hs_preconds :: "word32 \ object_type \ nat \ bool \ kernel_state \ bool" where "createObject_hs_preconds regionBase newType userSize d \ (invs' and pspace_no_overlap' regionBase (getObjectSize newType userSize) @@ -4942,14 +4942,14 @@ abbreviation (* these preconds actually used throughout the proof *) abbreviation(input) - createObject_c_preconds1 :: "word32 \ ArchTypes_H.object_type \ nat \ bool \ (globals myvars) set" + createObject_c_preconds1 :: "word32 \ object_type \ nat \ bool \ (globals myvars) set" where "createObject_c_preconds1 regionBase newType userSize deviceMemory \ {s. region_actually_is_dev_bytes regionBase (2 ^ getObjectSize newType userSize) deviceMemory s}" (* these preconds used at start of proof *) definition - createObject_c_preconds :: "word32 \ ArchTypes_H.object_type \ nat \ bool \ (globals myvars) set" + createObject_c_preconds :: "word32 \ object_type \ nat \ bool \ (globals myvars) set" where "createObject_c_preconds regionBase newType userSize deviceMemory \ (createObject_c_preconds1 regionBase newType userSize deviceMemory @@ -5676,6 +5676,40 @@ lemma placeNewObject_vcpu_ccorres: apply fastforce done +lemma placeNewDataObject_dev_ccorres: + "ccorresG rf_sr \ dc xfdc + (createObject_hs_preconds regionBase newType us True + and K (APIType_capBits newType us = pageBits + us)) + ({s. region_actually_is_bytes regionBase (2 ^ (pageBits + us)) s}) + hs + (placeNewDataObject regionBase us True) + (global_htd_update (\s. (ptr_retyps (2^us) (Ptr regionBase :: user_data_device_C ptr))))" + apply (simp add: placeNewDataObject_def ccorres_cond_univ_iff) + apply (rule ccorres_guard_imp, rule placeNewObject_user_data_device, simp_all) + apply (clarsimp simp: createObject_hs_preconds_def invs'_def + valid_state'_def valid_pspace'_def) + done + +lemma placeNewDataObject_no_dev_ccorres: + "ccorresG rf_sr \ dc xfdc + (createObject_hs_preconds regionBase newType us False + and K (APIType_capBits newType us = pageBits + us)) + ({s. region_actually_is_bytes regionBase (2 ^ (pageBits + us)) s + \ (heap_list_is_zero (hrs_mem (t_hrs_' (globals s))) regionBase (2 ^ (pageBits + us)))}) + hs + (placeNewDataObject regionBase us False) + (global_htd_update (\s. (ptr_retyps (2^us) (Ptr regionBase :: user_data_C ptr))))" + apply (simp add: placeNewDataObject_def ccorres_cond_empty_iff) + apply (rule ccorres_guard_imp, rule placeNewObject_user_data, simp_all) + apply (clarsimp simp: createObject_hs_preconds_def invs'_def + valid_state'_def valid_pspace'_def) + apply (frule range_cover.sz(1), simp add: word_bits_def) + done + +crunch placeNewDataObject + for gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" + (simp: crunch_simps) + lemma Arch_createObject_ccorres: assumes t: "toAPIType newType = None" notes is_aligned_neg_mask_eq[simp del] @@ -5698,173 +5732,285 @@ proof - apply (cut_tac t) apply (case_tac newType, simp_all add: toAPIType_def bind_assoc ARMLargePageBits_def) - apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') - apply (simp add: object_type_from_H_def Kernel_C_defs) - apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - ARMLargePageBits_def ARMSmallPageBits_def - ARMSectionBits_def ARMSuperSectionBits_def asidInvalid_def - sle_positive APIType_capBits_def shiftL_nat objBits_simps - ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def - fold_eq_0_to_bool) - apply (ccorres_remove_UNIV_guard) - apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def - ARM_HYP_H.createObject_def pageBits_def - cond_second_eq_seq_ccorres modify_gsUserPages_update - intro!: ccorres_rhs_assoc) - apply ((rule ccorres_return_C | simp | wp | vcg - | (rule match_ccorres, ctac add: - placeNewDataObject_ccorres[where us=0 and newType=newType, simplified] - gsUserPages_update_ccorres[folded modify_gsUserPages_update]) - | (rule match_ccorres, csymbr))+)[1] - apply (intro conjI) - apply (clarsimp simp: createObject_hs_preconds_def - APIType_capBits_def pageBits_def) - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_small_frame_cap_lift - vmrights_to_H_def vm_rights_defs is_aligned_neg_mask_eq, - simp add: mask_def) - - \ \Page objects: could possibly fix the duplication here\ + apply (in_case "SmallPageObject") + apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') + apply (simp add: object_type_from_H_def Kernel_C_defs) + apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff + asidInvalid_def APIType_capBits_def shiftL_nat objBits_simps + ptBits_def pageBits_def word_sle_def word_sless_def fold_eq_0_to_bool) + apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps + ARM_HYP_H.createObject_def pageBits_def + cond_second_eq_seq_ccorres modify_gsUserPages_update + intro!: ccorres_rhs_assoc) + apply (rule ccorres_cases[where P=deviceMemory]) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_dev_ccorres[where us=0 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_small_frame_cap_lift + vmrights_to_H_def vm_rights_defs is_aligned_neg_mask_eq, + simp add: mask_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_no_dev_ccorres[where us=0 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr+ + apply (rule ccorres_Guard_Seq) + apply (ctac (no_vcg) add: cleanCacheRange_RAM_ccorres) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_small_frame_cap_lift + vmrights_to_H_def vm_rights_defs is_aligned_neg_mask_eq gen_framesize_to_H_def + vm_page_size_defs) + apply (simp add: mask_def) + apply wpsimp + apply (simp add: guard_is_UNIV_def) + apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs + APIType_capBits_def pageBits_def is_aligned_no_overflow_mask) + apply (rule conjI) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply (simp add: mask_def) + + apply (in_case "LargePageObject") + apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') + apply (simp add: object_type_from_H_def Kernel_C_defs) + apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff + asidInvalid_def APIType_capBits_def shiftL_nat objBits_simps + ptBits_def pageBits_def word_sle_def word_sless_def fold_eq_0_to_bool) + apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps + ARM_HYP_H.createObject_def pageBits_def + cond_second_eq_seq_ccorres modify_gsUserPages_update + intro!: ccorres_rhs_assoc) + apply (rule ccorres_cases[where P=deviceMemory]) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_dev_ccorres[where us=4 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_no_dev_ccorres[where us=4 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr+ + apply (rule ccorres_Guard_Seq) + apply (ctac (no_vcg) add: cleanCacheRange_RAM_ccorres) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wpsimp + apply (simp add: guard_is_UNIV_def) + apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs + APIType_capBits_def pageBits_def is_aligned_no_overflow_mask) + apply (rule conjI) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply (simp add: mask_def) + + apply (in_case "SectionObject") apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - ARMLargePageBits_def ARMSmallPageBits_def - ARMSectionBits_def ARMSuperSectionBits_def asidInvalid_def - sle_positive APIType_capBits_def shiftL_nat objBits_simps - ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def - fold_eq_0_to_bool) - apply (ccorres_remove_UNIV_guard) - apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def + asidInvalid_def APIType_capBits_def shiftL_nat objBits_simps + ptBits_def pageBits_def word_sle_def word_sless_def fold_eq_0_to_bool) + apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps ARM_HYP_H.createObject_def pageBits_def cond_second_eq_seq_ccorres modify_gsUserPages_update - intro!: ccorres_rhs_assoc) - apply ((rule ccorres_return_C | simp | wp | vcg - | (rule match_ccorres, ctac add: - placeNewDataObject_ccorres[where us=4 and newType=newType, simplified] - gsUserPages_update_ccorres[folded modify_gsUserPages_update]) - | (rule match_ccorres, csymbr))+)[1] - apply (intro conjI) - apply (clarsimp simp: createObject_hs_preconds_def - APIType_capBits_def pageBits_def) - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_frame_cap_lift - vmrights_to_H_def mask_def vm_rights_defs vm_page_size_defs - cl_valid_cap_def c_valid_cap_def - is_aligned_neg_mask_eq_concrete[THEN sym]) - + intro!: ccorres_rhs_assoc) + apply (rule ccorres_cases[where P=deviceMemory]) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_dev_ccorres[where us=9 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_no_dev_ccorres[where us=9 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr+ + apply (rule ccorres_Guard_Seq) + apply (ctac (no_vcg) add: cleanCacheRange_RAM_ccorres) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wpsimp + apply (simp add: guard_is_UNIV_def) + apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs + APIType_capBits_def pageBits_def is_aligned_no_overflow_mask) + apply (rule conjI) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply (simp add: mask_def) + + apply (in_case "SuperSectionObject") apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - ARMLargePageBits_def ARMSmallPageBits_def - ARMSectionBits_def ARMSuperSectionBits_def asidInvalid_def - sle_positive APIType_capBits_def shiftL_nat objBits_simps - ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def - fold_eq_0_to_bool) - apply (ccorres_remove_UNIV_guard) - apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def + asidInvalid_def APIType_capBits_def shiftL_nat objBits_simps + ptBits_def pageBits_def word_sle_def word_sless_def fold_eq_0_to_bool) + apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps ARM_HYP_H.createObject_def pageBits_def cond_second_eq_seq_ccorres modify_gsUserPages_update - intro!: ccorres_rhs_assoc) - apply ((rule ccorres_return_C | simp | wp | vcg - | (rule match_ccorres, ctac add: - placeNewDataObject_ccorres[where us=9 and newType=newType, simplified] - gsUserPages_update_ccorres[folded modify_gsUserPages_update]) - | (rule match_ccorres, csymbr))+)[1] - apply (intro conjI) - apply (clarsimp simp: createObject_hs_preconds_def - APIType_capBits_def pageBits_def) - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_frame_cap_lift - vmrights_to_H_def mask_def vm_rights_defs vm_page_size_defs - cl_valid_cap_def c_valid_cap_def - is_aligned_neg_mask_eq_concrete[THEN sym]) + intro!: ccorres_rhs_assoc) + apply (rule ccorres_cases[where P=deviceMemory]) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_dev_ccorres[where us=13 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (rule ccorres_rhs_assoc)+ + apply (rule ccorres_split_nothrow_novcg) + apply (rule placeNewDataObject_no_dev_ccorres[where us=13 and newType=newType, simplified]) + apply ceqv + apply (ctac (no_vcg) add: gsUserPages_update_ccorres[folded modify_gsUserPages_update]) + apply csymbr+ + apply (rule ccorres_Guard_Seq) + apply (ctac (no_vcg) add: cleanCacheRange_RAM_ccorres) + apply ccorres_rewrite + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def + framesize_to_H_def cap_to_H_simps cap_frame_cap_lift + vmrights_to_H_def vm_rights_defs gen_framesize_to_H_def + is_aligned_neg_mask_eq_concrete[THEN sym] + vm_page_size_defs cl_valid_cap_def c_valid_cap_def mask_def) + apply wpsimp + apply (simp add: guard_is_UNIV_def) + apply (clarsimp simp: createObject_hs_preconds_def frameSizeConstants_defs + APIType_capBits_def pageBits_def is_aligned_no_overflow_mask) + apply (rule conjI) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply (simp add: mask_def) + apply (in_case "PageTableObject") apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) - apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - ARMLargePageBits_def ARMSmallPageBits_def - ARMSectionBits_def ARMSuperSectionBits_def asidInvalid_def - sle_positive APIType_capBits_def shiftL_nat objBits_simps - ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def - fold_eq_0_to_bool) - apply (ccorres_remove_UNIV_guard) + apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff asidInvalid_def + APIType_capBits_def shiftL_nat objBits_simps + ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def) + apply (rule ccorres_rhs_assoc)+ apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def - ARM_HYP_H.createObject_def pageBits_def - cond_second_eq_seq_ccorres modify_gsUserPages_update - intro!: ccorres_rhs_assoc) - apply ((rule ccorres_return_C | simp | wp | vcg - | (rule match_ccorres, ctac add: - placeNewDataObject_ccorres[where us=13 and newType=newType, simplified] - gsUserPages_update_ccorres[folded modify_gsUserPages_update]) - | (rule match_ccorres, csymbr))+)[1] + ARM_HYP_H.createObject_def pageBits_def pt_bits_def pte_bits_def) + apply (ctac pre only: add: placeNewObject_pte[simplified]) + apply csymbr + apply (ctac (no_vcg) add: cleanCacheRange_PoU_ccorres) + apply csymbr + apply (rule ccorres_return_C; simp) + apply wp + apply wp + apply vcg + apply clarify apply (intro conjI) - apply (clarsimp simp: createObject_hs_preconds_def - APIType_capBits_def pageBits_def) + apply (clarsimp simp: invs_pspace_aligned' invs_pspace_distinct' invs_valid_global' + APIType_capBits_def invs_valid_objs' is_aligned_no_overflow_mask + invs_urz) + apply (rule conjI, simp add: mask_def) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply clarsimp apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_frame_cap_lift - vmrights_to_H_def mask_def vm_rights_defs vm_page_size_defs - cl_valid_cap_def c_valid_cap_def - is_aligned_neg_mask_eq_concrete[THEN sym]) + framesize_to_H_def cap_to_H_simps cap_page_table_cap_lift + is_aligned_neg_mask_eq vmrights_to_H_def + Kernel_C.VMReadWrite_def Kernel_C.VMNoAccess_def + Kernel_C.VMKernelOnly_def Kernel_C.VMReadOnly_def) + apply (clarsimp simp: isFrameType_def mask_def is_aligned_neg_mask_eq_concrete[THEN sym]) - \ \PageTableObject\ + apply (in_case "PageDirectoryObject") apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - ARMLargePageBits_def ARMSmallPageBits_def - ARMSectionBits_def ARMSuperSectionBits_def asidInvalid_def - sle_positive APIType_capBits_def shiftL_nat objBits_simps - ptBits_def archObjSize_def pageBits_def word_sle_def word_sless_def) - apply (ccorres_remove_UNIV_guard) + asidInvalid_def APIType_capBits_def shiftL_nat + objBits_simps archObjSize_def isFrameType_def + ptBits_def pageBits_def pdBits_def word_sle_def word_sless_def) apply (rule ccorres_rhs_assoc)+ apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def - ARM_HYP_H.createObject_def pageBits_def pt_bits_def) - apply (ctac pre only: add: placeNewObject_pte[simplified]) - apply csymbr - apply (rule ccorres_return_C) - apply simp - apply simp - apply simp - apply wp - apply vcg - apply clarify - apply (intro conjI) - apply (clarsimp simp: invs_pspace_aligned' invs_pspace_distinct' invs_valid_global' - APIType_capBits_def invs_valid_objs' - invs_urz) - apply clarsimp - apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def - framesize_to_H_def cap_to_H_simps cap_page_table_cap_lift - is_aligned_neg_mask_eq vmrights_to_H_def - Kernel_C.VMReadWrite_def Kernel_C.VMNoAccess_def - Kernel_C.VMKernelOnly_def Kernel_C.VMReadOnly_def) - apply (clarsimp simp: isFrameType_def) - apply (rule sym) - apply (simp add: is_aligned_neg_mask_eq'[symmetric] is_aligned_weaken) - - \ \PageDirectoryObject\ - apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') - apply (simp add: object_type_from_H_def Kernel_C_defs) - apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - asidInvalid_def sle_positive APIType_capBits_def shiftL_nat - objBits_simps archObjSize_def - ptBits_def pageBits_def pdBits_def word_sle_def word_sless_def) - apply (ccorres_remove_UNIV_guard) - apply (rule ccorres_rhs_assoc)+ - apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def - ARM_HYP_H.createObject_def pageBits_def pdBits_def pd_bits_def) - apply (ctac pre only: add: placeNewObject_pde[simplified]) - apply (ctac add: copyGlobalMappings_ccorres) - apply csymbr - apply (ctac add: cleanCacheRange_PoU_ccorres) - apply csymbr - apply (rule ccorres_return_C) + ARM_HYP_H.createObject_def pageBits_def pdBits_def pd_bits_def) + apply (ctac pre only: add: placeNewObject_pde[simplified]) + apply (ctac add: copyGlobalMappings_ccorres) + apply csymbr + apply (ctac add: cleanCacheRange_PoU_ccorres) + apply csymbr + apply (rule ccorres_return_C) + apply simp apply simp apply simp - apply simp - apply wp - apply clarsimp - apply vcg - apply wp + apply wp + apply clarsimp + apply vcg + apply wp apply (clarsimp simp: pageBits_def ccap_relation_def APIType_capBits_def framesize_to_H_def cap_to_H_simps cap_page_directory_cap_lift is_aligned_neg_mask_eq vmrights_to_H_def @@ -5884,16 +6030,20 @@ proof - apply (frule invs_arch_state') apply (frule range_cover.aligned) apply (frule is_aligned_addrFromPPtr_n, simp) - apply (intro conjI, simp_all add: table_bits_defs)[1] - apply fastforce - apply ((clarsimp simp: is_aligned_no_overflow'[where n=14, simplified] - field_simps is_aligned_mask[symmetric] mask_AND_less_0)+)[3] + apply (intro conjI, simp_all add: table_bits_defs)[1] + apply fastforce + apply (clarsimp simp: mask_def) + apply (simp add: is_aligned_no_overflow_mask) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (simp add: is_aligned_no_overflow_mask) + apply (clarsimp simp: is_aligned_mask[symmetric] mask_AND_less_0) + apply (simp add: mask_def) \ \VCPU\ apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_') apply (simp add: object_type_from_H_def Kernel_C_defs) apply ccorres_rewrite apply (simp add: ccorres_cond_univ_iff ccorres_cond_empty_iff - asidInvalid_def sle_positive APIType_capBits_def shiftL_nat + asidInvalid_def APIType_capBits_def shiftL_nat objBits_simps archObjSize_def word_sle_def word_sless_def) apply (clarsimp simp: hrs_htd_update ptBits_def objBits_simps archObjSize_def ARM_HYP_H.createObject_def pageBits_def pdBits_def) @@ -7691,7 +7841,7 @@ lemma APIType_capBits_min: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma createNewCaps_1_gsCNodes_p: "\\s. P (gsCNodes s p) \ p \ ptr\ createNewCaps newType ptr 1 n dev\\rv s. P (gsCNodes s p)\" @@ -7808,6 +7958,43 @@ lemma cleanCacheRange_PoU_preserves_bytes: elim!: byte_regions_unmodified_trans byte_regions_unmodified_trans[rotated], (simp_all add: h_t_valid_field)+) +lemma cleanByVA_preserves_bytes: + "\s. \\\<^bsub>/UNIV\<^esub> {s} Call cleanByVA_'proc + {t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s)) + \ byte_regions_unmodified' s t}" + apply (rule allI, rule conseqPost, rule cleanByVA_preserves_kernel_bytes[rule_format]) + apply simp_all + apply (clarsimp simp: byte_regions_unmodified_def) + done + +lemma cleanCacheRange_PoC_preserves_bytes: + "\s. \\\<^bsub>/UNIV\<^esub> {s} Call cleanCacheRange_PoC_'proc + {t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s)) + \ byte_regions_unmodified' s t}" + apply (hoare_rule HoarePartial.ProcNoRec1) + apply (clarsimp simp only: whileAnno_def) + apply (subst whileAnno_def[symmetric, where V=undefined + and I="{t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s)) + \ byte_regions_unmodified' s t}" for s]) + apply (rule conseqPre, vcg exspec=cleanByVA_preserves_bytes) + by (safe intro!: byte_regions_unmodified_hrs_mem_update + elim!: byte_regions_unmodified_trans byte_regions_unmodified_trans[rotated], + (simp_all add: h_t_valid_field)+) + +lemma cleanCacheRange_RAM_preserves_bytes: + "\s. \\\<^bsub>/UNIV\<^esub> {s} Call cleanCacheRange_RAM_'proc + {t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s)) + \ byte_regions_unmodified' s t}" + apply (hoare_rule HoarePartial.ProcNoRec1, rule allI) + apply (rule conseqPre, vcg exspec=cleanCacheRange_PoC_preserves_bytes + exspec=cleanL2Range_preserves_kernel_bytes + exspec=dsb_preserves_kernel_bytes) + apply (safe intro!: byte_regions_unmodified_hrs_mem_update + elim!: byte_regions_unmodified_trans byte_regions_unmodified_trans[rotated], + (simp_all add: h_t_valid_field)+) + apply (clarsimp simp: byte_regions_unmodified_def) + done + lemma hrs_htd_update_canon: "hrs_htd_update (\_. f (hrs_htd hrs)) hrs = hrs_htd_update f hrs" by (cases hrs, simp add: hrs_htd_update_def hrs_htd_def) @@ -7821,21 +8008,24 @@ lemma Arch_createObject_preserves_bytes: apply (hoare_rule HoarePartial.ProcNoRec1) apply clarsimp apply (rule conseqPre, vcg exspec=cap_small_frame_cap_new_modifies - exspec=cap_frame_cap_new_modifies - exspec=cap_page_table_cap_new_modifies - exspec=copyGlobalMappings_preserves_bytes - exspec=addrFromPPtr_modifies - exspec=cleanCacheRange_PoU_preserves_bytes - exspec=cap_page_directory_cap_new_modifies - exspec=cap_vcpu_cap_new_modifies) + exspec=cap_frame_cap_new_modifies + exspec=cap_page_table_cap_new_modifies + exspec=copyGlobalMappings_preserves_bytes + exspec=addrFromPPtr_modifies + exspec=cleanCacheRange_PoU_preserves_bytes + exspec=cleanCacheRange_RAM_preserves_bytes + exspec=cap_page_directory_cap_new_modifies + exspec=cap_vcpu_cap_new_modifies) + apply (clarsimp simp: vm_page_size_defs) apply (safe intro!: byte_regions_unmodified_hrs_mem_update, (simp_all add: h_t_valid_field hrs_htd_update)+) - apply (safe intro!: ptr_retyp_d ptr_retyps_out) - apply (simp_all add: object_type_from_H_def Kernel_C_defs APIType_capBits_def - split: object_type.split_asm ArchTypes_H.apiobject_type.split_asm) - apply (rule byte_regions_unmodified_flip, simp) - apply (rule byte_regions_unmodified_trans[rotated], - assumption, simp_all add: hrs_htd_update_canon hrs_htd_update) + apply (safe intro!: ptr_retyp_d ptr_retyps_out) + apply (simp_all add: object_type_from_H_def Kernel_C_defs APIType_capBits_def + split: object_type.split_asm ArchTypes_H.apiobject_type.split_asm) + apply (all \(solves \simp add: mask_def\)?\) + apply (rule byte_regions_unmodified_flip, simp, + rule byte_regions_unmodified_trans[rotated], assumption; + simp add: hrs_htd_update_canon hrs_htd_update)+ apply (drule intvlD) apply clarsimp apply (erule notE, rule intvlI) @@ -7990,6 +8180,14 @@ lemma insertNewCap_ccorres: apply (simp add: untypedZeroRange_def Let_def) done +lemma Arch_createObject_not_untyped: + "\s. \\\<^bsub>/UNIV\<^esub> + {s} Call Arch_createObject_'proc {t. cap_get_tag (ret__struct_cap_C_' t) \ scast cap_untyped_cap}" + apply (rule allI, rule conseqPre) + apply (vcg exspec=cleanCacheRange_PoU_modifies exspec=cleanCacheRange_RAM_modifies) + apply (clarsimp simp: cap_tag_defs vm_page_size_defs mask_def) + done + lemma createObject_untyped_region_is_zero_bytes: "\\. \\\<^bsub>/UNIV\<^esub> {s. let tp = (object_type_to_H (t_' s)); sz = APIType_capBits tp (unat (userSize_' s)) @@ -8001,16 +8199,13 @@ lemma createObject_untyped_region_is_zero_bytes: {t. cap_get_tag (ret__struct_cap_C_' t) = scast cap_untyped_cap \ (case untypedZeroRange (cap_to_H (the (cap_lift (ret__struct_cap_C_' t)))) of None \ True | Some (a, b) \ region_actually_is_zero_bytes a (unat ((b + 1) - a)) t)}" - apply (rule allI, rule conseqPre, vcg exspec=copyGlobalMappings_modifies - exspec=Arch_initContext_modifies - exspec=cleanCacheRange_PoU_modifies) + apply (rule allI, rule conseqPre, vcg exspec=Arch_createObject_not_untyped) apply (clarsimp simp: cap_tag_defs Let_def) apply (simp add: cap_lift_untyped_cap cap_tag_defs cap_to_H_simps cap_untyped_cap_lift_def object_type_from_H_def) apply (simp add: untypedZeroRange_def split: if_split) apply (clarsimp simp: getFreeRef_def Let_def object_type_to_H_def untypedBits_defs) - apply (simp add: APIType_capBits_def - less_mask_eq word_less_nat_alt) + apply (simp add: APIType_capBits_def less_mask_eq word_less_nat_alt) done lemma createNewObjects_ccorres: diff --git a/proof/crefine/ARM_HYP/SR_lemmas_C.thy b/proof/crefine/ARM_HYP/SR_lemmas_C.thy index 01c81782c7..e60cc5e872 100644 --- a/proof/crefine/ARM_HYP/SR_lemmas_C.thy +++ b/proof/crefine/ARM_HYP/SR_lemmas_C.thy @@ -11,7 +11,7 @@ imports "Refine.Invariants_H" begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) section "ctes" diff --git a/proof/crefine/ARM_HYP/Schedule_C.thy b/proof/crefine/ARM_HYP/Schedule_C.thy index 858e21009b..be16239f3f 100644 --- a/proof/crefine/ARM_HYP/Schedule_C.thy +++ b/proof/crefine/ARM_HYP/Schedule_C.thy @@ -11,7 +11,7 @@ begin instance tcb :: no_vcpu by intro_classes auto -(*FIXME: arch_split: move up?*) +(*FIXME: arch-split: move up?*) context Arch begin context begin global_naming global requalify_facts diff --git a/proof/crefine/ARM_HYP/StateRelation_C.thy b/proof/crefine/ARM_HYP/StateRelation_C.thy index 980e6581af..dd7513b5bd 100644 --- a/proof/crefine/ARM_HYP/StateRelation_C.thy +++ b/proof/crefine/ARM_HYP/StateRelation_C.thy @@ -8,7 +8,7 @@ theory StateRelation_C imports Wellformed_C begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "lifth p s \ the (clift (t_hrs_' s) p)" @@ -96,7 +96,7 @@ text \ which can subsequently be instantiated for @{text kernel_all_global_addresses} as well as @{text kernel_all_substitute}. \ -locale state_rel = Arch + substitute_pre + (*FIXME: arch_split*) +locale state_rel = Arch + substitute_pre + (*FIXME: arch-split*) fixes armKSKernelVSpace_C :: "machine_word \ arm_vspace_region_use" locale kernel = kernel_all_substitute + state_rel @@ -139,7 +139,7 @@ where end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition cmachine_state_relation :: "machine_state \ globals \ bool" @@ -702,7 +702,7 @@ where ((\ (d \ maxDomain \ i < l2BitmapSize)) \ abitmap2 (d, i) = 0)" -end (* interpretation Arch . (*FIXME: arch_split*) *) +end (* interpretation Arch . (*FIXME: arch-split*) *) definition region_is_bytes' :: "word32 \ nat \ heap_typ_desc \ bool" diff --git a/proof/crefine/ARM_HYP/SyscallArgs_C.thy b/proof/crefine/ARM_HYP/SyscallArgs_C.thy index f94d5c2bd8..b1674729a1 100644 --- a/proof/crefine/ARM_HYP/SyscallArgs_C.thy +++ b/proof/crefine/ARM_HYP/SyscallArgs_C.thy @@ -12,13 +12,13 @@ imports StoreWord_C DetWP begin -(*FIXME: arch_split: C kernel names hidden by Haskell names *) +(*FIXME: arch-split: C kernel names hidden by Haskell names *) context kernel_m begin abbreviation "msgRegistersC \ kernel_all_substitute.msgRegisters" lemmas msgRegistersC_def = kernel_all_substitute.msgRegisters_def end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare word_neq_0_conv[simp del] @@ -1289,7 +1289,7 @@ lemma getSyscallArg_ccorres_foo: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma invocation_eq_use_type: "\ value \ (value' :: 32 signed word); diff --git a/proof/crefine/ARM_HYP/Syscall_C.thy b/proof/crefine/ARM_HYP/Syscall_C.thy index 3476c56537..8631445958 100644 --- a/proof/crefine/ARM_HYP/Syscall_C.thy +++ b/proof/crefine/ARM_HYP/Syscall_C.thy @@ -14,7 +14,7 @@ imports Arch_C begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch replyFromKernel for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" end @@ -1628,7 +1628,7 @@ lemma virq_virq_active_set_virqEOIIRQEN_spec': \ \ret__struct_virq_C = virq_C (ARRAY _. virqSetEOIIRQEN (virq_to_H \<^bsup>s\<^esup>virq) \<^bsup>s\<^esup>v32) \" apply (hoare_rule HoarePartial.ProcNoRec1) (* force vcg to unfold non-recursive procedure *) apply vcg - apply (clarsimp simp: virq_to_H_def ARM_A.virqSetEOIIRQEN_def) + apply (clarsimp simp: virq_to_H_def ARM_HYP_A.virqSetEOIIRQEN_def) apply (case_tac virq) apply clarsimp apply (rule array_ext) @@ -1641,7 +1641,7 @@ lemma virq_virq_invalid_set_virqEOIIRQEN_spec': \ \ret__struct_virq_C = virq_C (ARRAY _. virqSetEOIIRQEN (virq_to_H \<^bsup>s\<^esup>virq) \<^bsup>s\<^esup>v32) \" apply (hoare_rule HoarePartial.ProcNoRec1) (* force vcg to unfold non-recursive procedure *) apply vcg - apply (clarsimp simp: virq_to_H_def ARM_A.virqSetEOIIRQEN_def) + apply (clarsimp simp: virq_to_H_def ARM_HYP_A.virqSetEOIIRQEN_def) apply (case_tac virq) apply clarsimp apply (rule array_ext) @@ -1654,7 +1654,7 @@ lemma virq_virq_pending_set_virqEOIIRQEN_spec': \ \ret__struct_virq_C = virq_C (ARRAY _. virqSetEOIIRQEN (virq_to_H \<^bsup>s\<^esup>virq) \<^bsup>s\<^esup>v32) \" apply (hoare_rule HoarePartial.ProcNoRec1) (* force vcg to unfold non-recursive procedure *) apply vcg - apply (clarsimp simp: virq_to_H_def ARM_A.virqSetEOIIRQEN_def) + apply (clarsimp simp: virq_to_H_def ARM_HYP_A.virqSetEOIIRQEN_def) apply (case_tac virq) apply clarsimp apply (rule array_ext) @@ -1676,7 +1676,7 @@ lemma virqSetEOIIRQEN_id: virq_get_tag (virq_C (ARRAY _. idx)) \ scast virq_virq_pending; virq_get_tag (virq_C (ARRAY _. idx)) \ scast virq_virq_invalid \ \ virqSetEOIIRQEN idx 0 = idx" - apply (clarsimp simp: ARM_A.virqSetEOIIRQEN_def virq_get_tag_def virq_tag_defs mask_def + apply (clarsimp simp: ARM_HYP_A.virqSetEOIIRQEN_def virq_get_tag_def virq_tag_defs mask_def split: if_split) apply (rule_tac x="idx >> 28" in two_bits_cases; simp) done diff --git a/proof/crefine/ARM_HYP/Tcb_C.thy b/proof/crefine/ARM_HYP/Tcb_C.thy index 761e00e61f..9f710990d7 100644 --- a/proof/crefine/ARM_HYP/Tcb_C.thy +++ b/proof/crefine/ARM_HYP/Tcb_C.thy @@ -58,7 +58,7 @@ lemma doMachineOp_sched: apply fastforce done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch restart for curThread[wp]: "\s. P (ksCurThread s)" @@ -1090,7 +1090,7 @@ lemma Arch_performTransfer_ccorres: apply simp+ done -(*FIXME: arch_split: C kernel names hidden by Haskell names *) +(*FIXME: arch-split: C kernel names hidden by Haskell names *) abbreviation "frameRegistersC \ kernel_all_substitute.frameRegisters" lemmas frameRegistersC_def = kernel_all_substitute.frameRegisters_def abbreviation "gpRegistersC \ kernel_all_substitute.gpRegisters" diff --git a/proof/crefine/ARM_HYP/VSpace_C.thy b/proof/crefine/ARM_HYP/VSpace_C.thy index 37006652dd..6c150749d8 100644 --- a/proof/crefine/ARM_HYP/VSpace_C.thy +++ b/proof/crefine/ARM_HYP/VSpace_C.thy @@ -9,7 +9,7 @@ theory VSpace_C imports TcbAcc_C CSpace_C PSpace_C TcbQueue_C begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ccorres_name_pre_C: "(\s. s \ P' \ ccorres_underlying sr \ r xf arrel axf P {s} hs f g) @@ -1218,7 +1218,7 @@ lemma rf_sr_armKSNextASID: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch invalidateASID for armKSNextASID[wp]: "\s. P (armKSNextASID (ksArchState s))" @@ -2084,7 +2084,7 @@ lemma vcpu_enable_ccorres: apply (rule_tac Q'="\_. vcpu_at' v" in hoare_post_imp, fastforce) apply wpsimp apply (clarsimp simp: typ_heap_simps' Collect_const_mem cvcpu_relation_def - cvcpu_regs_relation_def Let_def cvgic_relation_def hcrVCPU_def + cvcpu_regs_relation_def Let_def cvgic_relation_def hcrVCPU_val | rule conjI | simp)+ apply (drule (1) vcpu_at_rf_sr) apply (clarsimp simp: typ_heap_simps' cvcpu_relation_def cvgic_relation_def) @@ -2668,10 +2668,12 @@ definition | ARM_HYP_H.flush_type.Unify \ (label = Kernel_C.ARMPageUnify_Instruction \ label = Kernel_C.ARMPDUnify_Instruction)" lemma doFlush_ccorres: - "ccorres dc xfdc (\s. vs \ ve \ ps \ ps + (ve - vs) \ vs && mask 6 = ps && mask 6 - \ \ahyp version translates ps into kernel virtual before flushing\ - \ ptrFromPAddr ps \ ptrFromPAddr ps + (ve - vs) - \ unat (ve - vs) \ gsMaxObjectSize s) + "ccorres dc xfdc + (\s. vs \ ve \ ps \ ps + (ve - vs) + \ vs && mask cacheLineBits = ps && mask cacheLineBits + \ \arm-hyp version translates ps into kernel virtual before flushing\ + \ ptrFromPAddr ps \ ptrFromPAddr ps + (ve - vs) + \ unat (ve - vs) \ gsMaxObjectSize s) (\flushtype_relation t \invLabel___int\ \ \\start = vs\ \ \\end = ve\ \ \\pstart = ps\) [] (doMachineOp (doFlush t vs ve ps)) (Call doFlush_'proc)" apply (cinit' lift: pstart_') @@ -2721,13 +2723,12 @@ lemma doFlush_ccorres: Kernel_C.ARMPageInvalidate_Data_def Kernel_C.ARMPDInvalidate_Data_def Kernel_C.ARMPageCleanInvalidate_Data_def Kernel_C.ARMPDCleanInvalidate_Data_def Kernel_C.ARMPageUnify_Instruction_def Kernel_C.ARMPDUnify_Instruction_def - ptrFromPAddr_mask_6 dest: ghost_assertion_size_logic[rotated] split: ARM_HYP_H.flush_type.splits) done end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch setVMRootForFlush for gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" (wp: crunch_wps) @@ -2738,7 +2739,7 @@ context kernel_m begin lemma performPageFlush_ccorres: "ccorres (K (K \) \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (invs' and K (asid \ mask asid_bits) - and (\s. ps \ ps + (ve - vs) \ vs && mask 6 = ps && mask 6 + and (\s. ps \ ps + (ve - vs) \ vs && mask cacheLineBits = ps && mask cacheLineBits \ ptrFromPAddr ps \ ptrFromPAddr ps + (ve - vs) \ unat (ve - vs) \ gsMaxObjectSize s)) (\\pd = Ptr pd\ \ \\asid = asid\ \ @@ -2911,7 +2912,7 @@ lemma setMessageInfo_ccorres: lemma performPageDirectoryInvocationFlush_ccorres: "ccorres (K (K \) \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (invs' and K (asid \ mask asid_bits) - and (\s. ps \ ps + (ve - vs) \ vs && mask 6 = ps && mask 6 + and (\s. ps \ ps + (ve - vs) \ vs && mask cacheLineBits = ps && mask cacheLineBits \ ptrFromPAddr ps \ ptrFromPAddr ps + (ve - vs) \ unat (ve - vs) \ gsMaxObjectSize s)) (\\pd = Ptr pd\ \ \\asid = asid\ \ @@ -3041,7 +3042,7 @@ lemmas unfold_checkMapping_return end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch flushPage for no_0_obj'[wp]: "no_0_obj'" end @@ -3129,18 +3130,13 @@ lemma ccorres_return_void_C': done lemma is_aligned_cache_preconds: - "\is_aligned rva n; n \ 7\ \ rva \ rva + 0x7F \ - addrFromPPtr rva \ addrFromPPtr rva + 0x7F \ rva && mask 6 = addrFromPPtr rva && mask 6" + "\is_aligned rva n; n \ 7\ \ rva \ rva + 0x7F \ addrFromPPtr rva \ addrFromPPtr rva + 0x7F" supply if_cong[cong] apply (drule is_aligned_weaken, simp) apply (rule conjI) apply (drule is_aligned_no_overflow, simp, unat_arith)[1] - apply (rule conjI) - apply (drule is_aligned_addrFromPPtr_n, simp) - apply (drule is_aligned_no_overflow, unat_arith) - apply (frule is_aligned_addrFromPPtr_n, simp) - apply (drule_tac x=7 and y=6 in is_aligned_weaken, simp)+ - apply (simp add: is_aligned_mask) + apply (drule is_aligned_addrFromPPtr_n, simp) + apply (drule is_aligned_no_overflow, unat_arith) done lemma pte_pte_invalid_new_spec: @@ -3386,7 +3382,7 @@ lemma unmapPage_ccorres: hd_map last_map typ_at_to_obj_at_arches field_simps objBits_simps archObjSize_def largePagePTEOffsets_def Let_def table_bits_defs, - clarsimp dest!: is_aligned_cache_preconds) + drule is_aligned_cache_preconds; clarsimp) apply (simp add: upto_enum_step_def upto_enum_word largePagePTEOffsets_def Let_def) apply (clarsimp simp: guard_is_UNIV_def Collect_const_mem) apply (simp add: hd_map last_map upto_enum_step_def objBits_simps archObjSize_def diff --git a/proof/crefine/ARM_HYP/Wellformed_C.thy b/proof/crefine/ARM_HYP/Wellformed_C.thy index c65d72a958..7cc8b68842 100644 --- a/proof/crefine/ARM_HYP/Wellformed_C.thy +++ b/proof/crefine/ARM_HYP/Wellformed_C.thy @@ -14,7 +14,7 @@ imports "CSpec.Substitute" begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) abbreviation cte_Ptr :: "word32 \ cte_C ptr" where "cte_Ptr == Ptr" @@ -265,7 +265,7 @@ record cte_CL = cap_CL :: cap_CL cteMDBNode_CL :: mdb_node_CL -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition cte_lift :: "cte_C \ cte_CL" @@ -529,6 +529,101 @@ lemma ucast_irq_array_guard[unfolded irq_array_size_val, simplified]: apply simp done + +text \cacheLineBits interface\ + +(* only use this inside cache op functions; see Arch_Kernel_Config_Lemmas.cacheLineBits_sanity *) +lemmas cacheLineBits_val = + cacheLineBits_def[unfolded Kernel_Config.CONFIG_L1_CACHE_LINE_SIZE_BITS_def] + +lemma cacheLineBits_le_ptBits: + "cacheLineBits \ ptBits" + using cacheLineBits_sanity + by (simp add: pt_bits_def pte_bits_def) + +(* This lemma and ptBits_leq_pdBits are for use with cacheLineBits_le_ptBits *) +lemma ptBits_leq_pageBits: + "ptBits \ pageBits" + by (simp add: pt_bits_def pte_bits_def pageBits_def) + +lemma ptBits_leq_pdBits: + "ptBits \ pdBits" + by (simp add: pt_bits_def pd_bits_def pde_bits_def pte_bits_def) + +lemma cacheLineBits_leq_pageBits: + "cacheLineBits \ pageBits" + using ptBits_leq_pageBits cacheLineBits_le_ptBits + by simp + +lemma cacheLineBits_leq_pdBits: + "cacheLineBits \ pdBits" + using ptBits_leq_pdBits cacheLineBits_le_ptBits + by simp + +lemma cacheLineBits_le_machine_word: + "cacheLineBits < LENGTH(machine_word_len)" + apply (rule le_less_trans, rule cacheLineBits_le_ptBits) + by (simp add: pt_bits_def pte_bits_def) + +lemma APIType_capBits_PageDirectoryObject_pdBits: + "APIType_capBits PageDirectoryObject us = pdBits" + by (simp add: pd_bits_def APIType_capBits_def pde_bits_def) + +lemma cacheLineBits_le_PageDirectoryObject_sz: + "cacheLineBits \ APIType_capBits PageDirectoryObject us" + using APIType_capBits_PageDirectoryObject_pdBits cacheLineBits_leq_pdBits + by simp + +lemma cacheLineBits_leq_pbfs: + "cacheLineBits \ pageBitsForSize sz" + by (rule order.trans, rule cacheLineBits_leq_pageBits, rule pbfs_atleast_pageBits) + +lemma addrFromPPtr_mask_SuperSection: + "n \ pageBitsForSize ARMSuperSection + \ addrFromPPtr ptr && mask n = ptr && mask n" + apply (simp add: addrFromPPtr_def) + apply (prop_tac "pptrBaseOffset AND mask n = 0") + apply (rule mask_zero[OF is_aligned_weaken[OF pptrBaseOffset_aligned]], simp) + apply (simp flip: mask_eqs(8)) + done + +lemma ptrFromPAddr_mask_SuperSection: + "n \ pageBitsForSize ARMSuperSection + \ ptrFromPAddr ptr && mask n = ptr && mask n" + apply (simp add: ptrFromPAddr_def) + apply (prop_tac "pptrBaseOffset AND mask n = 0") + apply (rule mask_zero[OF is_aligned_weaken[OF pptrBaseOffset_aligned]], simp) + apply (simp flip: mask_eqs(7)) + done + +lemma addrFromPPtr_mask_cacheLineBits[simp]: + "addrFromPPtr ptr && mask cacheLineBits = ptr && mask cacheLineBits" + by (rule addrFromPPtr_mask_SuperSection, rule cacheLineBits_leq_pbfs) + +lemma ptrFromPAddr_mask_cacheLineBits[simp]: + "ptrFromPAddr ptr && mask cacheLineBits = ptr && mask cacheLineBits" + by (rule ptrFromPAddr_mask_SuperSection, rule cacheLineBits_leq_pbfs) + +lemma shiftr_cacheLineBits_less_mask_word_bits: + "x >> cacheLineBits < mask word_bits" for x :: machine_word + using shiftr_less_max_mask[where n=cacheLineBits and x=x] cacheLineBits_sanity + by (simp add: word_bits_def) + + +text \hcrVCPU interface\ + +arch_requalify_facts hcrCommon_def hcrTWE_def hcrTWI_def + +(* hcrVCPU can have two values, based on configuration. We only need need the numerical value + to match with C, no other computations depend on it *) +schematic_goal hcrVCPU_val: + "hcrVCPU = ?val" + by (simp add: hcrVCPU_def hcrCommon_def hcrTWE_def hcrTWI_def + Kernel_Config.config_DISABLE_WFI_WFE_TRAPS_def) + +(* end of Kernel_Config interface section *) + + (* Input abbreviations for API object types *) (* disambiguates names *) diff --git a/proof/crefine/RISCV64/ADT_C.thy b/proof/crefine/RISCV64/ADT_C.thy index 7fe13dbe81..6c3fe1fc81 100644 --- a/proof/crefine/RISCV64/ADT_C.thy +++ b/proof/crefine/RISCV64/ADT_C.thy @@ -196,7 +196,7 @@ end consts Init_C' :: "unit observable \ cstate global_state set" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "Init_C \ \((tc,s),m,e). Init_C' ((tc, truncate_state s),m,e)" @@ -568,7 +568,7 @@ lemma carch_state_to_H_correct: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma tcb_queue_rel_unique: "hp NULL = None \ diff --git a/proof/crefine/RISCV64/Arch_C.thy b/proof/crefine/RISCV64/Arch_C.thy index 215801d28c..693ace70e1 100644 --- a/proof/crefine/RISCV64/Arch_C.thy +++ b/proof/crefine/RISCV64/Arch_C.thy @@ -12,7 +12,7 @@ begin unbundle l4v_word_context -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch unmapPageTable for gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" diff --git a/proof/crefine/RISCV64/CLevityCatch.thy b/proof/crefine/RISCV64/CLevityCatch.thy index fd35a1bad9..14dfa14e30 100644 --- a/proof/crefine/RISCV64/CLevityCatch.thy +++ b/proof/crefine/RISCV64/CLevityCatch.thy @@ -14,7 +14,7 @@ imports Boolean_C begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* Short-hand for unfolding cumbersome machine constants *) (* FIXME MOVE these should be in refine, and the _eq forms should NOT be declared [simp]! *) diff --git a/proof/crefine/RISCV64/DetWP.thy b/proof/crefine/RISCV64/DetWP.thy index bf29a7aa06..979a780f4e 100644 --- a/proof/crefine/RISCV64/DetWP.thy +++ b/proof/crefine/RISCV64/DetWP.thy @@ -10,7 +10,7 @@ theory DetWP imports "Lib.DetWPLib" "CBaseRefine.Include_C" begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma det_wp_doMachineOp [wp]: "det_wp (\_. P) f \ det_wp (\_. P) (doMachineOp f)" diff --git a/proof/crefine/RISCV64/Invoke_C.thy b/proof/crefine/RISCV64/Invoke_C.thy index 2d37d2e174..6eb2c54a5c 100644 --- a/proof/crefine/RISCV64/Invoke_C.thy +++ b/proof/crefine/RISCV64/Invoke_C.thy @@ -1301,7 +1301,7 @@ lemma decodeCNodeInvocation_ccorres: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas setCTE_def3 = setCTE_def2[THEN eq_reflection] @@ -2696,10 +2696,10 @@ lemma ctes_of_ex_cte_cap_to': lemma Arch_isFrameType_spec: - "\s. \ \ \s. unat \type \ fromEnum (maxBound::ArchTypes_H.object_type)\ + "\s. \ \ \s. unat \type \ fromEnum (maxBound::object_type)\ Call Arch_isFrameType_'proc \ \ret__unsigned_long = - from_bool (isFrameType ((toEnum (unat \<^bsup>s\<^esup> type))::ArchTypes_H.object_type))\" + from_bool (isFrameType ((toEnum (unat \<^bsup>s\<^esup> type))::object_type))\" apply vcg apply (simp add: toEnum_object_type_to_H) apply (frule object_type_from_to_H) diff --git a/proof/crefine/RISCV64/Ipc_C.thy b/proof/crefine/RISCV64/Ipc_C.thy index 52392b3cc6..5caf1bad09 100644 --- a/proof/crefine/RISCV64/Ipc_C.thy +++ b/proof/crefine/RISCV64/Ipc_C.thy @@ -14,7 +14,7 @@ imports IsolatedThreadAction begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "replyFromKernel_success_empty thread \ do @@ -291,7 +291,7 @@ lemma ccap_relation_reply_helpers: cap_reply_cap_lift_def word_size elim!: ccap_relationE) -(*FIXME: arch_split: C kernel names hidden by Haskell names *) +(*FIXME: arch-split: C kernel names hidden by Haskell names *) (*FIXME: fupdate simplification issues for 2D arrays *) abbreviation "syscallMessageC \ kernel_all_global_addresses.fault_messages.[unat MessageID_Syscall]" lemmas syscallMessageC_def = kernel_all_substitute.fault_messages_def @@ -314,7 +314,7 @@ lemma syscallMessage_ccorres: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "handleArchFaultReply' f sender receiver tag \ do @@ -1145,7 +1145,7 @@ lemma setMR_ccorres_dc: end (* FIXME: move *) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch setMR for valid_pspace'[wp]: "valid_pspace'" crunch setMR diff --git a/proof/crefine/RISCV64/IsolatedThreadAction.thy b/proof/crefine/RISCV64/IsolatedThreadAction.thy index 8e7892a042..8cf5825d06 100644 --- a/proof/crefine/RISCV64/IsolatedThreadAction.thy +++ b/proof/crefine/RISCV64/IsolatedThreadAction.thy @@ -108,7 +108,7 @@ lemma isolate_thread_actions_bind: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setObject_modify: fixes v :: "'a :: pspace_storable" shows @@ -158,7 +158,7 @@ lemma partial_overwrite_fun_upd: apply (clarsimp split: if_split) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma get_tcb_state_regs_ko_at': "ko_at' ko p s \ get_tcb_state_regs (ksPSpace s p) @@ -940,7 +940,7 @@ lemma bind_assoc: = do x \ m; y \ f x; g y od" by (rule bind_assoc) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setObject_modify_assert: "\updateObject v = updateObject_default v\ diff --git a/proof/crefine/RISCV64/Recycle_C.thy b/proof/crefine/RISCV64/Recycle_C.thy index a297e3d4e1..9e156bf41e 100644 --- a/proof/crefine/RISCV64/Recycle_C.thy +++ b/proof/crefine/RISCV64/Recycle_C.thy @@ -536,7 +536,7 @@ lemma heap_to_user_data_in_user_mem'[simp]: apply simp+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch deleteASIDPool for gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" (wp: crunch_wps getObject_inv diff --git a/proof/crefine/RISCV64/Refine_C.thy b/proof/crefine/RISCV64/Refine_C.thy index b8ef625385..4ba4f0efae 100644 --- a/proof/crefine/RISCV64/Refine_C.thy +++ b/proof/crefine/RISCV64/Refine_C.thy @@ -21,7 +21,7 @@ imports CToCRefine begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch handleVMFault for ksQ[wp]: "\s. P (ksReadyQueues s)" end diff --git a/proof/crefine/RISCV64/Retype_C.thy b/proof/crefine/RISCV64/Retype_C.thy index d3d7102c8b..bb70fb4475 100644 --- a/proof/crefine/RISCV64/Retype_C.thy +++ b/proof/crefine/RISCV64/Retype_C.thy @@ -46,7 +46,7 @@ lemma zero_le_sint: "\ 0 \ (a :: machine_word); a < 0x80000000000000 apply simp done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma map_option_byte_to_word_heap: assumes disj: "\(off :: 9 word) x. x<8 \ p + ucast off * 8 + x \ S " (*9=page table index*) @@ -5723,7 +5723,7 @@ lemma placeNewObject_user_data: done definition - createObject_hs_preconds :: "machine_word \ ArchTypes_H.object_type \ nat \ bool \ kernel_state \ bool" + createObject_hs_preconds :: "machine_word \ object_type \ nat \ bool \ kernel_state \ bool" where "createObject_hs_preconds regionBase newType userSize d \ (invs' and (\s. sym_refs (state_refs_of' s)) @@ -5748,14 +5748,14 @@ abbreviation (* these preconds actually used throughout the proof *) abbreviation(input) - createObject_c_preconds1 :: "machine_word \ ArchTypes_H.object_type \ nat \ bool \ (globals myvars) set" + createObject_c_preconds1 :: "machine_word \ object_type \ nat \ bool \ (globals myvars) set" where "createObject_c_preconds1 regionBase newType userSize deviceMemory \ {s. region_actually_is_dev_bytes regionBase (2 ^ getObjectSize newType userSize) deviceMemory s}" (* these preconds used at start of proof *) definition - createObject_c_preconds :: "machine_word \ ArchTypes_H.object_type \ nat \ bool \ (globals myvars) set" + createObject_c_preconds :: "machine_word \ object_type \ nat \ bool \ (globals myvars) set" where "createObject_c_preconds regionBase newType userSize deviceMemory \ (createObject_c_preconds1 regionBase newType userSize deviceMemory @@ -7925,7 +7925,7 @@ lemma APIType_capBits_min: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma createNewCaps_1_gsCNodes_p: "\\s. P (gsCNodes s p) \ p \ ptr\ createNewCaps newType ptr 1 n dev\\rv s. P (gsCNodes s p)\" diff --git a/proof/crefine/RISCV64/SR_lemmas_C.thy b/proof/crefine/RISCV64/SR_lemmas_C.thy index f004d6ca24..47004f01b8 100644 --- a/proof/crefine/RISCV64/SR_lemmas_C.thy +++ b/proof/crefine/RISCV64/SR_lemmas_C.thy @@ -12,7 +12,7 @@ imports "Refine.Invariants_H" begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) section "vm rights" diff --git a/proof/crefine/RISCV64/Schedule_C.thy b/proof/crefine/RISCV64/Schedule_C.thy index a312834f69..3c69e7b7e2 100644 --- a/proof/crefine/RISCV64/Schedule_C.thy +++ b/proof/crefine/RISCV64/Schedule_C.thy @@ -10,7 +10,7 @@ theory Schedule_C imports Tcb_C Retype_C begin -(*FIXME: arch_split: move up?*) +(*FIXME: arch-split: move up?*) context Arch begin context begin global_naming global requalify_facts diff --git a/proof/crefine/RISCV64/StateRelation_C.thy b/proof/crefine/RISCV64/StateRelation_C.thy index 707a2122b0..5b44be678d 100644 --- a/proof/crefine/RISCV64/StateRelation_C.thy +++ b/proof/crefine/RISCV64/StateRelation_C.thy @@ -10,7 +10,7 @@ theory StateRelation_C imports Wellformed_C begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "lifth p s \ the (clift (t_hrs_' s) p)" @@ -80,7 +80,7 @@ text \ which can subsequently be instantiated for @{text kernel_all_global_addresses} as well as @{text kernel_all_substitute}. \ -locale state_rel = Arch + substitute_pre + (*FIXME: arch_split*) +locale state_rel = Arch + substitute_pre + (*FIXME: arch-split*) fixes riscvKSKernelVSpace_C :: "machine_word \ riscvvspace_region_use" locale kernel = kernel_all_substitute + state_rel @@ -129,7 +129,7 @@ where end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition cmachine_state_relation :: "machine_state \ globals \ bool" @@ -789,7 +789,7 @@ where ((\ (d \ maxDomain \ i < l2BitmapSize)) \ abitmap2 (d, i) = 0)" -end (* interpretation Arch . (*FIXME: arch_split*) *) +end (* interpretation Arch . (*FIXME: arch-split*) *) definition region_is_bytes' :: "machine_word \ nat \ heap_typ_desc \ bool" diff --git a/proof/crefine/RISCV64/SyscallArgs_C.thy b/proof/crefine/RISCV64/SyscallArgs_C.thy index 2c31dd5b9e..012ac1b0a1 100644 --- a/proof/crefine/RISCV64/SyscallArgs_C.thy +++ b/proof/crefine/RISCV64/SyscallArgs_C.thy @@ -13,13 +13,13 @@ imports StoreWord_C DetWP begin -(*FIXME: arch_split: C kernel names hidden by Haskell names *) +(*FIXME: arch-split: C kernel names hidden by Haskell names *) context kernel_m begin abbreviation "msgRegistersC \ kernel_all_substitute.msgRegisters" lemmas msgRegistersC_def = kernel_all_substitute.msgRegisters_def end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare word_neq_0_conv[simp del] @@ -1664,7 +1664,7 @@ lemma getSyscallArg_ccorres_foo: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma invocation_eq_use_type: "\ value \ (value' :: 32 signed word); diff --git a/proof/crefine/RISCV64/Syscall_C.thy b/proof/crefine/RISCV64/Syscall_C.thy index 426bfb742c..2d009dc135 100644 --- a/proof/crefine/RISCV64/Syscall_C.thy +++ b/proof/crefine/RISCV64/Syscall_C.thy @@ -16,7 +16,7 @@ imports SchedContext_C begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch replyFromKernel for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" end diff --git a/proof/crefine/RISCV64/Tcb_C.thy b/proof/crefine/RISCV64/Tcb_C.thy index 099dba87cb..2967444e25 100644 --- a/proof/crefine/RISCV64/Tcb_C.thy +++ b/proof/crefine/RISCV64/Tcb_C.thy @@ -60,7 +60,7 @@ lemma doMachineOp_sched: apply fastforce done *) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch restart for curThread[wp]: "\s. P (ksCurThread s)" @@ -1168,7 +1168,7 @@ lemma Arch_performTransfer_ccorres: apply simp+ done -(*FIXME: arch_split: C kernel names hidden by Haskell names *) +(*FIXME: arch-split: C kernel names hidden by Haskell names *) abbreviation "frameRegistersC \ kernel_all_substitute.frameRegisters" lemmas frameRegistersC_def = kernel_all_substitute.frameRegisters_def abbreviation "gpRegistersC \ kernel_all_substitute.gpRegisters" diff --git a/proof/crefine/RISCV64/VSpace_C.thy b/proof/crefine/RISCV64/VSpace_C.thy index 60c62332fa..de54e0a4d1 100644 --- a/proof/crefine/RISCV64/VSpace_C.thy +++ b/proof/crefine/RISCV64/VSpace_C.thy @@ -19,7 +19,7 @@ autocorres c_locale = kernel_all_substitute ] "../c/build/$L4V_ARCH/kernel_all.c_pp" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ccorres_name_pre_C: "(\s. s \ P' \ ccorres_underlying sr \ r xf arrel axf P {s} hs f g) diff --git a/proof/crefine/RISCV64/Wellformed_C.thy b/proof/crefine/RISCV64/Wellformed_C.thy index 66c71b3d1b..37d9694458 100644 --- a/proof/crefine/RISCV64/Wellformed_C.thy +++ b/proof/crefine/RISCV64/Wellformed_C.thy @@ -16,7 +16,7 @@ imports "CSpec.Substitute" begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) abbreviation cte_Ptr :: "word64 \ cte_C ptr" where "cte_Ptr == Ptr" @@ -279,7 +279,7 @@ record cte_CL = cap_CL :: cap_CL cteMDBNode_CL :: mdb_node_CL -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition cte_lift :: "cte_C \ cte_CL" diff --git a/proof/crefine/X64/ADT_C.thy b/proof/crefine/X64/ADT_C.thy index 82672f5287..d3fa7a4f0b 100644 --- a/proof/crefine/X64/ADT_C.thy +++ b/proof/crefine/X64/ADT_C.thy @@ -201,7 +201,7 @@ end consts Init_C' :: "unit observable \ cstate global_state set" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "Init_C \ \((tc,s),m,e). Init_C' ((tc, truncate_state s),m,e)" @@ -604,7 +604,7 @@ lemma carch_state_to_H_correct: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma tcb_queue_rel_unique: "hp NULL = None \ diff --git a/proof/crefine/X64/Arch_C.thy b/proof/crefine/X64/Arch_C.thy index 668b7aa5bc..ad07f5ffad 100644 --- a/proof/crefine/X64/Arch_C.thy +++ b/proof/crefine/X64/Arch_C.thy @@ -11,7 +11,7 @@ begin unbundle l4v_word_context -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch unmapPageTable, unmapPageDirectory, unmapPDPT for gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" @@ -1468,21 +1468,6 @@ lemma obj_at_pte_aligned: elim!: is_aligned_weaken) done -(* FIXME x64: dont know what these are for yet *) -lemma addrFromPPtr_mask_5: - "addrFromPPtr ptr && mask (5::nat) = ptr && mask (5::nat)" - apply (simp add:addrFromPPtr_def X64.pptrBase_def) - apply word_bitwise - apply (simp add:mask_def) - done - -lemma addrFromPPtr_mask_6: - "addrFromPPtr ptr && mask (6::nat) = ptr && mask (6::nat)" - apply (simp add:addrFromPPtr_def X64.pptrBase_def) - apply word_bitwise - apply (simp add:mask_def) - done - lemma cpde_relation_invalid: "cpde_relation pdea pde \ (pde_get_tag pde = scast pde_pde_pt \ pde_pde_pt_CL.present_CL (pde_pde_pt_lift pde) = 0) = isInvalidPDE pdea" apply (simp add: cpde_relation_def Let_def) diff --git a/proof/crefine/X64/CLevityCatch.thy b/proof/crefine/X64/CLevityCatch.thy index e73e479189..788587750f 100644 --- a/proof/crefine/X64/CLevityCatch.thy +++ b/proof/crefine/X64/CLevityCatch.thy @@ -13,7 +13,7 @@ imports Boolean_C begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* Short-hand for unfolding cumbersome machine constants *) diff --git a/proof/crefine/X64/DetWP.thy b/proof/crefine/X64/DetWP.thy index 116016144b..6ae0fb6773 100644 --- a/proof/crefine/X64/DetWP.thy +++ b/proof/crefine/X64/DetWP.thy @@ -8,7 +8,7 @@ theory DetWP imports "Lib.DetWPLib" "CBaseRefine.Include_C" begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma det_wp_doMachineOp [wp]: "det_wp (\_. P) f \ det_wp (\_. P) (doMachineOp f)" diff --git a/proof/crefine/X64/Invoke_C.thy b/proof/crefine/X64/Invoke_C.thy index d60019524b..9b94f45d7a 100644 --- a/proof/crefine/X64/Invoke_C.thy +++ b/proof/crefine/X64/Invoke_C.thy @@ -1380,7 +1380,7 @@ lemma decodeCNodeInvocation_ccorres: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas setCTE_def3 = setCTE_def2[THEN eq_reflection] @@ -2800,10 +2800,10 @@ lemma ctes_of_ex_cte_cap_to': lemma Arch_isFrameType_spec: - "\s. \ \ \s. unat \type \ fromEnum (maxBound::ArchTypes_H.object_type)\ + "\s. \ \ \s. unat \type \ fromEnum (maxBound::object_type)\ Call Arch_isFrameType_'proc \ \ret__unsigned_long = - from_bool (isFrameType ((toEnum (unat \<^bsup>s\<^esup> type))::ArchTypes_H.object_type))\" + from_bool (isFrameType ((toEnum (unat \<^bsup>s\<^esup> type))::object_type))\" apply vcg apply (simp add: toEnum_object_type_to_H) apply (frule object_type_from_to_H) diff --git a/proof/crefine/X64/Ipc_C.thy b/proof/crefine/X64/Ipc_C.thy index cd1102418f..15040668c2 100644 --- a/proof/crefine/X64/Ipc_C.thy +++ b/proof/crefine/X64/Ipc_C.thy @@ -13,7 +13,7 @@ imports IsolatedThreadAction begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "replyFromKernel_success_empty thread \ do @@ -293,7 +293,7 @@ lemma ccap_relation_reply_helpers: cap_reply_cap_lift_def word_size elim!: ccap_relationE) -(*FIXME: arch_split: C kernel names hidden by Haskell names *) +(*FIXME: arch-split: C kernel names hidden by Haskell names *) (*FIXME: fupdate simplification issues for 2D arrays *) abbreviation "syscallMessageC \ kernel_all_global_addresses.fault_messages.[unat MessageID_Syscall]" lemmas syscallMessageC_def = kernel_all_substitute.fault_messages_def @@ -316,7 +316,7 @@ lemma syscallMessage_ccorres: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "handleArchFaultReply' f sender receiver tag \ do @@ -1016,7 +1016,7 @@ lemma setMR_ccorres_dc: end (* FIXME: move *) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch setMR for valid_pspace'[wp]: "valid_pspace'" crunch setMR diff --git a/proof/crefine/X64/IsolatedThreadAction.thy b/proof/crefine/X64/IsolatedThreadAction.thy index d7caf73cbd..20c7c11bde 100644 --- a/proof/crefine/X64/IsolatedThreadAction.thy +++ b/proof/crefine/X64/IsolatedThreadAction.thy @@ -111,7 +111,7 @@ lemmas setNotification_tcb = set_ntfn_tcb_obj_at' end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setObject_modify: fixes v :: "'a :: pspace_storable" shows @@ -162,7 +162,7 @@ lemma partial_overwrite_fun_upd: apply (clarsimp split: if_split) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma get_tcb_state_regs_ko_at': "ko_at' ko p s \ get_tcb_state_regs (ksPSpace s p) @@ -982,7 +982,7 @@ lemma bind_assoc: = do x \ m; y \ f x; g y od" by (rule bind_assoc) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setObject_modify_assert: "\ updateObject v = updateObject_default v \ diff --git a/proof/crefine/X64/Recycle_C.thy b/proof/crefine/X64/Recycle_C.thy index 568a1daa0c..213a6aaecf 100644 --- a/proof/crefine/X64/Recycle_C.thy +++ b/proof/crefine/X64/Recycle_C.thy @@ -556,7 +556,7 @@ lemma heap_to_user_data_in_user_mem'[simp]: apply simp+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch deleteASIDPool for gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" (wp: crunch_wps getObject_inv loadObject_default_inv diff --git a/proof/crefine/X64/Refine_C.thy b/proof/crefine/X64/Refine_C.thy index 9b68fde3d7..480e13078d 100644 --- a/proof/crefine/X64/Refine_C.thy +++ b/proof/crefine/X64/Refine_C.thy @@ -20,7 +20,7 @@ imports CToCRefine begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch handleVMFault for ksQ[wp]: "\s. P (ksReadyQueues s)" end diff --git a/proof/crefine/X64/Retype_C.thy b/proof/crefine/X64/Retype_C.thy index 5f4bdf4f46..122be6b735 100644 --- a/proof/crefine/X64/Retype_C.thy +++ b/proof/crefine/X64/Retype_C.thy @@ -46,7 +46,7 @@ lemma zero_le_sint: "\ 0 \ (a :: machine_word); a < 0x80000000000000 apply simp done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma map_option_byte_to_word_heap: assumes disj: "\(off :: 9 word) x. x<8 \ p + ucast off * 8 + x \ S " (*9=page table index*) @@ -5628,7 +5628,7 @@ lemma placeNewObject_user_data: done definition - createObject_hs_preconds :: "machine_word \ ArchTypes_H.object_type \ nat \ bool \ kernel_state \ bool" + createObject_hs_preconds :: "machine_word \ object_type \ nat \ bool \ kernel_state \ bool" where "createObject_hs_preconds regionBase newType userSize d \ (invs' and pspace_no_overlap' regionBase (getObjectSize newType userSize) @@ -5651,14 +5651,14 @@ abbreviation (* these preconds actually used throughout the proof *) abbreviation(input) - createObject_c_preconds1 :: "machine_word \ ArchTypes_H.object_type \ nat \ bool \ (globals myvars) set" + createObject_c_preconds1 :: "machine_word \ object_type \ nat \ bool \ (globals myvars) set" where "createObject_c_preconds1 regionBase newType userSize deviceMemory \ {s. region_actually_is_dev_bytes regionBase (2 ^ getObjectSize newType userSize) deviceMemory s}" (* these preconds used at start of proof *) definition - createObject_c_preconds :: "machine_word \ ArchTypes_H.object_type \ nat \ bool \ (globals myvars) set" + createObject_c_preconds :: "machine_word \ object_type \ nat \ bool \ (globals myvars) set" where "createObject_c_preconds regionBase newType userSize deviceMemory \ (createObject_c_preconds1 regionBase newType userSize deviceMemory @@ -7908,7 +7908,7 @@ lemma APIType_capBits_min: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma createNewCaps_1_gsCNodes_p: "\\s. P (gsCNodes s p) \ p \ ptr\ createNewCaps newType ptr 1 n dev\\rv s. P (gsCNodes s p)\" diff --git a/proof/crefine/X64/SR_lemmas_C.thy b/proof/crefine/X64/SR_lemmas_C.thy index 8b00610a92..0aa1b29c1a 100644 --- a/proof/crefine/X64/SR_lemmas_C.thy +++ b/proof/crefine/X64/SR_lemmas_C.thy @@ -10,7 +10,7 @@ imports "Refine.Invariants_H" begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) section "ctes" diff --git a/proof/crefine/X64/Schedule_C.thy b/proof/crefine/X64/Schedule_C.thy index 72020d91bb..cab2a5ab7e 100644 --- a/proof/crefine/X64/Schedule_C.thy +++ b/proof/crefine/X64/Schedule_C.thy @@ -9,7 +9,7 @@ theory Schedule_C imports Tcb_C Detype_C begin -(*FIXME: arch_split: move up?*) +(*FIXME: arch-split: move up?*) context Arch begin context begin global_naming global requalify_facts diff --git a/proof/crefine/X64/StateRelation_C.thy b/proof/crefine/X64/StateRelation_C.thy index 23d471c1da..b4aebf2435 100644 --- a/proof/crefine/X64/StateRelation_C.thy +++ b/proof/crefine/X64/StateRelation_C.thy @@ -8,7 +8,7 @@ theory StateRelation_C imports Wellformed_C begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "lifth p s \ the (clift (t_hrs_' s) p)" @@ -79,7 +79,7 @@ text \ which can subsequently be instantiated for @{text kernel_all_global_addresses} as well as @{text kernel_all_substitute}. \ -locale state_rel = Arch + substitute_pre + (*FIXME: arch_split*) +locale state_rel = Arch + substitute_pre + (*FIXME: arch-split*) fixes x64KSKernelVSpace_C :: "machine_word \ x64vspace_region_use" locale kernel = kernel_all_substitute + state_rel @@ -197,7 +197,7 @@ where end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition cmachine_state_relation :: "machine_state \ globals \ bool" @@ -863,7 +863,7 @@ where ((\ (d \ maxDomain \ i < l2BitmapSize)) \ abitmap2 (d, i) = 0)" -end (* interpretation Arch . (*FIXME: arch_split*) *) +end (* interpretation Arch . (*FIXME: arch-split*) *) definition region_is_bytes' :: "machine_word \ nat \ heap_typ_desc \ bool" diff --git a/proof/crefine/X64/SyscallArgs_C.thy b/proof/crefine/X64/SyscallArgs_C.thy index 6cf0b08990..808c4182c3 100644 --- a/proof/crefine/X64/SyscallArgs_C.thy +++ b/proof/crefine/X64/SyscallArgs_C.thy @@ -12,13 +12,13 @@ imports StoreWord_C DetWP begin -(*FIXME: arch_split: C kernel names hidden by Haskell names *) +(*FIXME: arch-split: C kernel names hidden by Haskell names *) context kernel_m begin abbreviation "msgRegistersC \ kernel_all_substitute.msgRegisters" lemmas msgRegistersC_def = kernel_all_substitute.msgRegisters_def end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare word_neq_0_conv[simp del] @@ -1196,7 +1196,7 @@ lemma getSyscallArg_ccorres_foo: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma invocation_eq_use_type: "\ value \ (value' :: 32 signed word); diff --git a/proof/crefine/X64/Syscall_C.thy b/proof/crefine/X64/Syscall_C.thy index 1deddeb2bf..adda71099e 100644 --- a/proof/crefine/X64/Syscall_C.thy +++ b/proof/crefine/X64/Syscall_C.thy @@ -14,7 +14,7 @@ imports Arch_C begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch replyFromKernel for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" end diff --git a/proof/crefine/X64/Tcb_C.thy b/proof/crefine/X64/Tcb_C.thy index aa55b64626..7c4f2dbae3 100644 --- a/proof/crefine/X64/Tcb_C.thy +++ b/proof/crefine/X64/Tcb_C.thy @@ -58,7 +58,7 @@ lemma doMachineOp_sched: apply fastforce done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch restart for curThread[wp]: "\s. P (ksCurThread s)" @@ -1098,7 +1098,7 @@ lemma Arch_performTransfer_ccorres: apply simp+ done -(*FIXME: arch_split: C kernel names hidden by Haskell names *) +(*FIXME: arch-split: C kernel names hidden by Haskell names *) abbreviation "frameRegistersC \ kernel_all_substitute.frameRegisters" lemmas frameRegistersC_def = kernel_all_substitute.frameRegisters_def abbreviation "gpRegistersC \ kernel_all_substitute.gpRegisters" diff --git a/proof/crefine/X64/VSpace_C.thy b/proof/crefine/X64/VSpace_C.thy index 192c989e5d..5da636c0d5 100644 --- a/proof/crefine/X64/VSpace_C.thy +++ b/proof/crefine/X64/VSpace_C.thy @@ -18,7 +18,7 @@ autocorres c_locale = kernel_all_substitute ] "../c/build/$L4V_ARCH/kernel_all.c_pp" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ccorres_name_pre_C: "(\s. s \ P' \ ccorres_underlying sr \ r xf arrel axf P {s} hs f g) @@ -999,7 +999,7 @@ lemma ccorres_from_vcg_might_throw: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) end diff --git a/proof/crefine/X64/Wellformed_C.thy b/proof/crefine/X64/Wellformed_C.thy index 78ad7a0e62..66d4ec6df8 100644 --- a/proof/crefine/X64/Wellformed_C.thy +++ b/proof/crefine/X64/Wellformed_C.thy @@ -14,7 +14,7 @@ imports "CSpec.Substitute" begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) abbreviation cte_Ptr :: "word64 \ cte_C ptr" where "cte_Ptr == Ptr" @@ -270,7 +270,7 @@ record cte_CL = cap_CL :: cap_CL cteMDBNode_CL :: mdb_node_CL -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition cte_lift :: "cte_C \ cte_CL" diff --git a/proof/dpolicy/Dpolicy.thy b/proof/dpolicy/Dpolicy.thy index b3a898485c..786af5eb04 100644 --- a/proof/dpolicy/Dpolicy.thy +++ b/proof/dpolicy/Dpolicy.thy @@ -23,7 +23,7 @@ downloaded from https://trustworthy.systems/publications/nictaabstracts/Klein_AEMSKH_14.abstract *) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition cdl_cap_auth_conferred :: "cdl_cap \ auth set" @@ -217,26 +217,26 @@ lemmas cdl_state_objs_to_policy_cases = cdl_state_bits_to_policy.cases[OF cdl_state_objs_to_policy_mem[THEN iffD1]] lemma transform_asid_rev [simp]: - "asid \ 2 ^ ARM_A.asid_bits - 1 \ transform_asid_rev (transform_asid asid) = asid" + "asid \ 2 ^ MiscMachine_A.asid_bits - 1 \ transform_asid_rev (transform_asid asid) = asid" apply (clarsimp simp:transform_asid_def transform_asid_rev_def - asid_high_bits_of_def ARM_A.asid_low_bits_def) + asid_high_bits_of_def asid_low_bits_def) apply (subgoal_tac "asid >> 10 < 2 ^ asid_high_bits") - apply (simp add:ARM_A.asid_high_bits_def ARM_A.asid_bits_def) + apply (simp add: MiscMachine_A.asid_high_bits_def MiscMachine_A.asid_bits_def MiscMachine_A.asid_low_bits_def) apply (subst ucast_ucast_len) apply simp apply (subst shiftr_shiftl1) apply simp apply (subst ucast_ucast_mask) apply (simp add:mask_out_sub_mask) - apply (simp add:ARM_A.asid_high_bits_def) - apply (rule shiftr_less_t2n[where m=7, simplified]) - apply (simp add:ARM_A.asid_bits_def) + apply (simp add: asid_high_bits_def) + apply (rule shiftr_less_t2n[where m=MiscMachine_A.asid_high_bits, simplified]) + apply (simp add: MiscMachine_A.asid_bits_def MiscMachine_A.asid_high_bits_def) done abbreviation "valid_asid_mapping mapping \ (case mapping of None \ True - | Some (asid, ref) \ asid \ 2 ^ ARM_A.asid_bits - 1)" + | Some (asid, ref) \ asid \ 2 ^ asid_bits - 1)" lemma transform_asid_rev_transform_mapping [simp]: "valid_asid_mapping mapping \ @@ -1073,7 +1073,7 @@ lemma state_vrefs_asid_pool_transform_rev: "\ einvs s; cdl_asid_table (transform s) (fst (transform_asid asid)) = Some poolcap; \ is_null_cap poolcap; \ is_null_cap pdcap; pdptr = cap_object pdcap; opt_cap (cap_object poolcap, snd (transform_asid asid)) (transform s) = Some pdcap \ \ - (pdptr, asid && mask ARM_A.asid_low_bits, AASIDPool, Control) + (pdptr, asid && mask MiscMachine_A.asid_low_bits, AASIDPool, Control) \ state_vrefs s (cap_object poolcap)" apply (subgoal_tac "cap_object poolcap \ idle_thread s") prefer 2 diff --git a/proof/drefine/Arch_DR.thy b/proof/drefine/Arch_DR.thy index e8c068f55a..fef2ce8487 100644 --- a/proof/drefine/Arch_DR.thy +++ b/proof/drefine/Arch_DR.thy @@ -9,7 +9,7 @@ theory Arch_DR imports Untyped_DR begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "make_arch_duplicate cap \ case cap of @@ -731,7 +731,7 @@ next apply (thin_tac "free_asid_select v \ dom v") apply clarsimp apply (subgoal_tac "unat ((ucast (free_asid_select v) :: word32) << 10) mod 1024=0") - apply (simp add: asid_high_bits_of_shift[simplified asid_low_bits_def]) + apply (simp add: asid_high_bits_of_shift[simplified asid_low_bits_def[simplified]]) apply (rule shiftl_mod[where n=10, simplified]) apply (cut_tac x="free_asid_select v" and 'a=32 in ucast_less) apply simp @@ -1639,8 +1639,8 @@ proof - "CSpaceAcc_A.descendants_of cref (cdt s') = {}" "caps_of_state s' cref = Some cap" "cap = cap.UntypedCap False frame pageBits idx" - "is_aligned (base::word32) ARM_A.asid_low_bits" - "base < 2 ^ ARM_A.asid_bits" + "is_aligned (base::word32) asid_low_bits" + "base < 2 ^ asid_bits" assume relation:"arch_invocation_relation (InvokeAsidControl asid_inv) (arch_invocation.InvokeASIDControl (asid_control_invocation.MakePool frame cnode_ref cref base))" assume asid_para: "asid_inv' = asid_control_invocation.MakePool frame cnode_ref cref base" diff --git a/proof/drefine/CNode_DR.thy b/proof/drefine/CNode_DR.thy index 147442a785..2e19318788 100644 --- a/proof/drefine/CNode_DR.thy +++ b/proof/drefine/CNode_DR.thy @@ -8,7 +8,7 @@ theory CNode_DR imports Finalise_DR begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition translate_cnode_invocation :: "Invocations_A.cnode_invocation \ cdl_cnode_invocation" @@ -1159,7 +1159,7 @@ lemma set_asid_pool_empty': done lemma empty_pool: - "(\x. if x \ 2 ^ ARM_A.asid_low_bits - 1 then None else (ap :: 10 word \ word32) x) = Map.empty" + "(\x. if x \ 2 ^ asid_low_bits - 1 then None else (ap :: 10 word \ word32) x) = Map.empty" apply (rule ext) apply (cut_tac ptr=x and 'a=10 in word_up_bound) apply (simp add:asid_low_bits_def) @@ -1180,8 +1180,8 @@ lemma get_set_asid_pool: lemma set_asid_pool_empty: "set_asid_pool a Map.empty \ mapM_x (\slot. get_asid_pool a >>= (\pool. set_asid_pool a (pool(ucast slot:=None)))) - [0 :: word32 .e. 2 ^ ARM_A.asid_low_bits - 1]" - using set_asid_pool_empty' [of "2 ^ ARM_A.asid_low_bits - 1" a] + [0 :: word32 .e. 2 ^ asid_low_bits - 1]" + using set_asid_pool_empty' [of "2 ^ asid_low_bits - 1" a] apply - apply (rule eq_reflection) apply simp @@ -1243,7 +1243,7 @@ lemma dcorres_set_asid_pool_empty: "dcorres dc \ (valid_idle and asid_pool_at a and (\s. mdb_cte_at (swp (cte_wp_at ((\) cap.NullCap)) s) (cdt s))) (mapM_x PageTableUnmap_D.empty_slot - (map (Pair a) [0 .e. 2 ^ ARM_A.asid_low_bits - 1])) + (map (Pair a) [0 .e. 2 ^ asid_low_bits - 1])) (set_asid_pool a Map.empty)" apply (unfold set_asid_pool_empty) apply (rule dcorres_list_all2_mapM_[where F="\x y. snd x = snd (transform_asid y)"]) @@ -1269,7 +1269,7 @@ lemma dcorres_set_asid_pool_empty: apply (wp | clarsimp)+ apply simp apply (wp get_asid_pool_triv | clarsimp simp:typ_at_eq_kheap_obj obj_at_def swp_def)+ - apply (subgoal_tac "(aa, snd (transform_asid y)) \ set (map (Pair a) [0..<2 ^ ARM_A.asid_low_bits])") + apply (subgoal_tac "(aa, snd (transform_asid y)) \ set (map (Pair a) [0..<2 ^ asid_low_bits])") apply clarsimp apply (clarsimp simp del:set_map simp: suffix_def) apply (wp | clarsimp simp:swp_def)+ diff --git a/proof/drefine/Finalise_DR.thy b/proof/drefine/Finalise_DR.thy index 142c3f39f7..8388aaec80 100644 --- a/proof/drefine/Finalise_DR.thy +++ b/proof/drefine/Finalise_DR.thy @@ -11,7 +11,7 @@ imports "AInvs.VSpaceEntries_AI" begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "transform_pd_slot_ref x @@ -1929,7 +1929,7 @@ lemma (in pspace_update_eq) pd_pt_relation_update[iff]: "pd_pt_relation a b c (f s) = pd_pt_relation a b c s" by (simp add: pd_pt_relation_def pspace) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch flush_page for cdt[wp]: "\s. P (cdt s)" diff --git a/proof/drefine/Intent_DR.thy b/proof/drefine/Intent_DR.thy index 3ffe0157c2..c6b74629fd 100644 --- a/proof/drefine/Intent_DR.thy +++ b/proof/drefine/Intent_DR.thy @@ -8,7 +8,7 @@ theory Intent_DR imports Corres_D begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition not_idle_thread:: "obj_ref \ 'z::state_ext state \ bool" where diff --git a/proof/drefine/Interrupt_DR.thy b/proof/drefine/Interrupt_DR.thy index eda6716e4c..46758648c7 100644 --- a/proof/drefine/Interrupt_DR.thy +++ b/proof/drefine/Interrupt_DR.thy @@ -8,7 +8,7 @@ theory Interrupt_DR imports Ipc_DR begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma arch_decode_irq_control_error_corres: "\ (\ ui. (Some (IrqControlIntent ui)) = (transform_intent (invocation_type label) args)) \ diff --git a/proof/drefine/Ipc_DR.thy b/proof/drefine/Ipc_DR.thy index 58212777d7..1129afcffb 100644 --- a/proof/drefine/Ipc_DR.thy +++ b/proof/drefine/Ipc_DR.thy @@ -8,7 +8,7 @@ theory Ipc_DR imports CNode_DR begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) abbreviation "thread_is_running y s \ st_tcb_at ((=) Structures_A.Running) y s" diff --git a/proof/drefine/KHeap_DR.thy b/proof/drefine/KHeap_DR.thy index 7dc895aa79..419ad01983 100644 --- a/proof/drefine/KHeap_DR.thy +++ b/proof/drefine/KHeap_DR.thy @@ -8,7 +8,7 @@ theory KHeap_DR imports Intent_DR begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare arch_post_cap_deletion_def[simp] lemmas post_cap_deletion_simps[simp] = post_cap_deletion_def[simplified arch_post_cap_deletion_def] diff --git a/proof/drefine/Refine_D.thy b/proof/drefine/Refine_D.thy index d3337e6846..af6e2e2b2f 100644 --- a/proof/drefine/Refine_D.thy +++ b/proof/drefine/Refine_D.thy @@ -12,7 +12,7 @@ theory Refine_D imports Syscall_DR begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \ Toplevel @{text dcorres} theorem. diff --git a/proof/drefine/Schedule_DR.thy b/proof/drefine/Schedule_DR.thy index 31f4f00865..0922912b1e 100644 --- a/proof/drefine/Schedule_DR.thy +++ b/proof/drefine/Schedule_DR.thy @@ -8,7 +8,7 @@ theory Schedule_DR imports Finalise_DR begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* getActiveTCBs returns a subset of CapDL's all_active_tcbs. *) lemma getActiveTCBs_subset: diff --git a/proof/drefine/StateTranslationProofs_DR.thy b/proof/drefine/StateTranslationProofs_DR.thy index 2a6bce8c2d..586e6f4080 100644 --- a/proof/drefine/StateTranslationProofs_DR.thy +++ b/proof/drefine/StateTranslationProofs_DR.thy @@ -12,7 +12,7 @@ theory StateTranslationProofs_DR imports StateTranslation_D begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare transform_current_domain_def [simp] diff --git a/proof/drefine/StateTranslation_D.thy b/proof/drefine/StateTranslation_D.thy index ec61531598..89b6f108be 100644 --- a/proof/drefine/StateTranslation_D.thy +++ b/proof/drefine/StateTranslation_D.thy @@ -16,7 +16,7 @@ theory StateTranslation_D imports Lemmas_D begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) type_synonym kernel_object = Structures_A.kernel_object type_synonym tcb = Structures_A.tcb diff --git a/proof/drefine/Syscall_DR.thy b/proof/drefine/Syscall_DR.thy index e8f9877fc9..4f003d0853 100644 --- a/proof/drefine/Syscall_DR.thy +++ b/proof/drefine/Syscall_DR.thy @@ -11,7 +11,7 @@ imports Interrupt_DR begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* * Translate an abstract invocation into a corresponding diff --git a/proof/drefine/Tcb_DR.thy b/proof/drefine/Tcb_DR.thy index 6fa7a6be13..2cdd322411 100644 --- a/proof/drefine/Tcb_DR.thy +++ b/proof/drefine/Tcb_DR.thy @@ -8,7 +8,7 @@ theory Tcb_DR imports Ipc_DR Arch_DR begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* * A "normal" TCB is a non-idle TCB. (Idle is special, because it diff --git a/proof/drefine/Untyped_DR.thy b/proof/drefine/Untyped_DR.thy index f3f602537c..9c833a3708 100644 --- a/proof/drefine/Untyped_DR.thy +++ b/proof/drefine/Untyped_DR.thy @@ -8,7 +8,7 @@ theory Untyped_DR imports CNode_DR begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma detype_dcorres: "S = {ptr..ptr + 2 ^ sz - 1} @@ -695,10 +695,23 @@ lemma clearMemory_unused_corres_noop: apply (clarsimp simp: word_size_def) apply (drule subsetD[OF upto_enum_step_subset]) apply simp - apply (rule dcorres_machine_op_noop, wp) + apply (rule corres_return_trivial; wp) apply (wp | simp)+ done +lemma dcorres_mapM_x_machine_op_noop: + "\ \m r. \\ms. underlying_memory ms = m\ mop r \\rv ms. underlying_memory ms = m\ \ + \ dcorres dc \ \ (return ()) (mapM_x (\r. do_machine_op (mop r)) xs)" + apply (induct xs) + apply (simp add: mapM_x_Nil) + apply (simp add: mapM_x_Cons) + apply (rule corres_guard_imp) + apply (rule corres_split_noop_rhs) + apply (rule dcorres_machine_op_noop, assumption) + apply assumption + apply wpsimp+ + done + lemma init_arch_objects_corres_noop: notes [simp del] = atLeastAtMost_iff atLeastatMost_subset_iff shows @@ -712,27 +725,31 @@ lemma init_arch_objects_corres_noop: obj_refs cap \ {ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1} = {}) \ valid_objs s \ pspace_aligned s \ pspace_distinct s \ valid_idle s \ valid_etcbs s) (return ()) - (init_arch_objects ty ptr n obj_sz refs)" + (init_arch_objects ty dev ptr n obj_sz refs)" apply (simp add: init_arch_objects_def split: Structures_A.apiobject_type.split aobject_type.split) - apply (simp add: dcorres_machine_op_noop[THEN corres_guard_imp] - cleanCacheRange_PoU_def machine_op_lift) - apply safe - apply (simp add:mapM_x_mapM) + apply (subst dcorres_machine_op_noop[THEN corres_guard_imp] + dcorres_mapM_x_machine_op_noop[THEN corres_guard_imp] + | rule cleanCacheRange_PoU_mem cleanCacheRange_RAM_mem TrueI)+ + apply clarsimp + apply (rule conj_commute[THEN iffD1]) + apply (rule context_conjI) + prefer 2 + apply clarsimp apply (rule corres_guard_imp) apply (rule corres_split_noop_rhs) apply (rule corres_noop[where P=\ and P'=valid_idle]) apply simp - apply (rule hoare_strengthen_post, rule mapM_wp') + apply (rule hoare_strengthen_post, rule mapM_x_wp') apply (subst eq_commute, wp copy_global_mappings_dwp) apply (simp add: obj_bits_api_def arch_kobj_size_def default_arch_object_def pd_bits_def pageBits_def) apply (wp mapM_wp' dmo_dwp | simp)+ - apply (rule corres_noop[where P=\ and P'=valid_idle]) - apply (simp add: clearMemory_def do_machine_op_bind - cleanCacheRange_PoU_def ef_storeWord - mapM_x_mapM dom_mapM) - apply (wp mapM_wp' dmo_dwp | simp)+ + apply (rule dcorres_mapM_x_machine_op_noop) + apply (rule cleanCacheRange_PoU_mem) + apply wp + apply simp + apply simp done lemma monad_commute_set_cap_cdt: @@ -1200,11 +1217,8 @@ lemma clearMemory_corres_noop: apply (simp add: clearMemory_def freeMemory_def[symmetric] do_machine_op_bind empty_fail_freeMemory) apply (rule corres_guard_imp) - apply (rule corres_add_noop_lhs) - apply (rule corres_split_nor) - apply (rule freeMemory_dcorres; simp) - apply (rule dcorres_machine_op_noop) - apply (wp | simp)+ + apply (rule freeMemory_dcorres; simp) + apply (wp | simp)+ apply (clarsimp simp: field_simps) done diff --git a/proof/infoflow/ADT_IF.thy b/proof/infoflow/ADT_IF.thy index c7a5213ab9..cfad4a99da 100644 --- a/proof/infoflow/ADT_IF.thy +++ b/proof/infoflow/ADT_IF.thy @@ -959,7 +959,7 @@ locale ADT_IF_1 = and arch_invoke_irq_control_noErr[wp]: "\Q. \\\ arch_invoke_irq_control ici -, \\rv s :: det_state. Q rv s\" and init_arch_objects_irq_state_of_state[wp]: - "\P. init_arch_objects new_type ptr num_objects obj_sz refs \\s. P (irq_state_of_state s)\" + "\P. init_arch_objects new_type dev ptr num_objects obj_sz refs \\s. P (irq_state_of_state s)\" and getActiveIRQ_None: "(None, s') \ fst (do_machine_op (getActiveIRQ in_kernel) (s :: det_state)) \ irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s)) = None" @@ -1487,7 +1487,7 @@ locale invariant_over_ADT_if = | None \ det_inv InIdleMode (snd rv)\" -locale valid_initial_state_noenabled = invariant_over_ADT_if + (* FIXME: arch_split *) +locale valid_initial_state_noenabled = invariant_over_ADT_if + (* FIXME: arch-split *) fixes s0_internal :: det_state fixes initial_aag :: "'a subject_label PAS" fixes timer_irq :: irq diff --git a/proof/infoflow/ARM/ArchADT_IF.thy b/proof/infoflow/ARM/ArchADT_IF.thy index 0f94f7ae05..48ab477666 100644 --- a/proof/infoflow/ARM/ArchADT_IF.thy +++ b/proof/infoflow/ARM/ArchADT_IF.thy @@ -148,9 +148,9 @@ lemma arch_invoke_irq_control_noErr[ADT_IF_assms, wp]: "\\\ arch_invoke_irq_control a -, \Q\" by (cases a; wpsimp) -crunch cleanCacheRange_PoU +crunch cleanCacheRange_PoU, cleanCacheRange_RAM for irq_state[wp]: "\s. P (irq_state s)" - (ignore_del: cleanCacheRange_PoU cleanByVA_PoU) + (ignore_del: cleanCacheRange_PoU cleanByVA_PoU cleanL2Range dsb cleanByVA) crunch init_arch_objects for irq_state_of_state[ADT_IF_assms, wp]: "\s. P (irq_state_of_state s)" diff --git a/proof/infoflow/ARM/ArchRetype_IF.thy b/proof/infoflow/ARM/ArchRetype_IF.thy index 4c50f20ad7..8a8060dc9d 100644 --- a/proof/infoflow/ARM/ArchRetype_IF.thy +++ b/proof/infoflow/ARM/ArchRetype_IF.thy @@ -51,12 +51,9 @@ lemma cleanCacheRange_RAM_ev: lemma clearMemory_ev[Retype_IF_assms]: "equiv_valid_inv (equiv_machine_state P) (equiv_machine_state Q) (\_. True) (clearMemory ptr bits)" unfolding clearMemory_def - apply simp apply (rule equiv_valid_guard_imp) - apply (rule bind_ev) - apply (rule cleanCacheRange_RAM_ev) - apply (rule mapM_x_ev[OF storeWord_ev]) - apply (rule wp_post_taut | simp)+ + apply (rule mapM_x_ev[OF storeWord_ev]) + apply (rule wp_post_taut | simp)+ done lemma freeMemory_ev[Retype_IF_assms]: @@ -214,13 +211,33 @@ lemma dmo_cleanCacheRange_PoU_globals_equiv: unfolding cleanCacheRange_PoU_def by (wp dmo_mol_globals_equiv dmo_cacheRangeOp_lift | simp add: cleanByVA_PoU_def)+ -lemma dmo_cleanCacheRange_reads_respects_g: +lemma dmo_cleanCacheRange_PoU_reads_respects_g: "reads_respects_g aag l \ (do_machine_op (cleanCacheRange_PoU x y z))" apply (rule equiv_valid_guard_imp[OF reads_respects_g]) apply (rule dmo_cleanCacheRange_PoU_reads_respects) apply (rule doesnt_touch_globalsI[where P="\", simplified, OF dmo_cleanCacheRange_PoU_globals_equiv]) by simp +lemma dmo_cleanCacheRange_RAM_globals_equiv: + "do_machine_op (cleanCacheRange_RAM x y z) \globals_equiv s\" + unfolding cleanCacheRange_RAM_def + by (wpsimp wp: dmo_mol_globals_equiv dmo_cacheRangeOp_lift + simp: dmo_bind_valid dsb_def cleanCacheRange_PoC_def cleanByVA_def cleanL2Range_def) + +lemma dmo_cleanCacheRange_RAM_reads_respects: + "reads_respects aag l \ (do_machine_op (cleanCacheRange_RAM vsrat vend pstart))" + unfolding cleanCacheRange_RAM_def + by (wp dmo_cacheRangeOp_reads_respects dmo_mol_reads_respects empty_fail_cleanByVA empty_fail_cacheRangeOp + | simp add: cleanL2Range_def dsb_def cleanCacheRange_PoC_def cleanByVA_def + | subst do_machine_op_bind)+ + +lemma dmo_cleanCacheRange_RAM_reads_respects_g: + "reads_respects_g aag l \ (do_machine_op (cleanCacheRange_RAM x y z))" + apply (rule equiv_valid_guard_imp[OF reads_respects_g]) + apply (rule dmo_cleanCacheRange_RAM_reads_respects) + apply (rule doesnt_touch_globalsI[where P="\", simplified, OF dmo_cleanCacheRange_RAM_globals_equiv]) + by simp + lemma mol_globals_equiv: "machine_op_lift mop \\ms. globals_equiv st (s\machine_state := ms\)\" unfolding machine_op_lift_def @@ -264,15 +281,16 @@ lemma init_arch_objects_reads_respects_g: K (\x\set refs. new_type = ArchObject PageDirectoryObj \ is_aligned x pd_bits) and K ((0::obj_ref) < of_nat num_objects)) - (init_arch_objects new_type ptr num_objects obj_sz refs)" + (init_arch_objects new_type dev ptr num_objects obj_sz refs)" apply (unfold init_arch_objects_def fun_app_def) apply (rule gen_asm_ev)+ - apply (subst do_machine_op_mapM_x[OF empty_fail_cleanCacheRange_PoU])+ apply (rule equiv_valid_guard_imp) - apply (wp dmo_cleanCacheRange_reads_respects_g mapM_x_ev'' - equiv_valid_guard_imp[OF copy_global_mappings_reads_respects_g] - copy_global_mappings_valid_arch_state copy_global_mappings_pspace_aligned - hoare_vcg_ball_lift | wpc | simp)+ + apply (wp dmo_cleanCacheRange_RAM_reads_respects_g + dmo_cleanCacheRange_PoU_reads_respects_g + mapM_x_ev'' when_ev + equiv_valid_guard_imp[OF copy_global_mappings_reads_respects_g] + copy_global_mappings_valid_arch_state copy_global_mappings_pspace_aligned + hoare_vcg_ball_lift | wpc | simp)+ apply clarsimp done @@ -294,13 +312,13 @@ lemma init_arch_objects_globals_equiv: "\globals_equiv s and (\s. arm_global_pd (arch_state s) \ set refs \ pspace_aligned s \ valid_arch_state s) and K (\x\set refs. is_aligned x (obj_bits_api new_type obj_sz))\ - init_arch_objects new_type ptr num_objects obj_sz refs + init_arch_objects new_type dev ptr num_objects obj_sz refs \\_. globals_equiv s\" unfolding init_arch_objects_def fun_app_def apply (rule hoare_gen_asm)+ - apply (subst do_machine_op_mapM_x[OF empty_fail_cleanCacheRange_PoU])+ apply (rule hoare_pre) - apply (wpc | wp mapM_x_wp[OF dmo_cleanCacheRange_PoU_globals_equiv subset_refl])+ + apply (wpc | wp mapM_x_wp[OF dmo_cleanCacheRange_PoU_globals_equiv subset_refl] + mapM_x_wp[OF dmo_cleanCacheRange_RAM_globals_equiv subset_refl])+ apply (rule_tac Q'="\_. globals_equiv s and (\ s. arm_global_pd (arch_state s) \ set refs)" in hoare_strengthen_post) apply (wp mapM_x_wp[OF _ subset_refl] copy_global_mappings_globals_equiv diff --git a/proof/infoflow/ARM/Example_Valid_State.thy b/proof/infoflow/ARM/Example_Valid_State.thy index 02f3d9367d..345832598b 100644 --- a/proof/infoflow/ARM/Example_Valid_State.thy +++ b/proof/infoflow/ARM/Example_Valid_State.thy @@ -29,7 +29,7 @@ consts s0_context :: user_context axiomatization where irq_oracle_def: "ARM.irq_oracle \ \pos. if pos mod 10 = 0 then 10 else 0" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) subsection \We show that the authority graph does not let information flow from High to Low\ diff --git a/proof/infoflow/FinalCaps.thy b/proof/infoflow/FinalCaps.thy index 63a099ae1a..aac6f1fedf 100644 --- a/proof/infoflow/FinalCaps.thy +++ b/proof/infoflow/FinalCaps.thy @@ -15,7 +15,7 @@ theory FinalCaps imports ArchInfoFlow_IF begin -(* FIXME: arch_split: need to have a label on arch refs*) +(* FIXME: arch-split: need to have a label on arch refs*) fun pasGenAbs :: "'a PAS \ gen_obj_ref \ 'a" where "pasGenAbs aag (ObjRef ref) = pasObjectAbs aag ref" | "pasGenAbs aag (IRQRef ref) = pasIRQAbs aag ref" @@ -347,9 +347,9 @@ locale FinalCaps_1 = and arch_switch_to_thread_silc_inv[wp]: "arch_switch_to_thread t \silc_inv aag st\" and init_arch_objects_silc_inv[wp]: - "init_arch_objects typ ptr num sz refs \silc_inv aag st\" + "init_arch_objects typ dev ptr num sz refs \silc_inv aag st\" and init_arch_objects_cte_wp_at[wp]: - "\P. init_arch_objects typ ptr num sz refs \\s :: det_state. P (cte_wp_at P' slot s)\" + "\P. init_arch_objects typ dev ptr num sz refs \\s :: det_state. P (cte_wp_at P' slot s)\" and finalise_cap_makes_halted: "\invs and valid_cap cap and (\s. ex = is_final_cap' cap s) and cte_wp_at ((=) cap) slot\ finalise_cap cap ex diff --git a/proof/infoflow/PasUpdates.thy b/proof/infoflow/PasUpdates.thy index b06cf8d206..b8c169437d 100644 --- a/proof/infoflow/PasUpdates.thy +++ b/proof/infoflow/PasUpdates.thy @@ -130,7 +130,7 @@ locale PasUpdates_2 = PasUpdates_1 + and handle_arch_fault_reply_domain_fields[wp]: "handle_arch_fault_reply vmf thread x y \domain_fields P\" and init_arch_objects_domain_fields[wp]: - "init_arch_objects typ ptr num sz refs \domain_fields P\" + "init_arch_objects typ dev ptr num sz refs \domain_fields P\" and state_asids_to_policy_pasSubject_update: "state_asids_to_policy (aag\pasSubject := subject\) s = state_asids_to_policy aag s" diff --git a/proof/infoflow/RISCV64/ArchIRQMasks_IF.thy b/proof/infoflow/RISCV64/ArchIRQMasks_IF.thy index 17cd0a26a7..e359be2327 100644 --- a/proof/infoflow/RISCV64/ArchIRQMasks_IF.thy +++ b/proof/infoflow/RISCV64/ArchIRQMasks_IF.thy @@ -152,7 +152,7 @@ lemma invoke_tcb_irq_masks[IRQMasks_IF_assms]: by fastforce+ lemma init_arch_objects_irq_masks: - "init_arch_objects new_type ptr num_objects obj_sz refs \\s. P (irq_masks_of_state s)\" + "init_arch_objects new_type dev ptr num_objects obj_sz refs \\s. P (irq_masks_of_state s)\" by (rule init_arch_objects_inv) end diff --git a/proof/infoflow/RISCV64/ArchRetype_IF.thy b/proof/infoflow/RISCV64/ArchRetype_IF.thy index 13f9d1e402..194bdbbf0d 100644 --- a/proof/infoflow/RISCV64/ArchRetype_IF.thy +++ b/proof/infoflow/RISCV64/ArchRetype_IF.thy @@ -227,7 +227,7 @@ lemma dmo_freeMemory_globals_equiv[Retype_IF_assms]: done lemma init_arch_objects_reads_respects_g: - "reads_respects_g aag l \ (init_arch_objects new_type ptr num_objects obj_sz refs)" + "reads_respects_g aag l \ (init_arch_objects new_type dev ptr num_objects obj_sz refs)" unfolding init_arch_objects_def by wp lemma copy_global_mappings_globals_equiv: diff --git a/proof/infoflow/RISCV64/Example_Valid_State.thy b/proof/infoflow/RISCV64/Example_Valid_State.thy index cc5a6f658e..29d4c04250 100644 --- a/proof/infoflow/RISCV64/Example_Valid_State.thy +++ b/proof/infoflow/RISCV64/Example_Valid_State.thy @@ -30,7 +30,7 @@ consts s0_context :: user_context axiomatization where irq_oracle_def: "RISCV64.irq_oracle \ \pos. if pos mod 10 = 0 then 10 else 0" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) subsection \We show that the authority graph does not let information flow from High to Low\ diff --git a/proof/infoflow/refine/ARM/Example_Valid_StateH.thy b/proof/infoflow/refine/ARM/Example_Valid_StateH.thy index 3853532bfb..0ce77db303 100644 --- a/proof/infoflow/refine/ARM/Example_Valid_StateH.thy +++ b/proof/infoflow/refine/ARM/Example_Valid_StateH.thy @@ -9,7 +9,7 @@ theory Example_Valid_StateH imports "InfoFlow.Example_Valid_State" ArchADT_IF_Refine begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) section \Haskell state\ @@ -2827,7 +2827,7 @@ axiomatization where kdr_valid_global_refs': "valid_global_refs' s0H_internal" and kdr_pspace_domain_valid: "pspace_domain_valid s0H_internal" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma timer_irq_not_outside_range[simp]: "\ Kernel_Config.maxIRQ < (timer_irq :: irq)" diff --git a/proof/invariant-abstract/AARCH64/ArchADT_AI.thy b/proof/invariant-abstract/AARCH64/ArchADT_AI.thy index c0376b854c..753c5e8949 100644 --- a/proof/invariant-abstract/AARCH64/ArchADT_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchADT_AI.thy @@ -12,7 +12,7 @@ imports "Lib.Simulation" Invariants_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming subsection \Constructing a virtual-memory view\ diff --git a/proof/invariant-abstract/AARCH64/ArchAInvsPre.thy b/proof/invariant-abstract/AARCH64/ArchAInvsPre.thy index 5f77c0be35..83ae5d2b58 100644 --- a/proof/invariant-abstract/AARCH64/ArchAInvsPre.thy +++ b/proof/invariant-abstract/AARCH64/ArchAInvsPre.thy @@ -11,9 +11,7 @@ begin unbundle l4v_word_context -context Arch begin - -global_naming AARCH64 +context Arch begin arch_global_naming lemma ucast_ucast_mask_low: "(ucast (x && mask asid_low_bits) :: asid_low_index) = ucast x" by (rule ucast_mask_drop, simp add: asid_low_bits_def) @@ -81,8 +79,7 @@ lemma device_frame_in_device_region: \ device_state (machine_state s) p \ None" by (auto simp add: pspace_respects_device_region_def dom_def device_mem_def) -global_naming Arch -named_theorems AInvsPre_asms +named_theorems AInvsPre_assms lemma get_vspace_of_thread_asid_or_global_pt: "(\asid. vspace_for_asid asid s = Some (get_vspace_of_thread (kheap s) (arch_state s) t)) @@ -102,7 +99,7 @@ lemma get_page_info_gpd_kmaps: table_base_pt_slot_offset[where level=max_pt_level, simplified]) done -lemma ptable_rights_imp_frame[AInvsPre_asms]: +lemma ptable_rights_imp_frame[AInvsPre_assms]: assumes "valid_state s" shows "\ ptable_rights t s vptr \ {}; ptable_lift t s vptr = Some (addrFromPPtr p) \ \ in_user_frame p s \ in_device_frame p s" @@ -140,12 +137,7 @@ end interpretation AInvsPre?: AInvsPre proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact AInvsPre_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact AInvsPre_assms)?) qed -requalify_facts - AARCH64.user_mem_dom_cong - AARCH64.device_mem_dom_cong - AARCH64.device_frame_in_device_region - end diff --git a/proof/invariant-abstract/AARCH64/ArchAcc_AI.thy b/proof/invariant-abstract/AARCH64/ArchAcc_AI.thy index df5aa1ef06..7ff2c2d231 100644 --- a/proof/invariant-abstract/AARCH64/ArchAcc_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchAcc_AI.thy @@ -17,7 +17,7 @@ lemma valid_vso_at[wp]:"\valid_vso_at level p\ f \\ case aci of MakePool frame slot parent base \ @@ -414,7 +414,7 @@ lemma equal_kernel_mappings: end -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma vmid_for_asid_empty_update: "\ asid_table s asid_high = None; asid_pools_of s ap = Some Map.empty \ \ @@ -1726,22 +1726,4 @@ lemma arch_pinv_st_tcb_at: end - -context begin interpretation Arch . - -requalify_consts - valid_arch_inv - -requalify_facts - invoke_arch_tcb - invoke_arch_invs - sts_valid_arch_inv - arch_decode_inv_wf - arch_pinv_st_tcb_at - -end - -declare invoke_arch_invs[wp] -declare arch_decode_inv_wf[wp] - end diff --git a/proof/invariant-abstract/AARCH64/ArchBCorres2_AI.thy b/proof/invariant-abstract/AARCH64/ArchBCorres2_AI.thy index 94caa7b577..6259833c46 100644 --- a/proof/invariant-abstract/AARCH64/ArchBCorres2_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchBCorres2_AI.thy @@ -10,7 +10,7 @@ imports BCorres2_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems BCorres2_AI_assms @@ -89,7 +89,7 @@ interpretation BCorres2_AI?: BCorres2_AI lemmas schedule_bcorres[wp] = schedule_bcorres1[OF BCorres2_AI_axioms] -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming crunch send_ipc,send_signal,do_reply_transfer,arch_perform_invocation for (bcorres) bcorres[wp]: truncate_state diff --git a/proof/invariant-abstract/AARCH64/ArchBCorres_AI.thy b/proof/invariant-abstract/AARCH64/ArchBCorres_AI.thy index 41388b855a..1bb2fb31c9 100644 --- a/proof/invariant-abstract/AARCH64/ArchBCorres_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchBCorres_AI.thy @@ -11,7 +11,7 @@ imports ArchBitSetup_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma entry_for_asid_truncate[simp]: "entry_for_asid asid (truncate_state s) = entry_for_asid asid s" @@ -45,8 +45,4 @@ crunch prepare_thread_delete end -requalify_facts AARCH64.arch_finalise_cap_bcorres AARCH64.prepare_thread_delete_bcorres - -declare arch_finalise_cap_bcorres[wp] prepare_thread_delete_bcorres[wp] - end diff --git a/proof/invariant-abstract/AARCH64/ArchBits_AI.thy b/proof/invariant-abstract/AARCH64/ArchBits_AI.thy index f5afcbc3fb..ff173a2570 100644 --- a/proof/invariant-abstract/AARCH64/ArchBits_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchBits_AI.thy @@ -9,7 +9,7 @@ theory ArchBits_AI imports Invariants_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming (* arch-specific interpretations of update locales: *) diff --git a/proof/invariant-abstract/AARCH64/ArchCNodeInv_AI.thy b/proof/invariant-abstract/AARCH64/ArchCNodeInv_AI.thy index 04467df833..2a9184bd13 100644 --- a/proof/invariant-abstract/AARCH64/ArchCNodeInv_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchCNodeInv_AI.thy @@ -9,7 +9,7 @@ theory ArchCNodeInv_AI imports CNodeInv_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems CNodeInv_AI_assms @@ -538,7 +538,7 @@ qed termination rec_del by (rule rec_del_termination) -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma post_cap_delete_pre_is_final_cap': "\valid_ioports s; caps_of_state s slot = Some cap; is_final_cap' cap s; cap_cleanup_opt cap \ NullCap\ @@ -800,7 +800,7 @@ global_interpretation CNodeInv_AI_2?: CNodeInv_AI_2 qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma finalise_cap_rvk_prog [CNodeInv_AI_assms]: "finalise_cap cap f \\s. revoke_progress_ord m (\x. map_option cap_to_rpo (caps_of_state s x))\" @@ -905,7 +905,7 @@ termination cap_revoke by (rule cap_revoke_termination) declare cap_revoke.simps[simp del] -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming crunch finalise_slot for typ_at[wp, CNodeInv_AI_assms]: "\s. P (typ_at T p s)" @@ -930,7 +930,7 @@ global_interpretation CNodeInv_AI_4?: CNodeInv_AI_4 qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma cap_move_ioports: "\valid_ioports and cte_wp_at ((=) cap.NullCap) ptr' diff --git a/proof/invariant-abstract/AARCH64/ArchCSpaceInvPre_AI.thy b/proof/invariant-abstract/AARCH64/ArchCSpaceInvPre_AI.thy index 3e3e165547..44df5b80cd 100644 --- a/proof/invariant-abstract/AARCH64/ArchCSpaceInvPre_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchCSpaceInvPre_AI.thy @@ -14,7 +14,7 @@ imports CSpaceInvPre_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma aobj_ref_acap_rights_update[simp]: "aobj_ref (acap_rights_update f x) = aobj_ref x" @@ -363,7 +363,7 @@ lemma cap_master_arch_cap_rights [simp]: by (simp add: cap_master_arch_cap_def acap_rights_update_def split: arch_cap.splits) -lemma acap_rights_update_id [intro!, simp]: +lemma valid_acap_rights_update_id [intro!, simp]: "valid_arch_cap ac s \ acap_rights_update (acap_rights ac) ac = ac" unfolding acap_rights_update_def acap_rights_def valid_arch_cap_def by (cases ac; simp) diff --git a/proof/invariant-abstract/AARCH64/ArchCSpaceInv_AI.thy b/proof/invariant-abstract/AARCH64/ArchCSpaceInv_AI.thy index b2c600a167..3ad84874c7 100644 --- a/proof/invariant-abstract/AARCH64/ArchCSpaceInv_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchCSpaceInv_AI.thy @@ -12,7 +12,7 @@ theory ArchCSpaceInv_AI imports CSpaceInv_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming definition safe_ioport_insert :: "cap \ cap \ 'a::state_ext state \ bool" @@ -210,8 +210,4 @@ lemmas cap_vptr_simps [simp] = end -context begin interpretation Arch . -requalify_facts replace_cap_invs -end - end diff --git a/proof/invariant-abstract/AARCH64/ArchCSpacePre_AI.thy b/proof/invariant-abstract/AARCH64/ArchCSpacePre_AI.thy index 7fdac5a929..2080df6b50 100644 --- a/proof/invariant-abstract/AARCH64/ArchCSpacePre_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchCSpacePre_AI.thy @@ -13,7 +13,7 @@ theory ArchCSpacePre_AI imports CSpacePre_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemmas typ_at_eq_kheap_obj = typ_at_eq_kheap_obj atyp_at_eq_kheap_obj diff --git a/proof/invariant-abstract/AARCH64/ArchCSpace_AI.thy b/proof/invariant-abstract/AARCH64/ArchCSpace_AI.thy index 42b0e4cfff..bc4db311ee 100644 --- a/proof/invariant-abstract/AARCH64/ArchCSpace_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchCSpace_AI.thy @@ -12,7 +12,7 @@ theory ArchCSpace_AI imports CSpace_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems CSpace_AI_assms @@ -304,7 +304,7 @@ end global_interpretation cap_insert_crunches?: cap_insert_crunches . -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma cap_insert_cap_refs_in_kernel_window[wp, CSpace_AI_assms]: "\cap_refs_in_kernel_window @@ -496,7 +496,7 @@ proof goal_cases qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma is_cap_simps': "is_cnode_cap cap = (\r bits g. cap = cap.CNodeCap r bits g)" @@ -599,12 +599,4 @@ lemma set_cap_kernel_window_simple: end -context begin interpretation Arch . - -requalify_facts - set_cap_valid_arch_caps_simple - set_cap_kernel_window_simple - -end - end diff --git a/proof/invariant-abstract/AARCH64/ArchCrunchSetup_AI.thy b/proof/invariant-abstract/AARCH64/ArchCrunchSetup_AI.thy index 0f783df33d..5cc6c4d7d3 100644 --- a/proof/invariant-abstract/AARCH64/ArchCrunchSetup_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchCrunchSetup_AI.thy @@ -10,7 +10,7 @@ imports "Lib.Crunch_Instances_NonDet" begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming crunch_ignore (add: debugPrint clearMemory pt_lookup_from_level) diff --git a/proof/invariant-abstract/AARCH64/ArchDetSchedAux_AI.thy b/proof/invariant-abstract/AARCH64/ArchDetSchedAux_AI.thy index 8d56752005..637024ae11 100644 --- a/proof/invariant-abstract/AARCH64/ArchDetSchedAux_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchDetSchedAux_AI.thy @@ -9,7 +9,7 @@ theory ArchDetSchedAux_AI imports DetSchedAux_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems DetSchedAux_AI_assms @@ -19,6 +19,7 @@ crunch init_arch_objects and valid_queues[wp]: valid_queues and valid_sched_action[wp]: valid_sched_action and valid_sched[wp]: valid_sched + (wp: mapM_x_wp') (* already proved earlier *) declare invoke_untyped_cur_thread[DetSchedAux_AI_assms] diff --git a/proof/invariant-abstract/AARCH64/ArchDetSchedDomainTime_AI.thy b/proof/invariant-abstract/AARCH64/ArchDetSchedDomainTime_AI.thy index 949773c328..44790fee8d 100644 --- a/proof/invariant-abstract/AARCH64/ArchDetSchedDomainTime_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchDetSchedDomainTime_AI.thy @@ -9,7 +9,7 @@ theory ArchDetSchedDomainTime_AI imports DetSchedDomainTime_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems DetSchedDomainTime_AI_assms @@ -62,7 +62,7 @@ proof goal_cases case 1 show ?case by (unfold_locales; (fact DetSchedDomainTime_AI_assms)?) qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming crunch arch_perform_invocation for domain_time_inv[wp, DetSchedDomainTime_AI_assms]: "\s. P (domain_time s)" diff --git a/proof/invariant-abstract/AARCH64/ArchDetSchedSchedule_AI.thy b/proof/invariant-abstract/AARCH64/ArchDetSchedSchedule_AI.thy index 84f6d9fb1b..b168ce488f 100644 --- a/proof/invariant-abstract/AARCH64/ArchDetSchedSchedule_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchDetSchedSchedule_AI.thy @@ -9,7 +9,7 @@ theory ArchDetSchedSchedule_AI imports DetSchedSchedule_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems DetSchedSchedule_AI_assms @@ -498,7 +498,7 @@ proof goal_cases case 1 show ?case by (unfold_locales; (fact DetSchedSchedule_AI_assms)?) qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma dmo_scheduler_act_sane[wp]: "\scheduler_act_sane\ do_machine_op f \\rv. scheduler_act_sane\" diff --git a/proof/invariant-abstract/AARCH64/ArchDeterministic_AI.thy b/proof/invariant-abstract/AARCH64/ArchDeterministic_AI.thy index 360d38f0f7..72360b387e 100644 --- a/proof/invariant-abstract/AARCH64/ArchDeterministic_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchDeterministic_AI.thy @@ -11,7 +11,7 @@ begin declare dxo_wp_weak[wp del] -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems Deterministic_AI_assms @@ -40,7 +40,7 @@ proof goal_cases case 1 show ?case by (unfold_locales; (fact Deterministic_AI_assms)?) qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming crunch arch_invoke_irq_handler for valid_list[wp,Deterministic_AI_assms]: valid_list diff --git a/proof/invariant-abstract/AARCH64/ArchDetype_AI.thy b/proof/invariant-abstract/AARCH64/ArchDetype_AI.thy index f448888f1d..b7a66c2305 100644 --- a/proof/invariant-abstract/AARCH64/ArchDetype_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchDetype_AI.thy @@ -9,18 +9,18 @@ theory ArchDetype_AI imports Detype_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming -named_theorems Detype_AI_asms +named_theorems Detype_AI_assms -lemma valid_globals_irq_node[Detype_AI_asms]: +lemma valid_globals_irq_node[Detype_AI_assms]: "\ valid_global_refs s; cte_wp_at ((=) cap) ptr s \ \ interrupt_irq_node s irq \ cap_range cap" apply (erule(1) valid_global_refsD) apply (simp add: global_refs_def) done -lemma caps_of_state_ko[Detype_AI_asms]: +lemma caps_of_state_ko[Detype_AI_assms]: "valid_cap cap s \ is_untyped_cap cap \ cap_range cap = {} \ @@ -34,7 +34,7 @@ lemma caps_of_state_ko[Detype_AI_asms]: split: option.splits if_splits)+ done -lemma mapM_x_storeWord[Detype_AI_asms]: +lemma mapM_x_storeWord[Detype_AI_assms]: (* FIXME: taken from Retype_C.thy and adapted wrt. the missing intvl syntax. *) assumes al: "is_aligned ptr word_size_bits" shows "mapM_x (\x. storeWord (ptr + of_nat x * word_size) 0) [0..x. if x \ S then {} else state_hyp_refs_of s x)" by (rule ext, simp add: state_hyp_refs_of_def detype_def) -lemma valid_ioports_detype[Detype_AI_asms]: +lemma valid_ioports_detype[Detype_AI_assms]: "valid_ioports s \ valid_ioports (detype (untyped_range cap) s)" by simp @@ -118,7 +118,7 @@ interpretation Detype_AI?: Detype_AI proof goal_cases interpret Arch . case 1 show ?case - by (intro_locales; (unfold_locales; fact Detype_AI_asms)?) + by (intro_locales; (unfold_locales; fact Detype_AI_assms)?) qed context detype_locale_arch begin @@ -636,8 +636,8 @@ interpretation Detype_AI_2 Detype_AI_2.intro by blast -context begin interpretation Arch . -lemma delete_objects_invs[wp]: +(* generic consequence of architecture-specific details *) +lemma (in Arch) delete_objects_invs[wp]: "\(\s. \slot. cte_wp_at ((=) (cap.UntypedCap dev ptr bits f)) slot s \ descendants_range (cap.UntypedCap dev ptr bits f) slot s) and invs and ct_active\ @@ -657,6 +657,8 @@ lemma delete_objects_invs[wp]: apply (drule (1) cte_wp_valid_cap) apply (simp add: valid_cap_def cap_aligned_def word_size_bits_def untyped_min_bits_def) done -end + +requalify_facts Arch.delete_objects_invs +lemmas [wp] = delete_objects_invs end diff --git a/proof/invariant-abstract/AARCH64/ArchEmptyFail_AI.thy b/proof/invariant-abstract/AARCH64/ArchEmptyFail_AI.thy index 3d8fc10556..8e229505a0 100644 --- a/proof/invariant-abstract/AARCH64/ArchEmptyFail_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchEmptyFail_AI.thy @@ -9,7 +9,7 @@ theory ArchEmptyFail_AI imports EmptyFail_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems EmptyFail_AI_assms @@ -30,7 +30,7 @@ global_interpretation EmptyFail_AI_load_word?: EmptyFail_AI_load_word case 1 show ?case by (unfold_locales; (fact EmptyFail_AI_assms)?) qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming crunch handle_fault for (empty_fail) empty_fail[wp, EmptyFail_AI_assms] @@ -128,7 +128,7 @@ proof goal_cases case 1 show ?case by (unfold_locales; (fact EmptyFail_AI_assms)?) qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma empty_fail_pt_lookup_from_level[wp]: "empty_fail (pt_lookup_from_level level pt_ptr vptr target_pt_ptr)" @@ -158,7 +158,7 @@ proof goal_cases case 1 show ?case by (unfold_locales; (fact EmptyFail_AI_assms)?) qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming crunch cap_delete, choose_thread for (empty_fail) empty_fail[wp, EmptyFail_AI_assms] @@ -182,7 +182,7 @@ proof goal_cases case 1 show ?case by (unfold_locales; (fact EmptyFail_AI_assms)?) qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma plic_complete_claim_empty_fail[wp, EmptyFail_AI_assms]: "empty_fail (plic_complete_claim irq)" diff --git a/proof/invariant-abstract/AARCH64/ArchFinalise_AI.thy b/proof/invariant-abstract/AARCH64/ArchFinalise_AI.thy index 91241010b0..4557bb0ada 100644 --- a/proof/invariant-abstract/AARCH64/ArchFinalise_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchFinalise_AI.thy @@ -9,11 +9,9 @@ theory ArchFinalise_AI imports Finalise_AI begin -context Arch begin +context Arch begin arch_global_naming -named_theorems Finalise_AI_asms - -global_naming AARCH64 +named_theorems Finalise_AI_assms lemma valid_global_refs_asid_table_udapte [iff]: "valid_global_refs (s\arch_state := arm_asid_table_update f (arch_state s)\) = @@ -219,19 +217,17 @@ lemma unmap_page_tcb_cap_valid: done -global_naming Arch - -lemma (* replaceable_cdt_update *)[simp,Finalise_AI_asms]: +lemma (* replaceable_cdt_update *)[simp,Finalise_AI_assms]: "replaceable (cdt_update f s) = replaceable s" by (fastforce simp: replaceable_def tcb_cap_valid_def reachable_frame_cap_def reachable_target_def) -lemma (* replaceable_revokable_update *)[simp,Finalise_AI_asms]: +lemma (* replaceable_revokable_update *)[simp,Finalise_AI_assms]: "replaceable (is_original_cap_update f s) = replaceable s" by (fastforce simp: replaceable_def is_final_cap'_def2 tcb_cap_valid_def reachable_frame_cap_def reachable_target_def) -lemma (* replaceable_more_update *) [simp,Finalise_AI_asms]: +lemma (* replaceable_more_update *) [simp,Finalise_AI_assms]: "replaceable (trans_state f s) sl cap cap' = replaceable s sl cap cap'" by (simp add: replaceable_def reachable_frame_cap_def reachable_target_def) @@ -243,9 +239,9 @@ lemma reachable_frame_cap_trans_state[simp]: "reachable_frame_cap cap (trans_state f s) = reachable_frame_cap cap s" by (simp add: reachable_frame_cap_def) -lemmas [Finalise_AI_asms] = obj_refs_obj_ref_of (* used under name obj_ref_ofI *) +lemmas [Finalise_AI_assms] = obj_refs_obj_ref_of (* used under name obj_ref_ofI *) -lemma (* empty_slot_invs *) [Finalise_AI_asms]: +lemma (* empty_slot_invs *) [Finalise_AI_assms]: "\\s. invs s \ cte_wp_at (replaceable s sl cap.NullCap) sl s \ emptyable sl s \ (info \ NullCap \ post_cap_delete_pre info ((caps_of_state s) (sl \ NullCap)))\ @@ -325,7 +321,7 @@ lemma (* empty_slot_invs *) [Finalise_AI_asms]: apply (simp add: is_final_cap'_def2 cte_wp_at_caps_of_state) by fastforce -lemma dom_tcb_cap_cases_lt_ARCH [Finalise_AI_asms]: +lemma dom_tcb_cap_cases_lt_ARCH [Finalise_AI_assms]: "dom tcb_cap_cases = {xs. length xs = 3 \ unat (of_bl xs :: machine_word) < 5}" apply (rule set_eqI, rule iffI) apply clarsimp @@ -335,7 +331,7 @@ lemma dom_tcb_cap_cases_lt_ARCH [Finalise_AI_asms]: apply (clarsimp simp: nat_to_cref_unat_of_bl') done -lemma (* unbind_notification_final *) [wp,Finalise_AI_asms]: +lemma (* unbind_notification_final *) [wp,Finalise_AI_assms]: "\is_final_cap' cap\ unbind_notification t \ \rv. is_final_cap' cap\" unfolding unbind_notification_def apply (wp final_cap_lift thread_set_caps_of_state_trivial hoare_drop_imps @@ -364,7 +360,7 @@ crunch prepare_thread_delete for caps_of_state[wp]: "\s. P (caps_of_state s)" (wp: crunch_wps ignore: do_machine_op) -declare prepare_thread_delete_caps_of_state [Finalise_AI_asms] +declare prepare_thread_delete_caps_of_state [Finalise_AI_assms] lemma dissociate_vcpu_tcb_final_cap[wp]: "\is_final_cap' cap\ dissociate_vcpu_tcb v t \\rv. is_final_cap' cap\" @@ -378,7 +374,7 @@ lemma length_and_unat_of_bl_length: "(length xs = x \ unat (of_bl xs :: 'a::len word) < 2 ^ x) = (length xs = x)" by (auto simp: unat_of_bl_length) -lemma (* finalise_cap_cases1 *)[Finalise_AI_asms]: +lemma (* finalise_cap_cases1 *)[Finalise_AI_assms]: "\\s. final \ is_final_cap' cap s \ cte_wp_at ((=) cap) slot s\ finalise_cap cap final @@ -417,12 +413,12 @@ crunch dissociate_vcpu_tcb ignore: do_machine_op set_object) crunch arch_finalise_cap - for typ_at[wp,Finalise_AI_asms]: "\s. P (typ_at T p s)" + for typ_at[wp,Finalise_AI_assms]: "\s. P (typ_at T p s)" (wp: crunch_wps simp: crunch_simps unless_def assertE_def ignore: maskInterrupt set_object) crunch prepare_thread_delete - for typ_at[wp,Finalise_AI_asms]: "\s. P (typ_at T p s)" + for typ_at[wp,Finalise_AI_assms]: "\s. P (typ_at T p s)" crunch arch_thread_set for tcb_at[wp]: "\s. tcb_at p s" @@ -441,7 +437,7 @@ crunch dissociate_vcpu_tcb crunch prepare_thread_delete for tcb_at[wp]: "\s. tcb_at p s" -lemma (* finalise_cap_new_valid_cap *)[wp,Finalise_AI_asms]: +lemma (* finalise_cap_new_valid_cap *)[wp,Finalise_AI_assms]: "\valid_cap cap\ finalise_cap cap x \\rv. valid_cap (fst rv)\" apply (cases cap; simp) apply (wp suspend_valid_cap prepare_thread_delete_typ_at @@ -1080,7 +1076,7 @@ crunch vcpu_finalise for invs[wp]: invs (ignore: dissociate_vcpu_tcb) -lemma arch_finalise_cap_invs' [wp,Finalise_AI_asms]: +lemma arch_finalise_cap_invs' [wp,Finalise_AI_assms]: "\invs and valid_cap (ArchObjectCap cap)\ arch_finalise_cap cap final \\rv. invs\" @@ -1140,14 +1136,14 @@ lemma arch_finalise_cap_vcpu: apply (wpsimp wp: wps simp: simps reachable_frame_cap_def | strengthen strg)+ done -lemma obj_at_not_live_valid_arch_cap_strg [Finalise_AI_asms]: +lemma obj_at_not_live_valid_arch_cap_strg [Finalise_AI_assms]: "(s \ ArchObjectCap cap \ aobj_ref cap = Some r \ \ typ_at (AArch AVCPU) r s) \ obj_at (\ko. \ live ko) r s" by (clarsimp simp: live_def valid_cap_def valid_arch_cap_ref_def obj_at_def a_type_arch_live valid_cap_simps hyp_live_def arch_live_def split: arch_cap.split_asm if_splits) -lemma obj_at_not_live_valid_arch_cap_strg' [Finalise_AI_asms]: +lemma obj_at_not_live_valid_arch_cap_strg' [Finalise_AI_assms]: "(s \ ArchObjectCap cap \ aobj_ref cap = Some r \ cap \ VCPUCap r) \ obj_at (\ko. \ live ko) r s" by (clarsimp simp: live_def valid_cap_def valid_arch_cap_ref_def obj_at_def @@ -1402,8 +1398,7 @@ lemma arch_finalise_cap_replaceable: apply (clarsimp simp: valid_cap_def wellformed_mapdata_def cap_aligned_def obj_at_def) done -global_naming Arch -lemma (* deleting_irq_handler_slot_not_irq_node *)[Finalise_AI_asms]: +lemma (* deleting_irq_handler_slot_not_irq_node *)[Finalise_AI_assms]: "\if_unsafe_then_cap and valid_global_refs and cte_wp_at (\cp. cap_irqs cp \ {}) sl\ deleting_irq_handler irq @@ -1424,7 +1419,7 @@ lemma (* deleting_irq_handler_slot_not_irq_node *)[Finalise_AI_asms]: apply (clarsimp simp: appropriate_cte_cap_def split: cap.split_asm) done -lemma no_cap_to_obj_with_diff_ref_finalI_ARCH[Finalise_AI_asms]: +lemma no_cap_to_obj_with_diff_ref_finalI_ARCH[Finalise_AI_assms]: "\ cte_wp_at ((=) cap) p s; is_final_cap' cap s; obj_refs cap' = obj_refs cap \ \ no_cap_to_obj_with_diff_ref cap' {p} s" @@ -1446,7 +1441,7 @@ lemma no_cap_to_obj_with_diff_ref_finalI_ARCH[Finalise_AI_asms]: gen_obj_refs_Int) done -lemma (* suspend_no_cap_to_obj_ref *)[wp,Finalise_AI_asms]: +lemma (* suspend_no_cap_to_obj_ref *)[wp,Finalise_AI_assms]: "\no_cap_to_obj_with_diff_ref cap S\ suspend t \\rv. no_cap_to_obj_with_diff_ref cap S\" @@ -1490,7 +1485,7 @@ lemma prepare_thread_delete_unlive[wp]: apply (clarsimp simp: obj_at_def, case_tac ko, simp_all add: is_tcb_def live_def) done -lemma finalise_cap_replaceable [Finalise_AI_asms]: +lemma finalise_cap_replaceable [Finalise_AI_assms]: "\\s. s \ cap \ x = is_final_cap' cap s \ valid_mdb s \ cte_wp_at ((=) cap) sl s \ valid_objs s \ sym_refs (state_refs_of s) \ (cap_irqs cap \ {} \ if_unsafe_then_cap s \ valid_global_refs s) @@ -1542,7 +1537,7 @@ lemma finalise_cap_replaceable [Finalise_AI_asms]: | simp add: valid_cap_simps is_nondevice_page_cap_simps)+)) done -lemma (* deleting_irq_handler_cte_preserved *)[Finalise_AI_asms]: +lemma (* deleting_irq_handler_cte_preserved *)[Finalise_AI_assms]: assumes x: "\cap. P cap \ \ can_fast_finalise cap" shows "\cte_wp_at P p\ deleting_irq_handler irq \\rv. cte_wp_at P p\" apply (simp add: deleting_irq_handler_def) @@ -1561,15 +1556,15 @@ lemma arch_thread_set_cte_wp_at[wp]: done crunch dissociate_vcpu_tcb - for cte_wp_at[wp,Finalise_AI_asms]: "\s. P (cte_wp_at P' p s)" + for cte_wp_at[wp,Finalise_AI_assms]: "\s. P (cte_wp_at P' p s)" (simp: crunch_simps assertE_def wp: crunch_wps set_object_cte_at ignore: arch_thread_set) crunch prepare_thread_delete - for cte_wp_at[wp,Finalise_AI_asms]: "\s. P (cte_wp_at P' p s)" + for cte_wp_at[wp,Finalise_AI_assms]: "\s. P (cte_wp_at P' p s)" (simp: crunch_simps assertE_def wp: crunch_wps set_object_cte_at ignore: arch_thread_set) crunch arch_finalise_cap - for cte_wp_at[wp,Finalise_AI_asms]: "\s. P (cte_wp_at P' p s)" + for cte_wp_at[wp,Finalise_AI_assms]: "\s. P (cte_wp_at P' p s)" (simp: crunch_simps assertE_def wp: crunch_wps set_object_cte_at ignore: arch_thread_set) end @@ -1578,10 +1573,10 @@ interpretation Finalise_AI_1?: Finalise_AI_1 proof goal_cases interpret Arch . case 1 show ?case - by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma fast_finalise_replaceable[wp]: "\\s. s \ cap \ x = is_final_cap' cap s @@ -1602,8 +1597,7 @@ lemma fast_finalise_replaceable[wp]: apply (clarsimp simp: cap_irqs_def cap_irq_opt_def split: cap.split_asm) done -global_naming Arch -lemma (* cap_delete_one_invs *) [Finalise_AI_asms,wp]: +lemma (* cap_delete_one_invs *) [Finalise_AI_assms,wp]: "\invs and emptyable ptr\ cap_delete_one ptr \\rv. invs\" apply (simp add: cap_delete_one_def unless_def is_final_cap_def) apply (rule hoare_pre) @@ -1617,10 +1611,10 @@ end interpretation Finalise_AI_2?: Finalise_AI_2 proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming crunch vcpu_update, vgic_update, vcpu_disable, vcpu_restore, vcpu_save_reg_range, vgic_update_lr, @@ -1629,7 +1623,7 @@ crunch (wp: crunch_wps subset_refl) crunch prepare_thread_delete - for irq_node[Finalise_AI_asms,wp]: "\s. P (interrupt_irq_node s)" + for irq_node[Finalise_AI_assms,wp]: "\s. P (interrupt_irq_node s)" (wp: crunch_wps simp: crunch_simps) crunch arch_finalise_cap @@ -1753,7 +1747,7 @@ lemma invs_valid_arch_capsI: "invs s \ valid_arch_caps s" by (simp add: invs_def valid_state_def) -context Arch begin global_naming AARCH64 (*FIXME: arch_split*) +context Arch begin arch_global_naming lemma do_machine_op_reachable_pg_cap[wp]: "\\s. P (reachable_frame_cap cap s)\ @@ -1773,14 +1767,11 @@ lemma replaceable_or_arch_update_pg: apply (auto simp: is_cap_simps is_arch_update_def cap_master_cap_simps) done - -global_naming Arch - crunch prepare_thread_delete for invs[wp]: invs (ignore: set_object do_machine_op wp: dmo_invs_lift) -lemma (* finalise_cap_invs *)[Finalise_AI_asms]: +lemma (* finalise_cap_invs *)[Finalise_AI_assms]: shows "\invs and cte_wp_at ((=) cap) slot\ finalise_cap cap x \\rv. invs\" apply (cases cap, simp_all split del: if_split) apply (wp cancel_all_ipc_invs cancel_all_signals_invs unbind_notification_invs @@ -1797,14 +1788,14 @@ lemma (* finalise_cap_invs *)[Finalise_AI_asms]: apply (auto dest: cte_wp_at_valid_objs_valid_cap) done -lemma (* finalise_cap_irq_node *)[Finalise_AI_asms]: +lemma (* finalise_cap_irq_node *)[Finalise_AI_assms]: "\\s. P (interrupt_irq_node s)\ finalise_cap a b \\_ s. P (interrupt_irq_node s)\" by (case_tac a, wpsimp+) -lemmas (*arch_finalise_cte_irq_node *) [wp,Finalise_AI_asms] +lemmas (*arch_finalise_cte_irq_node *) [wp,Finalise_AI_assms] = hoare_use_eq_irq_node [OF arch_finalise_cap_irq_node arch_finalise_cap_cte_wp_at] -lemma (* deleting_irq_handler_st_tcb_at *) [Finalise_AI_asms]: +lemma (* deleting_irq_handler_st_tcb_at *) [Finalise_AI_assms]: "\st_tcb_at P t and K (\st. simple st \ P st)\ deleting_irq_handler irq \\rv. st_tcb_at P t\" @@ -1813,11 +1804,11 @@ lemma (* deleting_irq_handler_st_tcb_at *) [Finalise_AI_asms]: apply simp done -lemma irq_node_global_refs_ARCH [Finalise_AI_asms]: +lemma irq_node_global_refs_ARCH [Finalise_AI_assms]: "interrupt_irq_node s irq \ global_refs s" by (simp add: global_refs_def) -lemma (* get_irq_slot_fast_finalisable *)[wp,Finalise_AI_asms]: +lemma (* get_irq_slot_fast_finalisable *)[wp,Finalise_AI_assms]: "\invs\ get_irq_slot irq \cte_wp_at can_fast_finalise\" apply (simp add: get_irq_slot_def) apply wp @@ -1839,12 +1830,12 @@ lemma (* get_irq_slot_fast_finalisable *)[wp,Finalise_AI_asms]: apply (clarsimp simp: cap_range_def) done -lemma (* replaceable_or_arch_update_same *) [Finalise_AI_asms]: +lemma (* replaceable_or_arch_update_same *) [Finalise_AI_assms]: "replaceable_or_arch_update s slot cap cap" by (clarsimp simp: replaceable_or_arch_update_def replaceable_def is_arch_update_def is_cap_simps) -lemma (* replace_cap_invs_arch_update *)[Finalise_AI_asms]: +lemma (* replace_cap_invs_arch_update *)[Finalise_AI_assms]: "\\s. cte_wp_at (replaceable_or_arch_update s p cap) p s \ invs s \ cap \ cap.NullCap @@ -1869,7 +1860,7 @@ lemma dmo_pred_tcb_at[wp]: apply (clarsimp simp: pred_tcb_at_def obj_at_def) done -lemma dmo_tcb_cap_valid_ARCH [Finalise_AI_asms]: +lemma dmo_tcb_cap_valid_ARCH [Finalise_AI_assms]: "do_machine_op mop \\s. P (tcb_cap_valid cap ptr s)\" apply (simp add: tcb_cap_valid_def no_cap_to_obj_with_diff_ref_def) apply (wp_pre, wps, rule hoare_vcg_prop) @@ -1887,7 +1878,7 @@ lemma dmo_reachable_target[wp]: apply simp done -lemma (* dmo_replaceable_or_arch_update *) [Finalise_AI_asms,wp]: +lemma (* dmo_replaceable_or_arch_update *) [Finalise_AI_assms,wp]: "\\s. replaceable_or_arch_update s slot cap cap'\ do_machine_op mo \\r s. replaceable_or_arch_update s slot cap cap'\" @@ -1900,19 +1891,17 @@ lemma (* dmo_replaceable_or_arch_update *) [Finalise_AI_asms,wp]: end -context begin interpretation Arch . -requalify_consts replaceable_or_arch_update -end +arch_requalify_consts replaceable_or_arch_update interpretation Finalise_AI_3?: Finalise_AI_3 where replaceable_or_arch_update = replaceable_or_arch_update proof goal_cases interpret Arch . case 1 show ?case - by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma typ_at_data_at_wp: assumes typ_wp: "\a.\typ_at a p \ g \\s. typ_at a p\" @@ -1927,10 +1916,10 @@ interpretation Finalise_AI_4?: Finalise_AI_4 where replaceable_or_arch_update = replaceable_or_arch_update proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma set_asid_pool_obj_at_ptr: "\\s. P (ArchObj (arch_kernel_obj.ASIDPool mp))\ @@ -1965,11 +1954,9 @@ lemma arch_finalise_cap_valid_cap[wp]: unfolding arch_finalise_cap_def by (wpsimp split: arch_cap.split option.split bool.split) -global_naming Arch - -lemmas clearMemory_invs[wp,Finalise_AI_asms] = clearMemory_invs +lemmas clearMemory_invs[wp,Finalise_AI_assms] = clearMemory_invs -lemma valid_idle_has_null_cap_ARCH[Finalise_AI_asms]: +lemma valid_idle_has_null_cap_ARCH[Finalise_AI_assms]: "\ if_unsafe_then_cap s; valid_global_refs s; valid_idle s; valid_irq_node s; caps_of_state s (idle_thread s, v) = Some cap \ \ cap = NullCap" @@ -1985,7 +1972,7 @@ lemma valid_idle_has_null_cap_ARCH[Finalise_AI_asms]: apply (drule_tac x=word in spec, simp) done -lemma (* zombie_cap_two_nonidles *)[Finalise_AI_asms]: +lemma (* zombie_cap_two_nonidles *)[Finalise_AI_assms]: "\ caps_of_state s ptr = Some (Zombie ptr' zbits n); invs s \ \ fst ptr \ idle_thread s \ ptr' \ idle_thread s" apply (frule valid_global_refsD2, clarsimp+) @@ -2011,7 +1998,7 @@ interpretation Finalise_AI_5?: Finalise_AI_5 where replaceable_or_arch_update = replaceable_or_arch_update proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed end diff --git a/proof/invariant-abstract/AARCH64/ArchInterruptAcc_AI.thy b/proof/invariant-abstract/AARCH64/ArchInterruptAcc_AI.thy index 89d96eedf9..b1ad88de5d 100644 --- a/proof/invariant-abstract/AARCH64/ArchInterruptAcc_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchInterruptAcc_AI.thy @@ -12,7 +12,7 @@ theory ArchInterruptAcc_AI imports InterruptAcc_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems InterruptAcc_AI_assms diff --git a/proof/invariant-abstract/AARCH64/ArchInterrupt_AI.thy b/proof/invariant-abstract/AARCH64/ArchInterrupt_AI.thy index 4ef745e647..d3948582f8 100644 --- a/proof/invariant-abstract/AARCH64/ArchInterrupt_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchInterrupt_AI.thy @@ -9,7 +9,7 @@ theory ArchInterrupt_AI imports Interrupt_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming primrec arch_irq_control_inv_valid_real :: "arch_irq_control_invocation \ 'a::state_ext state \ bool" @@ -24,16 +24,16 @@ primrec arch_irq_control_inv_valid_real :: defs arch_irq_control_inv_valid_def: "arch_irq_control_inv_valid \ arch_irq_control_inv_valid_real" -named_theorems Interrupt_AI_asms +named_theorems Interrupt_AI_assms -lemma (* decode_irq_control_invocation_inv *)[Interrupt_AI_asms]: +lemma (* decode_irq_control_invocation_inv *)[Interrupt_AI_assms]: "\P\ decode_irq_control_invocation label args slot caps \\rv. P\" apply (simp add: decode_irq_control_invocation_def Let_def arch_check_irq_def arch_decode_irq_control_invocation_def whenE_def, safe) apply (wp | simp)+ done -lemma decode_irq_control_valid [Interrupt_AI_asms]: +lemma decode_irq_control_valid [Interrupt_AI_assms]: "\\s. invs s \ (\cap \ set caps. s \ cap) \ (\cap \ set caps. is_cnode_cap cap \ (\r \ cte_refs cap (interrupt_irq_node s). ex_cte_cap_wp_to is_cnode_cap r s)) @@ -51,7 +51,7 @@ lemma decode_irq_control_valid [Interrupt_AI_asms]: apply (intro conjI impI; clarsimp) done -lemma get_irq_slot_different_ARCH[Interrupt_AI_asms]: +lemma get_irq_slot_different_ARCH[Interrupt_AI_assms]: "\\s. valid_global_refs s \ ex_cte_cap_wp_to is_cnode_cap ptr s\ get_irq_slot irq \\rv s. rv \ ptr\" @@ -63,7 +63,7 @@ lemma get_irq_slot_different_ARCH[Interrupt_AI_asms]: apply (clarsimp simp: global_refs_def is_cap_simps cap_range_def) done -lemma is_derived_use_interrupt_ARCH[Interrupt_AI_asms]: +lemma is_derived_use_interrupt_ARCH[Interrupt_AI_assms]: "(is_ntfn_cap cap \ interrupt_derived cap cap') \ (is_derived m p cap cap')" apply (clarsimp simp: is_cap_simps) apply (clarsimp simp: interrupt_derived_def is_derived_def) @@ -71,7 +71,7 @@ lemma is_derived_use_interrupt_ARCH[Interrupt_AI_asms]: apply (simp add: is_cap_simps is_pt_cap_def vs_cap_ref_def) done -lemma maskInterrupt_invs_ARCH[Interrupt_AI_asms]: +lemma maskInterrupt_invs_ARCH[Interrupt_AI_assms]: "\invs and (\s. \b \ interrupt_states s irq \ IRQInactive)\ do_machine_op (maskInterrupt b irq) \\rv. invs\" @@ -91,13 +91,13 @@ lemma dmo_plic_complete_claim[wp]: apply (auto simp: plic_complete_claim_def machine_op_lift_def machine_rest_lift_def in_monad select_f_def) done -lemma no_cap_to_obj_with_diff_IRQHandler_ARCH[Interrupt_AI_asms]: +lemma no_cap_to_obj_with_diff_IRQHandler_ARCH[Interrupt_AI_assms]: "no_cap_to_obj_with_diff_ref (IRQHandlerCap irq) S = \" by (rule ext, simp add: no_cap_to_obj_with_diff_ref_def cte_wp_at_caps_of_state obj_ref_none_no_asid) -lemma (* set_irq_state_valid_cap *)[Interrupt_AI_asms]: +lemma (* set_irq_state_valid_cap *)[Interrupt_AI_assms]: "\valid_cap cap\ set_irq_state IRQSignal irq \\rv. valid_cap cap\" apply (clarsimp simp: set_irq_state_def) apply (wp do_machine_op_valid_cap) @@ -107,9 +107,9 @@ lemma (* set_irq_state_valid_cap *)[Interrupt_AI_asms]: done crunch set_irq_state - for valid_global_refs[Interrupt_AI_asms]: "valid_global_refs" + for valid_global_refs[Interrupt_AI_assms]: "valid_global_refs" -lemma invoke_irq_handler_invs'[Interrupt_AI_asms]: +lemma invoke_irq_handler_invs'[Interrupt_AI_assms]: assumes dmo_ex_inv[wp]: "\f. \invs and ex_inv\ do_machine_op f \\rv::unit. ex_inv\" assumes cap_insert_ex_inv[wp]: "\cap src dest. \ex_inv and invs and K (src \ dest)\ @@ -165,7 +165,7 @@ lemma invoke_irq_handler_invs'[Interrupt_AI_asms]: done qed -lemma (* invoke_irq_control_invs *) [Interrupt_AI_asms]: +lemma (* invoke_irq_control_invs *) [Interrupt_AI_assms]: "\invs and irq_control_inv_valid i\ invoke_irq_control i \\rv. invs\" apply (cases i, simp_all) apply (wp cap_insert_simple_invs @@ -189,7 +189,7 @@ lemma (* invoke_irq_control_invs *) [Interrupt_AI_asms]: crunch resetTimer for device_state_inv[wp]: "\ms. P (device_state ms)" -lemma resetTimer_invs_ARCH[Interrupt_AI_asms]: +lemma resetTimer_invs_ARCH[Interrupt_AI_assms]: "\invs\ do_machine_op resetTimer \\_. invs\" apply (wp dmo_invs) apply safe @@ -202,11 +202,11 @@ lemma resetTimer_invs_ARCH[Interrupt_AI_asms]: apply(erule use_valid, wp no_irq_resetTimer no_irq, assumption) done -lemma empty_fail_ackInterrupt_ARCH[Interrupt_AI_asms]: +lemma empty_fail_ackInterrupt_ARCH[Interrupt_AI_assms]: "empty_fail (ackInterrupt irq)" by (wp | simp add: ackInterrupt_def)+ -lemma empty_fail_maskInterrupt_ARCH[Interrupt_AI_asms]: +lemma empty_fail_maskInterrupt_ARCH[Interrupt_AI_assms]: "empty_fail (maskInterrupt f irq)" by (wp | simp add: maskInterrupt_def)+ @@ -269,7 +269,7 @@ lemma handle_reserved_irq_invs[wp]: "\invs\ handle_reserved_irq irq \\_. invs\" unfolding handle_reserved_irq_def by (wpsimp simp: non_kernel_IRQs_def) -lemma (* handle_interrupt_invs *) [Interrupt_AI_asms]: +lemma (* handle_interrupt_invs *) [Interrupt_AI_assms]: "\invs\ handle_interrupt irq \\_. invs\" apply (simp add: handle_interrupt_def) apply (rule conjI; rule impI) @@ -286,7 +286,7 @@ lemma (* handle_interrupt_invs *) [Interrupt_AI_asms]: | rule conjI)+ done -lemma sts_arch_irq_control_inv_valid[wp, Interrupt_AI_asms]: +lemma sts_arch_irq_control_inv_valid[wp, Interrupt_AI_assms]: "\arch_irq_control_inv_valid i\ set_thread_state t st \\rv. arch_irq_control_inv_valid i\" @@ -303,7 +303,7 @@ end interpretation Interrupt_AI?: Interrupt_AI proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales, simp_all add: Interrupt_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales, simp_all add: Interrupt_AI_assms)?) qed end diff --git a/proof/invariant-abstract/AARCH64/ArchInvariants_AI.thy b/proof/invariant-abstract/AARCH64/ArchInvariants_AI.thy index a9f92a1061..ee66eb7045 100644 --- a/proof/invariant-abstract/AARCH64/ArchInvariants_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchInvariants_AI.thy @@ -9,7 +9,7 @@ theory ArchInvariants_AI imports InvariantsPre_AI "Eisbach_Tools.Apply_Trace_Cmd" begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming (* compatibility with other architectures, input only *) abbreviation @@ -29,7 +29,7 @@ record iarch_tcb = itcb_vcpu :: "obj_ref option" end_qualify -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming definition arch_tcb_to_iarch_tcb :: "arch_tcb \ iarch_tcb" where "arch_tcb_to_iarch_tcb arch_tcb \ \ itcb_vcpu = tcb_vcpu arch_tcb \" @@ -1272,7 +1272,7 @@ lemma aobj_at_default_arch_cap_valid: lemmas aobj_ref_default = aobj_ref_arch_cap -lemma acap_rights_update_id [intro!, simp]: +lemma wf_acap_rights_update_id [intro!, simp]: "wellformed_acap cap \ acap_rights_update (acap_rights cap) cap = cap" unfolding acap_rights_update_def by (auto split: arch_cap.splits option.splits) diff --git a/proof/invariant-abstract/AARCH64/ArchIpcCancel_AI.thy b/proof/invariant-abstract/AARCH64/ArchIpcCancel_AI.thy index 40371a827a..1a33884511 100644 --- a/proof/invariant-abstract/AARCH64/ArchIpcCancel_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchIpcCancel_AI.thy @@ -8,13 +8,13 @@ theory ArchIpcCancel_AI imports IpcCancel_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming -named_theorems IpcCancel_AI_asms +named_theorems IpcCancel_AI_assms crunch arch_post_cap_deletion - for typ_at[wp, IpcCancel_AI_asms]: "\s. P (typ_at T p s)" - and idle_thread[wp, IpcCancel_AI_asms]: "\s. P (idle_thread s)" + for typ_at[wp, IpcCancel_AI_assms]: "\s. P (typ_at T p s)" + and idle_thread[wp, IpcCancel_AI_assms]: "\s. P (idle_thread s)" end @@ -22,7 +22,7 @@ interpretation IpcCancel_AI?: IpcCancel_AI proof goal_cases interpret Arch . case 1 show ?case - by (intro_locales; (unfold_locales; fact IpcCancel_AI_asms)?) + by (intro_locales; (unfold_locales; fact IpcCancel_AI_assms)?) qed diff --git a/proof/invariant-abstract/AARCH64/ArchIpc_AI.thy b/proof/invariant-abstract/AARCH64/ArchIpc_AI.thy index 448c7690d0..0c3835fe49 100644 --- a/proof/invariant-abstract/AARCH64/ArchIpc_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchIpc_AI.thy @@ -9,7 +9,7 @@ theory ArchIpc_AI imports Ipc_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems Ipc_AI_assms @@ -499,7 +499,7 @@ proof goal_cases case 1 show ?case by (unfold_locales; (fact Ipc_AI_assms)?) qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems Ipc_AI_cont_assms diff --git a/proof/invariant-abstract/AARCH64/ArchKHeap_AI.thy b/proof/invariant-abstract/AARCH64/ArchKHeap_AI.thy index 4ec61c00b0..bcd7840fc9 100644 --- a/proof/invariant-abstract/AARCH64/ArchKHeap_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchKHeap_AI.thy @@ -9,7 +9,7 @@ theory ArchKHeap_AI imports KHeapPre_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming definition non_vspace_obj :: "kernel_object \ bool" where "non_vspace_obj ko \ case ko of @@ -129,7 +129,7 @@ locale vspace_only_obj_pred = Arch + sublocale vspace_only_obj_pred < arch_only_obj_pred using vspace_pred_imp[OF vspace_only] by unfold_locales -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma valid_vspace_obj_lift: assumes "\T p. T \ AVCPU \ f \typ_at (AArch T) p\" diff --git a/proof/invariant-abstract/AARCH64/ArchKernelInit_AI.thy b/proof/invariant-abstract/AARCH64/ArchKernelInit_AI.thy index 5b0a5e6c44..c9e7d1dfc1 100644 --- a/proof/invariant-abstract/AARCH64/ArchKernelInit_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchKernelInit_AI.thy @@ -12,7 +12,7 @@ imports Arch_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming text \ Showing that there is a state that satisfies the abstract invariants. diff --git a/proof/invariant-abstract/AARCH64/ArchLevityCatch_AI.thy b/proof/invariant-abstract/AARCH64/ArchLevityCatch_AI.thy index 925b19f736..8b22b3fd86 100644 --- a/proof/invariant-abstract/AARCH64/ArchLevityCatch_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchLevityCatch_AI.thy @@ -12,7 +12,7 @@ imports "Lib.SplitRule" begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma asid_high_bits_of_shift[simp]: "asid_high_bits_of (ucast x << asid_low_bits) = x" diff --git a/proof/invariant-abstract/AARCH64/ArchRetype_AI.thy b/proof/invariant-abstract/AARCH64/ArchRetype_AI.thy index 1ed3288e1f..2312ee018f 100644 --- a/proof/invariant-abstract/AARCH64/ArchRetype_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchRetype_AI.thy @@ -13,7 +13,7 @@ theory ArchRetype_AI imports Retype_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems Retype_AI_assms @@ -125,10 +125,7 @@ declare post_retype_invs_check_def[simp] end - -context begin interpretation Arch . -requalify_consts post_retype_invs_check -end +arch_requalify_consts post_retype_invs_check definition post_retype_invs :: "apiobject_type \ obj_ref list \ 'z::state_ext state \ bool" @@ -144,19 +141,16 @@ global_interpretation Retype_AI_post_retype_invs?: Retype_AI_post_retype_invs by (unfold_locales; fact post_retype_invs_def) -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma init_arch_objects_invs_from_restricted: "\post_retype_invs new_type refs and (\s. global_refs s \ set refs = {}) and K (\ref \ set refs. is_aligned ref (obj_bits_api new_type obj_sz))\ - init_arch_objects new_type ptr bits obj_sz refs + init_arch_objects new_type dev ptr bits obj_sz refs \\_. invs\" apply (simp add: init_arch_objects_def split del: if_split) - apply (rule hoare_pre) - apply (wp hoare_vcg_const_Ball_lift - valid_irq_node_typ - | wpc)+ + apply (wpsimp wp: dmo_invs_lift mapM_x_wp') apply (auto simp: post_retype_invs_def) done @@ -177,7 +171,7 @@ global_interpretation Retype_AI_slot_bits?: Retype_AI_slot_bits qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma valid_untyped_helper [Retype_AI_assms]: assumes valid_c : "s \ c" @@ -274,6 +268,7 @@ locale retype_region_proofs_arch context retype_region_proofs begin +(* FIXME arch-split: is there any way to optimise this interpretation out? we can't nest contexts *) interpretation Arch . lemma valid_cap: @@ -580,7 +575,7 @@ sublocale retype_region_proofs_gen?: retype_region_proofs_gen end -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma unique_table_caps_null: "unique_table_caps_2 (null_filter caps) @@ -683,10 +678,7 @@ lemma cap_range_respects_device_region_cong[cong]: by (clarsimp simp: cap_range_respects_device_region_def) -context begin interpretation Arch . -requalify_consts region_in_kernel_window -end - +arch_requalify_consts region_in_kernel_window context retype_region_proofs_arch begin @@ -875,7 +867,7 @@ lemmas post_retype_invs_axioms = retype_region_proofs_invs_axioms end -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems Retype_AI_assms' @@ -905,7 +897,7 @@ global_interpretation Retype_AI?: Retype_AI qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma retype_region_plain_invs: "\invs and caps_no_overlap ptr sz and pspace_no_overlap_range_cover ptr sz @@ -986,7 +978,7 @@ crunch init_arch_objects lemma init_arch_objects_excap: "\ex_cte_cap_wp_to P p\ - init_arch_objects tp ptr bits us refs + init_arch_objects tp dev ptr bits us refs \\rv s. ex_cte_cap_wp_to P p s\" by (wp ex_cte_cap_to_pres) diff --git a/proof/invariant-abstract/AARCH64/ArchSchedule_AI.thy b/proof/invariant-abstract/AARCH64/ArchSchedule_AI.thy index b482dcb70f..01d12ad001 100644 --- a/proof/invariant-abstract/AARCH64/ArchSchedule_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchSchedule_AI.thy @@ -9,11 +9,11 @@ theory ArchSchedule_AI imports Schedule_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming -named_theorems Schedule_AI_asms +named_theorems Schedule_AI_assms -lemma dmo_mapM_storeWord_0_invs[wp,Schedule_AI_asms]: +lemma dmo_mapM_storeWord_0_invs[wp,Schedule_AI_assms]: "do_machine_op (mapM (\p. storeWord p 0) S) \invs\" apply (simp add: dom_mapM) apply (rule mapM_UNIV_wp) @@ -28,18 +28,16 @@ lemma dmo_mapM_storeWord_0_invs[wp,Schedule_AI_asms]: apply wp by (simp add: upto.simps word_bits_def) -global_naming Arch - -lemma arch_stt_invs [wp,Schedule_AI_asms]: +lemma arch_stt_invs [wp,Schedule_AI_assms]: "arch_switch_to_thread t' \invs\" apply (wpsimp simp: arch_switch_to_thread_def) by (rule sym_refs_VCPU_hyp_live; fastforce) -lemma arch_stt_tcb [wp,Schedule_AI_asms]: +lemma arch_stt_tcb [wp,Schedule_AI_assms]: "arch_switch_to_thread t' \tcb_at t'\" by (wpsimp simp: arch_switch_to_thread_def wp: tcb_at_typ_at) -lemma arch_stt_runnable[Schedule_AI_asms]: +lemma arch_stt_runnable[Schedule_AI_assms]: "arch_switch_to_thread t \st_tcb_at runnable t\" by (wpsimp simp: arch_switch_to_thread_def) @@ -55,7 +53,7 @@ crunch and ct[wp]: "\s. P (cur_thread s)" (wp: mapM_x_wp mapM_wp subset_refl) -lemma arch_stit_invs[wp, Schedule_AI_asms]: +lemma arch_stit_invs[wp, Schedule_AI_assms]: "arch_switch_to_idle_thread \invs\" by (wpsimp simp: arch_switch_to_idle_thread_def) @@ -68,19 +66,19 @@ crunch set_vm_root and it[wp]: "\s. P (idle_thread s)" (simp: crunch_simps wp: hoare_drop_imps) -lemma arch_stit_activatable[wp, Schedule_AI_asms]: +lemma arch_stit_activatable[wp, Schedule_AI_assms]: "arch_switch_to_idle_thread \ct_in_state activatable\" apply (clarsimp simp: arch_switch_to_idle_thread_def) apply (wpsimp simp: ct_in_state_def wp: ct_in_state_thread_state_lift) done -lemma stit_invs [wp,Schedule_AI_asms]: +lemma stit_invs [wp,Schedule_AI_assms]: "switch_to_idle_thread \invs\" apply (simp add: switch_to_idle_thread_def arch_switch_to_idle_thread_def) apply (wpsimp|strengthen idle_strg)+ done -lemma stit_activatable[Schedule_AI_asms]: +lemma stit_activatable[Schedule_AI_assms]: "\invs\ switch_to_idle_thread \\_. ct_in_state activatable\" apply (simp add: switch_to_idle_thread_def arch_switch_to_idle_thread_def) apply (wpsimp simp: ct_in_state_def) @@ -88,7 +86,7 @@ lemma stit_activatable[Schedule_AI_asms]: elim!: pred_tcb_weaken_strongerE) done -lemma stt_invs [wp,Schedule_AI_asms]: +lemma stt_invs [wp,Schedule_AI_assms]: "switch_to_thread t' \invs\" apply (simp add: switch_to_thread_def) apply wp @@ -108,14 +106,14 @@ interpretation Schedule_AI_U?: Schedule_AI_U proof goal_cases interpret Arch . case 1 show ?case - by (intro_locales; (unfold_locales; fact Schedule_AI_asms)?) + by (intro_locales; (unfold_locales; fact Schedule_AI_assms)?) qed interpretation Schedule_AI?: Schedule_AI proof goal_cases interpret Arch . case 1 show ?case - by (intro_locales; (unfold_locales; fact Schedule_AI_asms)?) + by (intro_locales; (unfold_locales; fact Schedule_AI_assms)?) qed end diff --git a/proof/invariant-abstract/AARCH64/ArchSyscall_AI.thy b/proof/invariant-abstract/AARCH64/ArchSyscall_AI.thy index 4293491321..6c673e874c 100644 --- a/proof/invariant-abstract/AARCH64/ArchSyscall_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchSyscall_AI.thy @@ -14,7 +14,7 @@ imports Syscall_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems Syscall_AI_assms diff --git a/proof/invariant-abstract/AARCH64/ArchTcbAcc_AI.thy b/proof/invariant-abstract/AARCH64/ArchTcbAcc_AI.thy index 71494de427..99ad83388e 100644 --- a/proof/invariant-abstract/AARCH64/ArchTcbAcc_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchTcbAcc_AI.thy @@ -8,7 +8,7 @@ theory ArchTcbAcc_AI imports TcbAcc_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems TcbAcc_AI_assms diff --git a/proof/invariant-abstract/AARCH64/ArchTcb_AI.thy b/proof/invariant-abstract/AARCH64/ArchTcb_AI.thy index 70765d9317..33d7d7f6ed 100644 --- a/proof/invariant-abstract/AARCH64/ArchTcb_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchTcb_AI.thy @@ -9,19 +9,19 @@ theory ArchTcb_AI imports Tcb_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming -named_theorems Tcb_AI_asms +named_theorems Tcb_AI_assms -lemma activate_idle_invs[Tcb_AI_asms]: +lemma activate_idle_invs[Tcb_AI_assms]: "\invs and ct_idle\ arch_activate_idle_thread thread \\rv. invs and ct_idle\" by (simp add: arch_activate_idle_thread_def) -declare getRegister_empty_fail [Tcb_AI_asms] +declare getRegister_empty_fail [Tcb_AI_assms] lemma same_object_also_valid: (* arch specific *) "\ same_object_as cap cap'; s \ cap'; wellformed_cap cap; @@ -35,7 +35,7 @@ lemma same_object_also_valid: (* arch specific *) split: cap.split_asm arch_cap.split_asm option.splits)+) done -lemma same_object_obj_refs[Tcb_AI_asms]: +lemma same_object_obj_refs[Tcb_AI_assms]: "\ same_object_as cap cap' \ \ obj_refs cap = obj_refs cap'" apply (cases cap, simp_all add: same_object_as_def) @@ -122,13 +122,13 @@ lemma checked_insert_tcb_invs[wp]: (* arch specific *) done crunch arch_get_sanitise_register_info, arch_post_modify_registers - for tcb_at[wp, Tcb_AI_asms]: "tcb_at a" + for tcb_at[wp, Tcb_AI_assms]: "tcb_at a" crunch arch_get_sanitise_register_info, arch_post_modify_registers - for invs[wp, Tcb_AI_asms]: "invs" + for invs[wp, Tcb_AI_assms]: "invs" crunch arch_get_sanitise_register_info, arch_post_modify_registers - for ex_nonz_cap_to[wp, Tcb_AI_asms]: "ex_nonz_cap_to a" + for ex_nonz_cap_to[wp, Tcb_AI_assms]: "ex_nonz_cap_to a" -lemma finalise_cap_not_cte_wp_at[Tcb_AI_asms]: +lemma finalise_cap_not_cte_wp_at[Tcb_AI_assms]: assumes x: "P cap.NullCap" shows "\\s. \cp \ ran (caps_of_state s). P cp\ finalise_cap cap fin @@ -145,7 +145,7 @@ lemma finalise_cap_not_cte_wp_at[Tcb_AI_asms]: done -lemma table_cap_ref_max_free_index_upd[simp,Tcb_AI_asms]: +lemma table_cap_ref_max_free_index_upd[simp,Tcb_AI_assms]: "table_cap_ref (max_free_index_update cap) = table_cap_ref cap" by (simp add:free_index_update_def table_cap_ref_def split:cap.splits) @@ -156,10 +156,10 @@ global_interpretation Tcb_AI_1?: Tcb_AI_1 and is_cnode_or_valid_arch = is_cnode_or_valid_arch proof goal_cases interpret Arch . - case 1 show ?case by (unfold_locales; (fact Tcb_AI_asms)?) + case 1 show ?case by (unfold_locales; (fact Tcb_AI_assms)?) qed -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma use_no_cap_to_obj_asid_strg: (* arch specific *) "(cte_at p s \ no_cap_to_obj_dr_emp cap s \ valid_cap cap s \ invs s) @@ -175,7 +175,7 @@ lemma use_no_cap_to_obj_asid_strg: (* arch specific *) by (fastforce simp: table_cap_ref_def vspace_asid_def valid_cap_simps obj_at_def split: cap.splits arch_cap.splits option.splits prod.splits) -lemma cap_delete_no_cap_to_obj_asid[wp, Tcb_AI_asms]: +lemma cap_delete_no_cap_to_obj_asid[wp, Tcb_AI_assms]: "\no_cap_to_obj_dr_emp cap\ cap_delete slot \\rv. no_cap_to_obj_dr_emp cap\" @@ -209,7 +209,7 @@ lemma option_case_eq_None: "((case m of None \ None | Some (a,b) \ Some a) = None) = (m = None)" by (clarsimp split: option.splits) -lemma tc_invs[Tcb_AI_asms]: +lemma tc_invs[Tcb_AI_assms]: "\invs and tcb_at a and (case_option \ (valid_cap o fst) e) and (case_option \ (valid_cap o fst) f) @@ -285,7 +285,7 @@ lemma check_valid_ipc_buffer_inv: (* arch_specific *) apply (wp | simp add: if_apply_def2 split del: if_split | wpcw)+ done -lemma check_valid_ipc_buffer_wp[Tcb_AI_asms]: +lemma check_valid_ipc_buffer_wp[Tcb_AI_assms]: "\\(s::'state_ext::state_ext state). is_arch_cap cap \ is_cnode_or_valid_arch cap \ valid_ipc_buffer_cap cap vptr \ is_aligned vptr msg_align_bits @@ -301,7 +301,7 @@ lemma check_valid_ipc_buffer_wp[Tcb_AI_asms]: valid_ipc_buffer_cap_def) done -lemma derive_no_cap_asid[wp,Tcb_AI_asms]: +lemma derive_no_cap_asid[wp,Tcb_AI_assms]: "\(no_cap_to_obj_with_diff_ref cap S)::'state_ext::state_ext state\bool\ derive_cap slot cap \\rv. no_cap_to_obj_with_diff_ref rv S\,-" @@ -315,7 +315,7 @@ lemma derive_no_cap_asid[wp,Tcb_AI_asms]: done -lemma decode_set_ipc_inv[wp,Tcb_AI_asms]: +lemma decode_set_ipc_inv[wp,Tcb_AI_assms]: "\P::'state_ext::state_ext state \ bool\ decode_set_ipc_buffer args cap slot excaps \\rv. P\" apply (simp add: decode_set_ipc_buffer_def whenE_def split_def @@ -324,7 +324,7 @@ lemma decode_set_ipc_inv[wp,Tcb_AI_asms]: apply simp done -lemma no_cap_to_obj_with_diff_ref_update_cap_data[Tcb_AI_asms]: +lemma no_cap_to_obj_with_diff_ref_update_cap_data[Tcb_AI_assms]: "no_cap_to_obj_with_diff_ref c S s \ no_cap_to_obj_with_diff_ref (update_cap_data P x c) S s" apply (case_tac "update_cap_data P x c = NullCap") @@ -341,7 +341,7 @@ lemma no_cap_to_obj_with_diff_ref_update_cap_data[Tcb_AI_asms]: done -lemma update_cap_valid[Tcb_AI_asms]: +lemma update_cap_valid[Tcb_AI_assms]: "valid_cap cap (s::'state_ext::state_ext state) \ valid_cap (case capdata of None \ cap_rights_update rs cap @@ -376,16 +376,11 @@ crunch invoke_tcb end -context begin interpretation Arch . -requalify_consts is_cnode_or_valid_arch -requalify_facts invoke_tcb_typ_at -end - global_interpretation Tcb_AI?: Tcb_AI where is_cnode_or_valid_arch = AARCH64.is_cnode_or_valid_arch proof goal_cases interpret Arch . - case 1 show ?case by (unfold_locales; (fact Tcb_AI_asms)?) + case 1 show ?case by (unfold_locales; (fact Tcb_AI_assms)?) qed end diff --git a/proof/invariant-abstract/AARCH64/ArchUntyped_AI.thy b/proof/invariant-abstract/AARCH64/ArchUntyped_AI.thy index 3a046586e8..3a60b1f14a 100644 --- a/proof/invariant-abstract/AARCH64/ArchUntyped_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchUntyped_AI.thy @@ -9,7 +9,7 @@ theory ArchUntyped_AI imports Untyped_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming named_theorems Untyped_AI_assms @@ -192,15 +192,17 @@ lemma cap_refs_in_kernel_windowD2: lemma init_arch_objects_descendants_range[wp,Untyped_AI_assms]: "\\(s::'state_ext::state_ext state). descendants_range x cref s \ - init_arch_objects ty ptr n us y + init_arch_objects ty dev ptr n us y \\rv s. descendants_range x cref s\" - unfolding init_arch_objects_def by wp + unfolding init_arch_objects_def descendants_range_def + by (wp mapM_x_wp' | wps)+ simp lemma init_arch_objects_caps_overlap_reserved[wp,Untyped_AI_assms]: "\\(s::'state_ext::state_ext state). caps_overlap_reserved S s\ - init_arch_objects ty ptr n us y + init_arch_objects ty dev ptr n us y \\rv s. caps_overlap_reserved S s\" - unfolding init_arch_objects_def by wp + unfolding init_arch_objects_def caps_overlap_reserved_def + by (wp mapM_x_wp' | wps)+ simp lemma set_untyped_cap_invs_simple[Untyped_AI_assms]: "\\s. descendants_range_in {ptr .. ptr+2^sz - 1} cref s \ pspace_no_overlap_range_cover ptr sz s \ invs s @@ -325,9 +327,9 @@ lemma init_arch_objects_nonempty_table[Untyped_AI_assms, wp]: "\(\s. \ (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s) \ valid_global_objs s \ valid_arch_state s \ pspace_aligned s) and K (\ref\set refs. is_aligned ref (obj_bits_api tp us))\ - init_arch_objects tp ptr bits us refs + init_arch_objects tp dev ptr bits us refs \\rv s. \ (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)\" - unfolding init_arch_objects_def by wpsimp + unfolding init_arch_objects_def by (wpsimp wp: mapM_x_wp') lemma nonempty_table_caps_of[Untyped_AI_assms]: "nonempty_table S ko \ caps_of ko = {}" @@ -344,6 +346,7 @@ lemma nonempty_default[simp, Untyped_AI_assms]: crunch init_arch_objects for cte_wp_at_iin[wp]: "\s. P (cte_wp_at (P' (interrupt_irq_node s)) p s)" + (wp: mapM_x_wp') lemmas init_arch_objects_ex_cte_cap_wp_to = init_arch_objects_excap diff --git a/proof/invariant-abstract/AARCH64/ArchVCPU_AI.thy b/proof/invariant-abstract/AARCH64/ArchVCPU_AI.thy index 85de8526a7..35dc4a38bc 100644 --- a/proof/invariant-abstract/AARCH64/ArchVCPU_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchVCPU_AI.thy @@ -9,7 +9,7 @@ theory ArchVCPU_AI imports AInvs begin -context Arch begin global_naming AARCH64 (*FIXME: arch_split*) +context Arch begin arch_global_naming (* This is similar to cur_vcpu_2, but not close enough to reuse. *) definition active_cur_vcpu_of :: "'z state \ obj_ref option" where diff --git a/proof/invariant-abstract/AARCH64/ArchVSpaceEntries_AI.thy b/proof/invariant-abstract/AARCH64/ArchVSpaceEntries_AI.thy index f03ba67b39..738278552e 100644 --- a/proof/invariant-abstract/AARCH64/ArchVSpaceEntries_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchVSpaceEntries_AI.thy @@ -9,7 +9,7 @@ theory ArchVSpaceEntries_AI imports VSpaceEntries_AI begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming (* Since we're not doing anything with the index apart from returning it, this definition works for both, NormalPTs and VSRootPTs *) @@ -176,9 +176,9 @@ lemma init_arch_objects_valid_vspace: "\valid_vspace_objs' and pspace_aligned and valid_arch_state and K (orefs = retype_addrs ptr type n us) and K (range_cover ptr sz (obj_bits_api type us) n)\ - init_arch_objects type ptr n obj_sz orefs + init_arch_objects type dev ptr n obj_sz orefs \\rv. valid_vspace_objs'\" - unfolding init_arch_objects_def by wpsimp + unfolding init_arch_objects_def by (wpsimp wp: mapM_x_wp') lemma delete_objects_valid_vspace_objs'[wp]: "\valid_vspace_objs'\ delete_objects ptr bits \\rv. valid_vspace_objs'\" diff --git a/proof/invariant-abstract/AARCH64/ArchVSpace_AI.thy b/proof/invariant-abstract/AARCH64/ArchVSpace_AI.thy index d1fc5e4588..48bb3f688a 100644 --- a/proof/invariant-abstract/AARCH64/ArchVSpace_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchVSpace_AI.thy @@ -21,7 +21,7 @@ lemma valid_asid_map_upd[simp]: end -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming sublocale set_vcpu: non_vspace_non_cap_non_mem_op "set_vcpu p vcpu" + @@ -2324,7 +2324,7 @@ lemma valid_vspace_obj: end -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming lemma set_asid_pool_arch_objs_map: "\valid_vspace_objs and valid_arch_state and valid_global_objs and @@ -3142,9 +3142,4 @@ crunch vcpu_switch end -context begin interpretation Arch . -requalify_facts - do_machine_op_valid_kernel_mappings -end - end diff --git a/proof/invariant-abstract/AARCH64/Machine_AI.thy b/proof/invariant-abstract/AARCH64/Machine_AI.thy index 7fb8d8b961..793e63d832 100644 --- a/proof/invariant-abstract/AARCH64/Machine_AI.thy +++ b/proof/invariant-abstract/AARCH64/Machine_AI.thy @@ -69,7 +69,7 @@ crunch_ignore (no_irq) (add: handleE' handleE handle_elseE forM forM_x zipWithM ignore_failure) -context Arch begin +context Arch begin arch_global_naming text \Deterministic\ @@ -423,14 +423,4 @@ lemma dmo_gets_inv[wp]: end -context begin interpretation Arch . - -requalify_facts - det_getRegister - det_setRegister - det_getRestartPC - det_setNextPC - -end - end diff --git a/proof/invariant-abstract/ADT_AI.thy b/proof/invariant-abstract/ADT_AI.thy index 5471ceca89..4cd6033cb0 100644 --- a/proof/invariant-abstract/ADT_AI.thy +++ b/proof/invariant-abstract/ADT_AI.thy @@ -11,17 +11,13 @@ imports ArchADT_AI begin -context begin interpretation Arch . - -requalify_consts +arch_requalify_consts (A) empty_context init_A_st + +arch_requalify_consts ptable_lift ptable_rights - addrFromPPtr - ptrFromPAddr - -end text \ The general refinement calculus (see theory Simulation) requires diff --git a/proof/invariant-abstract/AInvs.thy b/proof/invariant-abstract/AInvs.thy index 5df6ff4184..0a413a00cb 100644 --- a/proof/invariant-abstract/AInvs.thy +++ b/proof/invariant-abstract/AInvs.thy @@ -12,6 +12,11 @@ theory AInvs imports ArchDetSchedSchedule_AI begin +arch_requalify_facts + user_mem_dom_cong + device_mem_dom_cong + device_frame_in_device_region + lemma st_tcb_at_nostate_upd: "\ get_tcb t s = Some y; tcb_state y = tcb_state y' \ \ st_tcb_at P t' (s \kheap := (kheap s)(t \ TCB y')\) = st_tcb_at P t' s" diff --git a/proof/invariant-abstract/ARM/ArchADT_AI.thy b/proof/invariant-abstract/ARM/ArchADT_AI.thy index b151a0c09c..8fd41009b7 100644 --- a/proof/invariant-abstract/ARM/ArchADT_AI.thy +++ b/proof/invariant-abstract/ARM/ArchADT_AI.thy @@ -11,7 +11,7 @@ imports "Lib.Simulation" Invariants_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming subsection \Constructing a virtual-memory view\ diff --git a/proof/invariant-abstract/ARM/ArchAInvsPre.thy b/proof/invariant-abstract/ARM/ArchAInvsPre.thy index 3b1a5e29ad..943760489e 100644 --- a/proof/invariant-abstract/ARM/ArchAInvsPre.thy +++ b/proof/invariant-abstract/ARM/ArchAInvsPre.thy @@ -8,9 +8,7 @@ theory ArchAInvsPre imports AInvsPre begin -context Arch begin - -global_naming ARM +context Arch begin arch_global_naming definition "kernel_mappings \ {x. x \ kernel_base}" @@ -177,12 +175,11 @@ lemma device_frame_in_device_region: by (auto simp add: pspace_respects_device_region_def dom_def device_mem_def) -global_naming Arch -named_theorems AInvsPre_asms +named_theorems AInvsPre_assms -lemma (* ptable_rights_imp_frame *)[AInvsPre_asms]: +lemma (* ptable_rights_imp_frame *)[AInvsPre_assms]: assumes "valid_state s" shows "ptable_rights t s x \ {} \ ptable_lift t s x = Some (addrFromPPtr y) \ @@ -225,12 +222,7 @@ end global_interpretation AInvsPre?: AInvsPre proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales, fact AInvsPre_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales, fact AInvsPre_assms)?) qed -requalify_facts - ARM.user_mem_dom_cong - ARM.device_mem_dom_cong - ARM.device_frame_in_device_region - ARM.is_aligned_pptrBaseOffset end diff --git a/proof/invariant-abstract/ARM/ArchAcc_AI.thy b/proof/invariant-abstract/ARM/ArchAcc_AI.thy index b601212ea9..27e0f92929 100644 --- a/proof/invariant-abstract/ARM/ArchAcc_AI.thy +++ b/proof/invariant-abstract/ARM/ArchAcc_AI.thy @@ -15,7 +15,7 @@ imports "Lib.Crunch_Instances_NonDet" begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming bundle unfold_objects = diff --git a/proof/invariant-abstract/ARM/ArchArch_AI.thy b/proof/invariant-abstract/ARM/ArchArch_AI.thy index befd003545..89132a5352 100644 --- a/proof/invariant-abstract/ARM/ArchArch_AI.thy +++ b/proof/invariant-abstract/ARM/ArchArch_AI.thy @@ -9,7 +9,7 @@ theory ArchArch_AI imports Arch_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming definition "valid_aci aci \ case aci of MakePool frame slot parent base \ @@ -399,7 +399,7 @@ lemma valid_asid_map': end -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemma valid_arch_state_strg: "valid_arch_state s \ ap \ ran (asid_table s) \ asid_pool_at ap s \ @@ -1079,7 +1079,7 @@ lemma find_pd_for_asid_ref_offset_voodoo: in hoare_strengthen_postE_R) apply (simp add: ucast_ucast_mask mask_asid_low_bits_ucast_ucast) - apply (fold asid_low_bits_def) + apply (fold asid_low_bits_def[simplified]) apply (rule hoare_pre, wp find_pd_for_asid_lookup_ref) apply (simp add: ) apply (simp add: pd_shifting) @@ -1524,22 +1524,4 @@ lemma arch_pinv_ct_active: end - -context begin interpretation Arch . - -requalify_consts - valid_arch_inv - -requalify_facts - invoke_arch_tcb - invoke_arch_invs - sts_valid_arch_inv - arch_decode_inv_wf - arch_pinv_st_tcb_at - arch_pinv_ct_active - -end - -declare invoke_arch_invs[wp] arch_decode_inv_wf[wp] arch_pinv_ct_active[wp] - end diff --git a/proof/invariant-abstract/ARM/ArchBCorres2_AI.thy b/proof/invariant-abstract/ARM/ArchBCorres2_AI.thy index bfa9410b30..de1680372e 100644 --- a/proof/invariant-abstract/ARM/ArchBCorres2_AI.thy +++ b/proof/invariant-abstract/ARM/ArchBCorres2_AI.thy @@ -9,7 +9,7 @@ imports BCorres2_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemma choose_switch_or_idle: "((), s') \ fst (choose_thread s) \ diff --git a/proof/invariant-abstract/ARM/ArchBCorres_AI.thy b/proof/invariant-abstract/ARM/ArchBCorres_AI.thy index af03a89c40..93423b94f9 100644 --- a/proof/invariant-abstract/ARM/ArchBCorres_AI.thy +++ b/proof/invariant-abstract/ARM/ArchBCorres_AI.thy @@ -9,7 +9,7 @@ imports BCorres_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming crunch arch_finalise_cap for (bcorres) bcorres[wp]: truncate_state @@ -21,8 +21,4 @@ crunch prepare_thread_delete end -requalify_facts ARM.arch_finalise_cap_bcorres ARM.prepare_thread_delete_bcorres - -declare arch_finalise_cap_bcorres[wp] prepare_thread_delete_bcorres[wp] - end diff --git a/proof/invariant-abstract/ARM/ArchBits_AI.thy b/proof/invariant-abstract/ARM/ArchBits_AI.thy index 937de344d0..4be6c8cd18 100644 --- a/proof/invariant-abstract/ARM/ArchBits_AI.thy +++ b/proof/invariant-abstract/ARM/ArchBits_AI.thy @@ -8,7 +8,7 @@ theory ArchBits_AI imports Invariants_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemma invs_unique_table_caps[elim!]: "invs s \ unique_table_caps (caps_of_state s)" diff --git a/proof/invariant-abstract/ARM/ArchCNodeInv_AI.thy b/proof/invariant-abstract/ARM/ArchCNodeInv_AI.thy index ba0e07acf7..557b0ef99f 100644 --- a/proof/invariant-abstract/ARM/ArchCNodeInv_AI.thy +++ b/proof/invariant-abstract/ARM/ArchCNodeInv_AI.thy @@ -8,7 +8,7 @@ theory ArchCNodeInv_AI imports CNodeInv_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming named_theorems CNodeInv_AI_assms @@ -503,7 +503,7 @@ global_interpretation CNodeInv_AI?: CNodeInv_AI termination rec_del by (rule rec_del_termination) -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemma post_cap_delete_pre_is_final_cap': "\rv s'' rva s''a s. @@ -754,7 +754,7 @@ global_interpretation CNodeInv_AI_2?: CNodeInv_AI_2 qed -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemma finalise_cap_rvk_prog [CNodeInv_AI_assms]: "\\s. revoke_progress_ord m (\x. map_option cap_to_rpo (caps_of_state s x))\ @@ -865,7 +865,7 @@ termination cap_revoke by (rule cap_revoke_termination) declare cap_revoke.simps[simp del] -context Arch begin global_naming ARM +context Arch begin arch_global_naming crunch finalise_slot for typ_at[wp, CNodeInv_AI_assms]: "\s. P (typ_at T p s)" @@ -889,7 +889,7 @@ global_interpretation CNodeInv_AI_4?: CNodeInv_AI_4 qed -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemma cap_move_invs[wp, CNodeInv_AI_assms]: "\invs and valid_cap cap and cte_wp_at ((=) cap.NullCap) ptr' diff --git a/proof/invariant-abstract/ARM/ArchCSpaceInvPre_AI.thy b/proof/invariant-abstract/ARM/ArchCSpaceInvPre_AI.thy index a5a4220129..85c41e73eb 100644 --- a/proof/invariant-abstract/ARM/ArchCSpaceInvPre_AI.thy +++ b/proof/invariant-abstract/ARM/ArchCSpaceInvPre_AI.thy @@ -11,7 +11,7 @@ CSpace invariants theory ArchCSpaceInvPre_AI imports CSpaceInvPre_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemma aobj_ref_acap_rights_update[simp]: "aobj_ref (acap_rights_update f x) = aobj_ref x" @@ -293,7 +293,7 @@ lemma cap_master_arch_cap_rights [simp]: by (simp add: cap_master_arch_cap_def acap_rights_update_def split: arch_cap.splits) -lemma acap_rights_update_id [intro!, simp]: +lemma valid_acap_rights_update_id [intro!, simp]: "valid_arch_cap ac s \ acap_rights_update (acap_rights ac) ac = ac" unfolding acap_rights_update_def acap_rights_def valid_arch_cap_def by (cases ac; simp) diff --git a/proof/invariant-abstract/ARM/ArchCSpaceInv_AI.thy b/proof/invariant-abstract/ARM/ArchCSpaceInv_AI.thy index 56ded97b1a..d330f16254 100644 --- a/proof/invariant-abstract/ARM/ArchCSpaceInv_AI.thy +++ b/proof/invariant-abstract/ARM/ArchCSpaceInv_AI.thy @@ -12,7 +12,7 @@ theory ArchCSpaceInv_AI imports CSpaceInv_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming definition safe_ioport_insert :: "cap \ cap \ 'a::state_ext state \ bool" @@ -217,8 +217,5 @@ lemmas cap_vptr_simps [simp] = cap_vptr_def [simplified, split_simps cap.split arch_cap.split option.split prod.split] end -context begin interpretation Arch . -requalify_facts replace_cap_invs -end end diff --git a/proof/invariant-abstract/ARM/ArchCSpacePre_AI.thy b/proof/invariant-abstract/ARM/ArchCSpacePre_AI.thy index 0310ddc60e..8560fe31d3 100644 --- a/proof/invariant-abstract/ARM/ArchCSpacePre_AI.thy +++ b/proof/invariant-abstract/ARM/ArchCSpacePre_AI.thy @@ -12,7 +12,7 @@ theory ArchCSpacePre_AI imports CSpacePre_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemmas typ_at_eq_kheap_obj = typ_at_eq_kheap_obj atyp_at_eq_kheap_obj diff --git a/proof/invariant-abstract/ARM/ArchCSpace_AI.thy b/proof/invariant-abstract/ARM/ArchCSpace_AI.thy index 84f042b83a..908efca102 100644 --- a/proof/invariant-abstract/ARM/ArchCSpace_AI.thy +++ b/proof/invariant-abstract/ARM/ArchCSpace_AI.thy @@ -12,7 +12,7 @@ theory ArchCSpace_AI imports CSpace_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming named_theorems CSpace_AI_assms @@ -368,7 +368,7 @@ end global_interpretation cap_insert_crunches?: cap_insert_crunches . -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemma cap_insert_cap_refs_in_kernel_window[wp, CSpace_AI_assms]: "\cap_refs_in_kernel_window @@ -532,7 +532,7 @@ global_interpretation CSpace_AI?: CSpace_AI qed -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemma is_cap_simps': "is_cnode_cap cap = (\r bits g. cap = cap.CNodeCap r bits g)" @@ -602,10 +602,6 @@ lemma arch_post_cap_deletion_invs: "\invs and (\s. arch_post_cap_delete_pre (ArchObjectCap c) (caps_of_state s))\ arch_post_cap_deletion c \\rv. invs\" by (wpsimp simp: arch_post_cap_delete_pre_def) -end - -(* is this the right way? we need this fact globally but it's proven with - ARM defns. *) lemma set_cap_valid_arch_caps_simple: "\\s. valid_arch_caps s \ valid_objs s @@ -614,6 +610,7 @@ lemma set_cap_valid_arch_caps_simple: \ \ (is_arch_cap cap)\ set_cap cap ptr \\rv. valid_arch_caps\" + supply vs_cap_ref_arch_def[simp del] table_cap_ref_arch_def[simp del] apply (wp ARM.set_cap_valid_arch_caps) apply (clarsimp simp: cte_wp_at_caps_of_state) apply (frule(1) caps_of_state_valid_cap) @@ -642,3 +639,5 @@ lemma set_cap_kernel_window_simple: done end + +end diff --git a/proof/invariant-abstract/ARM/ArchCrunchSetup_AI.thy b/proof/invariant-abstract/ARM/ArchCrunchSetup_AI.thy index e46bc63e82..5de9639dbf 100644 --- a/proof/invariant-abstract/ARM/ArchCrunchSetup_AI.thy +++ b/proof/invariant-abstract/ARM/ArchCrunchSetup_AI.thy @@ -9,7 +9,7 @@ imports "ASpec.Syscall_A" "Lib.Crunch_Instances_NonDet" begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming crunch_ignore (add: debugPrint invalidateLocalTLB_ASID invalidateLocalTLB_VAASID cleanByVA diff --git a/proof/invariant-abstract/ARM/ArchDetSchedAux_AI.thy b/proof/invariant-abstract/ARM/ArchDetSchedAux_AI.thy index 2d55d74de1..1ab432c4d3 100644 --- a/proof/invariant-abstract/ARM/ArchDetSchedAux_AI.thy +++ b/proof/invariant-abstract/ARM/ArchDetSchedAux_AI.thy @@ -8,8 +8,7 @@ theory ArchDetSchedAux_AI imports DetSchedAux_AI begin - -context Arch begin global_naming ARM +context Arch begin arch_global_naming named_theorems DetSchedAux_AI_assms @@ -40,8 +39,9 @@ lemma copy_global_mappings_valid_sched_pred[wp]: by (wpsimp simp: copy_global_mappings_def store_pde_def wp: mapM_x_wp_inv) lemma init_arch_objects_valid_sched_pred[wp, DetSchedAux_AI_assms]: - "init_arch_objects new_type ptr num_objects obj_sz refs \valid_sched_pred_strong P\" - by (wpsimp simp: init_arch_objects_def wp: dmo_valid_sched_pred mapM_x_wp_inv) + "init_arch_objects new_type dev ptr num_objects obj_sz refs \valid_sched_pred_strong P\" + unfolding init_arch_objects_def + by (wpsimp wp: dmo_valid_sched_pred mapM_x_wp_inv) crunch init_arch_objects for exst[wp]: "\s. P (exst s)" @@ -135,12 +135,12 @@ global_interpretation DetSchedAux_AI?: DetSchedAux_AI case 1 show ?case by (unfold_locales; (fact DetSchedAux_AI_assms)?) qed -context Arch begin global_naming ARM +context Arch begin arch_global_naming (* FIXME: move? *) lemma init_arch_objects_obj_at_impossible: "\ao. \ P (ArchObj ao) \ - \\s. Q (obj_at P p s)\ init_arch_objects a b c d e \\rv s. Q (obj_at P p s)\" + \\s. Q (obj_at P p s)\ init_arch_objects a b c d e f \\rv s. Q (obj_at P p s)\" by (auto intro: init_arch_objects_obj_at_non_pd) lemma perform_asid_control_etcb_at: diff --git a/proof/invariant-abstract/ARM/ArchDetSchedDomainTime_AI.thy b/proof/invariant-abstract/ARM/ArchDetSchedDomainTime_AI.thy index c1e38a9adb..1ccc3cd532 100644 --- a/proof/invariant-abstract/ARM/ArchDetSchedDomainTime_AI.thy +++ b/proof/invariant-abstract/ARM/ArchDetSchedDomainTime_AI.thy @@ -8,7 +8,7 @@ theory ArchDetSchedDomainTime_AI imports DetSchedDomainTime_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming named_theorems DetSchedDomainTime_AI_assms @@ -50,7 +50,7 @@ global_interpretation DetSchedDomainTime_AI?: DetSchedDomainTime_AI case 1 show ?case by (unfold_locales; (fact DetSchedDomainTime_AI_assms)?) qed -context Arch begin global_naming ARM +context Arch begin arch_global_naming crunch arch_perform_invocation, arch_mask_irq_signal for domain_list_inv [wp, DetSchedDomainTime_AI_assms]: "\s::det_state. P (domain_list s)" diff --git a/proof/invariant-abstract/ARM/ArchDetSchedSchedule_AI.thy b/proof/invariant-abstract/ARM/ArchDetSchedSchedule_AI.thy index 479fa1a329..6c59a3001d 100644 --- a/proof/invariant-abstract/ARM/ArchDetSchedSchedule_AI.thy +++ b/proof/invariant-abstract/ARM/ArchDetSchedSchedule_AI.thy @@ -8,7 +8,7 @@ theory ArchDetSchedSchedule_AI imports DetSchedSchedule_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming named_theorems DetSchedSchedule_AI_assms @@ -350,7 +350,7 @@ global_interpretation DetSchedSchedule_AI_det_ext?: DetSchedSchedule_AI_det_ext case 1 show ?case by (unfold_locales; (fact DetSchedSchedule_AI_assms)?; wpsimp) qed -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemma handle_reserved_irq_trivial[wp]: "handle_reserved_irq irq \Q\" diff --git a/proof/invariant-abstract/ARM/ArchDeterministic_AI.thy b/proof/invariant-abstract/ARM/ArchDeterministic_AI.thy index 5661e25bca..f81abe088e 100644 --- a/proof/invariant-abstract/ARM/ArchDeterministic_AI.thy +++ b/proof/invariant-abstract/ARM/ArchDeterministic_AI.thy @@ -8,7 +8,7 @@ theory ArchDeterministic_AI imports Deterministic_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming named_theorems Deterministic_AI_assms @@ -30,7 +30,7 @@ proof goal_cases case 1 show ?case by (unfold_locales; (fact Deterministic_AI_assms)?) qed -context Arch begin global_naming ARM +context Arch begin arch_global_naming crunch arch_invoke_irq_handler for valid_list[wp, Deterministic_AI_assms]: valid_list @@ -114,9 +114,9 @@ named_theorems machine_ops_last_machine_time' named_theorems arch_machine_ops_last_machine_time' \ \crunch these separately so they don't appear in machine_ops_last_machine_time\ -crunch cleanByVA_PoU, cleanCacheRange_PoU +crunch cleanByVA_PoU, cleanCacheRange_PoU, cleanCacheRange_RAM for machine_times[wp, arch_machine_ops_last_machine_time']: "\ms. P (last_machine_time ms) (time_state ms)" - (wp: crunch_wps simp: crunch_simps ignore_del: cleanByVA_PoU) + (wp: crunch_wps simp: crunch_simps ignore_del: cleanByVA_PoU cleanL2Range cleanByVA) crunch storeWord, clearMemory, freeMemory, ackDeadlineIRQ, ackInterrupt, maskInterrupt, setDeadline for machine_times[wp, machine_ops_last_machine_time']: "\ms. P (last_machine_time ms) (time_state ms)" diff --git a/proof/invariant-abstract/ARM/ArchDetype_AI.thy b/proof/invariant-abstract/ARM/ArchDetype_AI.thy index 30c21a733d..e6c216869c 100644 --- a/proof/invariant-abstract/ARM/ArchDetype_AI.thy +++ b/proof/invariant-abstract/ARM/ArchDetype_AI.thy @@ -8,18 +8,18 @@ theory ArchDetype_AI imports Detype_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming -named_theorems Detype_AI_asms +named_theorems Detype_AI_assms -lemma valid_globals_irq_node[Detype_AI_asms]: +lemma valid_globals_irq_node[Detype_AI_assms]: "\ valid_global_refs s; cte_wp_at ((=) cap) ptr s \ \ interrupt_irq_node s irq \ cap_range cap" apply (erule(1) valid_global_refsD) apply (simp add: global_refs_def) done -lemma caps_of_state_ko[Detype_AI_asms]: +lemma caps_of_state_ko[Detype_AI_assms]: "valid_cap cap s \ is_untyped_cap cap \ cap_range cap = {} \ @@ -34,7 +34,7 @@ lemma caps_of_state_ko[Detype_AI_asms]: done -lemma mapM_x_storeWord[Detype_AI_asms]: +lemma mapM_x_storeWord[Detype_AI_assms]: (* FIXME: taken from Retype_C.thy and adapted wrt. the missing intvl syntax. *) assumes al: "is_aligned ptr word_size_bits" shows "mapM_x (\x. storeWord (ptr + of_nat x * word_size) 0) [0..x. if x \ S then {} else state_hyp_refs_of s x)" by (rule ext, simp add: state_hyp_refs_of_def detype_def) -lemma valid_ioports_detype[Detype_AI_asms]: +lemma valid_ioports_detype[Detype_AI_assms]: "valid_ioports s \ valid_ioports (detype (untyped_range cap) s)" by auto @@ -124,7 +124,7 @@ interpretation Detype_AI?: Detype_AI proof goal_cases interpret Arch . case 1 show ?case - by (intro_locales; (unfold_locales; fact Detype_AI_asms)?) + by (intro_locales; (unfold_locales; fact Detype_AI_assms)?) qed context detype_locale_arch begin @@ -554,8 +554,8 @@ interpretation Detype_AI_2 Detype_AI_2.intro by blast -context begin interpretation Arch . -lemma delete_objects_invs[wp]: +(* generic consequence of architecture-specific details *) +lemma (in Arch) delete_objects_invs[wp]: "\(\s. \slot. cte_wp_at ((=) (cap.UntypedCap dev ptr bits f)) slot s \ descendants_range (cap.UntypedCap dev ptr bits f) slot s) and invs and ct_active and (\s. scheduler_action s = resume_cur_thread)\ @@ -577,6 +577,9 @@ lemma delete_objects_invs[wp]: apply (simp add: valid_cap_def cap_aligned_def word_size_bits_def untyped_min_bits_def) done +requalify_facts Arch.delete_objects_invs +lemmas [wp] = delete_objects_invs + lemma scheduler_action_detype: "P (scheduler_action s) \ P (scheduler_action (detype {ptr..ptr + 2 ^ bits - 1} s))" by (auto simp: detype_def) @@ -595,5 +598,3 @@ lemma delete_objects_scheduler_action [wp]: done end - -end diff --git a/proof/invariant-abstract/ARM/ArchEmptyFail_AI.thy b/proof/invariant-abstract/ARM/ArchEmptyFail_AI.thy index e2c6021d0b..e22ee76d2c 100644 --- a/proof/invariant-abstract/ARM/ArchEmptyFail_AI.thy +++ b/proof/invariant-abstract/ARM/ArchEmptyFail_AI.thy @@ -8,7 +8,7 @@ theory ArchEmptyFail_AI imports EmptyFail_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming named_theorems EmptyFail_AI_assms @@ -33,7 +33,7 @@ global_interpretation EmptyFail_AI_load_word?: EmptyFail_AI_load_word case 1 show ?case by (unfold_locales; (fact EmptyFail_AI_assms)?) qed -context Arch begin global_naming ARM +context Arch begin arch_global_naming crunch possible_switch_to,set_thread_state_act for (empty_fail) empty_fail[wp, EmptyFail_AI_assms] @@ -121,7 +121,7 @@ global_interpretation EmptyFail_AI_derive_cap?: EmptyFail_AI_derive_cap case 1 show ?case by (unfold_locales; (fact EmptyFail_AI_assms)?) qed -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemma preemption_point_empty_fail[wp, EmptyFail_AI_assms]: "empty_fail preemption_point" @@ -149,7 +149,7 @@ global_interpretation EmptyFail_AI_rec_del?: EmptyFail_AI_rec_del case 1 show ?case by (unfold_locales; (fact EmptyFail_AI_assms)?) qed -context Arch begin global_naming ARM +context Arch begin arch_global_naming crunch cap_delete, choose_thread for (empty_fail) empty_fail[wp, EmptyFail_AI_assms] @@ -168,7 +168,7 @@ global_interpretation EmptyFail_AI_schedule?: EmptyFail_AI_schedule case 1 show ?case by (unfold_locales; (fact EmptyFail_AI_assms)?) qed -context Arch begin global_naming ARM +context Arch begin arch_global_naming crunch handle_event, activate_thread, check_budget for (empty_fail) empty_fail[wp, EmptyFail_AI_assms] diff --git a/proof/invariant-abstract/ARM/ArchFinalise_AI.thy b/proof/invariant-abstract/ARM/ArchFinalise_AI.thy index 84f9fc983a..db10a90e68 100644 --- a/proof/invariant-abstract/ARM/ArchFinalise_AI.thy +++ b/proof/invariant-abstract/ARM/ArchFinalise_AI.thy @@ -10,9 +10,9 @@ begin context Arch begin -named_theorems Finalise_AI_asms +named_theorems Finalise_AI_assms -lemma (* obj_at_not_live_valid_arch_cap_strg *) [Finalise_AI_asms]: +lemma (* obj_at_not_live_valid_arch_cap_strg *) [Finalise_AI_assms]: "(s \ ArchObjectCap cap \ aobj_ref cap = Some r) \ obj_at (\ko. \ live ko) r s" by (clarsimp simp: valid_cap_def obj_at_def @@ -20,9 +20,9 @@ lemma (* obj_at_not_live_valid_arch_cap_strg *) [Finalise_AI_asms]: split: arch_cap.split_asm if_splits) crunch prepare_thread_delete - for caps_of_state[wp,Finalise_AI_asms]: "\s. P (caps_of_state s)" + for caps_of_state[wp,Finalise_AI_assms]: "\s. P (caps_of_state s)" -global_naming ARM +arch_global_naming lemma valid_global_refs_asid_table_udapte [iff]: "valid_global_refs (s\arch_state := arm_asid_table_update f (arch_state s)\) = @@ -232,24 +232,22 @@ lemma unmap_page_tcb_cap_valid: apply (wp unmap_page_tcb_at hoare_vcg_ex_lift hoare_vcg_all_lift)+ done -global_naming Arch - -lemma (* replaceable_cdt_update *)[simp,Finalise_AI_asms]: +lemma (* replaceable_cdt_update *)[simp,Finalise_AI_assms]: "replaceable (cdt_update f s) = replaceable s" by (fastforce simp: replaceable_def tcb_cap_valid_def) -lemma (* replaceable_revokable_update *)[simp,Finalise_AI_asms]: +lemma (* replaceable_revokable_update *)[simp,Finalise_AI_assms]: "replaceable (is_original_cap_update f s) = replaceable s" by (fastforce simp: replaceable_def is_final_cap'_def2 tcb_cap_valid_def) -lemma (* replaceable_more_update *) [simp,Finalise_AI_asms]: +lemma (* replaceable_more_update *) [simp,Finalise_AI_assms]: "replaceable (trans_state f s) sl cap cap' = replaceable s sl cap cap'" by (simp add: replaceable_def) -lemma (* obj_ref_ofI *) [Finalise_AI_asms]: "obj_refs cap = {x} \ obj_ref_of cap = x" +lemma (* obj_ref_ofI *) [Finalise_AI_assms]: "obj_refs cap = {x} \ obj_ref_of cap = x" by (case_tac cap, simp_all) (rename_tac arch_cap, case_tac arch_cap, simp_all) -lemma (* empty_slot_invs *) [Finalise_AI_asms]: +lemma (* empty_slot_invs *) [Finalise_AI_assms]: "\\s. invs s \ cte_wp_at (replaceable s sl cap.NullCap) sl s \ (info \ NullCap \ post_cap_delete_pre info ((caps_of_state s) (sl \ NullCap)))\ empty_slot sl info @@ -306,7 +304,7 @@ lemma (* empty_slot_invs *) [Finalise_AI_asms]: apply (simp add: is_final_cap'_def2 cte_wp_at_caps_of_state) done -lemma dom_tcb_cap_cases_lt_ARCH [Finalise_AI_asms]: +lemma dom_tcb_cap_cases_lt_ARCH [Finalise_AI_assms]: "dom tcb_cap_cases = {xs. length xs = 3 \ unat (of_bl xs :: machine_word) < 5}" apply (rule set_eqI, rule iffI) apply clarsimp @@ -316,7 +314,7 @@ lemma dom_tcb_cap_cases_lt_ARCH [Finalise_AI_asms]: apply (clarsimp simp: nat_to_cref_unat_of_bl') done -lemma (* unbind_notification_final *) [wp,Finalise_AI_asms]: +lemma (* unbind_notification_final *) [wp,Finalise_AI_assms]: "\is_final_cap' cap\ unbind_notification t \ \rv. is_final_cap' cap\" unfolding unbind_notification_def by (wpsimp wp: final_cap_lift thread_set_caps_of_state_trivial hoare_drop_imps @@ -325,7 +323,7 @@ lemma (* unbind_notification_final *) [wp,Finalise_AI_asms]: crunch prepare_thread_delete for is_final_cap'[wp]: "is_final_cap' cap" -lemma (* finalise_cap_cases1 *)[Finalise_AI_asms]: +lemma (* finalise_cap_cases1 *)[Finalise_AI_assms]: "\\s. final \ is_final_cap' cap s \ cte_wp_at ((=) cap) slot s\ finalise_cap cap final @@ -356,14 +354,14 @@ lemma (* finalise_cap_cases1 *)[Finalise_AI_asms]: done crunch arch_finalise_cap,prepare_thread_delete - for typ_at_arch[wp,Finalise_AI_asms]: "\s. P (typ_at T p s)" + for typ_at_arch[wp,Finalise_AI_assms]: "\s. P (typ_at T p s)" (wp: crunch_wps simp: crunch_simps unless_def assertE_def ignore: maskInterrupt ) crunch prepare_thread_delete for tcb_at[wp]: "\s. tcb_at p s" -lemma (* finalise_cap_new_valid_cap *)[wp,Finalise_AI_asms]: +lemma (* finalise_cap_new_valid_cap *)[wp,Finalise_AI_assms]: "\valid_cap cap\ finalise_cap cap x \\rv. valid_cap (fst rv)\" apply (cases cap, simp_all) apply (wp suspend_valid_cap get_simple_ko_wp @@ -377,7 +375,7 @@ lemma (* finalise_cap_new_valid_cap *)[wp,Finalise_AI_asms]: split del: if_split|clarsimp|wpc)+ done -lemma (* arch_finalise_cap_invs *)[wp,Finalise_AI_asms]: +lemma (* arch_finalise_cap_invs *)[wp,Finalise_AI_assms]: "\invs and valid_cap (ArchObjectCap cap)\ arch_finalise_cap cap final \\rv. invs\" @@ -388,7 +386,7 @@ lemma (* arch_finalise_cap_invs *)[wp,Finalise_AI_asms]: apply (auto simp: mask_def vmsz_aligned_def) done -lemma obj_at_not_live_valid_arch_cap_strg [Finalise_AI_asms]: +lemma obj_at_not_live_valid_arch_cap_strg [Finalise_AI_assms]: "(s \ ArchObjectCap cap \ aobj_ref cap = Some r) \ obj_at (\ko. \ live ko) r s" by (clarsimp simp: valid_cap_def obj_at_def @@ -434,8 +432,7 @@ lemma arch_finalise_cap_replaceable[wp]: split: cap.splits arch_cap.splits vmpage_size.splits)[1] done -global_naming Arch -lemma (* deleting_irq_handler_slot_not_irq_node *)[Finalise_AI_asms]: +lemma (* deleting_irq_handler_slot_not_irq_node *)[Finalise_AI_assms]: "\if_unsafe_then_cap and valid_global_refs and cte_wp_at (\cp. cap_irqs cp \ {}) sl\ deleting_irq_handler irq @@ -456,7 +453,7 @@ lemma (* deleting_irq_handler_slot_not_irq_node *)[Finalise_AI_asms]: apply (clarsimp simp: appropriate_cte_cap_def split: cap.split_asm) done -lemma no_cap_to_obj_with_diff_ref_finalI_ARCH[Finalise_AI_asms]: +lemma no_cap_to_obj_with_diff_ref_finalI_ARCH[Finalise_AI_assms]: "\ cte_wp_at ((=) cap) p s; is_final_cap' cap s; obj_refs cap' = obj_refs cap \ \ no_cap_to_obj_with_diff_ref cap' {p} s" @@ -478,7 +475,7 @@ lemma no_cap_to_obj_with_diff_ref_finalI_ARCH[Finalise_AI_asms]: gen_obj_refs_Int) done -lemma (* suspend_no_cap_to_obj_ref *)[wp,Finalise_AI_asms]: +lemma (* suspend_no_cap_to_obj_ref *)[wp,Finalise_AI_assms]: "\no_cap_to_obj_with_diff_ref cap S\ suspend t \\rv. no_cap_to_obj_with_diff_ref cap S\" @@ -537,7 +534,7 @@ method hammer = ((clarsimp simp: o_def dom_tcb_cap_cases_lt_ARCH wp (once) deleting_irq_handler_empty) | simp add: valid_cap_simps is_nondevice_page_cap_simps)+)[1] -lemma finalise_cap_replaceable [Finalise_AI_asms]: +lemma finalise_cap_replaceable [Finalise_AI_assms]: "\\s. s \ cap \ x = is_final_cap' cap s \ cte_wp_at ((=) cap) sl s \ invs s \ (cap_irqs cap \ {} \ if_unsafe_then_cap s \ valid_global_refs s) @@ -624,7 +621,7 @@ lemma finalise_cap_replaceable [Finalise_AI_asms]: apply (clarsimp simp: is_cap_simps) done -lemma (* deleting_irq_handler_cte_preserved *)[Finalise_AI_asms]: +lemma (* deleting_irq_handler_cte_preserved *)[Finalise_AI_assms]: assumes x: "\cap. P cap \ \ can_fast_finalise cap" shows "\cte_wp_at P p\ deleting_irq_handler irq \\rv. cte_wp_at P p\" apply (simp add: deleting_irq_handler_def) @@ -633,8 +630,8 @@ lemma (* deleting_irq_handler_cte_preserved *)[Finalise_AI_asms]: crunch arch_finalise_cap, prepare_thread_delete - for cte_wp_at[wp,Finalise_AI_asms]: "\s. P (cte_wp_at P' p s)" - and cur_thread[wp,Finalise_AI_asms]: "\s. P (cur_thread s)" + for cte_wp_at[wp,Finalise_AI_assms]: "\s. P (cte_wp_at P' p s)" + and cur_thread[wp,Finalise_AI_assms]: "\s. P (cur_thread s)" (simp: crunch_simps assertE_def wp: crunch_wps set_object_cte_at) end @@ -642,10 +639,10 @@ end interpretation Finalise_AI_1?: Finalise_AI_1 proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemma fast_finalise_replaceable[wp]: "\\s. s \ cap \ x = is_final_cap' cap s \ cte_wp_at ((=) cap) sl s \ invs s\ @@ -664,8 +661,7 @@ lemma fast_finalise_replaceable[wp]: apply (clarsimp simp: cap_irqs_def cap_irq_opt_def split: cap.split_asm) done -global_naming Arch -lemma (* cap_delete_one_invs *) [Finalise_AI_asms,wp]: +lemma (* cap_delete_one_invs *) [Finalise_AI_assms,wp]: "\invs\ cap_delete_one ptr \\rv. invs\" apply (simp add: cap_delete_one_def unless_def is_final_cap_def) apply (rule hoare_pre) @@ -680,17 +676,17 @@ end interpretation Finalise_AI_2?: Finalise_AI_2 proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed -context Arch begin global_naming ARM +context Arch begin arch_global_naming crunch arch_finalise_cap for irq_node[wp]: "\s. P (interrupt_irq_node s)" (wp: crunch_wps simp: crunch_simps) crunch prepare_thread_delete - for irq_node[wp,Finalise_AI_asms]: "\s. P (interrupt_irq_node s)" + for irq_node[wp,Finalise_AI_assms]: "\s. P (interrupt_irq_node s)" crunch arch_finalise_cap for pred_tcb_at[wp]: "pred_tcb_at proj P t" @@ -1176,7 +1172,7 @@ lemma invs_valid_arch_capsI: "invs s \ valid_arch_caps s" by (simp add: invs_def valid_state_def) -context Arch begin global_naming ARM (*FIXME: arch_split*) +context Arch begin arch_global_naming lemma arch_finalise_case_no_lookup: "\pspace_aligned and valid_vspace_objs and valid_objs and @@ -1270,12 +1266,10 @@ lemma mapM_x_swp_store_invalid_pde_invs: where pde=InvalidPDE, simplified]) done -global_naming Arch - crunch prepare_thread_delete for invs[wp]: invs -lemma (* finalise_cap_invs *)[Finalise_AI_asms]: +lemma (* finalise_cap_invs *)[Finalise_AI_assms]: shows "\invs and cte_wp_at ((=) cap) slot\ finalise_cap cap x \\rv (s\ \::det_ext state\). invs s\" apply (cases cap, simp_all split del: if_split) prefer 7 @@ -1297,21 +1291,21 @@ lemma (* finalise_cap_invs *)[Finalise_AI_asms]: apply (clarsimp simp: valid_cap_def) done -lemma (* finalise_cap_irq_node *)[Finalise_AI_asms]: +lemma (* finalise_cap_irq_node *)[Finalise_AI_assms]: "\\s. P (interrupt_irq_node s)\ finalise_cap a b \\_ s. P (interrupt_irq_node s)\" supply if_cong[cong] apply (case_tac a,simp_all) apply (wpsimp wp: hoare_drop_imps simp: o_def)+ done -lemmas (*arch_finalise_cte_irq_node *) [wp,Finalise_AI_asms] +lemmas (*arch_finalise_cte_irq_node *) [wp,Finalise_AI_assms] = hoare_use_eq_irq_node [OF arch_finalise_cap_irq_node arch_finalise_cap_cte_wp_at] -lemma irq_node_global_refs_ARCH [Finalise_AI_asms]: +lemma irq_node_global_refs_ARCH [Finalise_AI_assms]: "interrupt_irq_node s irq \ global_refs s" by (simp add: global_refs_def) -lemma (* get_irq_slot_fast_finalisable *)[wp,Finalise_AI_asms]: +lemma (* get_irq_slot_fast_finalisable *)[wp,Finalise_AI_assms]: "\invs\ get_irq_slot irq \cte_wp_at can_fast_finalise\" apply (simp add: get_irq_slot_def) apply wp @@ -1333,12 +1327,12 @@ lemma (* get_irq_slot_fast_finalisable *)[wp,Finalise_AI_asms]: apply (clarsimp simp: cap_range_def) done -lemma (* replaceable_or_arch_update_same *) [Finalise_AI_asms]: +lemma (* replaceable_or_arch_update_same *) [Finalise_AI_assms]: "replaceable_or_arch_update s slot cap cap" by (clarsimp simp: replaceable_or_arch_update_def replaceable_def is_arch_update_def is_cap_simps) -lemma (* replace_cap_invs_arch_update *)[Finalise_AI_asms]: +lemma (* replace_cap_invs_arch_update *)[Finalise_AI_assms]: "\\s. cte_wp_at (replaceable_or_arch_update s p cap) p s \ invs s \ cap \ cap.NullCap @@ -1356,7 +1350,7 @@ lemma (* replace_cap_invs_arch_update *)[Finalise_AI_asms]: apply simp done -lemma dmo_tcb_cap_valid_ARCH [Finalise_AI_asms]: +lemma dmo_tcb_cap_valid_ARCH [Finalise_AI_assms]: "\\s. P (tcb_cap_valid cap ptr s)\ do_machine_op mop \\_ s. P (tcb_cap_valid cap ptr s)\" apply (simp add: tcb_cap_valid_def no_cap_to_obj_with_diff_ref_def) apply (rule hoare_pre) @@ -1365,7 +1359,7 @@ lemma dmo_tcb_cap_valid_ARCH [Finalise_AI_asms]: apply simp done -lemma (* dmo_replaceable_or_arch_update *) [Finalise_AI_asms,wp]: +lemma (* dmo_replaceable_or_arch_update *) [Finalise_AI_assms,wp]: "\\s. replaceable_or_arch_update s slot cap cap'\ do_machine_op mo \\r s. replaceable_or_arch_update s slot cap cap'\" @@ -1380,18 +1374,16 @@ lemma (* dmo_replaceable_or_arch_update *) [Finalise_AI_asms,wp]: end -context begin interpretation Arch . -requalify_consts replaceable_or_arch_update -end +arch_requalify_consts replaceable_or_arch_update interpretation Finalise_AI_3?: Finalise_AI_3 where replaceable_or_arch_update = replaceable_or_arch_update proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemma typ_at_data_at_wp: assumes typ_wp: "\a.\typ_at a p \ g \\s. typ_at a p\" @@ -1406,10 +1398,10 @@ interpretation Finalise_AI_4?: Finalise_AI_4 where replaceable_or_arch_update = replaceable_or_arch_update proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemma set_asid_pool_obj_at_ptr: "\\s. P (ArchObj (arch_kernel_obj.ASIDPool mp))\ @@ -1701,12 +1693,10 @@ crunch unmap_page_table, invalidate_tlb_by_asid, (wp: mapM_wp_inv mapM_x_wp' simp: crunch_simps) end -global_naming Arch - -lemmas clearMemory_invs [wp,Finalise_AI_asms] +lemmas clearMemory_invs [wp,Finalise_AI_assms] = clearMemory_invs -lemma valid_idle_has_null_cap_ARCH[Finalise_AI_asms]: +lemma valid_idle_has_null_cap_ARCH[Finalise_AI_assms]: "\ if_unsafe_then_cap s; valid_global_refs s; valid_idle s; valid_irq_node s\ \ caps_of_state s (idle_thread s, v) = Some cap \ cap = NullCap" @@ -1722,7 +1712,7 @@ lemma valid_idle_has_null_cap_ARCH[Finalise_AI_asms]: apply (drule_tac x=word in spec, simp) done -lemma (* zombie_cap_two_nonidles *)[Finalise_AI_asms]: +lemma (* zombie_cap_two_nonidles *)[Finalise_AI_assms]: "\ caps_of_state s ptr = Some (Zombie ptr' zbits n); invs s \ \ fst ptr \ idle_thread s \ ptr' \ idle_thread s" apply (frule valid_global_refsD2, clarsimp+) @@ -1748,7 +1738,7 @@ interpretation Finalise_AI_5?: Finalise_AI_5 where replaceable_or_arch_update = replaceable_or_arch_update proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed end diff --git a/proof/invariant-abstract/ARM/ArchInterruptAcc_AI.thy b/proof/invariant-abstract/ARM/ArchInterruptAcc_AI.thy index 03553c132e..03face788f 100644 --- a/proof/invariant-abstract/ARM/ArchInterruptAcc_AI.thy +++ b/proof/invariant-abstract/ARM/ArchInterruptAcc_AI.thy @@ -12,7 +12,7 @@ theory ArchInterruptAcc_AI imports InterruptAcc_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming named_theorems InterruptAcc_AI_assms diff --git a/proof/invariant-abstract/ARM/ArchInterrupt_AI.thy b/proof/invariant-abstract/ARM/ArchInterrupt_AI.thy index 12a9cfaaff..22a09ebe32 100644 --- a/proof/invariant-abstract/ARM/ArchInterrupt_AI.thy +++ b/proof/invariant-abstract/ARM/ArchInterrupt_AI.thy @@ -8,7 +8,7 @@ theory ArchInterrupt_AI imports Interrupt_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming primrec arch_irq_control_inv_valid_real :: "arch_irq_control_invocation \ 'a::state_ext state \ bool" @@ -23,16 +23,16 @@ primrec arch_irq_control_inv_valid_real :: defs arch_irq_control_inv_valid_def: "arch_irq_control_inv_valid \ arch_irq_control_inv_valid_real" -named_theorems Interrupt_AI_asms +named_theorems Interrupt_AI_assms -lemma (* decode_irq_control_invocation_inv *)[Interrupt_AI_asms]: +lemma (* decode_irq_control_invocation_inv *)[Interrupt_AI_assms]: "\P\ decode_irq_control_invocation label args slot caps \\rv. P\" apply (simp add: decode_irq_control_invocation_def Let_def arch_check_irq_def arch_decode_irq_control_invocation_def whenE_def, safe) apply (wp | simp)+ done -lemma decode_irq_control_valid [Interrupt_AI_asms]: +lemma decode_irq_control_valid [Interrupt_AI_assms]: "\\s. invs s \ (\cap \ set caps. s \ cap) \ (\cap \ set caps. is_cnode_cap cap \ (\r \ cte_refs cap (interrupt_irq_node s). ex_cte_cap_wp_to is_cnode_cap r s)) @@ -49,7 +49,7 @@ lemma decode_irq_control_valid [Interrupt_AI_asms]: apply (cases caps ; fastforce simp: cte_wp_at_eq_simp) done -lemma get_irq_slot_different_ARCH[Interrupt_AI_asms]: +lemma get_irq_slot_different_ARCH[Interrupt_AI_assms]: "\\s. valid_global_refs s \ ex_cte_cap_wp_to is_cnode_cap ptr s\ get_irq_slot irq \\rv s. rv \ ptr\" @@ -61,7 +61,7 @@ lemma get_irq_slot_different_ARCH[Interrupt_AI_asms]: apply (clarsimp simp: global_refs_def is_cap_simps cap_range_def) done -lemma is_derived_use_interrupt_ARCH[Interrupt_AI_asms]: +lemma is_derived_use_interrupt_ARCH[Interrupt_AI_assms]: "(is_ntfn_cap cap \ interrupt_derived cap cap') \ (is_derived m p cap cap')" apply (clarsimp simp: is_cap_simps) apply (clarsimp simp: interrupt_derived_def is_derived_def) @@ -69,7 +69,7 @@ lemma is_derived_use_interrupt_ARCH[Interrupt_AI_asms]: apply (simp add: is_cap_simps is_pt_cap_def vs_cap_ref_def) done -lemma maskInterrupt_invs_ARCH[Interrupt_AI_asms]: +lemma maskInterrupt_invs_ARCH[Interrupt_AI_assms]: "\invs and (\s. \b \ interrupt_states s irq \ IRQInactive)\ do_machine_op (maskInterrupt b irq) \\rv. invs\" @@ -77,13 +77,13 @@ lemma maskInterrupt_invs_ARCH[Interrupt_AI_asms]: valid_machine_state_def cur_tcb_def cur_sc_tcb_def valid_irq_states_def valid_irq_masks_def) -lemma no_cap_to_obj_with_diff_IRQHandler_ARCH[Interrupt_AI_asms]: +lemma no_cap_to_obj_with_diff_IRQHandler_ARCH[Interrupt_AI_assms]: "no_cap_to_obj_with_diff_ref (IRQHandlerCap irq) S = \" by (rule ext, simp add: no_cap_to_obj_with_diff_ref_def cte_wp_at_caps_of_state obj_ref_none_no_asid) -lemma (* set_irq_state_valid_cap *)[Interrupt_AI_asms]: +lemma (* set_irq_state_valid_cap *)[Interrupt_AI_assms]: "\valid_cap cap\ set_irq_state IRQSignal irq \\rv. valid_cap cap\" apply (clarsimp simp: set_irq_state_def) apply (wp do_machine_op_valid_cap) @@ -94,12 +94,12 @@ lemma (* set_irq_state_valid_cap *)[Interrupt_AI_asms]: done crunch set_irq_state - for valid_global_refs[Interrupt_AI_asms]: "valid_global_refs" + for valid_global_refs[Interrupt_AI_assms]: "valid_global_refs" crunch arch_invoke_irq_handler for typ_at[wp]: "\s. P (typ_at T p s)" -lemma invoke_irq_handler_invs'[Interrupt_AI_asms]: +lemma invoke_irq_handler_invs'[Interrupt_AI_assms]: assumes dmo_ex_inv[wp]: "\f. \invs and ex_inv\ do_machine_op f \\rv::unit. ex_inv\" assumes cap_insert_ex_inv[wp]: "\cap src dest. \ex_inv and invs and K (src \ dest)\ @@ -156,7 +156,7 @@ lemma invoke_irq_handler_invs'[Interrupt_AI_asms]: done qed -lemma (* invoke_irq_control_invs *) [Interrupt_AI_asms]: +lemma (* invoke_irq_control_invs *) [Interrupt_AI_assms]: "\invs and irq_control_inv_valid i\ invoke_irq_control i \\rv. invs\" apply (cases i, simp_all) apply (wp cap_insert_simple_invs @@ -180,7 +180,7 @@ lemma (* invoke_irq_control_invs *) [Interrupt_AI_asms]: crunch resetTimer for device_state_inv[wp]: "\ms. P (device_state ms)" -lemma resetTimer_invs_ARCH[Interrupt_AI_asms]: +lemma resetTimer_invs_ARCH[Interrupt_AI_assms]: "\invs\ do_machine_op resetTimer \\_. invs\" apply (wp dmo_invs) apply safe @@ -193,15 +193,15 @@ lemma resetTimer_invs_ARCH[Interrupt_AI_asms]: apply(erule use_valid, wp no_irq_resetTimer no_irq, assumption) done -lemma empty_fail_ackInterrupt_ARCH[Interrupt_AI_asms]: +lemma empty_fail_ackInterrupt_ARCH[Interrupt_AI_assms]: "empty_fail (ackInterrupt irq)" by (wp | simp add: ackInterrupt_def)+ -lemma empty_fail_maskInterrupt_ARCH[Interrupt_AI_asms]: +lemma empty_fail_maskInterrupt_ARCH[Interrupt_AI_assms]: "empty_fail (maskInterrupt f irq)" by (wp | simp add: maskInterrupt_def)+ -lemma (* handle_interrupt_invs *) [Interrupt_AI_asms]: +lemma (* handle_interrupt_invs *) [Interrupt_AI_assms]: "\invs\ handle_interrupt irq \\_. invs\" apply (simp add: handle_interrupt_def) apply (rule conjI; rule impI) @@ -217,7 +217,7 @@ lemma (* handle_interrupt_invs *) [Interrupt_AI_asms]: | simp add: get_irq_state_def ackDeadlineIRQ_def handle_reserved_irq_def)+ done -lemma sts_arch_irq_control_inv_valid[wp, Interrupt_AI_asms]: +lemma sts_arch_irq_control_inv_valid[wp, Interrupt_AI_assms]: "\arch_irq_control_inv_valid i\ set_thread_state t st \\rv. arch_irq_control_inv_valid i\" @@ -228,12 +228,12 @@ lemma sts_arch_irq_control_inv_valid[wp, Interrupt_AI_asms]: done crunch invoke_irq_control - for cur_thread[wp, Interrupt_AI_asms]: "\s. P (cur_thread s)" - and ct_in_state[wp, Interrupt_AI_asms]: "ct_in_state P" + for cur_thread[wp, Interrupt_AI_assms]: "\s. P (cur_thread s)" + and ct_in_state[wp, Interrupt_AI_assms]: "ct_in_state P" (wp: crunch_wps simp: crunch_simps) crunch invoke_irq_handler - for ct_active[wp, Interrupt_AI_asms]: "ct_active" + for ct_active[wp, Interrupt_AI_assms]: "ct_active" (wp: gts_wp get_simple_ko_wp crunch_wps simp: crunch_simps) end @@ -241,7 +241,7 @@ end interpretation Interrupt_AI?: Interrupt_AI proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales, simp_all add: Interrupt_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales, simp_all add: Interrupt_AI_assms)?) qed end diff --git a/proof/invariant-abstract/ARM/ArchInvariants_AI.thy b/proof/invariant-abstract/ARM/ArchInvariants_AI.thy index ccef9724a4..946e5fb3f1 100644 --- a/proof/invariant-abstract/ARM/ArchInvariants_AI.thy +++ b/proof/invariant-abstract/ARM/ArchInvariants_AI.thy @@ -24,7 +24,7 @@ end_qualify \ \---------------------------------------------------------------------------\ section "ARM-specific invariant definitions" -qualify ARM_A (in Arch) +qualify ARM (in Arch) (* ARM has no interest for iarch_tcb (introduced for ARM_HYP) , and we consider no non-trivial predicates of iarch_tcb, so an unspecified typedecl seems appropriate. @@ -34,7 +34,7 @@ qualify ARM_A (in Arch) typedecl iarch_tcb end_qualify -context Arch begin global_naming ARM +context Arch begin arch_global_naming definition arch_tcb_to_iarch_tcb :: "arch_tcb \ iarch_tcb" @@ -450,16 +450,15 @@ definition "second_level_tables \ arch_state.arm_global_pts" end -context begin interpretation Arch . -requalify_consts vs_lookup -end +(* needed for abbreviation *) +arch_requalify_consts vs_lookup abbreviation vs_lookup_abbr ("_ \ _" [80,80] 81) where "rs \ p \ \s. (rs,p) \ vs_lookup s" -context Arch begin global_naming ARM +context Arch begin arch_global_naming abbreviation is_reachable_abbr :: "obj_ref \ 'z::state_ext state \ bool" ("\\ _" [80] 81) where @@ -534,9 +533,8 @@ where end -context begin interpretation Arch . -requalify_consts vs_lookup_pages -end +(* needed for abbreviation *) +arch_requalify_consts vs_lookup_pages abbreviation vs_lookup_pages_abbr @@ -548,7 +546,7 @@ abbreviation "\\ p \ \s. \ref. (ref \ p) s" -context Arch begin global_naming ARM +context Arch begin arch_global_naming definition "vspace_obj_fun_lift P F c \ case c of @@ -1349,7 +1347,7 @@ lemma valid_vspace_objs_update' [iff]: end -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemma global_refs_equiv: assumes "idle_thread s = idle_thread s'" @@ -2167,7 +2165,7 @@ lemma vs_cap_ref_eq_imp_table_cap_ref_eq: arch_cap_fun_lift_def split: cap.splits arch_cap.splits vmpage_size.splits option.splits) -lemma acap_rights_update_id [intro!, simp]: +lemma wf_acap_rights_update_id [intro!, simp]: "\wellformed_acap cap\ \ acap_rights_update (acap_rights cap) cap = cap" unfolding wellformed_acap_def acap_rights_update_def by (auto split: arch_cap.splits) diff --git a/proof/invariant-abstract/ARM/ArchIpcCancel_AI.thy b/proof/invariant-abstract/ARM/ArchIpcCancel_AI.thy index 8f0e8b96a3..1a33884511 100644 --- a/proof/invariant-abstract/ARM/ArchIpcCancel_AI.thy +++ b/proof/invariant-abstract/ARM/ArchIpcCancel_AI.thy @@ -8,13 +8,13 @@ theory ArchIpcCancel_AI imports IpcCancel_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming -named_theorems IpcCancel_AI_asms +named_theorems IpcCancel_AI_assms crunch arch_post_cap_deletion - for typ_at[wp, IpcCancel_AI_asms]: "\s. P (typ_at T p s)" - and idle_thread[wp, IpcCancel_AI_asms]: "\s. P (idle_thread s)" + for typ_at[wp, IpcCancel_AI_assms]: "\s. P (typ_at T p s)" + and idle_thread[wp, IpcCancel_AI_assms]: "\s. P (idle_thread s)" end @@ -22,7 +22,7 @@ interpretation IpcCancel_AI?: IpcCancel_AI proof goal_cases interpret Arch . case 1 show ?case - by (intro_locales; (unfold_locales; fact IpcCancel_AI_asms)?) + by (intro_locales; (unfold_locales; fact IpcCancel_AI_assms)?) qed diff --git a/proof/invariant-abstract/ARM/ArchIpc_AI.thy b/proof/invariant-abstract/ARM/ArchIpc_AI.thy index dd434a0ee2..62ab5db570 100644 --- a/proof/invariant-abstract/ARM/ArchIpc_AI.thy +++ b/proof/invariant-abstract/ARM/ArchIpc_AI.thy @@ -8,7 +8,7 @@ theory ArchIpc_AI imports Ipc_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming named_theorems Ipc_AI_assms @@ -447,7 +447,7 @@ proof goal_cases case 1 show ?case by (unfold_locales; (fact Ipc_AI_assms)?) qed -context Arch begin global_naming ARM +context Arch begin arch_global_naming named_theorems Ipc_AI_cont_assms diff --git a/proof/invariant-abstract/ARM/ArchKHeap_AI.thy b/proof/invariant-abstract/ARM/ArchKHeap_AI.thy index f712691b1b..c98560cb97 100644 --- a/proof/invariant-abstract/ARM/ArchKHeap_AI.thy +++ b/proof/invariant-abstract/ARM/ArchKHeap_AI.thy @@ -8,7 +8,7 @@ theory ArchKHeap_AI imports KHeapPre_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming fun non_vspace_obj :: "kernel_object \ bool" @@ -121,7 +121,7 @@ locale vspace_only_obj_pred = Arch + sublocale vspace_only_obj_pred < arch_only_obj_pred using vspace_pred_imp[OF vspace_only] by unfold_locales -context Arch begin global_naming ARM +context Arch begin arch_global_naming sublocale empty_table: vspace_only_obj_pred "empty_table S" for S by unfold_locales (clarsimp simp: vspace_obj_pred_def empty_table_def diff --git a/proof/invariant-abstract/ARM/ArchKernelInit_AI.thy b/proof/invariant-abstract/ARM/ArchKernelInit_AI.thy index 00de271b3e..19e81d775d 100644 --- a/proof/invariant-abstract/ARM/ArchKernelInit_AI.thy +++ b/proof/invariant-abstract/ARM/ArchKernelInit_AI.thy @@ -14,7 +14,7 @@ imports Arch_AI begin -context Arch begin global_naming ARM (*FIXME: arch_split*) +context Arch begin arch_global_naming text \ Showing that there is a state that satisfies the abstract invariants. diff --git a/proof/invariant-abstract/ARM/ArchLevityCatch_AI.thy b/proof/invariant-abstract/ARM/ArchLevityCatch_AI.thy index 481b6c9555..986b7b8a19 100644 --- a/proof/invariant-abstract/ARM/ArchLevityCatch_AI.thy +++ b/proof/invariant-abstract/ARM/ArchLevityCatch_AI.thy @@ -11,7 +11,7 @@ imports "Lib.SplitRule" begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemma asid_high_bits_of_shift : "asid_high_bits_of (ucast x << asid_low_bits) = x" diff --git a/proof/invariant-abstract/ARM/ArchRetype_AI.thy b/proof/invariant-abstract/ARM/ArchRetype_AI.thy index 2d9a9c4b64..42e03b2866 100644 --- a/proof/invariant-abstract/ARM/ArchRetype_AI.thy +++ b/proof/invariant-abstract/ARM/ArchRetype_AI.thy @@ -13,7 +13,7 @@ theory ArchRetype_AI imports Retype_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming named_theorems Retype_AI_assms @@ -562,10 +562,7 @@ declare post_retype_invs_check_def[simp] end - -context begin interpretation Arch . -requalify_consts post_retype_invs_check -end +arch_requalify_consts post_retype_invs_check definition post_retype_invs :: "apiobject_type \ machine_word list \ 'z::state_ext state \ bool" @@ -581,7 +578,7 @@ global_interpretation Retype_AI_post_retype_invs?: Retype_AI_post_retype_invs by (unfold_locales; fact post_retype_invs_def) -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemma dmo_mapM_x_ccr_invs[wp]: "\invs\ @@ -600,14 +597,11 @@ lemma init_arch_objects_invs_from_restricted: "\post_retype_invs new_type refs and (\s. global_refs s \ set refs = {}) and K (\ref \ set refs. is_aligned ref (obj_bits_api new_type obj_sz))\ - init_arch_objects new_type ptr bits obj_sz refs + init_arch_objects new_type dev ptr bits obj_sz refs \\_. invs\" apply (simp add: init_arch_objects_def split del: if_split) - apply (rule hoare_pre) - apply (wp mapM_copy_global_invs_mappings_restricted - hoare_vcg_const_Ball_lift - valid_irq_node_typ - | wpc)+ + apply (wpsimp wp: mapM_copy_global_invs_mappings_restricted dmo_invs_lift + mapM_x_wp'[where f="\r. do_machine_op (m r)" for m]) apply (auto simp: post_retype_invs_def default_arch_object_def pd_bits_def pageBits_def obj_bits_api_def global_refs_def) @@ -659,7 +653,7 @@ global_interpretation Retype_AI_slot_bits?: Retype_AI_slot_bits qed -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemma valid_untyped_helper [Retype_AI_assms]: assumes valid_c : "s \ c" @@ -901,7 +895,7 @@ sublocale retype_region_proofs_gen?: retype_region_proofs_gen end -context Arch begin global_naming ARM (*FIXME: arch_split*) +context Arch begin arch_global_naming definition valid_vs_lookup2 :: "(vs_ref list \ word32) set \ (cslot_ptr \ cap) \ bool" @@ -1017,10 +1011,7 @@ where end -context begin interpretation Arch . -requalify_consts region_in_kernel_window -end - +arch_requalify_consts region_in_kernel_window lemma cap_range_respects_device_region_cong[cong]: "device_state (machine_state s) = device_state (machine_state s') @@ -1238,7 +1229,7 @@ lemmas post_retype_invs_axioms = retype_region_proofs_invs_axioms end -context Arch begin global_naming ARM +context Arch begin arch_global_naming named_theorems Retype_AI_assms' @@ -1271,7 +1262,7 @@ global_interpretation Retype_AI?: Retype_AI qed -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemma retype_region_plain_invs: "\invs and caps_no_overlap ptr sz and pspace_no_overlap_range_cover ptr sz @@ -1401,7 +1392,7 @@ crunch init_arch_objects lemma init_arch_objects_excap: "\ex_cte_cap_wp_to P p\ - init_arch_objects tp ptr bits us refs + init_arch_objects tp dev ptr bits us refs \\rv s. ex_cte_cap_wp_to P p s\" by (wp ex_cte_cap_to_pres) diff --git a/proof/invariant-abstract/ARM/ArchSchedule_AI.thy b/proof/invariant-abstract/ARM/ArchSchedule_AI.thy index da0f9fea39..4a40f517d4 100644 --- a/proof/invariant-abstract/ARM/ArchSchedule_AI.thy +++ b/proof/invariant-abstract/ARM/ArchSchedule_AI.thy @@ -8,11 +8,11 @@ theory ArchSchedule_AI imports Schedule_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming -named_theorems Schedule_AI_asms +named_theorems Schedule_AI_assms -lemma dmo_mapM_storeWord_0_invs[wp,Schedule_AI_asms]: +lemma dmo_mapM_storeWord_0_invs[wp,Schedule_AI_assms]: "valid invs (do_machine_op (mapM (\p. storeWord p 0) S)) (\_. invs)" apply (simp add: dmo_mapM ef_storeWord) apply (rule mapM_UNIV_wp) @@ -38,37 +38,35 @@ lemma clearExMonitor_invs [wp]: machine_rest_lift_def in_monad select_f_def) done -global_naming Arch - -lemma arch_stt_invs [wp,Schedule_AI_asms]: +lemma arch_stt_invs [wp,Schedule_AI_assms]: "\invs\ arch_switch_to_thread t' \\_. invs\" apply (simp add: arch_switch_to_thread_def) apply wp done -lemma arch_stt_tcb [wp,Schedule_AI_asms]: +lemma arch_stt_tcb [wp,Schedule_AI_assms]: "\tcb_at t'\ arch_switch_to_thread t' \\_. tcb_at t'\" apply (simp add: arch_switch_to_thread_def) apply (wp) done -lemma arch_stt_sc_at[wp,Schedule_AI_asms]: +lemma arch_stt_sc_at[wp,Schedule_AI_assms]: "arch_switch_to_thread t' \sc_at sc_ptr\" apply (simp add: arch_switch_to_thread_def) apply wp done -lemma arch_stt_runnable[Schedule_AI_asms]: +lemma arch_stt_runnable[Schedule_AI_assms]: "\st_tcb_at Q t\ arch_switch_to_thread t \\r . st_tcb_at Q t\" apply (simp add: arch_switch_to_thread_def) apply wp done -lemma arch_stit_invs[wp, Schedule_AI_asms]: +lemma arch_stit_invs[wp, Schedule_AI_assms]: "\invs\ arch_switch_to_idle_thread \\r. invs\" by (wpsimp wp: svr_invs simp: arch_switch_to_idle_thread_def) -lemma arch_stit_tcb_at[wp, Schedule_AI_asms]: +lemma arch_stit_tcb_at[wp, Schedule_AI_assms]: "\tcb_at t\ arch_switch_to_idle_thread \\r. tcb_at t\" apply (simp add: arch_switch_to_idle_thread_def ) apply wp @@ -80,19 +78,19 @@ crunch set_vm_root and scheduler_action[wp]: "\s. P (scheduler_action s)" (simp: crunch_simps) -lemma arch_stit_sc_at[wp, Schedule_AI_asms]: +lemma arch_stit_sc_at[wp, Schedule_AI_assms]: "arch_switch_to_idle_thread \sc_at sc_ptr\" apply (simp add: arch_switch_to_idle_thread_def) apply wp done -lemma arch_stit_activatable[wp, Schedule_AI_asms]: +lemma arch_stit_activatable[wp, Schedule_AI_assms]: "\ct_in_state activatable\ arch_switch_to_idle_thread \\rv . ct_in_state activatable\" apply (clarsimp simp: arch_switch_to_idle_thread_def) apply (wpsimp simp: ct_in_state_def wp: ct_in_state_thread_state_lift) done -lemma stit_activatable[Schedule_AI_asms]: +lemma stit_activatable[Schedule_AI_assms]: "\invs\ switch_to_idle_thread \\rv . ct_in_state activatable\" apply (simp add: switch_to_idle_thread_def arch_switch_to_idle_thread_def) apply (wp | simp add: ct_in_state_def)+ @@ -100,11 +98,11 @@ lemma stit_activatable[Schedule_AI_asms]: elim!: pred_tcb_weaken_strongerE) done -lemma arch_stt_scheduler_action [wp, Schedule_AI_asms]: +lemma arch_stt_scheduler_action [wp, Schedule_AI_assms]: "\\s. P (scheduler_action s)\ arch_switch_to_thread t' \\_ s. P (scheduler_action s)\" by (wpsimp simp: arch_switch_to_thread_def) -lemma arch_stit_scheduler_action [wp, Schedule_AI_asms]: +lemma arch_stit_scheduler_action [wp, Schedule_AI_assms]: "\\s. P (scheduler_action s)\ arch_switch_to_idle_thread \\_ s. P (scheduler_action s)\" by (wpsimp simp: arch_switch_to_idle_thread_def) @@ -113,7 +111,7 @@ end interpretation Schedule_AI?: Schedule_AI proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Schedule_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Schedule_AI_assms)?) qed end diff --git a/proof/invariant-abstract/ARM/ArchSyscall_AI.thy b/proof/invariant-abstract/ARM/ArchSyscall_AI.thy index 10232407d1..63203958a6 100644 --- a/proof/invariant-abstract/ARM/ArchSyscall_AI.thy +++ b/proof/invariant-abstract/ARM/ArchSyscall_AI.thy @@ -13,7 +13,7 @@ imports Syscall_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming named_theorems Syscall_AI_assms diff --git a/proof/invariant-abstract/ARM/ArchTcbAcc_AI.thy b/proof/invariant-abstract/ARM/ArchTcbAcc_AI.thy index dad4403706..31382f438c 100644 --- a/proof/invariant-abstract/ARM/ArchTcbAcc_AI.thy +++ b/proof/invariant-abstract/ARM/ArchTcbAcc_AI.thy @@ -8,7 +8,7 @@ theory ArchTcbAcc_AI imports TcbAcc_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemma as_user_valid_tcbs[wp]: "as_user ptr f \valid_tcbs\" diff --git a/proof/invariant-abstract/ARM/ArchTcb_AI.thy b/proof/invariant-abstract/ARM/ArchTcb_AI.thy index a51c2e00c9..e48136dca7 100644 --- a/proof/invariant-abstract/ARM/ArchTcb_AI.thy +++ b/proof/invariant-abstract/ARM/ArchTcb_AI.thy @@ -8,19 +8,19 @@ theory ArchTcb_AI imports Tcb_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming -named_theorems Tcb_AI_asms +named_theorems Tcb_AI_assms -lemma activate_idle_invs[Tcb_AI_asms]: +lemma activate_idle_invs[Tcb_AI_assms]: "\invs and ct_idle\ arch_activate_idle_thread thread \\rv. invs and ct_idle\" by (simp add: arch_activate_idle_thread_def) -lemma empty_fail_getRegister [intro!, simp, Tcb_AI_asms]: +lemma empty_fail_getRegister [intro!, simp, Tcb_AI_assms]: "empty_fail (getRegister r)" by (simp add: getRegister_def) @@ -37,7 +37,7 @@ lemma same_object_also_valid: (* arch specific *) split: cap.split_asm arch_cap.split_asm option.splits)+) done -lemma same_object_obj_refs[Tcb_AI_asms]: +lemma same_object_obj_refs[Tcb_AI_assms]: "\ same_object_as cap cap' \ \ obj_refs cap = obj_refs cap'" apply (cases cap, simp_all add: same_object_as_def) @@ -158,15 +158,15 @@ lemma checked_insert_tcb_invs': (* arch specific *) by (auto simp: is_cap_simps is_cnode_or_valid_arch_def valid_fault_handler_def) crunch arch_post_modify_registers - for tcb_at[wp, Tcb_AI_asms]: "tcb_at a" - and invs[wp, Tcb_AI_asms]: invs - and ex_nonz_cap_to[wp, Tcb_AI_asms]: "ex_nonz_cap_to a" - and fault_tcb_at[wp, Tcb_AI_asms]: "fault_tcb_at P a" + for tcb_at[wp, Tcb_AI_assms]: "tcb_at a" + and invs[wp, Tcb_AI_assms]: invs + and ex_nonz_cap_to[wp, Tcb_AI_assms]: "ex_nonz_cap_to a" + and fault_tcb_at[wp, Tcb_AI_assms]: "fault_tcb_at P a" crunch arch_get_sanitise_register_info - for inv[wp, Tcb_AI_asms]: "P" + for inv[wp, Tcb_AI_assms]: "P" -lemma finalise_cap_not_cte_wp_at[Tcb_AI_asms]: +lemma finalise_cap_not_cte_wp_at[Tcb_AI_assms]: assumes x: "P cap.NullCap" shows "\\s. \cp \ ran (caps_of_state s). P cp\ finalise_cap cap fin @@ -179,14 +179,14 @@ lemma finalise_cap_not_cte_wp_at[Tcb_AI_asms]: simp: deleting_irq_handler_def get_irq_slot_def ball_ran_eq x) done -lemma table_cap_ref_max_free_index_upd[simp,Tcb_AI_asms]: +lemma table_cap_ref_max_free_index_upd[simp,Tcb_AI_assms]: "table_cap_ref (max_free_index_update cap) = table_cap_ref cap" by (simp add: free_index_update_def table_cap_ref_def split: cap.splits) interpretation Tcb_AI_1? : Tcb_AI_1 where is_cnode_or_valid_arch = is_cnode_or_valid_arch - by (unfold_locales; fact Tcb_AI_asms) + by (unfold_locales; fact Tcb_AI_assms) lemma use_no_cap_to_obj_asid_strg: (* arch specific *) @@ -203,7 +203,7 @@ lemma use_no_cap_to_obj_asid_strg: (* arch specific *) apply (fastforce simp: table_cap_ref_def valid_cap_simps elim!: asid_low_high_bits)+ done -lemma cap_delete_no_cap_to_obj_asid[wp, Tcb_AI_asms]: +lemma cap_delete_no_cap_to_obj_asid[wp, Tcb_AI_assms]: "\no_cap_to_obj_dr_emp cap\ cap_delete slot \\rv. no_cap_to_obj_dr_emp cap\" @@ -273,7 +273,7 @@ lemma install_tcb_cap_invs: elim!: cte_wp_at_weakenE) done -lemma install_tcb_cap_no_cap_to_obj_dr_emp[wp, Tcb_AI_asms]: +lemma install_tcb_cap_no_cap_to_obj_dr_emp[wp, Tcb_AI_assms]: "\no_cap_to_obj_dr_emp cap and (\s. \new_cap src_slot. slot_opt = Some (new_cap, src_slot) \ no_cap_to_obj_dr_emp new_cap s)\ @@ -319,7 +319,7 @@ lemma install_tcb_frame_cap_invs: | wp cap_delete_ep)+)[1] by (clarsimp simp: is_cap_simps' valid_fault_handler_def) -lemma tcc_invs[Tcb_AI_asms]: +lemma tcc_invs[Tcb_AI_assms]: "\invs and tcb_inv_wf (ThreadControlCaps t sl fh th croot vroot buf)\ invoke_tcb (ThreadControlCaps t sl fh th croot vroot buf) \\rv. invs\" @@ -382,7 +382,7 @@ lemma install_tcb_cap_sc_tcb_sc_at[wp]: apply (wpsimp wp: check_cap_inv cap_delete_fh_lift hoare_vcg_if_lift2 | simp)+ done -lemma tcs_invs[Tcb_AI_asms]: +lemma tcs_invs[Tcb_AI_assms]: "\invs and tcb_inv_wf (ThreadControlSched t sl fh mcp pr sc)\ invoke_tcb (ThreadControlSched t sl fh mcp pr sc) \\rv. invs\" @@ -431,7 +431,7 @@ lemma check_valid_ipc_buffer_inv: apply (wp | simp add: whenE_def if_apply_def2 | wpcw)+ done -lemma check_valid_ipc_buffer_wp[Tcb_AI_asms]: +lemma check_valid_ipc_buffer_wp[Tcb_AI_assms]: "\\(s::'state_ext::state_ext state). is_arch_cap cap \ is_cnode_or_valid_arch cap \ valid_ipc_buffer_cap cap vptr \ is_aligned vptr msg_align_bits @@ -447,7 +447,7 @@ lemma check_valid_ipc_buffer_wp[Tcb_AI_asms]: valid_ipc_buffer_cap_def) done -lemma derive_no_cap_asid[wp,Tcb_AI_asms]: +lemma derive_no_cap_asid[wp,Tcb_AI_assms]: "\(no_cap_to_obj_with_diff_ref cap S)::'state_ext::state_ext state\bool\ derive_cap slot cap \\rv. no_cap_to_obj_with_diff_ref rv S\,-" @@ -461,7 +461,7 @@ lemma derive_no_cap_asid[wp,Tcb_AI_asms]: done -lemma decode_set_ipc_inv[wp,Tcb_AI_asms]: +lemma decode_set_ipc_inv[wp,Tcb_AI_assms]: "\P::'state_ext::state_ext state \ bool\ decode_set_ipc_buffer args cap slot excaps \\rv. P\" apply (simp add: decode_set_ipc_buffer_def whenE_def split_def @@ -470,7 +470,7 @@ lemma decode_set_ipc_inv[wp,Tcb_AI_asms]: apply simp done -lemma no_cap_to_obj_with_diff_ref_update_cap_data[Tcb_AI_asms]: +lemma no_cap_to_obj_with_diff_ref_update_cap_data[Tcb_AI_assms]: "no_cap_to_obj_with_diff_ref c S s \ no_cap_to_obj_with_diff_ref (update_cap_data P x c) S s" apply (case_tac "update_cap_data P x c = NullCap") @@ -486,7 +486,7 @@ lemma no_cap_to_obj_with_diff_ref_update_cap_data[Tcb_AI_asms]: apply simp done -lemma update_cap_valid[Tcb_AI_asms]: +lemma update_cap_valid[Tcb_AI_assms]: "valid_cap cap (s::'state_ext::state_ext state) \ valid_cap (case capdata of None \ cap_rights_update rs cap @@ -516,19 +516,11 @@ crunch invoke_tcb end -context begin interpretation Arch . - -requalify_consts is_cnode_or_valid_arch -requalify_facts invoke_tcb_typ_at install_tcb_cap_invs - is_cnode_or_valid_arch_is_cap_simps - -end - global_interpretation Tcb_AI?: Tcb_AI where is_cnode_or_valid_arch = ARM.is_cnode_or_valid_arch proof goal_cases interpret Arch . - case 1 show ?case by (unfold_locales; (fact Tcb_AI_asms)?) + case 1 show ?case by (unfold_locales; (fact Tcb_AI_assms)?) qed end diff --git a/proof/invariant-abstract/ARM/ArchUntyped_AI.thy b/proof/invariant-abstract/ARM/ArchUntyped_AI.thy index f4c76b3453..43568a58b6 100644 --- a/proof/invariant-abstract/ARM/ArchUntyped_AI.thy +++ b/proof/invariant-abstract/ARM/ArchUntyped_AI.thy @@ -8,7 +8,7 @@ theory ArchUntyped_AI imports Untyped_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming named_theorems Untyped_AI_assms @@ -196,7 +196,7 @@ lemma retype_ret_valid_caps_aobj[Untyped_AI_assms]: -lemma copy_global_mappings_hoare_lift:(*FIXME: arch_split \ these do not seem to be used globally *) +lemma copy_global_mappings_hoare_lift:(*FIXME: arch-split \ these do not seem to be used globally *) assumes wp: "\ptr val. \Q\ store_pde ptr val \\rv. Q\" shows "\Q\ copy_global_mappings pd \\rv. Q\" apply (simp add: copy_global_mappings_def) @@ -204,24 +204,13 @@ lemma copy_global_mappings_hoare_lift:(*FIXME: arch_split \ these d done lemma init_arch_objects_hoare_lift: - assumes wp: "\oper. \(P::'state_ext::state_ext state\bool)\ do_machine_op oper \\rv :: unit. Q\" - "\ptr val. \P\ store_pde ptr val \\rv. P\" - shows "\P and Q\ init_arch_objects tp ptr sz us adds \\rv. Q\" -proof - - have pres: "\oper. \P and Q\ do_machine_op oper \\rv :: unit. Q\" - "\P and Q\ return () \\rv. Q\" - by (wp wp | simp)+ - show ?thesis - apply (simp add: init_arch_objects_def - pres reserve_region_def unless_def when_def - split: Structures_A.apiobject_type.split - aobject_type.split) - apply clarsimp - apply (rule hoare_pre) - apply (wp mapM_x_wp' copy_global_mappings_hoare_lift wp) - apply simp - done -qed + assumes wp: "\oper. \(Q::'state_ext::state_ext state\bool)\ do_machine_op oper \\rv :: unit. Q\" + "\ptr val. \Q\ store_pde ptr val \\rv. Q\" + shows "\Q\ init_arch_objects tp dev ptr sz us adds \\rv. Q\" + supply if_split[split del] + apply (simp add: init_arch_objects_def reserve_region_def) + apply (wpsimp wp: mapM_x_wp' copy_global_mappings_hoare_lift wp) + done lemma cap_refs_in_kernel_windowD2: "\ cte_wp_at P p (s::'state_ext::state_ext state); cap_refs_in_kernel_window s \ @@ -232,30 +221,21 @@ lemma cap_refs_in_kernel_windowD2: done lemma init_arch_objects_descendants_range[wp,Untyped_AI_assms]: - "\\(s::'state_ext::state_ext state). descendants_range x cref s \ init_arch_objects ty ptr n us y - \\rv s. descendants_range x cref s\" - apply (simp add:descendants_range_def) - apply (rule hoare_pre) - apply (wp retype_region_mdb init_arch_objects_hoare_lift) - apply (wps do_machine_op_mdb) - apply (wp hoare_vcg_ball_lift) - apply (rule hoare_pre) - apply (wps store_pde_mdb_inv) - apply wp - apply simp - apply fastforce + "\\(s::'state_ext::state_ext state). descendants_range x cref s \ + init_arch_objects ty dev ptr n us y + \\rv s. descendants_range x cref s\" + apply (simp add: descendants_range_def) + apply (wp retype_region_mdb init_arch_objects_hoare_lift) + apply (wp_pre, wps do_machine_op_mdb, wp, simp)+ + apply simp done - - lemma init_arch_objects_caps_overlap_reserved[wp,Untyped_AI_assms]: "\\(s::'state_ext::state_ext state). caps_overlap_reserved S s\ - init_arch_objects ty ptr n us y + init_arch_objects ty dev ptr n us y \\rv s. caps_overlap_reserved S s\" apply (simp add:caps_overlap_reserved_def) - apply (rule hoare_pre) - apply (wp retype_region_mdb init_arch_objects_hoare_lift) - apply fastforce + apply (wp retype_region_mdb init_arch_objects_hoare_lift) done lemma set_untyped_cap_invs_simple[Untyped_AI_assms]: @@ -539,12 +519,11 @@ lemma init_arch_objects_nonempty_table[Untyped_AI_assms, wp]: "\(\s. \ (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s) \ valid_global_objs s \ valid_arch_state s \ pspace_aligned s) and K (\ref\set refs. is_aligned ref (obj_bits_api tp us))\ - init_arch_objects tp ptr bits us refs + init_arch_objects tp dev ptr bits us refs \\rv s. \ (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)\" - apply (rule hoare_gen_asm) - apply (simp add: init_arch_objects_def split del: if_split) - apply (rule hoare_pre) - apply (wp unless_wp | wpc | simp add: reserve_region_def second_level_tables_def)+ + unfolding init_arch_objects_def + apply (wpsimp wp: mapM_x_wp'[where f="\r. do_machine_op (m r)" for m] + mapM_copy_global_mappings_nonempty_table) apply (clarsimp simp: obj_bits_api_def default_arch_object_def pd_bits_def pageBits_def) done @@ -630,9 +609,9 @@ qed lemma init_arch_objects_obj_at_other[Untyped_AI_assms]: "\\ptr\set ptrs. is_aligned ptr (obj_bits_api ty us); p \ set ptrs\ - \ init_arch_objects ty ptr n us ptrs \\s. N (obj_at P p s)\" - by (wpsimp simp: init_arch_objects_def obj_bits_api_def default_arch_object_def - pd_bits_def pageBits_def + \ init_arch_objects ty dev ptr n us ptrs \\s. N (obj_at P p s)\" + unfolding init_arch_objects_def + by (wpsimp simp: obj_bits_api_def default_arch_object_def pd_bits_def pageBits_def wp: mapM_x_wp' copy_global_mappings_obj_at_other) lemma copy_global_mappings_obj_at_non_pd: @@ -649,10 +628,9 @@ lemma copy_global_mappings_obj_at_non_pd: lemma init_arch_objects_obj_at_non_pd: assumes non_pd: "\ko. P ko \ (\pd. ko \ ArchObj (PageDirectory pd))" - shows "init_arch_objects ty ptr n us ptrs \\s. N (obj_at P p s)\" - by (wpsimp simp: init_arch_objects_def obj_bits_api_def default_arch_object_def - pd_bits_def pageBits_def - wp: mapM_x_wp' copy_global_mappings_obj_at_non_pd[OF non_pd]) + shows "init_arch_objects ty dev ptr n us ptrs \\s. N (obj_at P p s)\" + unfolding init_arch_objects_def + by (wpsimp wp: mapM_x_wp' copy_global_mappings_obj_at_non_pd[OF non_pd]) lemma non_arch_non_pd: "\ko. P ko \ non_arch_obj ko \ \ko. P ko \ (\pd. ko \ ArchObj (PageDirectory pd))" diff --git a/proof/invariant-abstract/ARM/ArchVSpaceEntries_AI.thy b/proof/invariant-abstract/ARM/ArchVSpaceEntries_AI.thy index 5f910bb507..4466e5d416 100644 --- a/proof/invariant-abstract/ARM/ArchVSpaceEntries_AI.thy +++ b/proof/invariant-abstract/ARM/ArchVSpaceEntries_AI.thy @@ -9,7 +9,7 @@ imports VSpaceEntries_AI begin -context Arch begin global_naming ARM (*FIXME: arch_split*) +context Arch begin arch_global_naming lemma a_type_pdD: "a_type ko = AArch APageDirectory \ \pd. ko = ArchObj (PageDirectory pd)" @@ -753,26 +753,25 @@ lemma init_arch_objects_valid_pdpt: "\valid_pdpt_objs and pspace_aligned and valid_arch_state and K (\us sz. orefs = retype_addrs ptr type n us \ range_cover ptr sz (obj_bits_api type us) n)\ - init_arch_objects type ptr n obj_sz orefs + init_arch_objects type dev ptr n obj_sz orefs \\rv. valid_pdpt_objs\" apply (rule hoare_gen_asm)+ - apply (clarsimp simp: init_arch_objects_def - split del: if_split) - apply (rule hoare_pre) + apply (clarsimp simp: init_arch_objects_def split del: if_split) apply wpsimp - apply (rule_tac Q'="\rv. valid_pdpt_objs and pspace_aligned and valid_arch_state" - in hoare_post_imp, simp) - apply (rule mapM_x_wp') - apply (rule hoare_pre, wp copy_global_mappings_valid_pdpt_objs) - apply clarsimp - apply (drule_tac sz=sz in retype_addrs_aligned) - apply (simp add:range_cover_def) - apply (drule range_cover.sz,simp add:word_bits_def) - apply (simp add:range_cover_def) - apply (clarsimp simp:obj_bits_api_def pd_bits_def pageBits_def - arch_kobj_size_def default_arch_object_def range_cover_def)+ + apply (wpsimp wp: mapM_x_wp' hoare_vcg_op_lift) + apply (wpsimp wp: mapM_x_wp' hoare_vcg_op_lift) + apply (rule_tac Q'="\rv. valid_pdpt_objs and pspace_aligned and valid_arch_state" + in hoare_post_imp, simp) apply wp - apply simp + apply (rule mapM_x_wp') + apply (wp copy_global_mappings_valid_pdpt_objs) + apply clarsimp + apply (drule_tac sz=sz in retype_addrs_aligned) + apply (simp add:range_cover_def) + apply (drule range_cover.sz,simp add:word_bits_def) + apply (simp add:range_cover_def) + apply (clarsimp simp: obj_bits_api_def pd_bits_def pageBits_def + arch_kobj_size_def default_arch_object_def range_cover_def)+ done lemma delete_objects_valid_pdpt: diff --git a/proof/invariant-abstract/ARM/ArchVSpace_AI.thy b/proof/invariant-abstract/ARM/ArchVSpace_AI.thy index 86f73f316a..17009623fa 100644 --- a/proof/invariant-abstract/ARM/ArchVSpace_AI.thy +++ b/proof/invariant-abstract/ARM/ArchVSpace_AI.thy @@ -12,7 +12,7 @@ theory ArchVSpace_AI imports VSpacePre_AI begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemma kernel_base_shift_cast_le: fixes x :: "12 word" @@ -1825,7 +1825,7 @@ lemma vs_lookup2: end -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemma set_pd_vspace_objs_map: notes valid_vspace_obj.simps[simp del] and a_type_elims[rule del] @@ -3425,17 +3425,13 @@ lemma unmap_page_table_unmapped2: lemma cacheRangeOp_lift[wp]: assumes o: "\a b. \P\ oper a b \\_. P\" shows "\P\ cacheRangeOp oper x y z \\_. P\" - apply (clarsimp simp: cacheRangeOp_def lineStart_def cacheLineBits_def cacheLine_def) - apply (rule hoare_pre) - apply (wp mapM_x_wp_inv o) - apply (case_tac x, simp, wp o, simp) - done + unfolding cacheRangeOp_def + by (wpsimp wp: mapM_x_wp_inv o) lemma cleanCacheRange_PoU_underlying_memory[wp]: - "\\m'. underlying_memory m' p = um\ cleanCacheRange_PoU a b c \\_ m'. underlying_memory m' p = um\" + "cleanCacheRange_PoU a b c \\m'. underlying_memory m' p = um\" by (clarsimp simp: cleanCacheRange_PoU_def, wp) - lemma unmap_page_table_unmapped3: "\pspace_aligned and valid_vspace_objs and page_table_at pt and K (ref = [VSRef (vaddr >> 20) (Some APageDirectory), @@ -4739,7 +4735,7 @@ lemma vs_lookup_pages2: end -context Arch begin global_naming ARM +context Arch begin arch_global_naming lemma not_kernel_slot_not_global_pt: "\pde_ref (pd x) = Some p; x \ kernel_mapping_slots; @@ -4944,7 +4940,7 @@ lemma perform_asid_pool_invs [wp]: apply (rule_tac x=a in exI) apply (rule_tac x=b in exI) apply (clarsimp simp: vs_cap_ref_def mask_asid_low_bits_ucast_ucast) - apply (clarsimp simp: asid_low_bits_def[symmetric] ucast_ucast_mask + apply (clarsimp simp: asid_low_bits_def[simplified, symmetric] ucast_ucast_mask word_neq_0_conv[symmetric]) apply (erule notE, rule asid_low_high_bits, simp_all)[1] apply (simp add: asid_high_bits_of_def) diff --git a/proof/invariant-abstract/ARM/Machine_AI.thy b/proof/invariant-abstract/ARM/Machine_AI.thy index 1b5a09c128..e602274617 100644 --- a/proof/invariant-abstract/ARM/Machine_AI.thy +++ b/proof/invariant-abstract/ARM/Machine_AI.thy @@ -67,7 +67,7 @@ crunch_ignore (no_irq) (add: handleE' handleE handle_elseE forM forM_x zipWithM ignore_failure) -context Arch begin +context Arch begin arch_global_naming lemma det_getRegister: "det (getRegister x)" by (simp add: getRegister_def) @@ -270,9 +270,8 @@ lemma no_fail_invalidateCacheRange_I[simp, wp]: lemma no_fail_invalidateCacheRange_RAM[simp, wp]: "no_fail \ (invalidateCacheRange_RAM s e p)" - apply (simp add: invalidateCacheRange_RAM_def lineStart_def cacheLineBits_def) - apply (wpsimp wp: no_fail_invalidateL2Range no_fail_invalidateByVA no_fail_dsb) - done + unfolding invalidateCacheRange_RAM_def + by (wpsimp wp: no_fail_invalidateL2Range no_fail_invalidateByVA no_fail_dsb) lemma no_fail_branchFlushRange[simp, wp]: "no_fail \ (branchFlushRange s e p)" @@ -593,7 +592,7 @@ lemma no_irq_when: lemma no_irq_invalidateCacheRange_RAM[simp, wp]: "no_irq (invalidateCacheRange_RAM s e p)" - apply (simp add: invalidateCacheRange_RAM_def lineStart_def cacheLineBits_def) + apply (simp add: invalidateCacheRange_RAM_def) apply (wp no_irq_invalidateL2Range no_irq_invalidateByVA no_irq_dsb no_irq_when) done @@ -711,12 +710,7 @@ lemma empty_fail_writeContextID: "empty_fail writeContextID" lemma empty_fail_cacheRangeOp [simp, intro!]: assumes ef: "\a b. empty_fail (oper a b)" shows "empty_fail (cacheRangeOp oper s e p)" - apply (simp add: cacheRangeOp_def mapM_x_mapM lineStart_def cacheLineBits_def cacheLine_def ef) - apply (rule empty_fail_bind) - apply (rule empty_fail_mapM) - apply (auto intro: ef) - done - + by (auto simp add: cacheRangeOp_def mapM_x_mapM intro: ef) lemma empty_fail_cleanCacheRange_PoU[simp, intro!]: "empty_fail (cleanCacheRange_PoU s e p)" @@ -741,7 +735,7 @@ lemma empty_fail_invalidateCacheRange_I[simp, intro!]: lemma empty_fail_invalidateCacheRange_RAM[simp, intro!]: "empty_fail (invalidateCacheRange_RAM s e p)" - by (fastforce simp: invalidateCacheRange_RAM_def lineStart_def cacheLineBits_def + by (fastforce simp: invalidateCacheRange_RAM_def empty_fail_invalidateL2Range empty_fail_invalidateByVA empty_fail_dsb) lemma empty_fail_branchFlushRange[simp, intro!]: @@ -772,14 +766,4 @@ lemmas msgRegisters_A_unfold end -context begin interpretation Arch . - -requalify_facts - det_getRegister - det_setRegister - det_getRestartPC - det_setNextPC - -end - end diff --git a/proof/invariant-abstract/ARM_HYP/ArchADT_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchADT_AI.thy index 9fe6b0491f..3130337668 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchADT_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchADT_AI.thy @@ -11,7 +11,7 @@ imports "Lib.Simulation" Invariants_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming lemma word_1FF_is_mask: "(0x1FF::'a::len word) = mask 9" diff --git a/proof/invariant-abstract/ARM_HYP/ArchAInvsPre.thy b/proof/invariant-abstract/ARM_HYP/ArchAInvsPre.thy index 102cd05218..6a2d67a303 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchAInvsPre.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchAInvsPre.thy @@ -8,9 +8,7 @@ theory ArchAInvsPre imports AInvsPre begin -context Arch begin - -global_naming ARM_HYP +context Arch begin arch_global_naming lemma get_pd_of_thread_reachable: "get_pd_of_thread (kheap s) (arch_state s) t \ 0 @@ -97,14 +95,13 @@ lemma device_frame_in_device_region: by (auto simp add: pspace_respects_device_region_def dom_def device_mem_def) -global_naming Arch -named_theorems AInvsPre_asms +named_theorems AInvsPre_assms lemma get_page_info_0[simp]: "get_page_info (\obj. get_arch_obj (kheap s obj)) 0 x = None" by (simp add: get_page_info_def) -lemma (* ptable_rights_imp_frame *)[AInvsPre_asms]: +lemma (* ptable_rights_imp_frame *)[AInvsPre_assms]: assumes "valid_state s" shows "ptable_rights t s x \ {} \ ptable_lift t s x = Some (addrFromPPtr y) \ @@ -138,12 +135,7 @@ end global_interpretation AInvsPre?: AInvsPre proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales, fact AInvsPre_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales, fact AInvsPre_assms)?) qed -requalify_facts - ARM_HYP.user_mem_dom_cong - ARM_HYP.device_mem_dom_cong - ARM_HYP.device_frame_in_device_region - ARM_HYP.is_aligned_pptrBaseOffset end diff --git a/proof/invariant-abstract/ARM_HYP/ArchAcc_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchAcc_AI.thy index 9ec4329e98..cb5d0fff4e 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchAcc_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchAcc_AI.thy @@ -14,7 +14,7 @@ imports "Lib.Crunch_Instances_NonDet" begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming bundle unfold_objects = diff --git a/proof/invariant-abstract/ARM_HYP/ArchArch_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchArch_AI.thy index 1a97ba31fe..8729252859 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchArch_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchArch_AI.thy @@ -9,7 +9,7 @@ theory ArchArch_AI imports Arch_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming definition "valid_aci aci \ case aci of MakePool frame slot parent base \ @@ -417,7 +417,7 @@ lemma valid_asid_map': end -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming lemma valid_arch_state_strg: "valid_arch_state s \ ap \ ran (arm_asid_table (arch_state s)) \ asid_pool_at ap s \ @@ -1416,7 +1416,7 @@ lemma find_pd_for_asid_ref_offset_voodoo: in hoare_strengthen_postE_R) apply (simp add: ucast_ucast_mask mask_asid_low_bits_ucast_ucast) - apply (fold asid_low_bits_def) + apply (fold asid_low_bits_def[simplified]) apply (rule hoare_pre, wp find_pd_for_asid_lookup_ref) apply (simp add: vspace_bits_defs) apply (simp add: pd_shifting[simplified vspace_bits_defs, simplified] vspace_bits_defs) @@ -1896,23 +1896,4 @@ lemma arch_pinv_st_tcb_at: end - -context begin interpretation Arch . - -requalify_consts - valid_arch_inv - -requalify_facts - invoke_arch_tcb - invoke_arch_invs - sts_valid_arch_inv - arch_decode_inv_wf - arch_pinv_st_tcb_at - -end - -declare invoke_arch_invs[wp] -declare arch_decode_inv_wf[wp] - - end diff --git a/proof/invariant-abstract/ARM_HYP/ArchBCorres2_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchBCorres2_AI.thy index 2fb35084e3..d834a0a937 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchBCorres2_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchBCorres2_AI.thy @@ -9,7 +9,7 @@ imports BCorres2_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming named_theorems BCorres2_AI_assms @@ -88,7 +88,7 @@ interpretation BCorres2_AI?: BCorres2_AI lemmas schedule_bcorres[wp] = schedule_bcorres1[OF BCorres2_AI_axioms] -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming crunch send_signal,arch_perform_invocation for (bcorres) bcorres[wp]: truncate_state diff --git a/proof/invariant-abstract/ARM_HYP/ArchBCorres_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchBCorres_AI.thy index 843a020702..93423b94f9 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchBCorres_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchBCorres_AI.thy @@ -9,7 +9,7 @@ imports BCorres_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming crunch arch_finalise_cap for (bcorres) bcorres[wp]: truncate_state @@ -21,8 +21,4 @@ crunch prepare_thread_delete end -requalify_facts ARM_HYP.arch_finalise_cap_bcorres ARM_HYP.prepare_thread_delete_bcorres - -declare arch_finalise_cap_bcorres[wp] prepare_thread_delete_bcorres[wp] - end diff --git a/proof/invariant-abstract/ARM_HYP/ArchBits_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchBits_AI.thy index 90c2ff8dd8..7d278ed853 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchBits_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchBits_AI.thy @@ -8,7 +8,7 @@ theory ArchBits_AI imports Invariants_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming lemma invs_unique_table_caps[elim!]: "invs s \ unique_table_caps (caps_of_state s)" diff --git a/proof/invariant-abstract/ARM_HYP/ArchCNodeInv_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchCNodeInv_AI.thy index b69456b525..feb647dab7 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchCNodeInv_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchCNodeInv_AI.thy @@ -8,7 +8,7 @@ theory ArchCNodeInv_AI imports CNodeInv_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming named_theorems CNodeInv_AI_assms @@ -553,7 +553,7 @@ global_interpretation CNodeInv_AI?: CNodeInv_AI termination rec_del by (rule rec_del_termination) -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming lemma post_cap_delete_pre_is_final_cap': "\rv s'' rva s''a s. @@ -815,7 +815,7 @@ global_interpretation CNodeInv_AI_2?: CNodeInv_AI_2 qed -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming lemma finalise_cap_rvk_prog [CNodeInv_AI_assms]: "\\s. revoke_progress_ord m (\x. map_option cap_to_rpo (caps_of_state s x))\ @@ -926,7 +926,7 @@ termination cap_revoke by (rule cap_revoke_termination) declare cap_revoke.simps[simp del] -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming crunch finalise_slot for typ_at[wp, CNodeInv_AI_assms]: "\s. P (typ_at T p s)" @@ -951,7 +951,7 @@ global_interpretation CNodeInv_AI_4?: CNodeInv_AI_4 qed -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming lemma cap_move_invs[wp, CNodeInv_AI_assms]: "\invs and valid_cap cap and cte_wp_at ((=) cap.NullCap) ptr' diff --git a/proof/invariant-abstract/ARM_HYP/ArchCSpaceInvPre_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchCSpaceInvPre_AI.thy index 16024bb9e6..08aacd04ea 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchCSpaceInvPre_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchCSpaceInvPre_AI.thy @@ -11,7 +11,7 @@ CSpace invariants theory ArchCSpaceInvPre_AI imports CSpaceInvPre_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming lemma aobj_ref_acap_rights_update[simp]: "aobj_ref (acap_rights_update f x) = aobj_ref x" @@ -293,7 +293,7 @@ lemma cap_master_arch_cap_rights [simp]: by (simp add: cap_master_arch_cap_def acap_rights_update_def split: arch_cap.splits) -lemma acap_rights_update_id [intro!, simp]: +lemma valid_acap_rights_update_id [intro!, simp]: "valid_arch_cap ac s \ acap_rights_update (acap_rights ac) ac = ac" unfolding acap_rights_update_def acap_rights_def valid_arch_cap_def by (cases ac; simp) diff --git a/proof/invariant-abstract/ARM_HYP/ArchCSpaceInv_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchCSpaceInv_AI.thy index fcd4c1f251..f59e602177 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchCSpaceInv_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchCSpaceInv_AI.thy @@ -12,7 +12,7 @@ theory ArchCSpaceInv_AI imports CSpaceInv_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming definition safe_ioport_insert :: "cap \ cap \ 'a::state_ext state \ bool" @@ -253,8 +253,4 @@ lemma safe_parent_cap_range_arch: end -context begin interpretation Arch . -requalify_facts replace_cap_invs -end - end diff --git a/proof/invariant-abstract/ARM_HYP/ArchCSpacePre_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchCSpacePre_AI.thy index ebf67e7ba6..6d8fba1bab 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchCSpacePre_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchCSpacePre_AI.thy @@ -12,7 +12,7 @@ theory ArchCSpacePre_AI imports CSpacePre_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming lemmas typ_at_eq_kheap_obj = typ_at_eq_kheap_obj atyp_at_eq_kheap_obj diff --git a/proof/invariant-abstract/ARM_HYP/ArchCSpace_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchCSpace_AI.thy index ea2daf2a0c..bd47005235 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchCSpace_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchCSpace_AI.thy @@ -12,7 +12,7 @@ theory ArchCSpace_AI imports CSpace_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming named_theorems CSpace_AI_assms @@ -341,7 +341,7 @@ end global_interpretation cap_insert_crunches?: cap_insert_crunches . -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming lemma cap_insert_cap_refs_in_kernel_window[wp, CSpace_AI_assms]: "\cap_refs_in_kernel_window @@ -535,7 +535,7 @@ global_interpretation CSpace_AI?: CSpace_AI qed -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming lemma is_cap_simps': "is_cnode_cap cap = (\r bits g. cap = cap.CNodeCap r bits g)" @@ -607,10 +607,6 @@ lemma arch_post_cap_deletion_invs: "\invs and (\s. arch_post_cap_delete_pre (ArchObjectCap c) (caps_of_state s))\ arch_post_cap_deletion c \\rv. invs\" by (wpsimp simp: arch_post_cap_delete_pre_def) -end - -(* is this the right way? we need this fact globally but it's proven with - ARM_HYP defns. *) lemma set_cap_valid_arch_caps_simple: "\\s. valid_arch_caps s \ valid_objs s @@ -647,3 +643,5 @@ lemma set_cap_kernel_window_simple: done end + +end diff --git a/proof/invariant-abstract/ARM_HYP/ArchCrunchSetup_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchCrunchSetup_AI.thy index a82d334bdc..8100aa3e79 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchCrunchSetup_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchCrunchSetup_AI.thy @@ -9,7 +9,7 @@ imports "ASpec.Syscall_A" "Lib.Crunch_Instances_NonDet" begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming crunch_ignore (add: debugPrint invalidateLocalTLB_ASID invalidateLocalTLB_VAASID cleanByVA diff --git a/proof/invariant-abstract/ARM_HYP/ArchDetSchedAux_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchDetSchedAux_AI.thy index f08ce94aca..8d954a1c33 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchDetSchedAux_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchDetSchedAux_AI.thy @@ -9,7 +9,7 @@ theory ArchDetSchedAux_AI imports DetSchedAux_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming named_theorems DetSchedAux_AI_assms diff --git a/proof/invariant-abstract/ARM_HYP/ArchDetSchedDomainTime_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchDetSchedDomainTime_AI.thy index 3dc7a909db..ff50654600 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchDetSchedDomainTime_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchDetSchedDomainTime_AI.thy @@ -8,7 +8,7 @@ theory ArchDetSchedDomainTime_AI imports DetSchedDomainTime_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming named_theorems DetSchedDomainTime_AI_assms @@ -63,7 +63,7 @@ global_interpretation DetSchedDomainTime_AI?: DetSchedDomainTime_AI case 1 show ?case by (unfold_locales; (fact DetSchedDomainTime_AI_assms)?) qed -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming crunch handle_hypervisor_fault for domain_list_inv[wp, DetSchedDomainTime_AI_assms]: "\s. P (domain_list s)" diff --git a/proof/invariant-abstract/ARM_HYP/ArchDetSchedSchedule_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchDetSchedSchedule_AI.thy index b6539cd1db..df1be37898 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchDetSchedSchedule_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchDetSchedSchedule_AI.thy @@ -8,7 +8,7 @@ theory ArchDetSchedSchedule_AI imports DetSchedSchedule_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming named_theorems DetSchedSchedule_AI_assms @@ -449,7 +449,7 @@ global_interpretation DetSchedSchedule_AI?: DetSchedSchedule_AI case 1 show ?case by (unfold_locales; (fact DetSchedSchedule_AI_assms)?) qed -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming lemma dmo_scheduler_act_sane[wp]: "\scheduler_act_sane\ do_machine_op f \\rv. scheduler_act_sane\" diff --git a/proof/invariant-abstract/ARM_HYP/ArchDeterministic_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchDeterministic_AI.thy index 0af4c604bb..66acf1b38e 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchDeterministic_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchDeterministic_AI.thy @@ -11,7 +11,7 @@ begin declare dxo_wp_weak[wp del] -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming named_theorems Deterministic_AI_assms @@ -40,7 +40,7 @@ global_interpretation Deterministic_AI_1?: Deterministic_AI_1 case 1 show ?case by (unfold_locales; (fact Deterministic_AI_assms)?) qed -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming declare arch_invoke_irq_handler_valid_list[Deterministic_AI_assms] diff --git a/proof/invariant-abstract/ARM_HYP/ArchDetype_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchDetype_AI.thy index ae44dac57a..b4394c41a3 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchDetype_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchDetype_AI.thy @@ -8,18 +8,18 @@ theory ArchDetype_AI imports Detype_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming -named_theorems Detype_AI_asms +named_theorems Detype_AI_assms -lemma valid_globals_irq_node[Detype_AI_asms]: +lemma valid_globals_irq_node[Detype_AI_assms]: "\ valid_global_refs s; cte_wp_at ((=) cap) ptr s \ \ interrupt_irq_node s irq \ cap_range cap" apply (erule(1) valid_global_refsD) apply (simp add: global_refs_def) done -lemma caps_of_state_ko[Detype_AI_asms]: +lemma caps_of_state_ko[Detype_AI_assms]: "valid_cap cap s \ is_untyped_cap cap \ cap_range cap = {} \ @@ -38,7 +38,7 @@ lemma caps_of_state_ko[Detype_AI_asms]: is_cap_simps )+ done -lemma mapM_x_storeWord[Detype_AI_asms]: +lemma mapM_x_storeWord[Detype_AI_assms]: (* FIXME: taken from Retype_C.thy and adapted wrt. the missing intvl syntax. *) assumes al: "is_aligned ptr word_size_bits" shows "mapM_x (\x. storeWord (ptr + of_nat x * word_size) 0) [0..x. if x \ S then {} else state_hyp_refs_of s x)" by (rule ext, simp add: state_hyp_refs_of_def detype_def) -lemma valid_ioports_detype[Detype_AI_asms]: +lemma valid_ioports_detype[Detype_AI_assms]: "valid_ioports s \ valid_ioports (detype (untyped_range cap) s)" by auto @@ -128,7 +128,7 @@ interpretation Detype_AI?: Detype_AI proof goal_cases interpret Arch . case 1 show ?case - by (intro_locales; (unfold_locales; fact Detype_AI_asms)?) + by (intro_locales; (unfold_locales; fact Detype_AI_assms)?) qed context detype_locale_arch begin @@ -636,8 +636,8 @@ interpretation Detype_AI_2 Detype_AI_2.intro by blast -context begin interpretation Arch . -lemma delete_objects_invs[wp]: +(* generic consequence of architecture-specific details *) +lemma (in Arch) delete_objects_invs[wp]: "\(\s. \slot. cte_wp_at ((=) (cap.UntypedCap dev ptr bits f)) slot s \ descendants_range (cap.UntypedCap dev ptr bits f) slot s) and invs and ct_active\ @@ -657,6 +657,8 @@ lemma delete_objects_invs[wp]: apply (drule (1) cte_wp_valid_cap) apply (simp add: valid_cap_def cap_aligned_def word_size_bits_def untyped_min_bits_def) done -end + +requalify_facts Arch.delete_objects_invs +lemmas [wp] = delete_objects_invs end diff --git a/proof/invariant-abstract/ARM_HYP/ArchEmptyFail_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchEmptyFail_AI.thy index ab6ad53b61..ef17b2da07 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchEmptyFail_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchEmptyFail_AI.thy @@ -8,7 +8,7 @@ theory ArchEmptyFail_AI imports EmptyFail_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming named_theorems EmptyFail_AI_assms @@ -33,7 +33,7 @@ global_interpretation EmptyFail_AI_load_word?: EmptyFail_AI_load_word case 1 show ?case by (unfold_locales; (fact EmptyFail_AI_assms)?) qed -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming crunch handle_fault for (empty_fail) empty_fail[wp, EmptyFail_AI_assms] @@ -123,7 +123,7 @@ global_interpretation EmptyFail_AI_derive_cap?: EmptyFail_AI_derive_cap case 1 show ?case by (unfold_locales; (fact EmptyFail_AI_assms)?) qed -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming crunch vcpu_update, vcpu_save_reg_range, vgic_update_lr, save_virt_timer for (empty_fail) empty_fail[wp] @@ -158,7 +158,7 @@ global_interpretation EmptyFail_AI_rec_del?: EmptyFail_AI_rec_del case 1 show ?case by (unfold_locales; (fact EmptyFail_AI_assms)?) qed -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming crunch cap_delete, choose_thread for (empty_fail) empty_fail[wp, EmptyFail_AI_assms] @@ -182,7 +182,7 @@ global_interpretation EmptyFail_AI_schedule?: EmptyFail_AI_schedule case 1 show ?case by (unfold_locales; (fact EmptyFail_AI_assms)?) qed -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming lemma vgic_maintenance_empty_fail[wp]: "empty_fail vgic_maintenance" by (wpsimp simp: get_gic_vcpu_ctrl_eisr0_def diff --git a/proof/invariant-abstract/ARM_HYP/ArchFinalise_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchFinalise_AI.thy index 319a668193..e384b6debc 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchFinalise_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchFinalise_AI.thy @@ -11,15 +11,15 @@ begin context Arch begin -named_theorems Finalise_AI_asms +named_theorems Finalise_AI_assms crunch prepare_thread_delete for caps_of_state[wp]: "\s. P (caps_of_state s)" (wp: crunch_wps) -declare prepare_thread_delete_caps_of_state [Finalise_AI_asms] +declare prepare_thread_delete_caps_of_state [Finalise_AI_assms] -global_naming ARM_HYP +arch_global_naming lemma valid_global_refs_asid_table_udapte [iff]: "valid_global_refs (s\arch_state := arm_asid_table_update f (arch_state s)\) = @@ -240,24 +240,22 @@ lemma unmap_page_tcb_cap_valid: done -global_naming Arch - -lemma (* replaceable_cdt_update *)[simp,Finalise_AI_asms]: +lemma (* replaceable_cdt_update *)[simp,Finalise_AI_assms]: "replaceable (cdt_update f s) = replaceable s" by (fastforce simp: replaceable_def tcb_cap_valid_def) -lemma (* replaceable_revokable_update *)[simp,Finalise_AI_asms]: +lemma (* replaceable_revokable_update *)[simp,Finalise_AI_assms]: "replaceable (is_original_cap_update f s) = replaceable s" by (fastforce simp: replaceable_def is_final_cap'_def2 tcb_cap_valid_def) -lemma (* replaceable_more_update *) [simp,Finalise_AI_asms]: +lemma (* replaceable_more_update *) [simp,Finalise_AI_assms]: "replaceable (trans_state f s) sl cap cap' = replaceable s sl cap cap'" by (simp add: replaceable_def) -lemma (* obj_ref_ofI *) [Finalise_AI_asms]: "obj_refs cap = {x} \ obj_ref_of cap = x" +lemma (* obj_ref_ofI *) [Finalise_AI_assms]: "obj_refs cap = {x} \ obj_ref_of cap = x" by (case_tac cap, simp_all) (rename_tac arch_cap, case_tac arch_cap, simp_all) -lemma (* empty_slot_invs *) [Finalise_AI_asms]: +lemma (* empty_slot_invs *) [Finalise_AI_assms]: "\\s. invs s \ cte_wp_at (replaceable s sl cap.NullCap) sl s \ emptyable sl s \ (info \ NullCap \ post_cap_delete_pre info ((caps_of_state s) (sl \ NullCap)))\ @@ -333,7 +331,7 @@ lemma (* empty_slot_invs *) [Finalise_AI_asms]: apply (simp add: is_final_cap'_def2 cte_wp_at_caps_of_state) done -lemma dom_tcb_cap_cases_lt_ARCH [Finalise_AI_asms]: +lemma dom_tcb_cap_cases_lt_ARCH [Finalise_AI_assms]: "dom tcb_cap_cases = {xs. length xs = 3 \ unat (of_bl xs :: machine_word) < 5}" apply (rule set_eqI, rule iffI) apply clarsimp @@ -343,7 +341,7 @@ lemma dom_tcb_cap_cases_lt_ARCH [Finalise_AI_asms]: apply (clarsimp simp: nat_to_cref_unat_of_bl') done -lemma (* unbind_notification_final *) [wp,Finalise_AI_asms]: +lemma (* unbind_notification_final *) [wp,Finalise_AI_assms]: "\is_final_cap' cap\ unbind_notification t \ \rv. is_final_cap' cap\" unfolding unbind_notification_def apply (wp final_cap_lift thread_set_caps_of_state_trivial hoare_drop_imps @@ -371,7 +369,7 @@ lemma prepare_thread_delete_final[wp]: | wpc | clarsimp simp add: tcb_cap_cases_def)+ done -lemma (* finalise_cap_cases1 *)[Finalise_AI_asms]: +lemma (* finalise_cap_cases1 *)[Finalise_AI_assms]: "\\s. final \ is_final_cap' cap s \ cte_wp_at ((=) cap) slot s\ finalise_cap cap final @@ -411,12 +409,12 @@ crunch dissociate_vcpu_tcb ignore: do_machine_op set_object) (* ARMHYP fix *) crunch arch_finalise_cap - for typ_at[wp,Finalise_AI_asms]: "\s. P (typ_at T p s)" + for typ_at[wp,Finalise_AI_assms]: "\s. P (typ_at T p s)" (wp: crunch_wps simp: crunch_simps unless_def assertE_def ignore: maskInterrupt set_object) (* ARMHYP fix *) crunch prepare_thread_delete - for typ_at[wp,Finalise_AI_asms]: "\s. P (typ_at T p s)" + for typ_at[wp,Finalise_AI_assms]: "\s. P (typ_at T p s)" crunch arch_thread_set for tcb_at[wp]: "\s. tcb_at p s" @@ -437,7 +435,7 @@ crunch dissociate_vcpu_tcb crunch prepare_thread_delete for tcb_at[wp]: "\s. tcb_at p s" -lemma (* finalise_cap_new_valid_cap *)[wp,Finalise_AI_asms]: +lemma (* finalise_cap_new_valid_cap *)[wp,Finalise_AI_assms]: "\valid_cap cap\ finalise_cap cap x \\rv. valid_cap (fst rv)\" apply (cases cap, simp_all) apply (wp suspend_valid_cap prepare_thread_delete_typ_at @@ -1076,7 +1074,7 @@ crunch vcpu_finalise for invs[wp]: invs (ignore: dissociate_vcpu_tcb) -lemma arch_finalise_cap_invs' [wp,Finalise_AI_asms]: +lemma arch_finalise_cap_invs' [wp,Finalise_AI_assms]: "\invs and valid_cap (ArchObjectCap cap)\ arch_finalise_cap cap final \\rv. invs\" @@ -1139,14 +1137,14 @@ lemma arch_finalise_cap_vcpu: done -lemma obj_at_not_live_valid_arch_cap_strg [Finalise_AI_asms]: +lemma obj_at_not_live_valid_arch_cap_strg [Finalise_AI_assms]: "(s \ ArchObjectCap cap \ aobj_ref cap = Some r \ \ typ_at (AArch AVCPU) r s) \ obj_at (\ko. \ live ko) r s" by (clarsimp simp: live_def valid_cap_def obj_at_def a_type_arch_live valid_cap_simps hyp_live_def arch_live_def split: arch_cap.split_asm if_splits) -lemma obj_at_not_live_valid_arch_cap_strg' [Finalise_AI_asms]: +lemma obj_at_not_live_valid_arch_cap_strg' [Finalise_AI_assms]: "(s \ ArchObjectCap cap \ aobj_ref cap = Some r \ cap \ VCPUCap r) \ obj_at (\ko. \ live ko) r s" by (clarsimp simp: live_def valid_cap_def obj_at_def @@ -1196,8 +1194,7 @@ lemma arch_finalise_cap_replaceable1: split: cap.splits arch_cap.splits vmpage_size.splits) -global_naming Arch -lemma (* deleting_irq_handler_slot_not_irq_node *)[Finalise_AI_asms]: +lemma (* deleting_irq_handler_slot_not_irq_node *)[Finalise_AI_assms]: "\if_unsafe_then_cap and valid_global_refs and cte_wp_at (\cp. cap_irqs cp \ {}) sl\ deleting_irq_handler irq @@ -1218,7 +1215,7 @@ lemma (* deleting_irq_handler_slot_not_irq_node *)[Finalise_AI_asms]: apply (clarsimp simp: appropriate_cte_cap_def split: cap.split_asm) done -lemma no_cap_to_obj_with_diff_ref_finalI_ARCH[Finalise_AI_asms]: +lemma no_cap_to_obj_with_diff_ref_finalI_ARCH[Finalise_AI_assms]: "\ cte_wp_at ((=) cap) p s; is_final_cap' cap s; obj_refs cap' = obj_refs cap \ \ no_cap_to_obj_with_diff_ref cap' {p} s" @@ -1240,7 +1237,7 @@ lemma no_cap_to_obj_with_diff_ref_finalI_ARCH[Finalise_AI_asms]: gen_obj_refs_Int) done -lemma (* suspend_no_cap_to_obj_ref *)[wp,Finalise_AI_asms]: +lemma (* suspend_no_cap_to_obj_ref *)[wp,Finalise_AI_assms]: "\no_cap_to_obj_with_diff_ref cap S\ suspend t \\rv. no_cap_to_obj_with_diff_ref cap S\" @@ -1293,7 +1290,7 @@ lemma arch_finalise_cap_replaceable: \\rv s. replaceable s sl (fst rv) (cap.ArchObjectCap cap)\" by (cases cap; simp add: arch_finalise_cap_vcpu arch_finalise_cap_replaceable1) -lemma finalise_cap_replaceable [Finalise_AI_asms]: +lemma finalise_cap_replaceable [Finalise_AI_assms]: "\\s. s \ cap \ x = is_final_cap' cap s \ valid_mdb s \ cte_wp_at ((=) cap) sl s \ valid_objs s \ sym_refs (state_refs_of s) \ (cap_irqs cap \ {} \ if_unsafe_then_cap s \ valid_global_refs s) @@ -1346,7 +1343,7 @@ lemma finalise_cap_replaceable [Finalise_AI_asms]: | simp add: valid_cap_simps is_nondevice_page_cap_simps)+) done -lemma (* deleting_irq_handler_cte_preserved *)[Finalise_AI_asms]: +lemma (* deleting_irq_handler_cte_preserved *)[Finalise_AI_assms]: assumes x: "\cap. P cap \ \ can_fast_finalise cap" shows "\cte_wp_at P p\ deleting_irq_handler irq \\rv. cte_wp_at P p\" apply (simp add: deleting_irq_handler_def) @@ -1365,25 +1362,25 @@ lemma arch_thread_set_cte_wp_at[wp]: done crunch dissociate_vcpu_tcb - for cte_wp_at[wp,Finalise_AI_asms]: "\s. P (cte_wp_at P' p s)" + for cte_wp_at[wp,Finalise_AI_assms]: "\s. P (cte_wp_at P' p s)" (simp: crunch_simps assertE_def wp: crunch_wps set_object_cte_at ignore: arch_thread_set) crunch prepare_thread_delete - for cte_wp_at[wp,Finalise_AI_asms]: "\s. P (cte_wp_at P' p s)" + for cte_wp_at[wp,Finalise_AI_assms]: "\s. P (cte_wp_at P' p s)" (simp: crunch_simps assertE_def wp: crunch_wps set_object_cte_at ignore: arch_thread_set) crunch arch_finalise_cap - for cte_wp_at[wp,Finalise_AI_asms]: "\s. P (cte_wp_at P' p s)" + for cte_wp_at[wp,Finalise_AI_assms]: "\s. P (cte_wp_at P' p s)" (simp: crunch_simps assertE_def wp: crunch_wps set_object_cte_at ignore: arch_thread_set) end interpretation Finalise_AI_1?: Finalise_AI_1 proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming lemma fast_finalise_replaceable[wp]: "\\s. s \ cap \ x = is_final_cap' cap s @@ -1404,8 +1401,7 @@ lemma fast_finalise_replaceable[wp]: apply (clarsimp simp: cap_irqs_def cap_irq_opt_def split: cap.split_asm) done -global_naming Arch -lemma (* cap_delete_one_invs *) [Finalise_AI_asms,wp]: +lemma (* cap_delete_one_invs *) [Finalise_AI_assms,wp]: "\invs and emptyable ptr\ cap_delete_one ptr \\rv. invs\" apply (simp add: cap_delete_one_def unless_def is_final_cap_def) apply (rule hoare_pre) @@ -1419,10 +1415,10 @@ end interpretation Finalise_AI_2?: Finalise_AI_2 proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming crunch vcpu_update, vgic_update, vcpu_disable, vcpu_restore, vcpu_save_reg_range, vgic_update_lr, @@ -1431,7 +1427,7 @@ crunch (wp: crunch_wps subset_refl) crunch prepare_thread_delete - for irq_node[Finalise_AI_asms,wp]: "\s. P (interrupt_irq_node s)" + for irq_node[Finalise_AI_assms,wp]: "\s. P (interrupt_irq_node s)" (wp: crunch_wps simp: crunch_simps) crunch arch_finalise_cap @@ -1900,7 +1896,7 @@ lemma invs_valid_arch_capsI: "invs s \ valid_arch_caps s" by (simp add: invs_def valid_state_def) -context Arch begin global_naming ARM_HYP (*FIXME: arch_split*) +context Arch begin arch_global_naming lemma arch_finalise_case_no_lookup: "\pspace_aligned and valid_vspace_objs and valid_objs and @@ -1994,13 +1990,11 @@ lemma mapM_x_swp_store_invalid_pde_invs: where pde=InvalidPDE, simplified]) done -global_naming Arch - crunch prepare_thread_delete for invs[wp]: invs (ignore: set_object) -lemma (* finalise_cap_invs *)[Finalise_AI_asms]: +lemma (* finalise_cap_invs *)[Finalise_AI_assms]: shows "\invs and cte_wp_at ((=) cap) slot\ finalise_cap cap x \\rv. invs\" apply (cases cap, simp_all split del: if_split) apply (wp cancel_all_ipc_invs cancel_all_signals_invs unbind_notification_invs @@ -2017,20 +2011,20 @@ lemma (* finalise_cap_invs *)[Finalise_AI_asms]: apply (auto dest: cte_wp_at_valid_objs_valid_cap) done -lemma (* finalise_cap_irq_node *)[Finalise_AI_asms]: +lemma (* finalise_cap_irq_node *)[Finalise_AI_assms]: "\\s. P (interrupt_irq_node s)\ finalise_cap a b \\_ s. P (interrupt_irq_node s)\" apply (case_tac a,simp_all) apply (wp | clarsimp)+ done -lemmas (*arch_finalise_cte_irq_node *) [wp,Finalise_AI_asms] +lemmas (*arch_finalise_cte_irq_node *) [wp,Finalise_AI_assms] = hoare_use_eq_irq_node [OF arch_finalise_cap_irq_node arch_finalise_cap_cte_wp_at] -lemma irq_node_global_refs_ARCH [Finalise_AI_asms]: +lemma irq_node_global_refs_ARCH [Finalise_AI_assms]: "interrupt_irq_node s irq \ global_refs s" by (simp add: global_refs_def) -lemma (* get_irq_slot_fast_finalisable *)[wp,Finalise_AI_asms]: +lemma (* get_irq_slot_fast_finalisable *)[wp,Finalise_AI_assms]: "\invs\ get_irq_slot irq \cte_wp_at can_fast_finalise\" apply (simp add: get_irq_slot_def) apply wp @@ -2052,12 +2046,12 @@ lemma (* get_irq_slot_fast_finalisable *)[wp,Finalise_AI_asms]: apply (clarsimp simp: cap_range_def) done -lemma (* replaceable_or_arch_update_same *) [Finalise_AI_asms]: +lemma (* replaceable_or_arch_update_same *) [Finalise_AI_assms]: "replaceable_or_arch_update s slot cap cap" by (clarsimp simp: replaceable_or_arch_update_def replaceable_def is_arch_update_def is_cap_simps) -lemma (* replace_cap_invs_arch_update *)[Finalise_AI_asms]: +lemma (* replace_cap_invs_arch_update *)[Finalise_AI_assms]: "\\s. cte_wp_at (replaceable_or_arch_update s p cap) p s \ invs s \ cap \ cap.NullCap @@ -2075,7 +2069,7 @@ lemma (* replace_cap_invs_arch_update *)[Finalise_AI_asms]: apply simp done -lemma dmo_tcb_cap_valid_ARCH [Finalise_AI_asms]: +lemma dmo_tcb_cap_valid_ARCH [Finalise_AI_assms]: "\\s. P (tcb_cap_valid cap ptr s)\ do_machine_op mop \\_ s. P (tcb_cap_valid cap ptr s)\" apply (simp add: tcb_cap_valid_def no_cap_to_obj_with_diff_ref_def) apply (rule hoare_pre) @@ -2084,7 +2078,7 @@ lemma dmo_tcb_cap_valid_ARCH [Finalise_AI_asms]: apply simp done -lemma (* dmo_replaceable_or_arch_update *) [Finalise_AI_asms,wp]: +lemma (* dmo_replaceable_or_arch_update *) [Finalise_AI_assms,wp]: "\\s. replaceable_or_arch_update s slot cap cap'\ do_machine_op mo \\r s. replaceable_or_arch_update s slot cap cap'\" @@ -2098,18 +2092,16 @@ lemma (* dmo_replaceable_or_arch_update *) [Finalise_AI_asms,wp]: end -context begin interpretation Arch . -requalify_consts replaceable_or_arch_update -end +arch_requalify_consts replaceable_or_arch_update interpretation Finalise_AI_3?: Finalise_AI_3 where replaceable_or_arch_update = replaceable_or_arch_update proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming lemma typ_at_data_at_wp: assumes typ_wp: "\a.\typ_at a p \ g \\s. typ_at a p\" @@ -2124,10 +2116,10 @@ interpretation Finalise_AI_4?: Finalise_AI_4 where replaceable_or_arch_update = replaceable_or_arch_update proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming lemma set_asid_pool_obj_at_ptr: "\\s. P (ArchObj (arch_kernel_obj.ASIDPool mp))\ @@ -2416,12 +2408,10 @@ lemma arch_finalise_cap_valid_cap [wp]: apply (wp | wpc | clarsimp simp: split: arch_cap.split option.split bool.split | safe)+ done -global_naming Arch - -lemmas clearMemory_invs [wp,Finalise_AI_asms] +lemmas clearMemory_invs [wp,Finalise_AI_assms] = clearMemory_invs -lemma valid_idle_has_null_cap_ARCH[Finalise_AI_asms]: +lemma valid_idle_has_null_cap_ARCH[Finalise_AI_assms]: "\ if_unsafe_then_cap s; valid_global_refs s; valid_idle s; valid_irq_node s\ \ caps_of_state s (idle_thread s, v) = Some cap \ cap = NullCap" @@ -2437,7 +2427,7 @@ lemma valid_idle_has_null_cap_ARCH[Finalise_AI_asms]: apply (drule_tac x=word in spec, simp) done -lemma (* zombie_cap_two_nonidles *)[Finalise_AI_asms]: +lemma (* zombie_cap_two_nonidles *)[Finalise_AI_assms]: "\ caps_of_state s ptr = Some (Zombie ptr' zbits n); invs s \ \ fst ptr \ idle_thread s \ ptr' \ idle_thread s" apply (frule valid_global_refsD2, clarsimp+) @@ -2463,7 +2453,7 @@ interpretation Finalise_AI_5?: Finalise_AI_5 where replaceable_or_arch_update = replaceable_or_arch_update proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed end diff --git a/proof/invariant-abstract/ARM_HYP/ArchInterruptAcc_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchInterruptAcc_AI.thy index 9581a0b65c..a43c92d343 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchInterruptAcc_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchInterruptAcc_AI.thy @@ -12,7 +12,7 @@ theory ArchInterruptAcc_AI imports InterruptAcc_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming named_theorems InterruptAcc_AI_assms diff --git a/proof/invariant-abstract/ARM_HYP/ArchInterrupt_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchInterrupt_AI.thy index 21d7e6a557..da61f6091b 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchInterrupt_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchInterrupt_AI.thy @@ -8,7 +8,7 @@ theory ArchInterrupt_AI imports Interrupt_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming primrec arch_irq_control_inv_valid_real :: "arch_irq_control_invocation \ 'a::state_ext state \ bool" @@ -23,16 +23,16 @@ primrec arch_irq_control_inv_valid_real :: defs arch_irq_control_inv_valid_def: "arch_irq_control_inv_valid \ arch_irq_control_inv_valid_real" -named_theorems Interrupt_AI_asms +named_theorems Interrupt_AI_assms -lemma (* decode_irq_control_invocation_inv *)[Interrupt_AI_asms]: +lemma (* decode_irq_control_invocation_inv *)[Interrupt_AI_assms]: "\P\ decode_irq_control_invocation label args slot caps \\rv. P\" apply (simp add: decode_irq_control_invocation_def Let_def arch_check_irq_def arch_decode_irq_control_invocation_def whenE_def, safe) apply (wp | simp)+ done -lemma decode_irq_control_valid [Interrupt_AI_asms]: +lemma decode_irq_control_valid [Interrupt_AI_assms]: "\\s. invs s \ (\cap \ set caps. s \ cap) \ (\cap \ set caps. is_cnode_cap cap \ (\r \ cte_refs cap (interrupt_irq_node s). ex_cte_cap_wp_to is_cnode_cap r s)) @@ -49,7 +49,7 @@ lemma decode_irq_control_valid [Interrupt_AI_asms]: apply (cases caps ; fastforce simp: cte_wp_at_eq_simp) done -lemma get_irq_slot_different_ARCH[Interrupt_AI_asms]: +lemma get_irq_slot_different_ARCH[Interrupt_AI_assms]: "\\s. valid_global_refs s \ ex_cte_cap_wp_to is_cnode_cap ptr s\ get_irq_slot irq \\rv s. rv \ ptr\" @@ -61,7 +61,7 @@ lemma get_irq_slot_different_ARCH[Interrupt_AI_asms]: apply (clarsimp simp: global_refs_def is_cap_simps cap_range_def) done -lemma is_derived_use_interrupt_ARCH[Interrupt_AI_asms]: +lemma is_derived_use_interrupt_ARCH[Interrupt_AI_assms]: "(is_ntfn_cap cap \ interrupt_derived cap cap') \ (is_derived m p cap cap')" apply (clarsimp simp: is_cap_simps) apply (clarsimp simp: interrupt_derived_def is_derived_def) @@ -69,15 +69,15 @@ lemma is_derived_use_interrupt_ARCH[Interrupt_AI_asms]: apply (simp add: is_cap_simps is_pt_cap_def vs_cap_ref_def) done -lemmas maskInterrupt_invs_ARCH[Interrupt_AI_asms] = maskInterrupt_invs +lemmas maskInterrupt_invs_ARCH[Interrupt_AI_assms] = maskInterrupt_invs -lemma no_cap_to_obj_with_diff_IRQHandler_ARCH[Interrupt_AI_asms]: +lemma no_cap_to_obj_with_diff_IRQHandler_ARCH[Interrupt_AI_assms]: "no_cap_to_obj_with_diff_ref (IRQHandlerCap irq) S = \" by (rule ext, simp add: no_cap_to_obj_with_diff_ref_def cte_wp_at_caps_of_state obj_ref_none_no_asid) -lemma (* set_irq_state_valid_cap *)[Interrupt_AI_asms]: +lemma (* set_irq_state_valid_cap *)[Interrupt_AI_assms]: "\valid_cap cap\ set_irq_state IRQSignal irq \\rv. valid_cap cap\" apply (clarsimp simp: set_irq_state_def) apply (wp do_machine_op_valid_cap) @@ -87,13 +87,13 @@ lemma (* set_irq_state_valid_cap *)[Interrupt_AI_asms]: done crunch set_irq_state - for valid_global_refs[Interrupt_AI_asms]: "valid_global_refs" + for valid_global_refs[Interrupt_AI_assms]: "valid_global_refs" crunch arch_invoke_irq_handler for typ_at[wp]: "\s. P (typ_at T p s)" and valid_list[wp]: valid_list -lemma invoke_irq_handler_invs'[Interrupt_AI_asms]: +lemma invoke_irq_handler_invs'[Interrupt_AI_assms]: assumes dmo_ex_inv[wp]: "\f. \invs and ex_inv\ do_machine_op f \\rv::unit. ex_inv\" assumes cap_insert_ex_inv[wp]: "\cap src dest. \ex_inv and invs and K (src \ dest)\ @@ -149,7 +149,7 @@ lemma invoke_irq_handler_invs'[Interrupt_AI_asms]: done qed -lemma (* invoke_irq_control_invs *) [Interrupt_AI_asms]: +lemma (* invoke_irq_control_invs *) [Interrupt_AI_assms]: "\invs and irq_control_inv_valid i\ invoke_irq_control i \\rv. invs\" apply (cases i, simp_all) apply (wp cap_insert_simple_invs @@ -174,7 +174,7 @@ lemma (* invoke_irq_control_invs *) [Interrupt_AI_asms]: crunch resetTimer for device_state_inv[wp]: "\ms. P (device_state ms)" -lemma resetTimer_invs_ARCH[Interrupt_AI_asms]: +lemma resetTimer_invs_ARCH[Interrupt_AI_assms]: "\invs\ do_machine_op resetTimer \\_. invs\" apply (wp dmo_invs) apply safe @@ -187,11 +187,11 @@ lemma resetTimer_invs_ARCH[Interrupt_AI_asms]: apply(erule use_valid, wp no_irq_resetTimer no_irq, assumption) done -lemma empty_fail_ackInterrupt_ARCH[Interrupt_AI_asms]: +lemma empty_fail_ackInterrupt_ARCH[Interrupt_AI_assms]: "empty_fail (ackInterrupt irq)" by (wp | simp add: ackInterrupt_def)+ -lemma empty_fail_maskInterrupt_ARCH[Interrupt_AI_asms]: +lemma empty_fail_maskInterrupt_ARCH[Interrupt_AI_assms]: "empty_fail (maskInterrupt f irq)" by (wp | simp add: maskInterrupt_def)+ @@ -254,7 +254,7 @@ lemma handle_reserved_irq_invs[wp]: "\invs\ handle_reserved_irq irq \\_. invs\" unfolding handle_reserved_irq_def by (wpsimp simp: non_kernel_IRQs_def) -lemma (* handle_interrupt_invs *) [Interrupt_AI_asms]: +lemma (* handle_interrupt_invs *) [Interrupt_AI_assms]: "\invs\ handle_interrupt irq \\_. invs\" apply (simp add: handle_interrupt_def) apply (rule conjI; rule impI) @@ -271,7 +271,7 @@ lemma (* handle_interrupt_invs *) [Interrupt_AI_asms]: | rule conjI)+ done -lemma sts_arch_irq_control_inv_valid[wp, Interrupt_AI_asms]: +lemma sts_arch_irq_control_inv_valid[wp, Interrupt_AI_assms]: "\arch_irq_control_inv_valid i\ set_thread_state t st \\rv. arch_irq_control_inv_valid i\" @@ -286,7 +286,7 @@ end interpretation Interrupt_AI?: Interrupt_AI proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales, simp_all add: Interrupt_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales, simp_all add: Interrupt_AI_assms)?) qed end diff --git a/proof/invariant-abstract/ARM_HYP/ArchInvariants_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchInvariants_AI.thy index c8b7c5586a..e44be22bd9 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchInvariants_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchInvariants_AI.thy @@ -24,12 +24,12 @@ end_qualify \ \---------------------------------------------------------------------------\ section "ARM-specific invariant definitions" -qualify ARM_HYP_A (in Arch) +qualify ARM_HYP (in Arch) record iarch_tcb = itcb_vcpu :: "obj_ref option" end_qualify -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming definition arch_tcb_to_iarch_tcb :: "arch_tcb \ iarch_tcb" @@ -474,16 +474,15 @@ where end -context begin interpretation Arch . -requalify_consts vs_lookup -end +(* needed for abbreviation *) +arch_requalify_consts vs_lookup abbreviation vs_lookup_abbr ("_ \ _" [80,80] 81) where "rs \ p \ \s. (rs,p) \ vs_lookup s" -context Arch begin global_naming ARM +context Arch begin arch_global_naming abbreviation is_reachable_abbr :: "obj_ref \ 'z::state_ext state \ bool" ("\\ _" [80] 81) where @@ -560,9 +559,8 @@ where end -context begin interpretation Arch . -requalify_consts vs_lookup_pages -end +(* needed for abbreviation *) +arch_requalify_consts vs_lookup_pages abbreviation vs_lookup_pages_abbr @@ -574,7 +572,7 @@ abbreviation "\\ p \ \s. \ref. (ref \ p) s" -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming definition pde_mapping_bits :: "nat" @@ -733,7 +731,7 @@ definition arch_live :: "arch_kernel_obj \ bool" where "arch_live ao \ case ao of - ARM_A.VCPU v \ bound (ARM_A.vcpu_tcb v) + ARM_HYP_A.VCPU v \ bound (ARM_HYP_A.vcpu_tcb v) | _ \ False" definition @@ -1340,7 +1338,7 @@ lemma valid_vspace_objs_update' [iff]: end -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming lemma global_refs_equiv: assumes "idle_thread s = idle_thread s'" @@ -2162,7 +2160,7 @@ lemma valid_vspace_objs_lift: apply (rule valid_vspace_obj_typ [OF z], auto) done -lemma acap_rights_update_id [intro!, simp]: +lemma wf_acap_rights_update_id [intro!, simp]: "\wellformed_acap cap\ \ acap_rights_update (acap_rights cap) cap = cap" unfolding wellformed_acap_def acap_rights_update_def by (auto split: arch_cap.splits) @@ -2626,24 +2624,6 @@ lemma is_aligned_ptrFromPAddrD[simplified pageBitsForSize_simps]: by (simp add: ptrFromPAddr_def) (erule is_aligned_addD2, erule is_aligned_weaken[OF pptrBaseOffset_aligned]) -lemma addrFromPPtr_mask[simplified ARM_HYP.pageBitsForSize_simps]: - "n \ pageBitsForSize ARMSuperSection - \ addrFromPPtr ptr && mask n = ptr && mask n" - apply (simp add: addrFromPPtr_def) - apply (prop_tac "pptrBaseOffset AND mask n = 0") - apply (rule mask_zero[OF is_aligned_weaken[OF pptrBaseOffset_aligned]], simp) - apply (simp flip: mask_eqs(8)) - done - -lemma ptrFromPAddr_mask[simplified ARM_HYP.pageBitsForSize_simps]: - "n \ pageBitsForSize ARMSuperSection - \ ptrFromPAddr ptr && mask n = ptr && mask n" - apply (simp add: ptrFromPAddr_def) - apply (prop_tac "pptrBaseOffset AND mask n = 0") - apply (rule mask_zero[OF is_aligned_weaken[OF pptrBaseOffset_aligned]], simp) - apply (simp flip: mask_eqs(7)) - done - end declare ARM_HYP.arch_tcb_context_absorbs[simp] diff --git a/proof/invariant-abstract/ARM_HYP/ArchIpcCancel_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchIpcCancel_AI.thy index 658ec7663e..1a33884511 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchIpcCancel_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchIpcCancel_AI.thy @@ -8,13 +8,13 @@ theory ArchIpcCancel_AI imports IpcCancel_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming -named_theorems IpcCancel_AI_asms +named_theorems IpcCancel_AI_assms crunch arch_post_cap_deletion - for typ_at[wp, IpcCancel_AI_asms]: "\s. P (typ_at T p s)" - and idle_thread[wp, IpcCancel_AI_asms]: "\s. P (idle_thread s)" + for typ_at[wp, IpcCancel_AI_assms]: "\s. P (typ_at T p s)" + and idle_thread[wp, IpcCancel_AI_assms]: "\s. P (idle_thread s)" end @@ -22,7 +22,7 @@ interpretation IpcCancel_AI?: IpcCancel_AI proof goal_cases interpret Arch . case 1 show ?case - by (intro_locales; (unfold_locales; fact IpcCancel_AI_asms)?) + by (intro_locales; (unfold_locales; fact IpcCancel_AI_assms)?) qed diff --git a/proof/invariant-abstract/ARM_HYP/ArchIpc_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchIpc_AI.thy index 3a452518ea..9030165d3a 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchIpc_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchIpc_AI.thy @@ -8,7 +8,7 @@ theory ArchIpc_AI imports Ipc_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming named_theorems Ipc_AI_assms @@ -511,7 +511,7 @@ proof goal_cases case 1 show ?case by (unfold_locales; (fact Ipc_AI_assms)?) qed -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming named_theorems Ipc_AI_cont_assms diff --git a/proof/invariant-abstract/ARM_HYP/ArchKHeap_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchKHeap_AI.thy index 46d25b008a..d42f40b02f 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchKHeap_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchKHeap_AI.thy @@ -8,7 +8,7 @@ theory ArchKHeap_AI imports KHeapPre_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming fun non_vspace_obj :: "kernel_object \ bool" @@ -133,7 +133,7 @@ locale vspace_only_obj_pred = Arch + sublocale vspace_only_obj_pred < arch_only_obj_pred using vspace_pred_imp[OF vspace_only] by unfold_locales -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming sublocale empty_table: vspace_only_obj_pred "empty_table S" for S by unfold_locales (clarsimp simp: vspace_obj_pred_def empty_table_def diff --git a/proof/invariant-abstract/ARM_HYP/ArchKernelInit_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchKernelInit_AI.thy index fda1220785..b6c45ff9b1 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchKernelInit_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchKernelInit_AI.thy @@ -14,7 +14,7 @@ imports Arch_AI begin -context Arch begin global_naming ARM (*FIXME: arch_split*) +context Arch begin arch_global_naming text \ Showing that there is a state that satisfies the abstract invariants. diff --git a/proof/invariant-abstract/ARM_HYP/ArchLevityCatch_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchLevityCatch_AI.thy index 8466beb75a..1f97241115 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchLevityCatch_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchLevityCatch_AI.thy @@ -11,7 +11,7 @@ imports "Lib.SplitRule" begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming lemma asid_high_bits_of_shift : "asid_high_bits_of (ucast x << asid_low_bits) = x" diff --git a/proof/invariant-abstract/ARM_HYP/ArchRetype_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchRetype_AI.thy index d4d824a6f4..60016782be 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchRetype_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchRetype_AI.thy @@ -13,7 +13,7 @@ theory ArchRetype_AI imports Retype_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming named_theorems Retype_AI_assms @@ -403,10 +403,7 @@ declare post_retype_invs_check_def[simp] end - -context begin interpretation Arch . -requalify_consts post_retype_invs_check -end +arch_requalify_consts post_retype_invs_check definition post_retype_invs :: "apiobject_type \ word32 list \ 'z::state_ext state \ bool" @@ -422,7 +419,7 @@ global_interpretation Retype_AI_post_retype_invs?: Retype_AI_post_retype_invs by (unfold_locales; fact post_retype_invs_def) -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming lemma dmo_mapM_x_ccr_invs[wp]: "\invs\ @@ -442,14 +439,11 @@ lemma init_arch_objects_invs_from_restricted: "\post_retype_invs new_type refs and (\s. global_refs s \ set refs = {}) and K (\ref \ set refs. is_aligned ref (obj_bits_api new_type obj_sz))\ - init_arch_objects new_type ptr bits obj_sz refs + init_arch_objects new_type dev ptr bits obj_sz refs \\_. invs\" apply (simp add: init_arch_objects_def split del: if_split) - apply (rule hoare_pre) - apply (wp mapM_copy_global_invs_mappings_restricted - hoare_vcg_const_Ball_lift - valid_irq_node_typ - | wpc)+ + apply (wpsimp wp: mapM_copy_global_invs_mappings_restricted dmo_invs_lift + mapM_x_wp'[where f="\r. do_machine_op (m r)" for m]) apply (auto simp: post_retype_invs_def default_arch_object_def pd_bits_def pageBits_def obj_bits_api_def global_refs_def) @@ -500,7 +494,7 @@ global_interpretation Retype_AI_slot_bits?: Retype_AI_slot_bits qed -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming lemma valid_untyped_helper [Retype_AI_assms]: assumes valid_c : "s \ c" @@ -689,7 +683,7 @@ lemma hyp_refs_eq: default_arch_tcb_def) apply (rename_tac ao) apply (clarsimp simp: refs_of_a_def ARM_HYP.vcpu_tcb_refs_def default_arch_object_def - ARM_A.default_vcpu_def + ARM_HYP_A.default_vcpu_def split: aobject_type.splits) done @@ -769,7 +763,7 @@ sublocale retype_region_proofs_gen?: retype_region_proofs_gen end -context Arch begin global_naming ARM_HYP (*FIXME: arch_split*) +context Arch begin arch_global_naming definition valid_vs_lookup2 :: "(vs_ref list \ word32) set \ word32 set \ (cslot_ptr \ cap) \ bool" @@ -893,10 +887,7 @@ lemma cap_range_respects_device_region_cong[cong]: by (clarsimp simp: cap_range_respects_device_region_def) -context begin interpretation Arch . -requalify_consts region_in_kernel_window -end - +arch_requalify_consts region_in_kernel_window context retype_region_proofs_arch begin @@ -1090,7 +1081,7 @@ lemmas post_retype_invs_axioms = retype_region_proofs_invs_axioms end -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming named_theorems Retype_AI_assms' @@ -1123,7 +1114,7 @@ global_interpretation Retype_AI?: Retype_AI qed -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming lemma retype_region_plain_invs: "\invs and caps_no_overlap ptr sz and pspace_no_overlap_range_cover ptr sz @@ -1219,7 +1210,7 @@ crunch init_arch_objects lemma init_arch_objects_excap: "\ex_cte_cap_wp_to P p\ - init_arch_objects tp ptr bits us refs + init_arch_objects tp dev ptr bits us refs \\rv s. ex_cte_cap_wp_to P p s\" by (wp ex_cte_cap_to_pres) diff --git a/proof/invariant-abstract/ARM_HYP/ArchSchedule_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchSchedule_AI.thy index 296b00e0bf..657e065c2a 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchSchedule_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchSchedule_AI.thy @@ -8,11 +8,11 @@ theory ArchSchedule_AI imports Schedule_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming -named_theorems Schedule_AI_asms +named_theorems Schedule_AI_assms -lemma dmo_mapM_storeWord_0_invs[wp,Schedule_AI_asms]: +lemma dmo_mapM_storeWord_0_invs[wp,Schedule_AI_assms]: "valid invs (do_machine_op (mapM (\p. storeWord p 0) S)) (\_. invs)" apply (simp add: dom_mapM ef_storeWord) apply (rule mapM_UNIV_wp) @@ -39,19 +39,17 @@ lemma clearExMonitor_invs [wp]: machine_rest_lift_def in_monad select_f_def) done -global_naming Arch - -lemma arch_stt_invs [wp,Schedule_AI_asms]: +lemma arch_stt_invs [wp,Schedule_AI_assms]: "\invs\ arch_switch_to_thread t' \\_. invs\" apply (wpsimp simp: arch_switch_to_thread_def) by (rule sym_refs_VCPU_hyp_live; fastforce) -lemma arch_stt_tcb [wp,Schedule_AI_asms]: +lemma arch_stt_tcb [wp,Schedule_AI_assms]: "\tcb_at t'\ arch_switch_to_thread t' \\_. tcb_at t'\" by (wpsimp simp: arch_switch_to_thread_def wp: tcb_at_typ_at) -lemma arch_stt_runnable[Schedule_AI_asms]: +lemma arch_stt_runnable[Schedule_AI_assms]: "\st_tcb_at runnable t\ arch_switch_to_thread t \\r. st_tcb_at runnable t\" by (wpsimp simp: arch_switch_to_thread_def) @@ -71,7 +69,7 @@ crunch and ct[wp]: "\s. P (cur_thread s)" (wp: mapM_x_wp mapM_wp subset_refl) -lemma arch_stit_invs[wp, Schedule_AI_asms]: +lemma arch_stit_invs[wp, Schedule_AI_assms]: "\invs\ arch_switch_to_idle_thread \\r. invs\" by (wpsimp wp: svr_invs simp: arch_switch_to_idle_thread_def) @@ -86,19 +84,19 @@ crunch set_vm_root and it[wp]: "\s. P (idle_thread s)" (simp: crunch_simps wp: hoare_drop_imps) -lemma arch_stit_activatable[wp, Schedule_AI_asms]: +lemma arch_stit_activatable[wp, Schedule_AI_assms]: "\ct_in_state activatable\ arch_switch_to_idle_thread \\rv . ct_in_state activatable\" apply (clarsimp simp: arch_switch_to_idle_thread_def) apply (wpsimp simp: ct_in_state_def wp: ct_in_state_thread_state_lift) done -lemma stit_invs [wp,Schedule_AI_asms]: +lemma stit_invs [wp,Schedule_AI_assms]: "\invs\ switch_to_idle_thread \\rv. invs\" apply (simp add: switch_to_idle_thread_def arch_switch_to_idle_thread_def) apply (wpsimp|strengthen idle_strg)+ done -lemma stit_activatable[Schedule_AI_asms]: +lemma stit_activatable[Schedule_AI_assms]: "\invs\ switch_to_idle_thread \\rv . ct_in_state activatable\" apply (simp add: switch_to_idle_thread_def arch_switch_to_idle_thread_def) apply (wp | simp add: ct_in_state_def)+ @@ -106,7 +104,7 @@ lemma stit_activatable[Schedule_AI_asms]: elim!: pred_tcb_weaken_strongerE) done -lemma stt_invs [wp,Schedule_AI_asms]: +lemma stt_invs [wp,Schedule_AI_assms]: "\invs\ switch_to_thread t' \\_. invs\" apply (simp add: switch_to_thread_def) apply wp @@ -126,14 +124,14 @@ interpretation Schedule_AI_U?: Schedule_AI_U proof goal_cases interpret Arch . case 1 show ?case - by (intro_locales; (unfold_locales; fact Schedule_AI_asms)?) + by (intro_locales; (unfold_locales; fact Schedule_AI_assms)?) qed interpretation Schedule_AI?: Schedule_AI proof goal_cases interpret Arch . case 1 show ?case - by (intro_locales; (unfold_locales; fact Schedule_AI_asms)?) + by (intro_locales; (unfold_locales; fact Schedule_AI_assms)?) qed end diff --git a/proof/invariant-abstract/ARM_HYP/ArchSyscall_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchSyscall_AI.thy index 28a9f953bf..4d713f2dc3 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchSyscall_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchSyscall_AI.thy @@ -13,7 +13,7 @@ imports Syscall_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming named_theorems Syscall_AI_assms diff --git a/proof/invariant-abstract/ARM_HYP/ArchTcbAcc_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchTcbAcc_AI.thy index 79d9442c6b..91f66dda4b 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchTcbAcc_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchTcbAcc_AI.thy @@ -8,7 +8,7 @@ theory ArchTcbAcc_AI imports TcbAcc_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming named_theorems TcbAcc_AI_assms diff --git a/proof/invariant-abstract/ARM_HYP/ArchTcb_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchTcb_AI.thy index 07fc1117b7..4663bb6d0a 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchTcb_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchTcb_AI.thy @@ -8,19 +8,19 @@ theory ArchTcb_AI imports Tcb_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming -named_theorems Tcb_AI_asms +named_theorems Tcb_AI_assms -lemma activate_idle_invs[Tcb_AI_asms]: +lemma activate_idle_invs[Tcb_AI_assms]: "\invs and ct_idle\ arch_activate_idle_thread thread \\rv. invs and ct_idle\" by (simp add: arch_activate_idle_thread_def) -lemma empty_fail_getRegister [intro!, simp, Tcb_AI_asms]: +lemma empty_fail_getRegister [intro!, simp, Tcb_AI_assms]: "empty_fail (getRegister r)" by (simp add: getRegister_def) @@ -37,7 +37,7 @@ lemma same_object_also_valid: (* arch specific *) split: cap.split_asm arch_cap.split_asm option.splits)+) done -lemma same_object_obj_refs[Tcb_AI_asms]: +lemma same_object_obj_refs[Tcb_AI_assms]: "\ same_object_as cap cap' \ \ obj_refs cap = obj_refs cap'" apply (cases cap, simp_all add: same_object_as_def) @@ -135,13 +135,13 @@ lemma checked_insert_tcb_invs[wp]: (* arch specific *) done crunch arch_get_sanitise_register_info, arch_post_modify_registers - for tcb_at[wp, Tcb_AI_asms]: "tcb_at a" + for tcb_at[wp, Tcb_AI_assms]: "tcb_at a" crunch arch_get_sanitise_register_info, arch_post_modify_registers - for invs[wp, Tcb_AI_asms]: "invs" + for invs[wp, Tcb_AI_assms]: "invs" crunch arch_get_sanitise_register_info, arch_post_modify_registers - for ex_nonz_cap_to[wp, Tcb_AI_asms]: "ex_nonz_cap_to a" + for ex_nonz_cap_to[wp, Tcb_AI_assms]: "ex_nonz_cap_to a" -lemma finalise_cap_not_cte_wp_at[Tcb_AI_asms]: +lemma finalise_cap_not_cte_wp_at[Tcb_AI_assms]: assumes x: "P cap.NullCap" shows "\\s. \cp \ ran (caps_of_state s). P cp\ finalise_cap cap fin @@ -159,7 +159,7 @@ lemma finalise_cap_not_cte_wp_at[Tcb_AI_asms]: done -lemma table_cap_ref_max_free_index_upd[simp,Tcb_AI_asms]: +lemma table_cap_ref_max_free_index_upd[simp,Tcb_AI_assms]: "table_cap_ref (max_free_index_update cap) = table_cap_ref cap" by (simp add:free_index_update_def table_cap_ref_def split:cap.splits) @@ -167,7 +167,7 @@ lemma table_cap_ref_max_free_index_upd[simp,Tcb_AI_asms]: interpretation Tcb_AI_1? : Tcb_AI_1 where state_ext_t = state_ext_t and is_cnode_or_valid_arch = is_cnode_or_valid_arch -by (unfold_locales; fact Tcb_AI_asms) +by (unfold_locales; fact Tcb_AI_assms) lemma use_no_cap_to_obj_asid_strg: (* arch specific *) @@ -185,7 +185,7 @@ lemma use_no_cap_to_obj_asid_strg: (* arch specific *) done declare arch_cap_fun_lift_simps [simp del] -lemma cap_delete_no_cap_to_obj_asid[wp, Tcb_AI_asms]: +lemma cap_delete_no_cap_to_obj_asid[wp, Tcb_AI_assms]: "\no_cap_to_obj_dr_emp cap\ cap_delete slot \\rv. no_cap_to_obj_dr_emp cap\" @@ -214,7 +214,7 @@ lemma as_user_ipc_tcb_cap_valid4[wp]: apply (clarsimp simp: get_tcb_def) done -lemma tc_invs[Tcb_AI_asms]: +lemma tc_invs[Tcb_AI_assms]: "\invs and tcb_at a and (case_option \ (valid_cap o fst) e) and (case_option \ (valid_cap o fst) f) @@ -292,7 +292,7 @@ lemma check_valid_ipc_buffer_inv: (* arch_specific *) apply (wp | simp add: if_apply_def2 split del: if_split | wpcw)+ done -lemma check_valid_ipc_buffer_wp[Tcb_AI_asms]: +lemma check_valid_ipc_buffer_wp[Tcb_AI_assms]: "\\(s::'state_ext::state_ext state). is_arch_cap cap \ is_cnode_or_valid_arch cap \ valid_ipc_buffer_cap cap vptr \ is_aligned vptr msg_align_bits @@ -308,7 +308,7 @@ lemma check_valid_ipc_buffer_wp[Tcb_AI_asms]: valid_ipc_buffer_cap_def) done -lemma derive_no_cap_asid[wp,Tcb_AI_asms]: +lemma derive_no_cap_asid[wp,Tcb_AI_assms]: "\(no_cap_to_obj_with_diff_ref cap S)::'state_ext::state_ext state\bool\ derive_cap slot cap \\rv. no_cap_to_obj_with_diff_ref rv S\,-" @@ -322,7 +322,7 @@ lemma derive_no_cap_asid[wp,Tcb_AI_asms]: done -lemma decode_set_ipc_inv[wp,Tcb_AI_asms]: +lemma decode_set_ipc_inv[wp,Tcb_AI_assms]: "\P::'state_ext::state_ext state \ bool\ decode_set_ipc_buffer args cap slot excaps \\rv. P\" apply (simp add: decode_set_ipc_buffer_def whenE_def split_def @@ -331,7 +331,7 @@ lemma decode_set_ipc_inv[wp,Tcb_AI_asms]: apply simp done -lemma no_cap_to_obj_with_diff_ref_update_cap_data[Tcb_AI_asms]: +lemma no_cap_to_obj_with_diff_ref_update_cap_data[Tcb_AI_assms]: "no_cap_to_obj_with_diff_ref c S s \ no_cap_to_obj_with_diff_ref (update_cap_data P x c) S s" apply (case_tac "update_cap_data P x c = NullCap") @@ -348,7 +348,7 @@ lemma no_cap_to_obj_with_diff_ref_update_cap_data[Tcb_AI_asms]: done -lemma update_cap_valid[Tcb_AI_asms]: +lemma update_cap_valid[Tcb_AI_assms]: "valid_cap cap (s::'state_ext::state_ext state) \ valid_cap (case capdata of None \ cap_rights_update rs cap @@ -380,17 +380,12 @@ crunch invoke_tcb end -context begin interpretation Arch . -requalify_consts is_cnode_or_valid_arch -requalify_facts invoke_tcb_typ_at -end - global_interpretation Tcb_AI?: Tcb_AI where is_cnode_or_valid_arch = ARM_HYP.is_cnode_or_valid_arch proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; fact Tcb_AI_asms) + by (unfold_locales; fact Tcb_AI_assms) qed end diff --git a/proof/invariant-abstract/ARM_HYP/ArchUntyped_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchUntyped_AI.thy index f569abd406..e03a03d936 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchUntyped_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchUntyped_AI.thy @@ -8,7 +8,7 @@ theory ArchUntyped_AI imports Untyped_AI begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming named_theorems Untyped_AI_assms @@ -167,7 +167,7 @@ lemma retype_ret_valid_caps_aobj[Untyped_AI_assms]: range_cover ptr sz (obj_bits_api (ArchObject x6) us) n \ ptr \ 0\ \ \y\{0..kheap := foldr (\p kh. kh(p \ default_object (ArchObject x6) dev us)) (map (\p. ptr_add ptr (p * 2 ^ obj_bits_api (ArchObject x6) us)) [0.. \ ArchObjectCap (ARM_A.arch_default_cap x6 (ptr_add ptr (y * 2 ^ obj_bits_api (ArchObject x6) us)) us dev)" + (kheap s)\ \ ArchObjectCap (ARM_HYP_A.arch_default_cap x6 (ptr_add ptr (y * 2 ^ obj_bits_api (ArchObject x6) us)) us dev)" apply (rename_tac aobject_type us n) apply (case_tac aobject_type) by (clarsimp simp:valid_cap_def default_object_def cap_aligned_def @@ -179,31 +179,20 @@ by (clarsimp simp:valid_cap_def default_object_def cap_aligned_def default_arch_object_def valid_vm_rights_def word_bits_def a_type_def)+ -lemma copy_global_mappings_hoare_lift:(*FIXME: arch_split \ these do not seem to be used globally *) +lemma copy_global_mappings_hoare_lift:(*FIXME: arch-split \ these do not seem to be used globally *) assumes wp: "\ptr val. \Q\ store_pde ptr val \\rv. Q\" shows "\Q\ copy_global_mappings pd \\rv. Q\" apply (simp add: copy_global_mappings_def) done lemma init_arch_objects_hoare_lift: - assumes wp: "\oper. \(P::'state_ext::state_ext state\bool)\ do_machine_op oper \\rv :: unit. Q\" - "\ptr val. \P\ store_pde ptr val \\rv. P\" - shows "\P and Q\ init_arch_objects tp ptr sz us adds \\rv. Q\" -proof - - have pres: "\oper. \P and Q\ do_machine_op oper \\rv :: unit. Q\" - "\P and Q\ return () \\rv. Q\" - by (wp wp | simp)+ - show ?thesis - apply (simp add: init_arch_objects_def - pres reserve_region_def - split: Structures_A.apiobject_type.split - aobject_type.split) - apply clarsimp - apply (rule hoare_pre) - apply (wp mapM_x_wp' copy_global_mappings_hoare_lift wp) - apply simp - done -qed + assumes wp: "\oper. \(Q::'state_ext::state_ext state\bool)\ do_machine_op oper \\rv :: unit. Q\" + "\ptr val. \Q\ store_pde ptr val \\rv. Q\" + shows "\Q\ init_arch_objects tp dev ptr sz us adds \\rv. Q\" + supply if_split[split del] + apply (simp add: init_arch_objects_def reserve_region_def) + apply (wpsimp wp: mapM_x_wp' copy_global_mappings_hoare_lift wp) + done lemma cap_refs_in_kernel_windowD2: @@ -215,28 +204,20 @@ lemma cap_refs_in_kernel_windowD2: done lemma init_arch_objects_descendants_range[wp,Untyped_AI_assms]: - "\\(s::'state_ext::state_ext state). descendants_range x cref s \ init_arch_objects ty ptr n us y + "\\(s::'state_ext::state_ext state). descendants_range x cref s \ init_arch_objects ty dev ptr n us y \\rv s. descendants_range x cref s\" - apply (simp add:descendants_range_def) - apply (rule hoare_pre) - apply (wp retype_region_mdb init_arch_objects_hoare_lift) - apply (wps do_machine_op_mdb) - apply (wp hoare_vcg_ball_lift) - apply (rule hoare_pre) - apply (wps store_pde_mdb_inv) - apply wp - apply simp - apply fastforce + apply (simp add: descendants_range_def) + apply (wp retype_region_mdb init_arch_objects_hoare_lift) + apply (wp_pre, wps do_machine_op_mdb, wp, simp)+ + apply simp done lemma init_arch_objects_caps_overlap_reserved[wp,Untyped_AI_assms]: "\\(s::'state_ext::state_ext state). caps_overlap_reserved S s\ - init_arch_objects ty ptr n us y + init_arch_objects ty dev ptr n us y \\rv s. caps_overlap_reserved S s\" apply (simp add:caps_overlap_reserved_def) - apply (rule hoare_pre) - apply (wp retype_region_mdb init_arch_objects_hoare_lift) - apply fastforce + apply (wp retype_region_mdb init_arch_objects_hoare_lift) done lemma set_untyped_cap_invs_simple[Untyped_AI_assms]: @@ -408,12 +389,10 @@ lemma init_arch_objects_nonempty_table[Untyped_AI_assms, wp]: "\(\s. \ (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s) \ valid_global_objs s \ valid_arch_state s \ pspace_aligned s) and K (\ref\set refs. is_aligned ref (obj_bits_api tp us))\ - init_arch_objects tp ptr bits us refs + init_arch_objects tp dev ptr bits us refs \\rv s. \ (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)\" - apply (rule hoare_gen_asm) apply (simp add: init_arch_objects_def split del: if_split) - apply (rule hoare_pre) - apply (wp unless_wp | wpc | simp add: reserve_region_def)+ + apply (wpsimp wp: mapM_x_wp'[where f="\r. do_machine_op (m r)" for m]) apply (clarsimp simp: obj_bits_api_def default_arch_object_def pd_bits_def pageBits_def) done diff --git a/proof/invariant-abstract/ARM_HYP/ArchVCPU_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchVCPU_AI.thy index 019acf8bad..023f273197 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchVCPU_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchVCPU_AI.thy @@ -9,7 +9,7 @@ theory ArchVCPU_AI imports AInvs begin -context Arch begin global_naming ARM_HYP (*FIXME: arch_split*) +context Arch begin arch_global_naming definition active_cur_vcpu_of :: "'z state \ obj_ref option" where "active_cur_vcpu_of s \ case arm_current_vcpu (arch_state s) of Some (vr, True) \ Some vr diff --git a/proof/invariant-abstract/ARM_HYP/ArchVSpaceEntries_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchVSpaceEntries_AI.thy index caafa1c4e1..5c7cbc4c1f 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchVSpaceEntries_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchVSpaceEntries_AI.thy @@ -8,7 +8,7 @@ theory ArchVSpaceEntries_AI imports VSpaceEntries_AI begin -context Arch begin global_naming ARM_HYP (*FIXME: arch_split*) +context Arch begin arch_global_naming lemma a_type_pdD: "a_type ko = AArch APageDirectory \ \pd. ko = ArchObj (PageDirectory pd)" @@ -600,26 +600,25 @@ lemma init_arch_objects_valid_pdpt: "\valid_pdpt_objs and pspace_aligned and valid_arch_state and K (\us sz. orefs = retype_addrs ptr type n us \ range_cover ptr sz (obj_bits_api type us) n)\ - init_arch_objects type ptr n obj_sz orefs + init_arch_objects type dev ptr n obj_sz orefs \\rv. valid_pdpt_objs\" apply (rule hoare_gen_asm)+ - apply (clarsimp simp: init_arch_objects_def - split del: if_split) - apply (rule hoare_pre) - apply (wp | wpc)+ - apply (rule_tac Q'="\rv. valid_pdpt_objs and pspace_aligned and valid_arch_state" - in hoare_post_imp, simp) - apply (rule mapM_x_wp') - apply (rule hoare_pre, wp copy_global_mappings_valid_pdpt_objs) - apply clarsimp - apply (drule_tac sz=sz in retype_addrs_aligned) - apply (simp add:range_cover_def) - apply (drule range_cover.sz,simp add:word_bits_def) - apply (simp add:range_cover_def) - apply (clarsimp simp:obj_bits_api_def pd_bits_def pageBits_def - arch_kobj_size_def default_arch_object_def range_cover_def)+ + apply (clarsimp simp: init_arch_objects_def split del: if_split) + apply (wp | wpc)+ + apply (wpsimp wp: mapM_x_wp' hoare_vcg_op_lift) + apply (wpsimp wp: mapM_x_wp' hoare_vcg_op_lift) + apply (rule_tac Q'="\rv. valid_pdpt_objs and pspace_aligned and valid_arch_state" + in hoare_post_imp, simp) apply wp - apply simp + apply (rule mapM_x_wp') + apply (wp copy_global_mappings_valid_pdpt_objs) + apply clarsimp + apply (drule_tac sz=sz in retype_addrs_aligned) + apply (simp add: range_cover_def) + apply (drule range_cover.sz,simp add:word_bits_def) + apply (simp add: range_cover_def) + apply (clarsimp simp: obj_bits_api_def pd_bits_def pageBits_def + arch_kobj_size_def default_arch_object_def range_cover_def)+ done lemma delete_objects_valid_pdpt: diff --git a/proof/invariant-abstract/ARM_HYP/ArchVSpace_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchVSpace_AI.thy index 96e43ad9bc..f67a722904 100644 --- a/proof/invariant-abstract/ARM_HYP/ArchVSpace_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/ArchVSpace_AI.thy @@ -23,7 +23,7 @@ lemma get_tcb_Some_ko_at: "(get_tcb p s = Some t) = ko_at (TCB t) p s" by (auto simp: get_tcb_def obj_at_def is_tcb_def split: kernel_object.splits option.splits) -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming lemma kernel_base_shift_cast_le: (* ARMHYP *) fixes x :: "11 word" @@ -2874,7 +2874,7 @@ lemma vs_lookup2: end -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming lemma set_pd_vspace_objs_map: (* ARMHYP *) notes valid_vspace_obj.simps[simp del] and a_type_elims[rule del] @@ -4477,17 +4477,13 @@ lemma unmap_page_table_unmapped2: lemma cacheRangeOp_lift[wp]: assumes o: "\a b. \P\ oper a b \\_. P\" shows "\P\ cacheRangeOp oper x y z \\_. P\" - apply (clarsimp simp: cacheRangeOp_def lineStart_def cacheLineBits_def cacheLine_def) - apply (rule hoare_pre) - apply (wp mapM_x_wp_inv o) - apply (case_tac x, simp, wp o, simp) - done + unfolding cacheRangeOp_def + by (wpsimp wp: mapM_x_wp_inv o) lemma cleanCacheRange_PoU_underlying_memory[wp]: - "\\m'. underlying_memory m' p = um\ cleanCacheRange_PoU a b c \\_ m'. underlying_memory m' p = um\" + "cleanCacheRange_PoU a b c \\m'. underlying_memory m' p = um\" by (clarsimp simp: cleanCacheRange_PoU_def, wp) - lemma unmap_page_table_unmapped3: "\pspace_aligned and valid_vspace_objs and page_table_at pt and K (ref = [VSRef (vaddr >> 21) (Some APageDirectory), @@ -5794,7 +5790,7 @@ lemma vs_lookup_pages2: end -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming lemma not_kernel_slot_not_global_pt: (* ARMHYP? remove? *) "\pde_ref (pd x) = Some p; @@ -5991,7 +5987,7 @@ lemma perform_asid_pool_invs [wp]: apply (rule_tac x=a in exI) apply (rule_tac x=b in exI) apply (clarsimp simp: vs_cap_ref_def mask_asid_low_bits_ucast_ucast) - apply (clarsimp simp: asid_low_bits_def[symmetric] ucast_ucast_mask + apply (clarsimp simp: asid_low_bits_def[simplified, symmetric] ucast_ucast_mask word_neq_0_conv[symmetric]) apply (erule notE, rule asid_low_high_bits, simp_all)[1] apply (simp add: asid_high_bits_of_def) diff --git a/proof/invariant-abstract/ARM_HYP/Machine_AI.thy b/proof/invariant-abstract/ARM_HYP/Machine_AI.thy index 63c93cb977..16c70721cb 100644 --- a/proof/invariant-abstract/ARM_HYP/Machine_AI.thy +++ b/proof/invariant-abstract/ARM_HYP/Machine_AI.thy @@ -67,7 +67,7 @@ crunch_ignore (no_irq) (add: handleE' handleE handle_elseE forM forM_x zipWithM ignore_failure) -context Arch begin +context Arch begin arch_global_naming lemma det_getRegister: "det (getRegister x)" by (simp add: getRegister_def) @@ -279,9 +279,8 @@ lemma no_fail_invalidateCacheRange_I[simp, wp]: lemma no_fail_invalidateCacheRange_RAM[simp, wp]: "no_fail \ (invalidateCacheRange_RAM s e p)" - apply (simp add: invalidateCacheRange_RAM_def lineStart_def cacheLineBits_def) - apply (wpsimp wp: no_fail_invalidateL2Range no_fail_invalidateByVA no_fail_dsb) - done + unfolding invalidateCacheRange_RAM_def + by (wpsimp wp: no_fail_invalidateL2Range no_fail_invalidateByVA no_fail_dsb) lemma no_fail_branchFlushRange[simp, wp]: "no_fail \ (branchFlushRange s e p)" @@ -643,7 +642,7 @@ lemma no_irq_when: lemma no_irq_invalidateCacheRange_RAM[simp, wp]: "no_irq (invalidateCacheRange_RAM s e p)" - apply (simp add: invalidateCacheRange_RAM_def lineStart_def cacheLineBits_def) + apply (simp add: invalidateCacheRange_RAM_def) apply (wp no_irq_invalidateL2Range no_irq_invalidateByVA no_irq_dsb no_irq_when) done @@ -821,12 +820,7 @@ crunch readVCPUHardwareReg, writeVCPUHardwareReg, get_cntv_cval_64, set_cntv_cva lemma empty_fail_cacheRangeOp [simp, intro!]: assumes ef: "\a b. empty_fail (oper a b)" shows "empty_fail (cacheRangeOp oper s e p)" - apply (simp add: cacheRangeOp_def mapM_x_mapM lineStart_def cacheLineBits_def cacheLine_def ef) - apply (rule empty_fail_bind) - apply (rule empty_fail_mapM) - apply (auto intro: ef) - done - + by (auto simp add: cacheRangeOp_def mapM_x_mapM intro: ef) lemma empty_fail_cleanCacheRange_PoU[simp, intro!]: "empty_fail (cleanCacheRange_PoU s e p)" @@ -851,7 +845,7 @@ lemma empty_fail_invalidateCacheRange_I[simp, intro!]: lemma empty_fail_invalidateCacheRange_RAM[simp, intro!]: "empty_fail (invalidateCacheRange_RAM s e p)" - by (fastforce simp: invalidateCacheRange_RAM_def lineStart_def cacheLineBits_def + by (fastforce simp: invalidateCacheRange_RAM_def empty_fail_invalidateL2Range empty_fail_invalidateByVA empty_fail_dsb) lemma empty_fail_branchFlushRange[simp, intro!]: @@ -875,14 +869,4 @@ lemma empty_fail_clearMemory [simp, intro!]: end end -context begin interpretation Arch . - -requalify_facts - det_getRegister - det_setRegister - det_getRestartPC - det_setNextPC - -end - end diff --git a/proof/invariant-abstract/BCorres_AI.thy b/proof/invariant-abstract/BCorres_AI.thy index 56fc08f1b0..b0fc8df584 100644 --- a/proof/invariant-abstract/BCorres_AI.thy +++ b/proof/invariant-abstract/BCorres_AI.thy @@ -16,6 +16,23 @@ abbreviation "bcorres \ bcorres_underlying truncate_state" abbreviation "s_bcorres \ s_bcorres_underlying truncate_state" +crunch_ignore (bcorres) + (add: Nondet_Monad.bind gets modify get put do_extended_op empty_slot_ext mapM_x "when" + select unless mapM catch bindE liftE whenE alternative cap_swap_ext + cap_insert_ext cap_move_ext liftM create_cap_ext + lookup_error_on_failure getActiveIRQ maybeM + gets_the liftME zipWithM_x unlessE mapME_x handleE forM_x) + +context Arch begin arch_global_naming + +crunch arch_post_cap_deletion + for (bcorres) bcorres[wp]: truncate_state + +end + +arch_requalify_facts + arch_post_cap_deletion_bcorres + lemma get_object_bcorres[wp]: "bcorres (get_object p) (get_object p)" apply (simp add: get_object_def) @@ -57,28 +74,11 @@ lemma OR_choiceE_bcorres[wp]: apply force done -crunch_ignore (bcorres) - (add: Nondet_Monad.bind gets modify get put do_extended_op empty_slot_ext mapM_x "when" - select unless mapM catch bindE liftE whenE alternative cap_swap_ext - cap_insert_ext cap_move_ext liftM create_cap_ext - lookup_error_on_failure getActiveIRQ maybeM - gets_the liftME zipWithM_x unlessE mapME_x handleE forM_x) - lemma bcorres_select_ext[wp]: "bcorres (select_ext a A) (select_ext a A)" by (clarsimp simp: select_ext_def bind_def gets_def return_def select_def assert_def get_def select_switch_unit_def bcorres_underlying_def s_bcorres_underlying_def fail_def) -context Arch begin - -crunch arch_post_cap_deletion - for (bcorres) bcorres[wp]: truncate_state - -end - -requalify_facts - Arch.arch_post_cap_deletion_bcorres - crunch set_original, set_object, set_cap, set_irq_state, deleted_irq_handler, get_cap,set_cdt, empty_slot for (bcorres) bcorres[wp]: truncate_state @@ -209,8 +209,6 @@ lemma throw_on_false_bcorres[wp]: "bcorres f f' \ bcorres (throw_on_false e f) (throw_on_false e f')" by (simp add: throw_on_false_def | wp)+ -crunch_ignore (bcorres) (add: getActiveIRQ) - lemma preemption_point_bcorres[wp]: "bcorres preemption_point preemption_point" unfolding preemption_point_def is_cur_domain_expired_def andM_def ifM_def get_sc_active_def diff --git a/proof/invariant-abstract/CNodeInv_AI.thy b/proof/invariant-abstract/CNodeInv_AI.thy index 7bbe15897d..1fab269d60 100644 --- a/proof/invariant-abstract/CNodeInv_AI.thy +++ b/proof/invariant-abstract/CNodeInv_AI.thy @@ -13,14 +13,10 @@ theory CNodeInv_AI imports ArchIpc_AI begin - -context begin interpretation Arch . -requalify_facts - set_cap_arch +arch_requalify_facts cte_at_length_limit arch_derive_cap_untyped valid_arch_mdb_cap_swap -end declare set_cap_arch[wp] diff --git a/proof/invariant-abstract/CSpaceInvPre_AI.thy b/proof/invariant-abstract/CSpaceInvPre_AI.thy index 5ef1ffdf28..8e810f0b8f 100644 --- a/proof/invariant-abstract/CSpaceInvPre_AI.thy +++ b/proof/invariant-abstract/CSpaceInvPre_AI.thy @@ -8,16 +8,13 @@ theory CSpaceInvPre_AI imports ArchAcc_AI begin -context begin interpretation Arch . - -requalify_consts +arch_requalify_consts table_cap_ref empty_table -requalify_facts +arch_requalify_facts empty_table_def cur_tcb_more_update -end declare cur_tcb_more_update[iff] @@ -142,8 +139,9 @@ lemma empty_table_caps_of: "empty_table S ko \ caps_of ko = {}" by (cases ko, simp_all add: empty_table_def caps_of_def cap_of_def) -context begin interpretation Arch . -lemma free_index_update_test_function_stuff[simp]: +(* FIXME arch-split: exports properties of functions that are not necessarily in global context, + and then they get placed in the global simpset *) +lemma (in Arch) free_index_update_test_function_stuff[simp]: "cap_asid (src_cap\free_index := a\) = cap_asid src_cap" "gen_obj_refs (src_cap\free_index := a\) = gen_obj_refs src_cap" "vs_cap_ref (src_cap\free_index := a\) = vs_cap_ref src_cap" @@ -153,6 +151,9 @@ lemma free_index_update_test_function_stuff[simp]: by (auto simp: cap_asid_def free_index_update_def vs_cap_ref_def is_cap_simps gen_obj_refs_def split: cap.splits arch_cap.splits) -end + +requalify_facts Arch.free_index_update_test_function_stuff + +lemmas [simp] = free_index_update_test_function_stuff end diff --git a/proof/invariant-abstract/CSpaceInv_AI.thy b/proof/invariant-abstract/CSpaceInv_AI.thy index 71422a485f..4386096fc9 100644 --- a/proof/invariant-abstract/CSpaceInv_AI.thy +++ b/proof/invariant-abstract/CSpaceInv_AI.thy @@ -12,31 +12,27 @@ theory CSpaceInv_AI imports ArchCSpaceInvPre_AI begin -context begin interpretation Arch . - -requalify_consts +arch_requalify_consts cap_master_arch_cap replaceable_final_arch_cap replaceable_non_final_arch_cap unique_table_refs -requalify_facts +arch_requalify_facts aobj_ref_acap_rights_update arch_obj_size_acap_rights_update valid_arch_cap_acap_rights_update - valid_validate_vm_rights cap_master_arch_inv unique_table_refs_def valid_ipc_buffer_cap_def acap_rights_update_idem + valid_acap_rights_update_id cap_master_arch_cap_rights - acap_rights_update_id is_nondevice_page_cap_simps set_cap_hyp_refs_of state_hyp_refs_of_revokable set_cap_hyp_refs_of is_valid_vtable_root_is_arch_cap -end lemmas bits_of_simps[simp] = bits_of_def[split_simps cap.split] @@ -54,10 +50,10 @@ lemma is_valid_vtable_root_simps[simp]: lemmas [simp] = aobj_ref_acap_rights_update arch_obj_size_acap_rights_update valid_validate_vm_rights cap_master_arch_inv acap_rights_update_idem - cap_master_arch_cap_rights acap_rights_update_id state_hyp_refs_of_revokable + cap_master_arch_cap_rights valid_acap_rights_update_id state_hyp_refs_of_revokable lemmas [intro] = valid_arch_cap_acap_rights_update -lemmas [intro!] = acap_rights_update_id +lemmas [intro!] = valid_acap_rights_update_id lemmas [wp] = set_cap_hyp_refs_of lemma remove_rights_cap_valid[simp]: @@ -1044,17 +1040,14 @@ lemma get_cap_caps_of_state: "(fst (get_cap p s) = {(cap, s)}) = (Some cap = caps_of_state s p)" by (clarsimp simp: caps_of_state_def eq_commute) -context Arch begin - -lemma abj_ref_none_no_refs: +(* generic consequence of architecture-specific details *) +lemma (in Arch) abj_ref_none_no_refs: "obj_refs c = {} \ table_cap_ref c = None" unfolding table_cap_ref_def apply (cases c; simp) subgoal for ac by (cases ac; simp) done -end - requalify_facts Arch.abj_ref_none_no_refs lemma no_cap_to_obj_with_diff_ref_Null: diff --git a/proof/invariant-abstract/CSpacePre_AI.thy b/proof/invariant-abstract/CSpacePre_AI.thy index e32a6d8863..817d130c1a 100644 --- a/proof/invariant-abstract/CSpacePre_AI.thy +++ b/proof/invariant-abstract/CSpacePre_AI.thy @@ -12,15 +12,16 @@ theory CSpacePre_AI imports ArchCSpaceInv_AI begin -context begin interpretation Arch . -requalify_consts +arch_requalify_consts cap_asid is_simple_cap_arch is_derived_arch safe_parent_for_arch cap_asid_base cap_vptr -end + +arch_requalify_facts + replace_cap_invs lemma fun_upd_Some: "ms p = Some k \ (ms(a \ b)) p = Some (if a = p then b else k)" diff --git a/proof/invariant-abstract/CSpace_AI.thy b/proof/invariant-abstract/CSpace_AI.thy index eead885c70..419c0be924 100644 --- a/proof/invariant-abstract/CSpace_AI.thy +++ b/proof/invariant-abstract/CSpace_AI.thy @@ -12,29 +12,25 @@ theory CSpace_AI imports ArchCSpacePre_AI begin -context begin interpretation Arch . - -requalify_consts +arch_requalify_consts irq_state_update irq_state - time_state_update - time_state - last_machine_time_update - last_machine_time final_matters_arch ups_of_heap -requalify_facts +arch_requalify_facts (A) + update_cnode_cap_data_def + +arch_requalify_facts + loadWord_inv is_derived_arch_non_arch ups_of_heap_non_arch_upd master_arch_cap_obj_refs master_arch_cap_cap_class same_aobject_as_commute arch_derive_cap_inv - loadWord_inv valid_global_refsD2 arch_derived_is_device - update_cnode_cap_data_def safe_parent_for_arch_not_arch safe_parent_cap_range_arch valid_arch_mdb_simple @@ -48,7 +44,6 @@ requalify_facts valid_arch_mdb_null_filter valid_arch_mdb_untypeds lookup_ipc_buffer_inv -end declare set_cap_update_free_index_valid_arch_mdb[wp] @@ -3047,14 +3042,14 @@ lemma weak_derived_is_reply: same_object_as_def is_cap_simps split: if_split_asm cap.split_asm) -context begin interpretation Arch . -lemma non_arch_cap_asid_vptr_None: +lemma (in Arch) non_arch_cap_asid_vptr_None: assumes "\ is_arch_cap cap" shows "cap_asid cap = None" and "cap_asid_base cap = None" and "cap_vptr cap = None" using assms by (cases cap; simp add: is_cap_simps cap_asid_def cap_asid_base_def cap_vptr_def)+ -end + +requalify_facts Arch.non_arch_cap_asid_vptr_None lemma weak_derived_Reply: "weak_derived (cap.ReplyCap t R) c = (\ R'. c = cap.ReplyCap t R')" diff --git a/proof/invariant-abstract/DetSchedAux_AI.thy b/proof/invariant-abstract/DetSchedAux_AI.thy index 547980acdf..cdb7a7cab0 100644 --- a/proof/invariant-abstract/DetSchedAux_AI.thy +++ b/proof/invariant-abstract/DetSchedAux_AI.thy @@ -8,14 +8,11 @@ theory DetSchedAux_AI imports DetSchedInvs_AI begin -context begin interpretation Arch . -requalify_facts - invoke_untyped_pred_tcb_at +arch_requalify_facts init_arch_objects_typ_at init_arch_objects_pred_tcb_at init_arch_objects_cur_thread hyp_live_default_object -end lemmas [wp] = init_arch_objects_typ_at @@ -73,11 +70,11 @@ global_interpretation cap_insert: valid_sched_pred_locale _ "cap_insert new_cap locale DetSchedAux_AI = fixes state_ext_t :: "'state_ext::state_ext itself" assumes init_arch_objects_valid_idle[wp]: - "\t p n s r. init_arch_objects t p n s r \\s::'state_ext state. valid_idle s\" + "\t d p n s r. init_arch_objects t d p n s r \\s::'state_ext state. valid_idle s\" assumes init_arch_objects_valid_sched_pred[wp]: - "\t p n s r P. init_arch_objects t p n s r \valid_sched_pred_strong P::'state_ext state \ _\" + "\t d p n s r P. init_arch_objects t d p n s r \valid_sched_pred_strong P::'state_ext state \ _\" assumes init_arch_object_valid_machine_time[wp]: - "\t p n s r. init_arch_objects t p n s r \valid_machine_time ::'state_ext state \ _\" + "\t d p n s r. init_arch_objects t d p n s r \valid_machine_time ::'state_ext state \ _\" assumes update_time_stamp_valid_machine_time[wp]: "update_time_stamp \valid_machine_time::'state_ext state \ _\" assumes dmo_getCurrentTime_vmt_sp: @@ -89,7 +86,7 @@ lemmas mapM_x_defsym = mapM_x_def[symmetric] context DetSchedAux_AI begin -sublocale init_arch_objects: valid_sched_pred_locale _ "init_arch_objects t p n s r" +sublocale init_arch_objects: valid_sched_pred_locale _ "init_arch_objects t d p n s r" by unfold_locales (rule init_arch_objects_valid_sched_pred) crunch delete_objects @@ -113,7 +110,7 @@ crunch invoke_untyped end lemma init_arch_objects_tcb_heap[wp]: - "init_arch_objects t p n s r \\s. P (tcbs_of s)\" + "init_arch_objects t d p n s r \\s. P (tcbs_of s)\" apply (rule pred_map_heap_lift[where heap=tcbs_of and P=P and R=\, simplified]) apply (rule rsubst[where P="\t. _ \t\", OF _ ext], rename_tac ref) apply (rule_tac N=N and P="\ko. \tcb. ko = TCB tcb \ P tcb" and p=ref in init_arch_objects_obj_at_non_arch) @@ -122,7 +119,7 @@ lemma init_arch_objects_tcb_heap[wp]: by (auto simp: obj_at_kh_kheap_simps pred_map_simps vs_heap_simps) lemma init_arch_objects_sc_heap[wp]: - "init_arch_objects t p n s r \\s. P (scs_of s)\" + "init_arch_objects t d p n s r \\s. P (scs_of s)\" apply (rule pred_map_heap_lift[where heap=scs_of and P=P and R=\, simplified]) apply (rule rsubst[where P="\t. _ \t\", OF _ ext], rename_tac ref) apply (rule_tac N=N and P="\ko. \sc n. ko = SchedContext sc n \ P sc" and p=ref in init_arch_objects_obj_at_non_arch) diff --git a/proof/invariant-abstract/DetSchedDomainTime_AI.thy b/proof/invariant-abstract/DetSchedDomainTime_AI.thy index b511682e6b..1ce4ce8ca3 100644 --- a/proof/invariant-abstract/DetSchedDomainTime_AI.thy +++ b/proof/invariant-abstract/DetSchedDomainTime_AI.thy @@ -58,7 +58,7 @@ locale DetSchedDomainTime_AI = assumes handle_arch_fault_reply_domain_list_inv'[wp]: "\P f t x y. \\s::det_state. P (domain_list s)\ handle_arch_fault_reply f t x y \\_ s. P (domain_list s)\" assumes init_arch_objects_domain_list_inv'[wp]: - "\P t p n s r. \\s::det_state. P (domain_list s)\ init_arch_objects t p n s r \\_ s. P (domain_list s)\" + "\P t d p n s r. \\s::det_state. P (domain_list s)\ init_arch_objects t d p n s r \\_ s. P (domain_list s)\" assumes arch_post_modify_registers_domain_list_inv'[wp]: "\P t p. \\s::det_state. P (domain_list s)\ arch_post_modify_registers t p \\_ s. P (domain_list s)\" assumes arch_invoke_irq_control_domain_list_inv'[wp]: diff --git a/proof/invariant-abstract/DetSchedInvs_AI.thy b/proof/invariant-abstract/DetSchedInvs_AI.thy index c4bcdb477b..f6e6d0b15b 100644 --- a/proof/invariant-abstract/DetSchedInvs_AI.thy +++ b/proof/invariant-abstract/DetSchedInvs_AI.thy @@ -8,11 +8,9 @@ theory DetSchedInvs_AI imports ArchDeterministic_AI begin -context begin interpretation Arch . -requalify_facts +arch_requalify_facts machine_op_lift_machine_times machine_ops_last_machine_time -end lemmas [wp] = machine_op_lift_machine_times diff --git a/proof/invariant-abstract/DetSchedSchedule_AI.thy b/proof/invariant-abstract/DetSchedSchedule_AI.thy index 79f069d9ae..2eaf948e64 100644 --- a/proof/invariant-abstract/DetSchedSchedule_AI.thy +++ b/proof/invariant-abstract/DetSchedSchedule_AI.thy @@ -8,26 +8,21 @@ theory DetSchedSchedule_AI imports ArchDetSchedDomainTime_AI begin -context begin interpretation Arch . - -requalify_consts +arch_requalify_consts time_oracle -requalify_facts +arch_requalify_facts kernelWCET_us_non_zero kernelWCET_ticks_non_zero - do_ipc_transfer_cur_thread - machine_ops_last_machine_time - handle_arch_fault_reply_typ_at getCurrentTime_def install_tcb_cap_sc_tcb_sc_at - -end + set_simple_ko_ioports lemmas [wp] = do_ipc_transfer_cur_thread handle_arch_fault_reply_typ_at machine_ops_last_machine_time + set_simple_ko_ioports (* FIXME RT: move and rename *) lemma hoare_drop_assertion: @@ -22891,7 +22886,7 @@ lemma update_waiting_ntfn_cur_sc_in_release_q_imp_zero_consumed: \\_. cur_sc_in_release_q_imp_zero_consumed\" supply if_split[split del] if_cong[cong] apply (clarsimp simp: update_waiting_ntfn_def) - apply (wpsimp wp: set_thread_state_invs set_ntfn_minor_invs Arch.set_simple_ko_ioports + apply (wpsimp wp: set_thread_state_invs set_ntfn_minor_invs maybe_donate_sc_cur_sc_in_release_q_imp_zero_consumed refill_unblock_check_active_scs_valid maybeM_inv simp: invs_def valid_state_def valid_pspace_def) diff --git a/proof/invariant-abstract/Deterministic_AI.thy b/proof/invariant-abstract/Deterministic_AI.thy index 20128220d3..7872d5eb45 100644 --- a/proof/invariant-abstract/Deterministic_AI.thy +++ b/proof/invariant-abstract/Deterministic_AI.thy @@ -8,14 +8,12 @@ theory Deterministic_AI imports ArchAInvsPre begin -context begin interpretation Arch . -requalify_facts +arch_requalify_facts update_work_units_empty_fail reset_work_units_empty_fail set_domain_empty_fail thread_set_domain_empty_fail arch_post_cap_deletion_valid_list -end lemmas [wp] = update_work_units_empty_fail diff --git a/proof/invariant-abstract/Detype_AI.thy b/proof/invariant-abstract/Detype_AI.thy index 2d5072dbcf..4f475d795c 100644 --- a/proof/invariant-abstract/Detype_AI.thy +++ b/proof/invariant-abstract/Detype_AI.thy @@ -8,9 +8,7 @@ theory Detype_AI imports ArchRetype_AI IpcCancel_AI begin -context begin interpretation Arch . - -requalify_facts +arch_requalify_facts valid_arch_mdb_detype clearMemory_invs invs_irq_state_independent @@ -20,8 +18,6 @@ requalify_facts caps_region_kernel_window_imp init_arch_objects_wps -end - declare clearMemory_invs[wp] declare invs_irq_state_independent[intro!, simp] @@ -1108,7 +1104,7 @@ lemma dom_known_length: by (drule domI[where m=f], simp) -lemma (in Detype_AI) cte_map_not_null_outside: (*FIXME: arch_split*) +lemma (in Detype_AI) cte_map_not_null_outside: (*FIXME: arch-split*) "\ cte_wp_at ((\) cap.NullCap) p (s :: 'a state); cte_wp_at ((=) cap) p' s;is_untyped_cap cap; descendants_range cap p' s; untyped_children_in_mdb s; diff --git a/proof/invariant-abstract/EmptyFail_AI.thy b/proof/invariant-abstract/EmptyFail_AI.thy index 4034fc5929..367830a4ef 100644 --- a/proof/invariant-abstract/EmptyFail_AI.thy +++ b/proof/invariant-abstract/EmptyFail_AI.thy @@ -8,11 +8,9 @@ theory EmptyFail_AI imports ArchTcb_AI begin -context begin interpretation Arch . -requalify_facts +arch_requalify_facts ef_machine_op_lift empty_fail_setDeadline -end lemmas [wp] = ef_ignore_failure ef_machine_op_lift diff --git a/proof/invariant-abstract/Finalise_AI.thy b/proof/invariant-abstract/Finalise_AI.thy index 69d631c52f..985b81689d 100644 --- a/proof/invariant-abstract/Finalise_AI.thy +++ b/proof/invariant-abstract/Finalise_AI.thy @@ -20,19 +20,16 @@ where | cap.Zombie r zb n \ {(r, replicate (zombie_cte_bits zb) False)} | _ \ {})" -context begin interpretation Arch . +arch_requalify_consts (A) + unmap_page -requalify_consts +arch_requalify_consts vs_cap_ref - unmap_page - clearMemory arch_post_cap_delete_pre -requalify_facts - final_cap_lift +arch_requalify_facts no_irq_clearMemory - valid_global_refsD - valid_global_refsD2 + final_cap_lift arch_post_cap_deletion_valid_objs arch_post_cap_deletion_cte_wp_at arch_post_cap_deletion_caps_of_state @@ -43,8 +40,6 @@ requalify_facts invs_update_time_stamp_independent invs_getCurrentTime_independent -end - declare invs_irq_state_independent[intro!, simp] declare invs_update_time_stamp_independent[intro!, simp] declare invs_getCurrentTime_independent[intro!, simp] diff --git a/proof/invariant-abstract/Interrupt_AI.thy b/proof/invariant-abstract/Interrupt_AI.thy index 5642df93e9..5d322779da 100644 --- a/proof/invariant-abstract/Interrupt_AI.thy +++ b/proof/invariant-abstract/Interrupt_AI.thy @@ -12,14 +12,8 @@ theory Interrupt_AI imports ArchIpc_AI begin - -context begin interpretation Arch . -requalify_consts - maxIRQ - -requalify_facts +arch_requalify_facts arch_post_cap_deletion_mdb_inv -end definition interrupt_derived :: "cap \ cap \ bool" diff --git a/proof/invariant-abstract/InvariantsPre_AI.thy b/proof/invariant-abstract/InvariantsPre_AI.thy index e26e3585a6..28d7f19651 100644 --- a/proof/invariant-abstract/InvariantsPre_AI.thy +++ b/proof/invariant-abstract/InvariantsPre_AI.thy @@ -8,16 +8,6 @@ theory InvariantsPre_AI imports LevityCatch_AI begin -context begin interpretation Arch . - -requalify_types - aa_type - -requalify_consts - aa_type - -end - (* FIXME: move *) declare ranI [intro] diff --git a/proof/invariant-abstract/Invariants_AI.thy b/proof/invariant-abstract/Invariants_AI.thy index 03cd92f40a..9f04e347f6 100644 --- a/proof/invariant-abstract/Invariants_AI.thy +++ b/proof/invariant-abstract/Invariants_AI.thy @@ -9,16 +9,25 @@ theory Invariants_AI imports ArchInvariants_AI begin -context begin interpretation Arch . - -requalify_types +arch_requalify_types iarch_tcb -requalify_consts +arch_requalify_consts (A) + arch_cap_is_device + ASIDPoolObj + +(* we need to know the sizes of arch objects in the generic context *) +arch_requalify_facts (A) + cte_level_bits_def + tcb_bits_def + endpoint_bits_def + ntfn_bits_def + reply_bits_def + +arch_requalify_consts not_kernel_window global_refs arch_obj_bits_type - arch_cap_is_device is_nondevice_page_cap state_hyp_refs_of hyp_refs_of @@ -45,9 +54,9 @@ requalify_consts valid_global_vspace_mappings pspace_in_kernel_window - ASIDPoolObj - + last_machine_time_update last_machine_time + time_state_update time_state valid_vs_lookup @@ -62,7 +71,7 @@ requalify_consts vs_lookup vs_lookup_pages -requalify_facts +arch_requalify_facts valid_arch_sizes aobj_bits_T valid_arch_cap_def2 @@ -77,7 +86,7 @@ requalify_facts valid_arch_state_lift aobj_at_default_arch_cap_valid aobj_ref_default - acap_rights_update_id + wf_acap_rights_update_id physical_arch_cap_has_ref wellformed_arch_default valid_vspace_obj_default' @@ -98,12 +107,13 @@ requalify_facts wellformed_arch_typ valid_arch_tcb_pspaceI valid_arch_tcb_lift - cte_level_bits_def obj_ref_not_arch_gen_ref arch_gen_ref_not_obj_ref arch_gen_obj_refs_inD same_aobject_same_arch_gen_refs valid_arch_mdb_eqI + iarch_tcb_context_set + iarch_tcb_set_registers valid_sc_size_less_word_bits kernelWCET_us_pos @@ -115,12 +125,10 @@ lemmas x_bit_defs [simp] = iarch_tcb_context_set iarch_tcb_set_registers -end +lemmas [intro!] = idle_global idle_sc_global wf_acap_rights_update_id -lemmas [intro!] = idle_global idle_sc_global acap_rights_update_id - -lemmas [simp] = acap_rights_update_id state_hyp_refs_update idle_ptrs_neq - tcb_arch_ref_simps hyp_live_tcb_simps hyp_refs_of_simps +lemmas [simp] = wf_acap_rights_update_id state_hyp_refs_update idle_ptrs_neq + tcb_arch_ref_simps hyp_live_tcb_simps hyp_refs_of_simps \ \---------------------------------------------------------------------------\ @@ -2111,17 +2119,13 @@ lemma cte_wp_at_pspaceI: "\ cte_wp_at P slot s; kheap s = kheap s' \ \ cte_wp_at P slot s'" by (simp add: cte_wp_at_cases) -context Arch begin -lemma valid_arch_cap_pspaceI: +(* generic consequence of architecture-specific details *) +lemma (in Arch) valid_arch_cap_pspaceI: "\ valid_arch_cap acap s; kheap s = kheap s' \ \ valid_arch_cap acap s'" unfolding valid_arch_cap_def by (auto intro: obj_at_pspaceI split: arch_cap.split) -end -context begin interpretation Arch . -requalify_facts - valid_arch_cap_pspaceI -end +requalify_facts Arch.valid_arch_cap_pspaceI lemma valid_cap_pspaceI: "\ s \ cap; kheap s = kheap s' \ \ s' \ cap" @@ -3635,11 +3639,11 @@ lemma valid_idle_lift: lemmas caps_of_state_valid_cap = cte_wp_valid_cap [OF caps_of_state_cteD] - +(* generic consequence of architecture-specific details *) lemma (in Arch) obj_ref_is_arch: "\aobj_ref c = Some r; valid_arch_cap c s\ \ \ ako. kheap s r = Some (ArchObj ako)" -by (auto simp add: valid_arch_cap_def obj_at_def valid_arch_cap_ref_def split: arch_cap.splits if_splits) - + by (auto simp: valid_arch_cap_def obj_at_def valid_arch_cap_ref_def + split: arch_cap.splits if_splits) requalify_facts Arch.obj_ref_is_arch @@ -4036,7 +4040,7 @@ lemma invs_sym_refs [elim!]: "invs s \ sym_refs (state_refs_of s)" by (simp add: invs_def valid_state_def valid_pspace_def) -lemma invs_hyp_sym_refs [elim!]: (* ARMHYP move and requalify *) +lemma invs_hyp_sym_refs [elim!]: "invs s \ sym_refs (state_hyp_refs_of s)" by (simp add: invs_def valid_state_def valid_pspace_def) diff --git a/proof/invariant-abstract/IpcCancel_AI.thy b/proof/invariant-abstract/IpcCancel_AI.thy index e58794000f..d012d54109 100644 --- a/proof/invariant-abstract/IpcCancel_AI.thy +++ b/proof/invariant-abstract/IpcCancel_AI.thy @@ -8,16 +8,11 @@ theory IpcCancel_AI imports ArchSchedule_AI begin -context begin interpretation Arch . - -requalify_facts - arch_stit_invs +arch_requalify_facts arch_post_cap_deletion_pred_tcb_at arch_post_cap_deletion_cur_thread as_user_hyp_refs_of -end - declare arch_post_cap_deletion_pred_tcb_at[wp] declare as_user_hyp_refs_of[wp] diff --git a/proof/invariant-abstract/IpcDet_AI.thy b/proof/invariant-abstract/IpcDet_AI.thy index 995af624df..22a236a90e 100644 --- a/proof/invariant-abstract/IpcDet_AI.thy +++ b/proof/invariant-abstract/IpcDet_AI.thy @@ -10,17 +10,9 @@ imports "./$L4V_ARCH/ArchIpc_AI" begin -context begin interpretation Arch . - -requalify_consts - make_arch_fault_msg - -requalify_facts - make_arch_fault_msg_invs +arch_requalify_facts make_arch_fault_msg_valid_replies -end - lemma replies_with_sc_kh_update_sc: "sc_replies (f sc v) = sc_replies sc \ replies_with_sc (s\kheap := (kheap s)(p \ SchedContext (f sc v) n)\) diff --git a/proof/invariant-abstract/Ipc_AI.thy b/proof/invariant-abstract/Ipc_AI.thy index 223f0d6a37..47f067d43e 100644 --- a/proof/invariant-abstract/Ipc_AI.thy +++ b/proof/invariant-abstract/Ipc_AI.thy @@ -10,21 +10,18 @@ imports "Monads.WPBang" begin -context begin interpretation Arch . -requalify_consts +arch_requalify_consts in_device_frame -requalify_facts - set_mi_invs + +arch_requalify_facts set_mrs_ioports - as_user_ioports set_message_info_ioports copy_mrs_ioports store_word_offs_ioports make_arch_fault_msg_ioports arch_derive_cap_notzombie arch_derive_cap_notIRQ - -end + set_mi_invs declare set_mi_invs[wp] diff --git a/proof/invariant-abstract/KHeapPre_AI.thy b/proof/invariant-abstract/KHeapPre_AI.thy index b89e1b22ac..83628357b1 100644 --- a/proof/invariant-abstract/KHeapPre_AI.thy +++ b/proof/invariant-abstract/KHeapPre_AI.thy @@ -8,6 +8,12 @@ theory KHeapPre_AI imports Machine_AI begin +arch_requalify_facts + det_getRegister + det_setRegister + det_getRestartPC + det_setNextPC + primrec same_caps :: "Structures_A.kernel_object \ Structures_A.kernel_object \ bool" where diff --git a/proof/invariant-abstract/KHeap_AI.thy b/proof/invariant-abstract/KHeap_AI.thy index e0fbc72341..8f0f18bc3f 100644 --- a/proof/invariant-abstract/KHeap_AI.thy +++ b/proof/invariant-abstract/KHeap_AI.thy @@ -8,15 +8,15 @@ theory KHeap_AI imports ArchKHeap_AI begin -context begin interpretation Arch . - -requalify_consts +arch_requalify_consts obj_is_device valid_vso_at non_vspace_obj vspace_obj_pred -requalify_facts +arch_requalify_facts + getActiveIRQ_neq_non_kernel + dmo_getActiveIRQ_non_kernel pspace_in_kernel_window_atyp_lift valid_vspace_objs_lift_weak vs_lookup_vspace_obj_at_lift @@ -63,17 +63,12 @@ requalify_facts default_arch_object_not_live default_tcb_not_live - getActiveIRQ_neq_non_kernel - dmo_getActiveIRQ_non_kernel - valid_arch_tcb_same_type valid_arch_tcb_typ_at valid_tcb_arch_ref_lift update_valid_tcb valid_tcbs_machine_state_update -end - declare update_sched_context_hyp_refs_of[wp] lemmas cap_is_device_obj_is_device[simp] = cap_is_device_obj_is_device diff --git a/proof/invariant-abstract/LevityCatch_AI.thy b/proof/invariant-abstract/LevityCatch_AI.thy index f17cce99d3..25a8b9e1ba 100644 --- a/proof/invariant-abstract/LevityCatch_AI.thy +++ b/proof/invariant-abstract/LevityCatch_AI.thy @@ -13,17 +13,19 @@ begin (* FIXME: eliminate mapM_UNIV_wp, use mapM_wp' directly *) lemmas mapM_UNIV_wp = mapM_wp' -context begin interpretation Arch . - -requalify_consts +arch_requalify_consts ptrFromPAddr addrFromPPtr -requalify_facts + +arch_requalify_facts ptrFormPAddr_addFromPPtr aobj_ref_arch_cap -end + arch_finalise_cap_bcorres + prepare_thread_delete_bcorres lemmas aobj_ref_arch_cap_simps[simp] = aobj_ref_arch_cap +lemmas [wp] = arch_finalise_cap_bcorres prepare_thread_delete_bcorres + lemma detype_arch_state: "arch_state (detype S s) = arch_state s" by (simp add: detype_def) @@ -49,7 +51,6 @@ lemmas cap_irqs_simps[simp] = declare liftE_wp[wp] declare case_sum_True[simp] -declare select_singleton[simp] crunch_ignore (add: do_extended_op) diff --git a/proof/invariant-abstract/RISCV64/ArchADT_AI.thy b/proof/invariant-abstract/RISCV64/ArchADT_AI.thy index 17c4ce4666..ed33b01b48 100644 --- a/proof/invariant-abstract/RISCV64/ArchADT_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchADT_AI.thy @@ -11,7 +11,7 @@ imports "Lib.Simulation" Invariants_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming subsection \Constructing a virtual-memory view\ diff --git a/proof/invariant-abstract/RISCV64/ArchAInvsPre.thy b/proof/invariant-abstract/RISCV64/ArchAInvsPre.thy index b9609db770..7beaffcb88 100644 --- a/proof/invariant-abstract/RISCV64/ArchAInvsPre.thy +++ b/proof/invariant-abstract/RISCV64/ArchAInvsPre.thy @@ -10,9 +10,7 @@ begin unbundle l4v_word_context -context Arch begin - -global_naming RISCV64 +context Arch begin arch_global_naming lemma canonical_not_kernel_is_user: "\ v \ kernel_mappings; canonical_address v \ \ v \ user_region " @@ -213,8 +211,7 @@ lemma device_frame_in_device_region: \ device_state (machine_state s) p \ None" by (auto simp add: pspace_respects_device_region_def dom_def device_mem_def) -global_naming Arch -named_theorems AInvsPre_asms +named_theorems AInvsPre_assms lemma get_vspace_of_thread_asid_or_global_pt: "(\asid. vspace_for_asid asid s = Some (get_vspace_of_thread (kheap s) (arch_state s) t)) @@ -222,7 +219,7 @@ lemma get_vspace_of_thread_asid_or_global_pt: by (auto simp: get_vspace_of_thread_def split: option.split kernel_object.split cap.split arch_cap.split) -lemma ptable_rights_imp_frame[AInvsPre_asms]: +lemma ptable_rights_imp_frame[AInvsPre_assms]: assumes "valid_state s" shows "\ ptable_rights t s x \ {}; ptable_lift t s x = Some (addrFromPPtr y) \ \ in_user_frame y s \ in_device_frame y s" @@ -264,12 +261,7 @@ end interpretation AInvsPre?: AInvsPre proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact AInvsPre_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact AInvsPre_assms)?) qed -requalify_facts - RISCV64.user_mem_dom_cong - RISCV64.device_mem_dom_cong - RISCV64.device_frame_in_device_region - end diff --git a/proof/invariant-abstract/RISCV64/ArchAcc_AI.thy b/proof/invariant-abstract/RISCV64/ArchAcc_AI.thy index 82c31d024d..fcb569ae7d 100644 --- a/proof/invariant-abstract/RISCV64/ArchAcc_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchAcc_AI.thy @@ -20,7 +20,7 @@ lemma valid_vso_at[wp]:"\valid_vso_at level p\ f \\ case aci of MakePool frame slot parent base \ @@ -438,7 +438,7 @@ lemma equal_kernel_mappings: end -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemma valid_arch_state_strg: "valid_arch_state s \ ap \ ran (asid_table s) \ asid_pool_at ap s \ @@ -1346,22 +1346,4 @@ lemma arch_pinv_ct_active: end - -context begin interpretation Arch . - -requalify_consts - valid_arch_inv - -requalify_facts - invoke_arch_tcb - invoke_arch_invs - sts_valid_arch_inv - arch_decode_inv_wf - arch_pinv_st_tcb_at - arch_pinv_ct_active - -end - -lemmas [wp] = invoke_arch_invs arch_decode_inv_wf arch_pinv_ct_active - end diff --git a/proof/invariant-abstract/RISCV64/ArchBCorres2_AI.thy b/proof/invariant-abstract/RISCV64/ArchBCorres2_AI.thy index 88b0e12e8b..600480fec5 100644 --- a/proof/invariant-abstract/RISCV64/ArchBCorres2_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchBCorres2_AI.thy @@ -9,7 +9,7 @@ imports BCorres2_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemma choose_switch_or_idle: "((), s') \ fst (choose_thread s) \ diff --git a/proof/invariant-abstract/RISCV64/ArchBCorres_AI.thy b/proof/invariant-abstract/RISCV64/ArchBCorres_AI.thy index b87bd87d44..35c7a74f4f 100644 --- a/proof/invariant-abstract/RISCV64/ArchBCorres_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchBCorres_AI.thy @@ -9,7 +9,7 @@ imports BCorres_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemma vspace_for_asid_truncate[simp]: "vspace_for_asid asid (truncate_state s) = vspace_for_asid asid s" @@ -39,8 +39,4 @@ crunch prepare_thread_delete end -requalify_facts RISCV64.arch_finalise_cap_bcorres RISCV64.prepare_thread_delete_bcorres - -declare arch_finalise_cap_bcorres[wp] prepare_thread_delete_bcorres[wp] - end diff --git a/proof/invariant-abstract/RISCV64/ArchBits_AI.thy b/proof/invariant-abstract/RISCV64/ArchBits_AI.thy index f5064287ec..e2665392f5 100644 --- a/proof/invariant-abstract/RISCV64/ArchBits_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchBits_AI.thy @@ -8,7 +8,7 @@ theory ArchBits_AI imports Invariants_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemma invs_unique_table_caps[elim!]: "invs s \ unique_table_caps s" diff --git a/proof/invariant-abstract/RISCV64/ArchCNodeInv_AI.thy b/proof/invariant-abstract/RISCV64/ArchCNodeInv_AI.thy index d50860c4a4..66cdc0b39d 100644 --- a/proof/invariant-abstract/RISCV64/ArchCNodeInv_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchCNodeInv_AI.thy @@ -8,7 +8,7 @@ theory ArchCNodeInv_AI imports CNodeInv_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming named_theorems CNodeInv_AI_assms @@ -514,7 +514,7 @@ global_interpretation CNodeInv_AI?: CNodeInv_AI termination rec_del by (rule rec_del_termination) -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemma post_cap_delete_pre_is_final_cap': "\s. @@ -766,7 +766,7 @@ global_interpretation CNodeInv_AI_2?: CNodeInv_AI_2 qed -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemma finalise_cap_rvk_prog [CNodeInv_AI_assms]: "\\s. revoke_progress_ord m (\x. map_option cap_to_rpo (caps_of_state s x))\ @@ -877,7 +877,7 @@ termination cap_revoke by (rule cap_revoke_termination) declare cap_revoke.simps[simp del] -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming crunch finalise_slot for typ_at[wp, CNodeInv_AI_assms]: "\s. P (typ_at T p s)" @@ -902,7 +902,7 @@ global_interpretation CNodeInv_AI_4?: CNodeInv_AI_4 qed -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemma cap_move_ioports: "\valid_ioports and cte_wp_at ((=) cap.NullCap) ptr' diff --git a/proof/invariant-abstract/RISCV64/ArchCSpaceInvPre_AI.thy b/proof/invariant-abstract/RISCV64/ArchCSpaceInvPre_AI.thy index 26c89dc4e8..65898cf05a 100644 --- a/proof/invariant-abstract/RISCV64/ArchCSpaceInvPre_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchCSpaceInvPre_AI.thy @@ -13,7 +13,7 @@ imports CSpaceInvPre_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemma aobj_ref_acap_rights_update[simp]: "aobj_ref (acap_rights_update f x) = aobj_ref x" @@ -368,7 +368,7 @@ lemma cap_master_arch_cap_rights [simp]: by (simp add: cap_master_arch_cap_def acap_rights_update_def split: arch_cap.splits) -lemma acap_rights_update_id [intro!, simp]: +lemma valid_acap_rights_update_id [intro!, simp]: "valid_arch_cap ac s \ acap_rights_update (acap_rights ac) ac = ac" unfolding acap_rights_update_def acap_rights_def valid_arch_cap_def by (cases ac; simp) diff --git a/proof/invariant-abstract/RISCV64/ArchCSpaceInv_AI.thy b/proof/invariant-abstract/RISCV64/ArchCSpaceInv_AI.thy index 81ad680760..d914fefd90 100644 --- a/proof/invariant-abstract/RISCV64/ArchCSpaceInv_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchCSpaceInv_AI.thy @@ -12,7 +12,7 @@ theory ArchCSpaceInv_AI imports CSpaceInv_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming definition safe_ioport_insert :: "cap \ cap \ 'a::state_ext state \ bool" @@ -178,8 +178,4 @@ lemmas cap_vptr_simps [simp] = end -context begin interpretation Arch . -requalify_facts replace_cap_invs -end - end diff --git a/proof/invariant-abstract/RISCV64/ArchCSpacePre_AI.thy b/proof/invariant-abstract/RISCV64/ArchCSpacePre_AI.thy index 059a2d01ba..74e8ce205b 100644 --- a/proof/invariant-abstract/RISCV64/ArchCSpacePre_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchCSpacePre_AI.thy @@ -12,7 +12,7 @@ theory ArchCSpacePre_AI imports CSpacePre_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemmas typ_at_eq_kheap_obj = typ_at_eq_kheap_obj atyp_at_eq_kheap_obj diff --git a/proof/invariant-abstract/RISCV64/ArchCSpace_AI.thy b/proof/invariant-abstract/RISCV64/ArchCSpace_AI.thy index 8d7e5a762a..79a5f74e7d 100644 --- a/proof/invariant-abstract/RISCV64/ArchCSpace_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchCSpace_AI.thy @@ -12,7 +12,7 @@ theory ArchCSpace_AI imports CSpace_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming named_theorems CSpace_AI_assms @@ -330,7 +330,7 @@ end global_interpretation cap_insert_crunches?: cap_insert_crunches . -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemma cap_insert_cap_refs_in_kernel_window[wp, CSpace_AI_assms]: "\cap_refs_in_kernel_window @@ -492,7 +492,7 @@ global_interpretation CSpace_AI?: CSpace_AI qed -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemma is_cap_simps': "is_cnode_cap cap = (\r bits g. cap = cap.CNodeCap r bits g)" @@ -597,12 +597,4 @@ lemma set_cap_kernel_window_simple: end -context begin interpretation Arch . - -requalify_facts - set_cap_valid_arch_caps_simple - set_cap_kernel_window_simple - -end - end diff --git a/proof/invariant-abstract/RISCV64/ArchCrunchSetup_AI.thy b/proof/invariant-abstract/RISCV64/ArchCrunchSetup_AI.thy index 7191762c17..5cc6c4d7d3 100644 --- a/proof/invariant-abstract/RISCV64/ArchCrunchSetup_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchCrunchSetup_AI.thy @@ -10,7 +10,7 @@ imports "Lib.Crunch_Instances_NonDet" begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming crunch_ignore (add: debugPrint clearMemory pt_lookup_from_level) diff --git a/proof/invariant-abstract/RISCV64/ArchDetSchedAux_AI.thy b/proof/invariant-abstract/RISCV64/ArchDetSchedAux_AI.thy index 8bf5a4f022..68bea77d3d 100644 --- a/proof/invariant-abstract/RISCV64/ArchDetSchedAux_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchDetSchedAux_AI.thy @@ -8,7 +8,7 @@ theory ArchDetSchedAux_AI imports DetSchedAux_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming named_theorems DetSchedAux_AI_assms @@ -33,7 +33,7 @@ lemma copy_global_mappings_valid_sched_pred[wp]: by (wpsimp simp: copy_global_mappings_def store_pte_def wp: mapM_x_wp_inv) lemma init_arch_objects_valid_sched_pred[wp, DetSchedAux_AI_assms]: - "init_arch_objects new_type ptr num_objects obj_sz refs \valid_sched_pred_strong P\" + "init_arch_objects new_type dev ptr num_objects obj_sz refs \valid_sched_pred_strong P\" by (wpsimp simp: init_arch_objects_def wp: dmo_valid_sched_pred mapM_x_wp_inv) crunch init_arch_objects @@ -127,12 +127,12 @@ proof goal_cases case 1 show ?case by (unfold_locales; (fact DetSchedAux_AI_assms)?) qed -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming (* FIXME: move? *) lemma init_arch_objects_obj_at_impossible: "\ao. \ P (ArchObj ao) \ - \\s. Q (obj_at P p s)\ init_arch_objects a b c d e \\rv s. Q (obj_at P p s)\" + \\s. Q (obj_at P p s)\ init_arch_objects a b c d e f \\rv s. Q (obj_at P p s)\" by (auto intro: init_arch_objects_obj_at_non_pt) lemma perform_asid_control_etcb_at: diff --git a/proof/invariant-abstract/RISCV64/ArchDetSchedDomainTime_AI.thy b/proof/invariant-abstract/RISCV64/ArchDetSchedDomainTime_AI.thy index e25e14eed2..a7303085e3 100644 --- a/proof/invariant-abstract/RISCV64/ArchDetSchedDomainTime_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchDetSchedDomainTime_AI.thy @@ -8,7 +8,7 @@ theory ArchDetSchedDomainTime_AI imports DetSchedDomainTime_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming named_theorems DetSchedDomainTime_AI_assms @@ -63,7 +63,7 @@ proof goal_cases case 1 show ?case by (unfold_locales; (fact DetSchedDomainTime_AI_assms)?) qed -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming crunch arch_perform_invocation, arch_mask_irq_signal for domain_list_inv [wp, DetSchedDomainTime_AI_assms]: "\s::det_state. P (domain_list s)" diff --git a/proof/invariant-abstract/RISCV64/ArchDetSchedSchedule_AI.thy b/proof/invariant-abstract/RISCV64/ArchDetSchedSchedule_AI.thy index c14de118d4..0a24a54c15 100644 --- a/proof/invariant-abstract/RISCV64/ArchDetSchedSchedule_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchDetSchedSchedule_AI.thy @@ -8,7 +8,7 @@ theory ArchDetSchedSchedule_AI imports DetSchedSchedule_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming named_theorems DetSchedSchedule_AI_assms @@ -330,7 +330,7 @@ proof goal_cases case 1 show ?case by (unfold_locales; (fact DetSchedSchedule_AI_assms)?; wpsimp) qed -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemma handle_reserved_irq_trivial[wp]: "handle_reserved_irq irq \Q\" diff --git a/proof/invariant-abstract/RISCV64/ArchDeterministic_AI.thy b/proof/invariant-abstract/RISCV64/ArchDeterministic_AI.thy index 429d705bb3..bfd8f93b9a 100644 --- a/proof/invariant-abstract/RISCV64/ArchDeterministic_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchDeterministic_AI.thy @@ -8,7 +8,7 @@ theory ArchDeterministic_AI imports Deterministic_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming named_theorems Deterministic_AI_assms @@ -30,7 +30,7 @@ global_interpretation Deterministic_AI_1?: Deterministic_AI_1 case 1 show ?case by (unfold_locales; (fact Deterministic_AI_assms)?) qed -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming crunch arch_invoke_irq_handler for valid_list[wp,Deterministic_AI_assms]: valid_list diff --git a/proof/invariant-abstract/RISCV64/ArchDetype_AI.thy b/proof/invariant-abstract/RISCV64/ArchDetype_AI.thy index d8943c8b2b..b369bb5a51 100644 --- a/proof/invariant-abstract/RISCV64/ArchDetype_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchDetype_AI.thy @@ -8,18 +8,18 @@ theory ArchDetype_AI imports Detype_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming -named_theorems Detype_AI_asms +named_theorems Detype_AI_assms -lemma valid_globals_irq_node[Detype_AI_asms]: +lemma valid_globals_irq_node[Detype_AI_assms]: "\ valid_global_refs s; cte_wp_at ((=) cap) ptr s \ \ interrupt_irq_node s irq \ cap_range cap" apply (erule(1) valid_global_refsD) apply (simp add: global_refs_def) done -lemma caps_of_state_ko[Detype_AI_asms]: +lemma caps_of_state_ko[Detype_AI_assms]: "valid_cap cap s \ is_untyped_cap cap \ cap_range cap = {} \ @@ -33,7 +33,7 @@ lemma caps_of_state_ko[Detype_AI_asms]: split: option.splits if_splits)+ done -lemma mapM_x_storeWord[Detype_AI_asms]: +lemma mapM_x_storeWord[Detype_AI_assms]: (* FIXME: taken from Retype_C.thy and adapted wrt. the missing intvl syntax. *) assumes al: "is_aligned ptr word_size_bits" shows "mapM_x (\x. storeWord (ptr + of_nat x * word_size) 0) [0..x. if x \ S then {} else state_hyp_refs_of s x)" by (rule ext, simp add: state_hyp_refs_of_def detype_def) -lemma valid_ioports_detype[Detype_AI_asms]: +lemma valid_ioports_detype[Detype_AI_assms]: "valid_ioports s \ valid_ioports (detype (untyped_range cap) s)" by simp @@ -117,7 +117,7 @@ interpretation Detype_AI?: Detype_AI proof goal_cases interpret Arch . case 1 show ?case - by (intro_locales; (unfold_locales; fact Detype_AI_asms)?) + by (intro_locales; (unfold_locales; fact Detype_AI_assms)?) qed context detype_locale_arch begin @@ -599,8 +599,8 @@ interpretation Detype_AI_2 Detype_AI_2.intro by blast -context begin interpretation Arch . -lemma delete_objects_invs[wp]: +(* generic consequence of architecture-specific details *) +lemma (in Arch) delete_objects_invs[wp]: "\(\s. \slot. cte_wp_at ((=) (cap.UntypedCap dev ptr bits f)) slot s \ descendants_range (cap.UntypedCap dev ptr bits f) slot s) and invs and ct_active and (\s. scheduler_action s = resume_cur_thread)\ @@ -621,6 +621,9 @@ lemma delete_objects_invs[wp]: apply (simp add: valid_cap_def cap_aligned_def word_size_bits_def untyped_min_bits_def) done +requalify_facts Arch.delete_objects_invs +lemmas [wp] = delete_objects_invs + lemma scheduler_action_detype: "P (scheduler_action s) \ P (scheduler_action (detype {ptr..ptr + 2 ^ bits - 1} s))" by (auto simp: detype_def) @@ -639,5 +642,3 @@ lemma delete_objects_scheduler_action [wp]: done end - -end diff --git a/proof/invariant-abstract/RISCV64/ArchEmptyFail_AI.thy b/proof/invariant-abstract/RISCV64/ArchEmptyFail_AI.thy index cc78fb9bbc..80bbc43f39 100644 --- a/proof/invariant-abstract/RISCV64/ArchEmptyFail_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchEmptyFail_AI.thy @@ -8,7 +8,7 @@ theory ArchEmptyFail_AI imports EmptyFail_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming named_theorems EmptyFail_AI_assms @@ -28,7 +28,7 @@ global_interpretation EmptyFail_AI_load_word?: EmptyFail_AI_load_word case 1 show ?case by (unfold_locales; (fact EmptyFail_AI_assms)?) qed -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming crunch possible_switch_to,set_thread_state_act for (empty_fail) empty_fail[wp, EmptyFail_AI_assms] @@ -121,7 +121,7 @@ global_interpretation EmptyFail_AI_derive_cap?: EmptyFail_AI_derive_cap case 1 show ?case by (unfold_locales; (fact EmptyFail_AI_assms)?) qed -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemma empty_fail_pt_lookup_from_level[wp]: "empty_fail (pt_lookup_from_level level pt_ptr vptr target_pt_ptr)" @@ -156,7 +156,7 @@ global_interpretation EmptyFail_AI_rec_del?: EmptyFail_AI_rec_del case 1 show ?case by (unfold_locales; (fact EmptyFail_AI_assms)?) qed -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming crunch cap_delete, choose_thread for (empty_fail) empty_fail[wp, EmptyFail_AI_assms] @@ -175,7 +175,7 @@ global_interpretation EmptyFail_AI_schedule?: EmptyFail_AI_schedule case 1 show ?case by (unfold_locales; (fact EmptyFail_AI_assms)?) qed -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming crunch read_stval for (empty_fail) empty_fail[wp] diff --git a/proof/invariant-abstract/RISCV64/ArchFinalise_AI.thy b/proof/invariant-abstract/RISCV64/ArchFinalise_AI.thy index b881a721db..7de95b9c34 100644 --- a/proof/invariant-abstract/RISCV64/ArchFinalise_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchFinalise_AI.thy @@ -10,15 +10,15 @@ begin context Arch begin -named_theorems Finalise_AI_asms +named_theorems Finalise_AI_assms crunch prepare_thread_delete for caps_of_state[wp]: "\s. P (caps_of_state s)" (wp: crunch_wps) -declare prepare_thread_delete_caps_of_state [Finalise_AI_asms] +declare prepare_thread_delete_caps_of_state [Finalise_AI_assms] -global_naming RISCV64 +arch_global_naming lemma valid_global_refs_asid_table_udapte [iff]: "valid_global_refs (s\arch_state := riscv_asid_table_update f (arch_state s)\) = @@ -160,19 +160,17 @@ lemma unmap_page_tcb_cap_valid: done -global_naming Arch - -lemma (* replaceable_cdt_update *)[simp,Finalise_AI_asms]: +lemma (* replaceable_cdt_update *)[simp,Finalise_AI_assms]: "replaceable (cdt_update f s) = replaceable s" by (fastforce simp: replaceable_def tcb_cap_valid_def reachable_frame_cap_def reachable_target_def) -lemma (* replaceable_revokable_update *)[simp,Finalise_AI_asms]: +lemma (* replaceable_revokable_update *)[simp,Finalise_AI_assms]: "replaceable (is_original_cap_update f s) = replaceable s" by (fastforce simp: replaceable_def is_final_cap'_def2 tcb_cap_valid_def reachable_frame_cap_def reachable_target_def) -lemma (* replaceable_more_update *) [simp,Finalise_AI_asms]: +lemma (* replaceable_more_update *) [simp,Finalise_AI_assms]: "replaceable (trans_state f s) sl cap cap' = replaceable s sl cap cap'" by (simp add: replaceable_def reachable_frame_cap_def reachable_target_def) @@ -184,9 +182,9 @@ lemma reachable_frame_cap_trans_state[simp]: "reachable_frame_cap cap (trans_state f s) = reachable_frame_cap cap s" by (simp add: reachable_frame_cap_def) -lemmas [Finalise_AI_asms] = obj_refs_obj_ref_of (* used under name obj_ref_ofI *) +lemmas [Finalise_AI_assms] = obj_refs_obj_ref_of (* used under name obj_ref_ofI *) -lemma (* empty_slot_invs *) [Finalise_AI_asms]: +lemma (* empty_slot_invs *) [Finalise_AI_assms]: "\\s. invs s \ cte_wp_at (replaceable s sl cap.NullCap) sl s \ (info \ NullCap \ post_cap_delete_pre info ((caps_of_state s) (sl \ NullCap)))\ empty_slot sl info @@ -247,7 +245,7 @@ lemma (* empty_slot_invs *) [Finalise_AI_asms]: apply (simp add: is_final_cap'_def2 cte_wp_at_caps_of_state) by fastforce -lemma dom_tcb_cap_cases_lt_ARCH [Finalise_AI_asms]: +lemma dom_tcb_cap_cases_lt_ARCH [Finalise_AI_assms]: "dom tcb_cap_cases = {xs. length xs = 3 \ unat (of_bl xs :: machine_word) < 5}" apply (rule set_eqI, rule iffI) apply clarsimp @@ -257,7 +255,7 @@ lemma dom_tcb_cap_cases_lt_ARCH [Finalise_AI_asms]: apply (clarsimp simp: nat_to_cref_unat_of_bl') done -lemma (* unbind_notification_final *) [wp,Finalise_AI_asms]: +lemma (* unbind_notification_final *) [wp,Finalise_AI_assms]: "\is_final_cap' cap\ unbind_notification t \ \rv. is_final_cap' cap\" unfolding unbind_notification_def apply (wp final_cap_lift thread_set_caps_of_state_trivial hoare_drop_imps @@ -293,7 +291,7 @@ lemma length_and_unat_of_bl_length: lemmas unbind_from_sc_final_cap[wp] = final_cap_lift [OF unbind_from_sc_caps_of_state] -lemma (* finalise_cap_cases1 *)[Finalise_AI_asms]: +lemma (* finalise_cap_cases1 *)[Finalise_AI_assms]: "\\s. final \ is_final_cap' cap s \ cte_wp_at ((=) cap) slot s\ finalise_cap cap final @@ -328,12 +326,12 @@ crunch arch_thread_set (wp: crunch_wps set_object_typ_at) crunch arch_finalise_cap - for typ_at[wp,Finalise_AI_asms]: "\s. P (typ_at T p s)" + for typ_at[wp,Finalise_AI_assms]: "\s. P (typ_at T p s)" (wp: crunch_wps simp: crunch_simps unless_def assertE_def ignore: maskInterrupt set_object) crunch prepare_thread_delete - for typ_at[wp,Finalise_AI_asms]: "\s. P (typ_at T p s)" + for typ_at[wp,Finalise_AI_assms]: "\s. P (typ_at T p s)" crunch arch_thread_set for tcb_at[wp]: "\s. tcb_at p s" @@ -345,7 +343,7 @@ crunch arch_thread_get crunch prepare_thread_delete for tcb_at[wp]: "\s. tcb_at p s" -lemma (* finalise_cap_new_valid_cap *)[wp,Finalise_AI_asms]: +lemma (* finalise_cap_new_valid_cap *)[wp,Finalise_AI_assms]: "\valid_cap cap\ finalise_cap cap x \\rv. valid_cap (fst rv)\" apply (cases cap; simp) apply (wp suspend_valid_cap prepare_thread_delete_typ_at @@ -597,7 +595,7 @@ lemma as_user_valid_ioc[wp]: "\valid_ioc\ as_user t f \\rv. valid_ioc\" unfolding valid_ioc_def by (wpsimp wp: hoare_vcg_imp_lift hoare_vcg_all_lift) -lemma arch_finalise_cap_invs' [wp,Finalise_AI_asms]: +lemma arch_finalise_cap_invs' [wp,Finalise_AI_assms]: "\invs and valid_cap (ArchObjectCap cap)\ arch_finalise_cap cap final \\rv. invs\" @@ -614,7 +612,7 @@ lemma as_user_unlive[wp]: apply (wpsimp wp: set_object_wp) by (clarsimp simp: obj_at_def live_def hyp_live_def arch_tcb_context_set_def dest!: get_tcb_SomeD) -lemma obj_at_not_live_valid_arch_cap_strg [Finalise_AI_asms]: +lemma obj_at_not_live_valid_arch_cap_strg [Finalise_AI_assms]: "(s \ ArchObjectCap cap \ aobj_ref cap = Some r) \ obj_at (\ko. \ live ko) r s" by (clarsimp simp: valid_cap_def obj_at_def valid_arch_cap_ref_def @@ -783,8 +781,7 @@ lemma arch_finalise_cap_replaceable[wp]: | rule conjI)+ -global_naming Arch -lemma (* deleting_irq_handler_slot_not_irq_node *)[Finalise_AI_asms]: +lemma (* deleting_irq_handler_slot_not_irq_node *)[Finalise_AI_assms]: "\if_unsafe_then_cap and valid_global_refs and cte_wp_at (\cp. cap_irqs cp \ {}) sl\ deleting_irq_handler irq @@ -805,7 +802,7 @@ lemma (* deleting_irq_handler_slot_not_irq_node *)[Finalise_AI_asms]: apply (clarsimp simp: appropriate_cte_cap_def split: cap.split_asm) done -lemma no_cap_to_obj_with_diff_ref_finalI_ARCH[Finalise_AI_asms]: +lemma no_cap_to_obj_with_diff_ref_finalI_ARCH[Finalise_AI_assms]: "\ cte_wp_at ((=) cap) p s; is_final_cap' cap s; obj_refs cap' = obj_refs cap \ \ no_cap_to_obj_with_diff_ref cap' {p} s" @@ -827,7 +824,7 @@ lemma no_cap_to_obj_with_diff_ref_finalI_ARCH[Finalise_AI_asms]: gen_obj_refs_Int) done -lemma (* suspend_no_cap_to_obj_ref *)[wp,Finalise_AI_asms]: +lemma (* suspend_no_cap_to_obj_ref *)[wp,Finalise_AI_assms]: "\no_cap_to_obj_with_diff_ref cap S\ suspend t \\rv. no_cap_to_obj_with_diff_ref cap S\" @@ -910,7 +907,7 @@ method hammer = ((clarsimp simp: o_def dom_tcb_cap_cases_lt_ARCH wp (once) deleting_irq_handler_empty) | simp add: valid_cap_simps)+)[1] -lemma finalise_cap_replaceable [Finalise_AI_asms]: +lemma finalise_cap_replaceable [Finalise_AI_assms]: "\\s. s \ cap \ x = is_final_cap' cap s \ cte_wp_at ((=) cap) sl s \ invs s \ (cap_irqs cap \ {} \ if_unsafe_then_cap s \ valid_global_refs s) @@ -998,7 +995,7 @@ lemma finalise_cap_replaceable [Finalise_AI_asms]: apply (clarsimp simp: is_cap_simps) done -lemma (* deleting_irq_handler_cte_preserved *)[Finalise_AI_asms]: +lemma (* deleting_irq_handler_cte_preserved *)[Finalise_AI_assms]: assumes x: "\cap. P cap \ \ can_fast_finalise cap" shows "\cte_wp_at P p\ deleting_irq_handler irq \\rv. cte_wp_at P p\" apply (simp add: deleting_irq_handler_def) @@ -1016,8 +1013,8 @@ lemma arch_thread_set_cte_wp_at[wp]: done crunch prepare_thread_delete, arch_finalise_cap - for cte_wp_at[wp, Finalise_AI_asms]: "\s. P (cte_wp_at P' p s)" - and cur[wp, Finalise_AI_asms]: "\s. P (cur_thread s)" + for cte_wp_at[wp, Finalise_AI_assms]: "\s. P (cte_wp_at P' p s)" + and cur[wp, Finalise_AI_assms]: "\s. P (cur_thread s)" (simp: crunch_simps assertE_def wp: crunch_wps set_object_cte_at ignore: arch_thread_set) @@ -1026,10 +1023,10 @@ end interpretation Finalise_AI_1?: Finalise_AI_1 proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemma fast_finalise_replaceable[wp]: "\\s. s \ cap \ x = is_final_cap' cap s \ cte_wp_at ((=) cap) sl s \ invs s\ @@ -1048,8 +1045,7 @@ lemma fast_finalise_replaceable[wp]: apply (clarsimp simp: cap_irqs_def cap_irq_opt_def split: cap.split_asm) done -global_naming Arch -lemma (* cap_delete_one_invs *) [Finalise_AI_asms,wp]: +lemma (* cap_delete_one_invs *) [Finalise_AI_assms,wp]: "\invs\ cap_delete_one ptr \\rv. invs\" apply (simp add: cap_delete_one_def unless_def is_final_cap_def) apply (rule hoare_pre) @@ -1064,13 +1060,13 @@ end interpretation Finalise_AI_2?: Finalise_AI_2 proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming crunch prepare_thread_delete - for irq_node[Finalise_AI_asms,wp]: "\s. P (interrupt_irq_node s)" + for irq_node[Finalise_AI_assms,wp]: "\s. P (interrupt_irq_node s)" crunch arch_finalise_cap for irq_node[wp]: "\s. P (interrupt_irq_node s)" @@ -1176,7 +1172,7 @@ lemma invs_valid_arch_capsI: "invs s \ valid_arch_caps s" by (simp add: invs_def valid_state_def) -context Arch begin global_naming RISCV64 (*FIXME: arch_split*) +context Arch begin arch_global_naming lemma do_machine_op_reachable_pg_cap[wp]: "\\s. P (reachable_frame_cap cap s)\ @@ -1197,13 +1193,11 @@ lemma replaceable_or_arch_update_pg: done -global_naming Arch - crunch prepare_thread_delete for invs[wp]: invs (ignore: set_object) -lemma (* finalise_cap_invs *)[Finalise_AI_asms]: +lemma (* finalise_cap_invs *)[Finalise_AI_assms]: "\invs and cte_wp_at ((=) cap) slot\ finalise_cap cap x \\_ s. invs s\" apply (cases cap, simp_all split del: if_split) prefer 7 @@ -1225,21 +1219,21 @@ lemma (* finalise_cap_invs *)[Finalise_AI_asms]: apply (clarsimp simp: valid_cap_def) done -lemma (* finalise_cap_irq_node *)[Finalise_AI_asms]: +lemma (* finalise_cap_irq_node *)[Finalise_AI_assms]: "\\s. P (interrupt_irq_node s)\ finalise_cap a b \\_ s. P (interrupt_irq_node s)\" supply if_cong[cong] apply (case_tac a; simp) apply (wpsimp wp: hoare_drop_imps simp: o_def)+ done -lemmas (*arch_finalise_cte_irq_node *) [wp,Finalise_AI_asms] +lemmas (*arch_finalise_cte_irq_node *) [wp,Finalise_AI_assms] = hoare_use_eq_irq_node [OF arch_finalise_cap_irq_node arch_finalise_cap_cte_wp_at] -lemma irq_node_global_refs_ARCH [Finalise_AI_asms]: +lemma irq_node_global_refs_ARCH [Finalise_AI_assms]: "interrupt_irq_node s irq \ global_refs s" by (simp add: global_refs_def) -lemma (* get_irq_slot_fast_finalisable *)[wp,Finalise_AI_asms]: +lemma (* get_irq_slot_fast_finalisable *)[wp,Finalise_AI_assms]: "\invs\ get_irq_slot irq \cte_wp_at can_fast_finalise\" apply (simp add: get_irq_slot_def) apply wp @@ -1261,12 +1255,12 @@ lemma (* get_irq_slot_fast_finalisable *)[wp,Finalise_AI_asms]: apply (clarsimp simp: cap_range_def) done -lemma (* replaceable_or_arch_update_same *) [Finalise_AI_asms]: +lemma (* replaceable_or_arch_update_same *) [Finalise_AI_assms]: "replaceable_or_arch_update s slot cap cap" by (clarsimp simp: replaceable_or_arch_update_def replaceable_def is_arch_update_def is_cap_simps) -lemma (* replace_cap_invs_arch_update *)[Finalise_AI_asms]: +lemma (* replace_cap_invs_arch_update *)[Finalise_AI_assms]: "\\s. cte_wp_at (replaceable_or_arch_update s p cap) p s \ invs s \ cap \ cap.NullCap @@ -1291,7 +1285,7 @@ lemma dmo_pred_tcb_at[wp]: apply (clarsimp simp: pred_tcb_at_def obj_at_def) done -lemma dmo_tcb_cap_valid_ARCH [Finalise_AI_asms]: +lemma dmo_tcb_cap_valid_ARCH [Finalise_AI_assms]: "do_machine_op mop \\s. P (tcb_cap_valid cap ptr s)\" apply (simp add: tcb_cap_valid_def no_cap_to_obj_with_diff_ref_def) apply (wp_pre, wps, rule hoare_vcg_prop) @@ -1309,7 +1303,7 @@ lemma dmo_reachable_target[wp]: apply simp done -lemma (* dmo_replaceable_or_arch_update *) [Finalise_AI_asms,wp]: +lemma (* dmo_replaceable_or_arch_update *) [Finalise_AI_assms,wp]: "\\s. replaceable_or_arch_update s slot cap cap'\ do_machine_op mo \\r s. replaceable_or_arch_update s slot cap cap'\" @@ -1324,18 +1318,16 @@ lemma (* dmo_replaceable_or_arch_update *) [Finalise_AI_asms,wp]: end -context begin interpretation Arch . -requalify_consts replaceable_or_arch_update -end +arch_requalify_consts replaceable_or_arch_update interpretation Finalise_AI_3?: Finalise_AI_3 where replaceable_or_arch_update = replaceable_or_arch_update proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemma typ_at_data_at_wp: assumes typ_wp: "\a.\typ_at a p \ g \\s. typ_at a p\" @@ -1350,10 +1342,10 @@ interpretation Finalise_AI_4?: Finalise_AI_4 where replaceable_or_arch_update = replaceable_or_arch_update proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemma set_asid_pool_obj_at_ptr: "\\s. P (ArchObj (arch_kernel_obj.ASIDPool mp))\ @@ -1387,11 +1379,9 @@ lemma arch_finalise_cap_valid_cap[wp]: unfolding arch_finalise_cap_def by (wpsimp split: arch_cap.split option.split bool.split) -global_naming Arch - -lemmas clearMemory_invs[wp,Finalise_AI_asms] = clearMemory_invs +lemmas clearMemory_invs[wp,Finalise_AI_assms] = clearMemory_invs -lemma valid_idle_has_null_cap_ARCH[Finalise_AI_asms]: +lemma valid_idle_has_null_cap_ARCH[Finalise_AI_assms]: "\ if_unsafe_then_cap s; valid_global_refs s; valid_idle s; valid_irq_node s; caps_of_state s (idle_thread s, v) = Some cap \ \ cap = NullCap" @@ -1407,7 +1397,7 @@ lemma valid_idle_has_null_cap_ARCH[Finalise_AI_asms]: apply (drule_tac x=word in spec, simp) done -lemma (* zombie_cap_two_nonidles *)[Finalise_AI_asms]: +lemma (* zombie_cap_two_nonidles *)[Finalise_AI_assms]: "\ caps_of_state s ptr = Some (Zombie ptr' zbits n); invs s \ \ fst ptr \ idle_thread s \ ptr' \ idle_thread s" apply (frule valid_global_refsD2, clarsimp+) @@ -1433,7 +1423,7 @@ interpretation Finalise_AI_5?: Finalise_AI_5 where replaceable_or_arch_update = replaceable_or_arch_update proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed end diff --git a/proof/invariant-abstract/RISCV64/ArchInterruptAcc_AI.thy b/proof/invariant-abstract/RISCV64/ArchInterruptAcc_AI.thy index 3f51bd7b4e..2536ad4365 100644 --- a/proof/invariant-abstract/RISCV64/ArchInterruptAcc_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchInterruptAcc_AI.thy @@ -12,7 +12,7 @@ theory ArchInterruptAcc_AI imports InterruptAcc_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming named_theorems InterruptAcc_AI_assms diff --git a/proof/invariant-abstract/RISCV64/ArchInterrupt_AI.thy b/proof/invariant-abstract/RISCV64/ArchInterrupt_AI.thy index c456a81654..578b856ac1 100644 --- a/proof/invariant-abstract/RISCV64/ArchInterrupt_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchInterrupt_AI.thy @@ -8,7 +8,7 @@ theory ArchInterrupt_AI imports Interrupt_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming primrec arch_irq_control_inv_valid_real :: "arch_irq_control_invocation \ 'a::state_ext state \ bool" @@ -23,16 +23,16 @@ primrec arch_irq_control_inv_valid_real :: defs arch_irq_control_inv_valid_def: "arch_irq_control_inv_valid \ arch_irq_control_inv_valid_real" -named_theorems Interrupt_AI_asms +named_theorems Interrupt_AI_assms -lemma (* decode_irq_control_invocation_inv *)[Interrupt_AI_asms]: +lemma (* decode_irq_control_invocation_inv *)[Interrupt_AI_assms]: "\P\ decode_irq_control_invocation label args slot caps \\rv. P\" apply (simp add: decode_irq_control_invocation_def Let_def arch_check_irq_def arch_decode_irq_control_invocation_def whenE_def, safe) apply (wp | simp)+ done -lemma decode_irq_control_valid [Interrupt_AI_asms]: +lemma decode_irq_control_valid [Interrupt_AI_assms]: "\\s. invs s \ (\cap \ set caps. s \ cap) \ (\cap \ set caps. is_cnode_cap cap \ (\r \ cte_refs cap (interrupt_irq_node s). ex_cte_cap_wp_to is_cnode_cap r s)) @@ -54,7 +54,7 @@ lemma decode_irq_control_valid [Interrupt_AI_asms]: apply fast done -lemma get_irq_slot_different_ARCH[Interrupt_AI_asms]: +lemma get_irq_slot_different_ARCH[Interrupt_AI_assms]: "\\s. valid_global_refs s \ ex_cte_cap_wp_to is_cnode_cap ptr s\ get_irq_slot irq \\rv s. rv \ ptr\" @@ -66,7 +66,7 @@ lemma get_irq_slot_different_ARCH[Interrupt_AI_asms]: apply (clarsimp simp: global_refs_def is_cap_simps cap_range_def) done -lemma is_derived_use_interrupt_ARCH[Interrupt_AI_asms]: +lemma is_derived_use_interrupt_ARCH[Interrupt_AI_assms]: "(is_ntfn_cap cap \ interrupt_derived cap cap') \ (is_derived m p cap cap')" apply (clarsimp simp: is_cap_simps) apply (clarsimp simp: interrupt_derived_def is_derived_def) @@ -74,7 +74,7 @@ lemma is_derived_use_interrupt_ARCH[Interrupt_AI_asms]: apply (simp add: is_cap_simps is_pt_cap_def vs_cap_ref_def) done -lemma maskInterrupt_invs_ARCH[Interrupt_AI_asms]: +lemma maskInterrupt_invs_ARCH[Interrupt_AI_assms]: "\invs and (\s. \b \ interrupt_states s irq \ IRQInactive)\ do_machine_op (maskInterrupt b irq) \\rv. invs\" @@ -91,13 +91,13 @@ lemma dmo_plic_complete_claim[wp]: apply (auto simp: plic_complete_claim_def machine_op_lift_def machine_rest_lift_def in_monad select_f_def) done -lemma no_cap_to_obj_with_diff_IRQHandler_ARCH[Interrupt_AI_asms]: +lemma no_cap_to_obj_with_diff_IRQHandler_ARCH[Interrupt_AI_assms]: "no_cap_to_obj_with_diff_ref (IRQHandlerCap irq) S = \" by (rule ext, simp add: no_cap_to_obj_with_diff_ref_def cte_wp_at_caps_of_state obj_ref_none_no_asid) -lemma (* set_irq_state_valid_cap *)[Interrupt_AI_asms]: +lemma (* set_irq_state_valid_cap *)[Interrupt_AI_assms]: "\valid_cap cap\ set_irq_state IRQSignal irq \\rv. valid_cap cap\" apply (clarsimp simp: set_irq_state_def) apply (wp do_machine_op_valid_cap) @@ -108,9 +108,9 @@ lemma (* set_irq_state_valid_cap *)[Interrupt_AI_asms]: done crunch set_irq_state - for valid_global_refs[Interrupt_AI_asms]: "valid_global_refs" + for valid_global_refs[Interrupt_AI_assms]: "valid_global_refs" -lemma invoke_irq_handler_invs'[Interrupt_AI_asms]: +lemma invoke_irq_handler_invs'[Interrupt_AI_assms]: assumes dmo_ex_inv[wp]: "\f. \invs and ex_inv\ do_machine_op f \\rv::unit. ex_inv\" assumes cap_insert_ex_inv[wp]: "\cap src dest. \ex_inv and invs and K (src \ dest)\ @@ -167,7 +167,7 @@ lemma invoke_irq_handler_invs'[Interrupt_AI_asms]: done qed -lemma (* invoke_irq_control_invs *) [Interrupt_AI_asms]: +lemma (* invoke_irq_control_invs *) [Interrupt_AI_assms]: "\invs and irq_control_inv_valid i\ invoke_irq_control i \\rv. invs\" apply (cases i, simp_all) apply (wp cap_insert_simple_invs @@ -191,7 +191,7 @@ lemma (* invoke_irq_control_invs *) [Interrupt_AI_asms]: crunch resetTimer for device_state_inv[wp]: "\ms. P (device_state ms)" -lemma resetTimer_invs_ARCH[Interrupt_AI_asms]: +lemma resetTimer_invs_ARCH[Interrupt_AI_assms]: "\invs\ do_machine_op resetTimer \\_. invs\" apply (wp dmo_invs) apply safe @@ -204,11 +204,11 @@ lemma resetTimer_invs_ARCH[Interrupt_AI_asms]: apply(erule use_valid, wp no_irq_resetTimer no_irq, assumption) done -lemma empty_fail_ackInterrupt_ARCH[Interrupt_AI_asms]: +lemma empty_fail_ackInterrupt_ARCH[Interrupt_AI_assms]: "empty_fail (ackInterrupt irq)" by (wp | simp add: ackInterrupt_def)+ -lemma empty_fail_maskInterrupt_ARCH[Interrupt_AI_asms]: +lemma empty_fail_maskInterrupt_ARCH[Interrupt_AI_assms]: "empty_fail (maskInterrupt f irq)" by (wp | simp add: maskInterrupt_def)+ @@ -235,7 +235,7 @@ lemma handle_reserved_irq_invs[wp]: "\invs\ handle_reserved_irq irq \\_. invs\" unfolding handle_reserved_irq_def by (wpsimp simp: non_kernel_IRQs_def) -lemma (* handle_interrupt_invs *) [Interrupt_AI_asms]: +lemma (* handle_interrupt_invs *) [Interrupt_AI_assms]: "\invs\ handle_interrupt irq \\_. invs\" apply (simp add: handle_interrupt_def) apply (rule conjI; rule impI) @@ -251,7 +251,7 @@ lemma (* handle_interrupt_invs *) [Interrupt_AI_asms]: | simp add: get_irq_state_def ackDeadlineIRQ_def handle_reserved_irq_def)+ done -lemma sts_arch_irq_control_inv_valid[wp, Interrupt_AI_asms]: +lemma sts_arch_irq_control_inv_valid[wp, Interrupt_AI_assms]: "\arch_irq_control_inv_valid i\ set_thread_state t st \\rv. arch_irq_control_inv_valid i\" @@ -264,12 +264,12 @@ crunch arch_invoke_irq_handler for typ_at[wp]: "\s. P (typ_at T p s)" crunch invoke_irq_control - for cur_thread[wp, Interrupt_AI_asms]: "\s. P (cur_thread s)" - and ct_in_state[wp, Interrupt_AI_asms]: "ct_in_state P" + for cur_thread[wp, Interrupt_AI_assms]: "\s. P (cur_thread s)" + and ct_in_state[wp, Interrupt_AI_assms]: "ct_in_state P" (wp: crunch_wps simp: crunch_simps) crunch invoke_irq_handler - for ct_active[wp, Interrupt_AI_asms]: "ct_active" + for ct_active[wp, Interrupt_AI_assms]: "ct_active" (wp: gts_wp get_simple_ko_wp crunch_wps simp: crunch_simps) end @@ -277,7 +277,7 @@ end interpretation Interrupt_AI?: Interrupt_AI proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales, simp_all add: Interrupt_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales, simp_all add: Interrupt_AI_assms)?) qed end diff --git a/proof/invariant-abstract/RISCV64/ArchInvariants_AI.thy b/proof/invariant-abstract/RISCV64/ArchInvariants_AI.thy index 8715744f84..3ba3092e24 100644 --- a/proof/invariant-abstract/RISCV64/ArchInvariants_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchInvariants_AI.thy @@ -21,7 +21,7 @@ qualify RISCV64 (in Arch) type_synonym iarch_tcb = void end_qualify -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming (* compatibility with other architectures, input only *) abbreviation @@ -1092,7 +1092,7 @@ lemma aobj_at_default_arch_cap_valid: lemmas aobj_ref_default = aobj_ref_arch_cap -lemma acap_rights_update_id [intro!, simp]: +lemma wf_acap_rights_update_id [intro!, simp]: "wellformed_acap cap \ acap_rights_update (acap_rights cap) cap = cap" unfolding acap_rights_update_def by (auto split: arch_cap.splits option.splits) diff --git a/proof/invariant-abstract/RISCV64/ArchIpcCancel_AI.thy b/proof/invariant-abstract/RISCV64/ArchIpcCancel_AI.thy index 84a5cdca86..1a33884511 100644 --- a/proof/invariant-abstract/RISCV64/ArchIpcCancel_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchIpcCancel_AI.thy @@ -8,13 +8,13 @@ theory ArchIpcCancel_AI imports IpcCancel_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming -named_theorems IpcCancel_AI_asms +named_theorems IpcCancel_AI_assms crunch arch_post_cap_deletion - for typ_at[wp, IpcCancel_AI_asms]: "\s. P (typ_at T p s)" - and idle_thread[wp, IpcCancel_AI_asms]: "\s. P (idle_thread s)" + for typ_at[wp, IpcCancel_AI_assms]: "\s. P (typ_at T p s)" + and idle_thread[wp, IpcCancel_AI_assms]: "\s. P (idle_thread s)" end @@ -22,7 +22,7 @@ interpretation IpcCancel_AI?: IpcCancel_AI proof goal_cases interpret Arch . case 1 show ?case - by (intro_locales; (unfold_locales; fact IpcCancel_AI_asms)?) + by (intro_locales; (unfold_locales; fact IpcCancel_AI_assms)?) qed diff --git a/proof/invariant-abstract/RISCV64/ArchIpc_AI.thy b/proof/invariant-abstract/RISCV64/ArchIpc_AI.thy index 30173693c3..2566b9bf6f 100644 --- a/proof/invariant-abstract/RISCV64/ArchIpc_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchIpc_AI.thy @@ -8,7 +8,7 @@ theory ArchIpc_AI imports Ipc_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming named_theorems Ipc_AI_assms @@ -474,7 +474,7 @@ proof goal_cases case 1 show ?case by (unfold_locales; (fact Ipc_AI_assms)?) qed -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming named_theorems Ipc_AI_cont_assms diff --git a/proof/invariant-abstract/RISCV64/ArchKHeap_AI.thy b/proof/invariant-abstract/RISCV64/ArchKHeap_AI.thy index 712561e98d..44c2961a45 100644 --- a/proof/invariant-abstract/RISCV64/ArchKHeap_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchKHeap_AI.thy @@ -8,7 +8,7 @@ theory ArchKHeap_AI imports KHeapPre_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming definition "non_vspace_obj \ non_arch_obj" definition "vspace_obj_pred \ arch_obj_pred" @@ -22,7 +22,7 @@ locale vspace_only_obj_pred = Arch + sublocale vspace_only_obj_pred < arch_only_obj_pred using vspace_only[unfolded vspace_obj_pred_def] by unfold_locales -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemma valid_vspace_obj_lift: assumes "\T p. f \typ_at (AArch T) p\" diff --git a/proof/invariant-abstract/RISCV64/ArchKernelInit_AI.thy b/proof/invariant-abstract/RISCV64/ArchKernelInit_AI.thy index 2b0c109765..590d5d401b 100644 --- a/proof/invariant-abstract/RISCV64/ArchKernelInit_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchKernelInit_AI.thy @@ -12,7 +12,7 @@ imports Arch_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming text \ Showing that there is a state that satisfies the abstract invariants. diff --git a/proof/invariant-abstract/RISCV64/ArchLevityCatch_AI.thy b/proof/invariant-abstract/RISCV64/ArchLevityCatch_AI.thy index d3718975a7..dd701359a0 100644 --- a/proof/invariant-abstract/RISCV64/ArchLevityCatch_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchLevityCatch_AI.thy @@ -9,7 +9,7 @@ imports "ArchBCorres_AI" begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemma asid_high_bits_of_shift[simp]: "asid_high_bits_of (ucast x << asid_low_bits) = x" diff --git a/proof/invariant-abstract/RISCV64/ArchRetype_AI.thy b/proof/invariant-abstract/RISCV64/ArchRetype_AI.thy index a3f2e00388..2979690d86 100644 --- a/proof/invariant-abstract/RISCV64/ArchRetype_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchRetype_AI.thy @@ -13,7 +13,7 @@ theory ArchRetype_AI imports Retype_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming named_theorems Retype_AI_assms @@ -179,10 +179,7 @@ declare post_retype_invs_check_def[simp] end - -context begin interpretation Arch . -requalify_consts post_retype_invs_check -end +arch_requalify_consts post_retype_invs_check definition post_retype_invs :: "apiobject_type \ obj_ref list \ 'z::state_ext state \ bool" @@ -198,13 +195,13 @@ global_interpretation Retype_AI_post_retype_invs?: Retype_AI_post_retype_invs by (unfold_locales; fact post_retype_invs_def) -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemma init_arch_objects_invs_from_restricted: "\post_retype_invs new_type refs and (\s. global_refs s \ set refs = {}) and K (\ref \ set refs. is_aligned ref (obj_bits_api new_type obj_sz))\ - init_arch_objects new_type ptr bits obj_sz refs + init_arch_objects new_type dev ptr bits obj_sz refs \\_. invs\" apply (simp add: init_arch_objects_def split del: if_split) apply (rule hoare_pre) @@ -231,7 +228,7 @@ global_interpretation Retype_AI_slot_bits?: Retype_AI_slot_bits qed -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemma valid_untyped_helper [Retype_AI_assms]: assumes valid_c: "s \ c" @@ -620,7 +617,7 @@ sublocale retype_region_proofs_gen?: retype_region_proofs_gen end -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemma unique_table_caps_null: "unique_table_caps_2 (null_filter caps) @@ -723,10 +720,7 @@ lemma cap_range_respects_device_region_cong[cong]: by (clarsimp simp: cap_range_respects_device_region_def) -context begin interpretation Arch . -requalify_consts region_in_kernel_window -end - +arch_requalify_consts region_in_kernel_window context retype_region_proofs_arch begin @@ -924,7 +918,7 @@ lemmas post_retype_invs_axioms = retype_region_proofs_invs_axioms end -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming named_theorems Retype_AI_assms' @@ -954,7 +948,7 @@ global_interpretation Retype_AI?: Retype_AI qed -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemma retype_region_plain_invs: "\invs and caps_no_overlap ptr sz and pspace_no_overlap_range_cover ptr sz @@ -1073,7 +1067,7 @@ crunch init_arch_objects lemma init_arch_objects_excap: "\ex_cte_cap_wp_to P p\ - init_arch_objects tp ptr bits us refs + init_arch_objects tp dev ptr bits us refs \\rv s. ex_cte_cap_wp_to P p s\" by (wp ex_cte_cap_to_pres) diff --git a/proof/invariant-abstract/RISCV64/ArchSchedule_AI.thy b/proof/invariant-abstract/RISCV64/ArchSchedule_AI.thy index b0abd517c4..3ae4776efb 100644 --- a/proof/invariant-abstract/RISCV64/ArchSchedule_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchSchedule_AI.thy @@ -8,13 +8,13 @@ theory ArchSchedule_AI imports Schedule_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming declare opt_mapE[rule del] -named_theorems Schedule_AI_asms +named_theorems Schedule_AI_assms -lemma dmo_mapM_storeWord_0_invs[wp,Schedule_AI_asms]: +lemma dmo_mapM_storeWord_0_invs[wp,Schedule_AI_assms]: "do_machine_op (mapM (\p. storeWord p 0) S) \invs\" apply (simp add: dmo_mapM ef_storeWord) apply (rule mapM_UNIV_wp) @@ -30,43 +30,41 @@ lemma dmo_mapM_storeWord_0_invs[wp,Schedule_AI_asms]: apply (simp add: upto.simps cur_sc_tcb_def word_bits_def) done -global_naming Arch - -lemma arch_stt_invs [wp,Schedule_AI_asms]: +lemma arch_stt_invs [wp,Schedule_AI_assms]: "\invs\ arch_switch_to_thread t' \\_. invs\" apply (simp add: arch_switch_to_thread_def) apply wp done -lemma arch_stt_tcb [wp,Schedule_AI_asms]: +lemma arch_stt_tcb [wp,Schedule_AI_assms]: "\tcb_at t'\ arch_switch_to_thread t' \\_. tcb_at t'\" apply (simp add: arch_switch_to_thread_def) apply (wp) done -lemma arch_stt_sc_at[wp,Schedule_AI_asms]: +lemma arch_stt_sc_at[wp,Schedule_AI_assms]: "arch_switch_to_thread t' \sc_at sc_ptr\" apply (simp add: arch_switch_to_thread_def) apply wp done -lemma arch_stt_runnable[Schedule_AI_asms]: +lemma arch_stt_runnable[Schedule_AI_assms]: "\st_tcb_at Q t\ arch_switch_to_thread t \\r . st_tcb_at Q t\" apply (simp add: arch_switch_to_thread_def) apply wp done -lemma arch_stit_invs[wp, Schedule_AI_asms]: +lemma arch_stit_invs[wp, Schedule_AI_assms]: "\invs\ arch_switch_to_idle_thread \\r. invs\" by (wpsimp simp: arch_switch_to_idle_thread_def) -lemma arch_stit_tcb_at[wp, Schedule_AI_asms]: +lemma arch_stit_tcb_at[wp, Schedule_AI_assms]: "\tcb_at t\ arch_switch_to_idle_thread \\r. tcb_at t\" apply (simp add: arch_switch_to_idle_thread_def ) apply (wp tcb_at_typ_at) done -lemma arch_stit_sc_at[wp, Schedule_AI_asms]: +lemma arch_stit_sc_at[wp, Schedule_AI_assms]: "arch_switch_to_idle_thread \sc_at sc_ptr\" apply (simp add: arch_switch_to_idle_thread_def) apply wp @@ -77,13 +75,13 @@ crunch set_vm_root and it[wp]: "\s. P (idle_thread s)" (simp: crunch_simps wp: hoare_drop_imps) -lemma arch_stit_activatable[wp, Schedule_AI_asms]: +lemma arch_stit_activatable[wp, Schedule_AI_assms]: "\ct_in_state activatable\ arch_switch_to_idle_thread \\rv . ct_in_state activatable\" apply (clarsimp simp: arch_switch_to_idle_thread_def) apply (wpsimp simp: ct_in_state_def wp: ct_in_state_thread_state_lift) done -lemma stit_activatable[Schedule_AI_asms]: +lemma stit_activatable[Schedule_AI_assms]: "\invs\ switch_to_idle_thread \\rv . ct_in_state activatable\" apply (simp add: switch_to_idle_thread_def arch_switch_to_idle_thread_def) apply (wp | simp add: ct_in_state_def)+ @@ -95,11 +93,11 @@ crunch set_vm_root for scheduler_action[wp]: "\s. P (scheduler_action s)" (simp: crunch_simps) -lemma arch_stt_scheduler_action [wp, Schedule_AI_asms]: +lemma arch_stt_scheduler_action [wp, Schedule_AI_assms]: "\\s. P (scheduler_action s)\ arch_switch_to_thread t' \\_ s. P (scheduler_action s)\" by (wpsimp simp: arch_switch_to_thread_def) -lemma arch_stit_scheduler_action [wp, Schedule_AI_asms]: +lemma arch_stit_scheduler_action [wp, Schedule_AI_assms]: "\\s. P (scheduler_action s)\ arch_switch_to_idle_thread \\_ s. P (scheduler_action s)\" by (wpsimp simp: arch_switch_to_idle_thread_def) @@ -108,7 +106,7 @@ end interpretation Schedule_AI?: Schedule_AI proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Schedule_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Schedule_AI_assms)?) qed end diff --git a/proof/invariant-abstract/RISCV64/ArchSyscall_AI.thy b/proof/invariant-abstract/RISCV64/ArchSyscall_AI.thy index 1596f5ab13..5a1f239a62 100644 --- a/proof/invariant-abstract/RISCV64/ArchSyscall_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchSyscall_AI.thy @@ -13,7 +13,7 @@ imports Syscall_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming named_theorems Syscall_AI_assms diff --git a/proof/invariant-abstract/RISCV64/ArchTcbAcc_AI.thy b/proof/invariant-abstract/RISCV64/ArchTcbAcc_AI.thy index 367f519d42..9efec86cac 100644 --- a/proof/invariant-abstract/RISCV64/ArchTcbAcc_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchTcbAcc_AI.thy @@ -8,7 +8,7 @@ theory ArchTcbAcc_AI imports TcbAcc_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemma as_user_valid_tcbs[wp]: "as_user ptr f \valid_tcbs\" diff --git a/proof/invariant-abstract/RISCV64/ArchTcb_AI.thy b/proof/invariant-abstract/RISCV64/ArchTcb_AI.thy index d62e5b3c36..e29c0a0e84 100644 --- a/proof/invariant-abstract/RISCV64/ArchTcb_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchTcb_AI.thy @@ -8,19 +8,19 @@ theory ArchTcb_AI imports Tcb_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming -named_theorems Tcb_AI_asms +named_theorems Tcb_AI_assms -lemma activate_idle_invs[Tcb_AI_asms]: +lemma activate_idle_invs[Tcb_AI_assms]: "\invs and ct_idle\ arch_activate_idle_thread thread \\rv. invs and ct_idle\" by (simp add: arch_activate_idle_thread_def) -lemma empty_fail_getRegister [intro!, simp, Tcb_AI_asms]: +lemma empty_fail_getRegister [intro!, simp, Tcb_AI_assms]: "empty_fail (getRegister r)" by (simp add: getRegister_def) @@ -37,7 +37,7 @@ lemma same_object_also_valid: (* arch specific *) split: cap.split_asm arch_cap.split_asm option.splits)+) done -lemma same_object_obj_refs[Tcb_AI_asms]: +lemma same_object_obj_refs[Tcb_AI_assms]: "\ same_object_as cap cap' \ \ obj_refs cap = obj_refs cap'" apply (cases cap, simp_all add: same_object_as_def) @@ -146,15 +146,15 @@ lemma checked_insert_tcb_invs': (* arch specific *) by (auto simp: is_cap_simps is_cnode_or_valid_arch_def valid_fault_handler_def) crunch arch_post_modify_registers - for tcb_at[wp, Tcb_AI_asms]: "tcb_at a" - and invs[wp, Tcb_AI_asms]: invs - and ex_nonz_cap_to[wp, Tcb_AI_asms]: "ex_nonz_cap_to a" - and fault_tcb_at[wp, Tcb_AI_asms]: "fault_tcb_at P a" + for tcb_at[wp, Tcb_AI_assms]: "tcb_at a" + and invs[wp, Tcb_AI_assms]: invs + and ex_nonz_cap_to[wp, Tcb_AI_assms]: "ex_nonz_cap_to a" + and fault_tcb_at[wp, Tcb_AI_assms]: "fault_tcb_at P a" crunch arch_get_sanitise_register_info - for inv[wp, Tcb_AI_asms]: "P" + for inv[wp, Tcb_AI_assms]: "P" -lemma finalise_cap_not_cte_wp_at[Tcb_AI_asms]: +lemma finalise_cap_not_cte_wp_at[Tcb_AI_assms]: assumes x: "P cap.NullCap" shows "\\s. \cp \ ran (caps_of_state s). P cp\ finalise_cap cap fin @@ -167,7 +167,7 @@ lemma finalise_cap_not_cte_wp_at[Tcb_AI_asms]: simp: deleting_irq_handler_def get_irq_slot_def ball_ran_eq x) done -lemma table_cap_ref_max_free_index_upd[simp,Tcb_AI_asms]: +lemma table_cap_ref_max_free_index_upd[simp,Tcb_AI_assms]: "table_cap_ref (max_free_index_update cap) = table_cap_ref cap" by (simp add:free_index_update_def table_cap_ref_def split:cap.splits) @@ -178,10 +178,10 @@ global_interpretation Tcb_AI_1?: Tcb_AI_1 and is_cnode_or_valid_arch = RISCV64.is_cnode_or_valid_arch proof goal_cases interpret Arch . - case 1 show ?case by (unfold_locales; (fact Tcb_AI_asms)?) + case 1 show ?case by (unfold_locales; (fact Tcb_AI_assms)?) qed -context Arch begin global_naming RISVB64 +context Arch begin arch_global_naming lemma use_no_cap_to_obj_asid_strg: (* arch specific *) "(cte_at p s \ no_cap_to_obj_dr_emp cap s \ valid_cap cap s \ invs s) @@ -197,7 +197,7 @@ lemma use_no_cap_to_obj_asid_strg: (* arch specific *) by (fastforce simp: table_cap_ref_def vspace_asid_def valid_cap_simps obj_at_def split: cap.splits arch_cap.splits option.splits prod.splits) -lemma cap_delete_no_cap_to_obj_asid[wp, Tcb_AI_asms]: +lemma cap_delete_no_cap_to_obj_asid[wp, Tcb_AI_assms]: "\no_cap_to_obj_dr_emp cap\ cap_delete slot \\rv. no_cap_to_obj_dr_emp cap\" @@ -262,7 +262,7 @@ lemma install_tcb_cap_invs: elim!: cte_wp_at_weakenE) done -lemma install_tcb_cap_no_cap_to_obj_dr_emp[wp, Tcb_AI_asms]: +lemma install_tcb_cap_no_cap_to_obj_dr_emp[wp, Tcb_AI_assms]: "\no_cap_to_obj_dr_emp cap and (\s. \new_cap src_slot. slot_opt = Some (new_cap, src_slot) \ no_cap_to_obj_dr_emp new_cap s)\ @@ -309,7 +309,7 @@ lemma install_tcb_frame_cap_invs: | wp cap_delete_ep)+)[1] by (clarsimp simp: is_cap_simps' valid_fault_handler_def is_cnode_or_valid_arch_def) -lemma tcc_invs[Tcb_AI_asms]: +lemma tcc_invs[Tcb_AI_assms]: "\invs and tcb_inv_wf (ThreadControlCaps t sl fh th croot vroot buf)\ invoke_tcb (ThreadControlCaps t sl fh th croot vroot buf) \\rv. invs\" @@ -372,7 +372,7 @@ lemma install_tcb_cap_sc_tcb_sc_at[wp]: apply (wpsimp wp: check_cap_inv cap_delete_fh_lift hoare_vcg_if_lift2 | simp)+ done -lemma tcs_invs[Tcb_AI_asms]: +lemma tcs_invs[Tcb_AI_assms]: "\invs and tcb_inv_wf (ThreadControlSched t sl fh mcp pr sc)\ invoke_tcb (ThreadControlSched t sl fh mcp pr sc) \\rv. invs\" @@ -421,7 +421,7 @@ lemma check_valid_ipc_buffer_inv: apply (wp | simp add: whenE_def if_apply_def2 | wpcw)+ done -lemma check_valid_ipc_buffer_wp[Tcb_AI_asms]: +lemma check_valid_ipc_buffer_wp[Tcb_AI_assms]: "\\(s::'state_ext::state_ext state). is_arch_cap cap \ is_cnode_or_valid_arch cap \ valid_ipc_buffer_cap cap vptr \ is_aligned vptr msg_align_bits @@ -437,7 +437,7 @@ lemma check_valid_ipc_buffer_wp[Tcb_AI_asms]: valid_ipc_buffer_cap_def) done -lemma derive_no_cap_asid[wp,Tcb_AI_asms]: +lemma derive_no_cap_asid[wp,Tcb_AI_assms]: "\(no_cap_to_obj_with_diff_ref cap S)::'state_ext::state_ext state\bool\ derive_cap slot cap \\rv. no_cap_to_obj_with_diff_ref rv S\,-" @@ -451,7 +451,7 @@ lemma derive_no_cap_asid[wp,Tcb_AI_asms]: done -lemma decode_set_ipc_inv[wp,Tcb_AI_asms]: +lemma decode_set_ipc_inv[wp,Tcb_AI_assms]: "\P::'state_ext::state_ext state \ bool\ decode_set_ipc_buffer args cap slot excaps \\rv. P\" apply (simp add: decode_set_ipc_buffer_def whenE_def split_def @@ -460,7 +460,7 @@ lemma decode_set_ipc_inv[wp,Tcb_AI_asms]: apply simp done -lemma no_cap_to_obj_with_diff_ref_update_cap_data[Tcb_AI_asms]: +lemma no_cap_to_obj_with_diff_ref_update_cap_data[Tcb_AI_assms]: "no_cap_to_obj_with_diff_ref c S s \ no_cap_to_obj_with_diff_ref (update_cap_data P x c) S s" apply (case_tac "update_cap_data P x c = NullCap") @@ -476,7 +476,7 @@ lemma no_cap_to_obj_with_diff_ref_update_cap_data[Tcb_AI_asms]: apply simp done -lemma update_cap_valid[Tcb_AI_asms]: +lemma update_cap_valid[Tcb_AI_assms]: "valid_cap cap (s::'state_ext::state_ext state) \ valid_cap (case capdata of None \ cap_rights_update rs cap @@ -506,17 +506,11 @@ crunch invoke_tcb end -context begin interpretation Arch . -requalify_consts is_cnode_or_valid_arch -requalify_facts invoke_tcb_typ_at install_tcb_cap_invs - is_cnode_or_valid_arch_is_cap_simps -end - global_interpretation Tcb_AI?: Tcb_AI where is_cnode_or_valid_arch = RISCV64.is_cnode_or_valid_arch proof goal_cases interpret Arch . - case 1 show ?case by (unfold_locales; (fact Tcb_AI_asms)?) + case 1 show ?case by (unfold_locales; (fact Tcb_AI_assms)?) qed end diff --git a/proof/invariant-abstract/RISCV64/ArchUntyped_AI.thy b/proof/invariant-abstract/RISCV64/ArchUntyped_AI.thy index 5debf0ffbe..ca0d9a3b6a 100644 --- a/proof/invariant-abstract/RISCV64/ArchUntyped_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchUntyped_AI.thy @@ -8,7 +8,7 @@ theory ArchUntyped_AI imports Untyped_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming named_theorems Untyped_AI_assms @@ -193,13 +193,13 @@ lemma cap_refs_in_kernel_windowD2: lemma init_arch_objects_descendants_range[wp,Untyped_AI_assms]: "\\(s::'state_ext::state_ext state). descendants_range x cref s \ - init_arch_objects ty ptr n us y + init_arch_objects ty dev ptr n us y \\rv s. descendants_range x cref s\" unfolding init_arch_objects_def by wp lemma init_arch_objects_caps_overlap_reserved[wp,Untyped_AI_assms]: "\\(s::'state_ext::state_ext state). caps_overlap_reserved S s\ - init_arch_objects ty ptr n us y + init_arch_objects ty dev ptr n us y \\rv s. caps_overlap_reserved S s\" unfolding init_arch_objects_def by wp @@ -329,7 +329,7 @@ lemma init_arch_objects_nonempty_table[Untyped_AI_assms, wp]: "\(\s. \ (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s) \ valid_global_objs s \ valid_arch_state s \ pspace_aligned s) and K (\ref\set refs. is_aligned ref (obj_bits_api tp us))\ - init_arch_objects tp ptr bits us refs + init_arch_objects tp dev ptr bits us refs \\rv s. \ (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)\" unfolding init_arch_objects_def by wpsimp @@ -387,7 +387,7 @@ qed lemma init_arch_objects_obj_at_other[Untyped_AI_assms]: "\\ptr\set ptrs. is_aligned ptr (obj_bits_api ty us); p \ set ptrs\ - \ init_arch_objects ty ptr n us ptrs \\s. N (obj_at P p s)\" + \ init_arch_objects ty dev ptr n us ptrs \\s. N (obj_at P p s)\" by (wpsimp simp: init_arch_objects_def obj_bits_api_def default_arch_object_def wp: mapM_x_wp' copy_global_mappings_obj_at_other) @@ -405,7 +405,7 @@ lemma copy_global_mappings_obj_at_non_pt: lemma init_arch_objects_obj_at_non_pt: assumes non_pt: "\ko. P ko \ (\pd. ko \ ArchObj (PageTable pd))" - shows "init_arch_objects ty ptr n us ptrs \\s. N (obj_at P p s)\" + shows "init_arch_objects ty dev ptr n us ptrs \\s. N (obj_at P p s)\" by (wpsimp simp: init_arch_objects_def obj_bits_api_def default_arch_object_def wp: mapM_x_wp' copy_global_mappings_obj_at_non_pt[OF non_pt]) diff --git a/proof/invariant-abstract/RISCV64/ArchVSpaceEntries_AI.thy b/proof/invariant-abstract/RISCV64/ArchVSpaceEntries_AI.thy index 0887e962e1..dc1961727e 100644 --- a/proof/invariant-abstract/RISCV64/ArchVSpaceEntries_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchVSpaceEntries_AI.thy @@ -8,7 +8,7 @@ theory ArchVSpaceEntries_AI imports VSpaceEntries_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming primrec pte_range :: "pte \ pt_index \ pt_index set" where "pte_range (InvalidPTE) p = {}" @@ -211,7 +211,7 @@ lemma init_arch_objects_valid_vspace: "\valid_vspace_objs' and pspace_aligned and valid_arch_state and K (orefs = retype_addrs ptr type n us) and K (range_cover ptr sz (obj_bits_api type us) n)\ - init_arch_objects type ptr n obj_sz orefs + init_arch_objects type dev ptr n obj_sz orefs \\rv. valid_vspace_objs'\" unfolding init_arch_objects_def by wpsimp diff --git a/proof/invariant-abstract/RISCV64/ArchVSpace_AI.thy b/proof/invariant-abstract/RISCV64/ArchVSpace_AI.thy index ede44f5809..434fa4681a 100644 --- a/proof/invariant-abstract/RISCV64/ArchVSpace_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchVSpace_AI.thy @@ -12,7 +12,7 @@ theory ArchVSpace_AI imports VSpacePre_AI begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming definition kernel_mappings_only :: "(pt_index \ pte) \ 'z::state_ext state \ bool" where "kernel_mappings_only pt s \ @@ -1610,7 +1610,7 @@ lemma valid_vspace_obj: end -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming lemma set_asid_pool_arch_objs_map: "\valid_vspace_objs and valid_arch_state and valid_global_objs and @@ -1954,10 +1954,6 @@ lemma invs_aligned_pdD: "\ pspace_aligned s; valid_arch_state s \ \ is_aligned (riscv_global_pt (arch_state s)) pt_bits" by (clarsimp simp: valid_arch_state_def) -lemma do_machine_op_valid_kernel_mappings: - "do_machine_op f \valid_kernel_mappings\" - unfolding valid_kernel_mappings_def by wp - lemma valid_vspace_obj_default: assumes tyunt: "ty \ Structures_A.apiobject_type.Untyped" shows "ArchObj ao = default_object ty dev us d \ valid_vspace_obj level ao s'" @@ -1980,9 +1976,4 @@ lemma dmo_setDeadline[wp]: end -context begin interpretation Arch . -requalify_facts - do_machine_op_valid_kernel_mappings -end - end diff --git a/proof/invariant-abstract/RISCV64/Machine_AI.thy b/proof/invariant-abstract/RISCV64/Machine_AI.thy index 0a8a1c843b..22e0a6028b 100644 --- a/proof/invariant-abstract/RISCV64/Machine_AI.thy +++ b/proof/invariant-abstract/RISCV64/Machine_AI.thy @@ -67,7 +67,7 @@ crunch_ignore (no_irq) (add: handleE' handleE handle_elseE forM forM_x zipWithM ignore_failure) -context Arch begin +context Arch begin arch_global_naming lemma det_getRegister: "det (getRegister x)" by (simp add: getRegister_def) @@ -377,14 +377,4 @@ lemma no_irq_hwASIDFlush: end end -context begin interpretation Arch . - -requalify_facts - det_getRegister - det_setRegister - det_getRestartPC - det_setNextPC - -end - end diff --git a/proof/invariant-abstract/Retype_AI.thy b/proof/invariant-abstract/Retype_AI.thy index 71ac8e5b16..1668dd6176 100644 --- a/proof/invariant-abstract/Retype_AI.thy +++ b/proof/invariant-abstract/Retype_AI.thy @@ -19,13 +19,11 @@ lemmas atLeastAtMost_simps = abbreviation "up_aligned_area ptr sz \ {ptr..(ptr && ~~ mask sz) + (2 ^ sz - 1)}" abbreviation "down_aligned_area ptr sz \ {(ptr && ~~ mask sz) + (2 ^ sz - 1) .. ptr}" -context begin interpretation Arch . -requalify_facts +arch_requalify_facts valid_vspace_obj_default -requalify_consts - clearMemory + +arch_requalify_consts clearMemoryVM -end locale Retype_AI_clearMemoryVM = diff --git a/proof/invariant-abstract/SchedContext_AI.thy b/proof/invariant-abstract/SchedContext_AI.thy index 159d0c9452..2f024c9a3c 100644 --- a/proof/invariant-abstract/SchedContext_AI.thy +++ b/proof/invariant-abstract/SchedContext_AI.thy @@ -11,13 +11,9 @@ imports begin -context begin interpretation Arch . - -requalify_facts +arch_requalify_facts valid_global_refsD -end - lemma no_cap_to_idle_sc_ptr: "\cte_wp_at ((=) (SchedContextCap a b)) slot s; invs s\ \ a \ idle_sc_ptr" by (fastforce simp: invs_def valid_state_def cap_range_def dest!: valid_global_refsD) diff --git a/proof/invariant-abstract/Schedule_AI.thy b/proof/invariant-abstract/Schedule_AI.thy index 8713c100c9..d06aa6c76b 100644 --- a/proof/invariant-abstract/Schedule_AI.thy +++ b/proof/invariant-abstract/Schedule_AI.thy @@ -8,6 +8,10 @@ theory Schedule_AI imports SchedContext_AI begin +arch_requalify_facts + no_irq + no_irq_storeWord + abbreviation "activatable \ \st. runnable st \ idle st" @@ -39,14 +43,6 @@ locale Schedule_AI = assumes stit_activatable: "\invs\ switch_to_idle_thread \\rv . (ct_in_state activatable :: 'a state \ bool)\" -context begin interpretation Arch . -(* FIXME arch_split: some of these could be moved to generic theories - so they don't need to be unqualified. *) -requalify_facts - no_irq - no_irq_storeWord -end - crunch schedule_switch_thread_fastfail for inv[wp]: P diff --git a/proof/invariant-abstract/Syscall_AI.thy b/proof/invariant-abstract/Syscall_AI.thy index 182e4c001f..6ea3854dcb 100644 --- a/proof/invariant-abstract/Syscall_AI.thy +++ b/proof/invariant-abstract/Syscall_AI.thy @@ -16,22 +16,36 @@ imports ArchInterrupt_AI begin -context begin interpretation Arch . -requalify_facts - arch_decode_invocation_inv - lookup_cap_and_slot_inv +arch_requalify_facts (A) data_to_cptr_def - arch_post_cap_deletion_cur_thread + +arch_requalify_consts + is_cnode_or_valid_arch + valid_arch_inv + +arch_requalify_facts + resetTimer_device_state_inv + arch_decode_invocation_inv arch_post_cap_deletion_state_refs_of arch_invoke_irq_handler_typ_at + invoke_tcb_typ_at + invoke_arch_tcb + invoke_arch_invs + sts_valid_arch_inv + arch_decode_inv_wf + arch_pinv_st_tcb_at getCurrentTime_invs - resetTimer_device_state_inv -end + install_tcb_cap_invs + is_cnode_or_valid_arch_is_cap_simps + arch_pinv_ct_active lemmas [wp] = arch_decode_invocation_inv lookup_cap_and_slot_inv + invoke_arch_invs + arch_decode_inv_wf getCurrentTime_invs + arch_pinv_ct_active lemmas [simp] = data_to_cptr_def diff --git a/proof/invariant-abstract/TcbAcc_AI.thy b/proof/invariant-abstract/TcbAcc_AI.thy index 8f51839263..afef4e4efe 100644 --- a/proof/invariant-abstract/TcbAcc_AI.thy +++ b/proof/invariant-abstract/TcbAcc_AI.thy @@ -8,21 +8,19 @@ theory TcbAcc_AI imports ArchCSpace_AI begin -context begin interpretation Arch . - -requalify_facts +arch_requalify_facts valid_arch_arch_tcb_context_set as_user_inv getRegister_inv user_getreg_inv + set_cap_valid_arch_caps_simple + set_cap_kernel_window_simple state_hyp_refs_of_tcb_sched_context_update state_hyp_refs_of_tcb_yield_to_update global_refs_kheap declare user_getreg_inv[wp] -end - lemma gets_the_thread_read: "gets_the (thread_read f t) = thread_get f t" by (clarsimp simp: thread_read_def thread_get_def oliftM_def) diff --git a/proof/invariant-abstract/Tcb_AI.thy b/proof/invariant-abstract/Tcb_AI.thy index a26c274651..a542654cb2 100644 --- a/proof/invariant-abstract/Tcb_AI.thy +++ b/proof/invariant-abstract/Tcb_AI.thy @@ -8,14 +8,11 @@ theory Tcb_AI imports ArchCNodeInv_AI SchedContextInv_AI IpcDet_AI begin -context begin interpretation Arch . - -requalify_facts - arch_derive_is_arch rec_del_invs'' +arch_requalify_facts + arch_derive_is_arch + rec_del_invs'' as_user_valid_tcbs -end - locale Tcb_AI_1 = fixes state_ext_t :: "'state_ext::state_ext itself" fixes is_cnode_or_valid_arch :: "cap \ bool" diff --git a/proof/invariant-abstract/Untyped_AI.thy b/proof/invariant-abstract/Untyped_AI.thy index 3232dfe609..8dbb199051 100644 --- a/proof/invariant-abstract/Untyped_AI.thy +++ b/proof/invariant-abstract/Untyped_AI.thy @@ -15,22 +15,14 @@ begin unbundle l4v_word_context (* because of Lib.MonadicRewrite *) -context begin interpretation Arch . - -requalify_consts - region_in_kernel_window - arch_default_cap +arch_requalify_consts second_level_tables safe_ioport_insert -requalify_facts - set_cap_valid_arch_caps_simple - set_cap_kernel_window_simple +arch_requalify_facts set_cap_ioports' safe_ioport_insert_triv -end - primrec valid_untyped_inv_wcap :: "Invocations_A.untyped_invocation \ cap option \ 'z::state_ext state \ bool" @@ -280,12 +272,15 @@ locale Untyped_AI_arch = (kheap s)\ \ ArchObjectCap (arch_default_cap x6 (ptr_add ptr (y * 2 ^ obj_bits_api (ArchObject x6) us)) us dev)" assumes init_arch_objects_descendants_range[wp]: - "\x cref ty ptr n us y. \\(s::'state_ext state). descendants_range x cref s \ init_arch_objects ty ptr n us y - \\rv s. descendants_range x cref s\" + "\x cref ty dev ptr n us y. + \\(s::'state_ext state). descendants_range x cref s \ + init_arch_objects ty dev ptr n us y + \\rv s. descendants_range x cref s\" assumes init_arch_objects_caps_overlap_reserved[wp]: - "\S ty ptr n us y. \\(s::'state_ext state). caps_overlap_reserved S s\ - init_arch_objects ty ptr n us y - \\rv s. caps_overlap_reserved S s\" + "\S ty dev ptr n us y. + \\(s::'state_ext state). caps_overlap_reserved S s\ + init_arch_objects ty dev ptr n us y + \\rv s. caps_overlap_reserved S s\" assumes delete_objects_rewrite: "\sz ptr. \ word_size_bits \ sz; sz\ word_bits; ptr && ~~ mask sz = ptr \ \ delete_objects ptr sz = @@ -299,17 +294,17 @@ locale Untyped_AI_arch = \ obj_is_device tp dev = dev" (* FIXME: not needed? *) assumes init_arch_objects_obj_at_other: - "\ptrs ty us p ptr n N P. + "\ptrs ty dev us p ptr n N P. \\ptr\set ptrs. is_aligned ptr (obj_bits_api ty us); p \ set ptrs\ - \ init_arch_objects ty ptr n us ptrs \\s::'state_ext state. N (obj_at P p s)\" + \ init_arch_objects ty dev ptr n us ptrs \\s::'state_ext state. N (obj_at P p s)\" assumes init_arch_objects_obj_at_live: - "\ptrs ty us p ptr n N P. + "\ptrs ty dev us p ptr n N P. \ko. P ko \ live ko - \ init_arch_objects ty ptr n us ptrs \\s::'state_ext state. N (obj_at P p s)\" + \ init_arch_objects ty dev ptr n us ptrs \\s::'state_ext state. N (obj_at P p s)\" assumes init_arch_objects_obj_at_non_arch: - "\ptrs ty us p ptr n N P. + "\ptrs ty dev us p ptr n N P. \ko. P ko \ non_arch_obj ko - \ init_arch_objects ty ptr n us ptrs \\s::'state_ext state. N (obj_at P p s)\" + \ init_arch_objects ty dev ptr n us ptrs \\s::'state_ext state. N (obj_at P p s)\" lemmas is_aligned_triv2 = Aligned.is_aligned_triv @@ -534,11 +529,6 @@ lemma range_cover_stuff: done qed (simp add: word_bits_def) -context Arch begin - (*FIXME: generify proof that uses this *) - lemmas range_cover_stuff_arch = range_cover_stuff[unfolded word_bits_def, simplified] -end - lemma cte_wp_at_range_cover: "\bits < word_bits; rv\ 2^ sz; invs s; @@ -2991,7 +2981,7 @@ locale Untyped_AI_nonempty_table = "\(\s. \ (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s) \ valid_global_objs s \ valid_arch_state s \ pspace_aligned s) and K (\ref\set refs. is_aligned ref (obj_bits_api tp us))\ - init_arch_objects tp ptr bits us refs + init_arch_objects tp dev ptr bits us refs \\rv. \s :: 'state_ext state. \ (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)\" assumes create_cap_ioports[wp]: "\tp oref sz dev cref p. \valid_ioports and cte_wp_at (\_. True) cref\ @@ -3571,7 +3561,7 @@ lemma invoke_untyp_invs': and cte_wp_at (\c. \idx. c = UntypedCap dev (ptr && ~~ mask sz) sz idx) slot and K (refs = retype_addrs ptr tp (length slots) us \ range_cover ptr sz (obj_bits_api tp us) (length slots))\ - init_arch_objects tp ptr (length slots) us refs \\_. Q\" + init_arch_objects tp dev ptr (length slots) us refs \\_. Q\" assumes retype_region_Q: "\ptr us tp slot reset sz slots dev. ui = Invocations_A.Retype slot reset (ptr && ~~ mask sz) ptr tp us slots dev \ \\s. invs s \ Q s diff --git a/proof/invariant-abstract/VSpacePre_AI.thy b/proof/invariant-abstract/VSpacePre_AI.thy index b12216f129..b0ec9c180f 100644 --- a/proof/invariant-abstract/VSpacePre_AI.thy +++ b/proof/invariant-abstract/VSpacePre_AI.thy @@ -12,13 +12,9 @@ theory VSpacePre_AI imports ArchTcbAcc_AI begin -context begin interpretation Arch . - -requalify_facts +arch_requalify_facts cap_master_cap_tcb_cap_valid_arch -end - lemma throw_on_false_wp[wp]: "\P\ f \\rv s. (rv \ Q () s) \ (\ rv \ E x s)\ \ \P\ throw_on_false x f \Q\,\E\" diff --git a/proof/invariant-abstract/VSpace_AI.thy b/proof/invariant-abstract/VSpace_AI.thy index b36a1c4c46..9eb1379823 100644 --- a/proof/invariant-abstract/VSpace_AI.thy +++ b/proof/invariant-abstract/VSpace_AI.thy @@ -11,15 +11,12 @@ Architecture-independent VSpace invariant proofs theory VSpace_AI imports ArchVSpace_AI begin -context begin interpretation Arch . -requalify_facts - pspace_respects_device_region_dmo - cap_refs_respects_device_region_dmo - dmo_setDeadline - ackInterrupt_device_state_inv - -end +arch_requalify_facts + ackInterrupt_device_state_inv + pspace_respects_device_region_dmo + cap_refs_respects_device_region_dmo + dmo_setDeadline lemmas device_region_dmos = pspace_respects_device_region_dmo diff --git a/proof/invariant-abstract/X64/ArchADT_AI.thy b/proof/invariant-abstract/X64/ArchADT_AI.thy index 858bcd24b9..a3ebb73387 100644 --- a/proof/invariant-abstract/X64/ArchADT_AI.thy +++ b/proof/invariant-abstract/X64/ArchADT_AI.thy @@ -11,7 +11,7 @@ imports "Lib.Simulation" Invariants_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming subsection \Constructing a virtual-memory view\ diff --git a/proof/invariant-abstract/X64/ArchAInvsPre.thy b/proof/invariant-abstract/X64/ArchAInvsPre.thy index f345647dda..4d42b94fc0 100644 --- a/proof/invariant-abstract/X64/ArchAInvsPre.thy +++ b/proof/invariant-abstract/X64/ArchAInvsPre.thy @@ -8,9 +8,7 @@ theory ArchAInvsPre imports AInvsPre begin -context Arch begin - -global_naming X64 +context Arch begin arch_global_naming definition "kernel_mappings \ {x. x \ pptr_base}" @@ -178,10 +176,9 @@ lemma device_frame_in_device_region: \ device_state (machine_state s) p \ None" by (auto simp add: pspace_respects_device_region_def dom_def device_mem_def) -global_naming Arch -named_theorems AInvsPre_asms +named_theorems AInvsPre_assms -lemma ptable_rights_imp_frame[AInvsPre_asms]: +lemma ptable_rights_imp_frame[AInvsPre_assms]: assumes "valid_state s" shows "ptable_rights t s x \ {} \ ptable_lift t s x = Some (addrFromPPtr y) \ @@ -223,12 +220,7 @@ end interpretation AInvsPre?: AInvsPre proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact AInvsPre_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact AInvsPre_assms)?) qed -requalify_facts - X64.user_mem_dom_cong - X64.device_mem_dom_cong - X64.device_frame_in_device_region - end diff --git a/proof/invariant-abstract/X64/ArchAcc_AI.thy b/proof/invariant-abstract/X64/ArchAcc_AI.thy index 1b321a3e48..558ecfc6b2 100644 --- a/proof/invariant-abstract/X64/ArchAcc_AI.thy +++ b/proof/invariant-abstract/X64/ArchAcc_AI.thy @@ -14,7 +14,7 @@ imports begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming bundle unfold_objects = diff --git a/proof/invariant-abstract/X64/ArchArch_AI.thy b/proof/invariant-abstract/X64/ArchArch_AI.thy index 422d02d6f1..9f60cbbaf2 100644 --- a/proof/invariant-abstract/X64/ArchArch_AI.thy +++ b/proof/invariant-abstract/X64/ArchArch_AI.thy @@ -9,7 +9,7 @@ theory ArchArch_AI imports Arch_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming definition "valid_aci aci \ case aci of MakePool frame slot parent base \ @@ -398,7 +398,7 @@ lemma valid_asid_map': end -context Arch begin global_naming X64 +context Arch begin arch_global_naming lemma valid_arch_state_strg: "valid_arch_state s \ ap \ ran (x64_asid_table (arch_state s)) \ asid_pool_at ap s \ @@ -1686,22 +1686,4 @@ lemma arch_pinv_st_tcb_at: end - -context begin interpretation Arch . - -requalify_consts - valid_arch_inv - -requalify_facts - invoke_arch_tcb - invoke_arch_invs - sts_valid_arch_inv - arch_decode_inv_wf - arch_pinv_st_tcb_at - -end - -declare invoke_arch_invs[wp] -declare arch_decode_inv_wf[wp] - end diff --git a/proof/invariant-abstract/X64/ArchBCorres2_AI.thy b/proof/invariant-abstract/X64/ArchBCorres2_AI.thy index 316b797d8c..79bb0d6ce9 100644 --- a/proof/invariant-abstract/X64/ArchBCorres2_AI.thy +++ b/proof/invariant-abstract/X64/ArchBCorres2_AI.thy @@ -9,7 +9,7 @@ imports BCorres2_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming named_theorems BCorres2_AI_assms @@ -90,7 +90,7 @@ interpretation BCorres2_AI?: BCorres2_AI lemmas schedule_bcorres[wp] = schedule_bcorres1[OF BCorres2_AI_axioms] -context Arch begin global_naming X64 +context Arch begin arch_global_naming crunch send_ipc,send_signal,do_reply_transfer,arch_perform_invocation for (bcorres) bcorres[wp]: truncate_state diff --git a/proof/invariant-abstract/X64/ArchBCorres_AI.thy b/proof/invariant-abstract/X64/ArchBCorres_AI.thy index 31b7ebb9aa..93423b94f9 100644 --- a/proof/invariant-abstract/X64/ArchBCorres_AI.thy +++ b/proof/invariant-abstract/X64/ArchBCorres_AI.thy @@ -9,7 +9,7 @@ imports BCorres_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming crunch arch_finalise_cap for (bcorres) bcorres[wp]: truncate_state @@ -21,8 +21,4 @@ crunch prepare_thread_delete end -requalify_facts X64.arch_finalise_cap_bcorres X64.prepare_thread_delete_bcorres - -declare arch_finalise_cap_bcorres[wp] prepare_thread_delete_bcorres[wp] - end diff --git a/proof/invariant-abstract/X64/ArchBits_AI.thy b/proof/invariant-abstract/X64/ArchBits_AI.thy index 357f3b095a..80df51803b 100644 --- a/proof/invariant-abstract/X64/ArchBits_AI.thy +++ b/proof/invariant-abstract/X64/ArchBits_AI.thy @@ -8,7 +8,7 @@ theory ArchBits_AI imports Invariants_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming lemma invs_unique_table_caps[elim!]: "invs s \ unique_table_caps (caps_of_state s)" diff --git a/proof/invariant-abstract/X64/ArchCNodeInv_AI.thy b/proof/invariant-abstract/X64/ArchCNodeInv_AI.thy index 49f00d05d6..8815d1ec73 100644 --- a/proof/invariant-abstract/X64/ArchCNodeInv_AI.thy +++ b/proof/invariant-abstract/X64/ArchCNodeInv_AI.thy @@ -8,7 +8,7 @@ theory ArchCNodeInv_AI imports CNodeInv_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming named_theorems CNodeInv_AI_assms @@ -553,7 +553,7 @@ global_interpretation CNodeInv_AI?: CNodeInv_AI termination rec_del by (rule rec_del_termination) -context Arch begin global_naming X64 +context Arch begin arch_global_naming lemma post_cap_delete_pre_is_final_cap': "\rv s'' rva s''a s. @@ -829,7 +829,7 @@ global_interpretation CNodeInv_AI_2?: CNodeInv_AI_2 qed -context Arch begin global_naming X64 +context Arch begin arch_global_naming lemma finalise_cap_rvk_prog [CNodeInv_AI_assms]: "\\s. revoke_progress_ord m (\x. map_option cap_to_rpo (caps_of_state s x))\ @@ -940,7 +940,7 @@ termination cap_revoke by (rule cap_revoke_termination) declare cap_revoke.simps[simp del] -context Arch begin global_naming X64 +context Arch begin arch_global_naming crunch finalise_slot for typ_at[wp, CNodeInv_AI_assms]: "\s. P (typ_at T p s)" @@ -965,7 +965,7 @@ global_interpretation CNodeInv_AI_4?: CNodeInv_AI_4 qed -context Arch begin global_naming X64 +context Arch begin arch_global_naming lemma cap_move_ioports: "\valid_ioports and cte_wp_at ((=) cap.NullCap) ptr' diff --git a/proof/invariant-abstract/X64/ArchCSpaceInvPre_AI.thy b/proof/invariant-abstract/X64/ArchCSpaceInvPre_AI.thy index 1f6b81000c..db13cf8104 100644 --- a/proof/invariant-abstract/X64/ArchCSpaceInvPre_AI.thy +++ b/proof/invariant-abstract/X64/ArchCSpaceInvPre_AI.thy @@ -12,7 +12,7 @@ theory ArchCSpaceInvPre_AI imports CSpaceInvPre_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming lemma aobj_ref_acap_rights_update[simp]: "aobj_ref (acap_rights_update f x) = aobj_ref x" @@ -320,7 +320,7 @@ lemma cap_master_arch_cap_rights [simp]: by (simp add: cap_master_arch_cap_def acap_rights_update_def split: arch_cap.splits) -lemma acap_rights_update_id [intro!, simp]: +lemma valid_acap_rights_update_id [intro!, simp]: "valid_arch_cap ac s \ acap_rights_update (acap_rights ac) ac = ac" unfolding acap_rights_update_def acap_rights_def valid_arch_cap_def by (cases ac; simp) diff --git a/proof/invariant-abstract/X64/ArchCSpaceInv_AI.thy b/proof/invariant-abstract/X64/ArchCSpaceInv_AI.thy index 38057d28d6..097199048f 100644 --- a/proof/invariant-abstract/X64/ArchCSpaceInv_AI.thy +++ b/proof/invariant-abstract/X64/ArchCSpaceInv_AI.thy @@ -12,7 +12,7 @@ theory ArchCSpaceInv_AI imports CSpaceInv_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming definition safe_ioport_insert :: "cap \ cap \ 'a::state_ext state \ bool" @@ -304,8 +304,4 @@ lemmas cap_vptr_simps [simp] = end -context begin interpretation Arch . -requalify_facts replace_cap_invs -end - end diff --git a/proof/invariant-abstract/X64/ArchCSpacePre_AI.thy b/proof/invariant-abstract/X64/ArchCSpacePre_AI.thy index 7d3a609817..3612e6f412 100644 --- a/proof/invariant-abstract/X64/ArchCSpacePre_AI.thy +++ b/proof/invariant-abstract/X64/ArchCSpacePre_AI.thy @@ -12,7 +12,7 @@ theory ArchCSpacePre_AI imports CSpacePre_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming lemmas typ_at_eq_kheap_obj = typ_at_eq_kheap_obj atyp_at_eq_kheap_obj diff --git a/proof/invariant-abstract/X64/ArchCSpace_AI.thy b/proof/invariant-abstract/X64/ArchCSpace_AI.thy index 5e7b5ca269..f7f5129075 100644 --- a/proof/invariant-abstract/X64/ArchCSpace_AI.thy +++ b/proof/invariant-abstract/X64/ArchCSpace_AI.thy @@ -12,7 +12,7 @@ theory ArchCSpace_AI imports CSpace_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming named_theorems CSpace_AI_assms @@ -436,7 +436,7 @@ end global_interpretation cap_insert_crunches?: cap_insert_crunches . -context Arch begin global_naming X64 +context Arch begin arch_global_naming lemma cap_insert_cap_refs_in_kernel_window[wp, CSpace_AI_assms]: "\cap_refs_in_kernel_window @@ -624,7 +624,7 @@ global_interpretation CSpace_AI?: CSpace_AI qed -context Arch begin global_naming X64 +context Arch begin arch_global_naming lemma cap_insert_simple_invs: "\invs and valid_cap cap and tcb_cap_valid cap dest and @@ -718,9 +718,6 @@ lemma arch_post_cap_deletion_invs: by (wpsimp simp: arch_post_cap_deletion_def free_ioport_range_def arch_post_cap_delete_pre_def wp: set_ioport_mask_invs) -end - -(* FIXME x64: these needs to be available globally but uses Arch facts *) lemma set_cap_valid_arch_caps_simple: "\\s. valid_arch_caps s \ valid_objs s @@ -729,6 +726,7 @@ lemma set_cap_valid_arch_caps_simple: \ \ (is_arch_cap cap)\ set_cap cap ptr \\rv. valid_arch_caps\" + supply vs_cap_ref_arch_def[simp del] table_cap_ref_arch_def[simp del] apply (wp X64.set_cap_valid_arch_caps) apply (clarsimp simp: cte_wp_at_caps_of_state) apply (frule(1) caps_of_state_valid_cap) @@ -736,26 +734,16 @@ lemma set_cap_valid_arch_caps_simple: apply (subgoal_tac "\x \ {cap, cap'}. \ X64.is_pt_cap x \ \ X64.is_pd_cap x \ \ X64.is_pdpt_cap x \ \ X64.is_pml4_cap x") apply simp apply (rule conjI) - apply (clarsimp simp: X64.vs_cap_ref_def is_cap_simps) + apply (clarsimp simp: X64.vs_cap_ref_def Invariants_AI.is_cap_simps) apply (erule impCE) apply (clarsimp simp: no_cap_to_obj_with_diff_ref_def cte_wp_at_caps_of_state X64.obj_ref_none_no_asid) apply (rule X64.no_cap_to_obj_with_diff_ref_triv, simp_all) - apply (rule ccontr, clarsimp simp: X64.table_cap_ref_def is_cap_simps) + apply (rule ccontr, clarsimp simp: X64.table_cap_ref_def Invariants_AI.is_cap_simps ) apply (auto simp: X64.is_cap_simps) done -lemma set_cap_kernel_window_simple: - "\\s. cap_refs_in_kernel_window s - \ cte_wp_at (\cap'. cap_range cap' = cap_range cap) ptr s\ - set_cap cap ptr - \\rv. cap_refs_in_kernel_window\" - apply (wp X64.set_cap_cap_refs_in_kernel_window) - apply (clarsimp simp: cte_wp_at_caps_of_state - X64.cap_refs_in_kernel_windowD) - done - - +end end diff --git a/proof/invariant-abstract/X64/ArchCrunchSetup_AI.thy b/proof/invariant-abstract/X64/ArchCrunchSetup_AI.thy index 45a9b90dab..08b3f37974 100644 --- a/proof/invariant-abstract/X64/ArchCrunchSetup_AI.thy +++ b/proof/invariant-abstract/X64/ArchCrunchSetup_AI.thy @@ -9,7 +9,7 @@ imports "ASpec.Syscall_A" "Lib.Crunch_Instances_NonDet" begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming crunch_ignore (add: debugPrint clearMemory invalidateTLB initL2Cache) diff --git a/proof/invariant-abstract/X64/ArchDetSchedAux_AI.thy b/proof/invariant-abstract/X64/ArchDetSchedAux_AI.thy index f6d35eb9b1..911c334098 100644 --- a/proof/invariant-abstract/X64/ArchDetSchedAux_AI.thy +++ b/proof/invariant-abstract/X64/ArchDetSchedAux_AI.thy @@ -8,7 +8,7 @@ theory ArchDetSchedAux_AI imports DetSchedAux_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming named_theorems DetSchedAux_AI_assms diff --git a/proof/invariant-abstract/X64/ArchDetSchedDomainTime_AI.thy b/proof/invariant-abstract/X64/ArchDetSchedDomainTime_AI.thy index dc583a270a..cef49d1278 100644 --- a/proof/invariant-abstract/X64/ArchDetSchedDomainTime_AI.thy +++ b/proof/invariant-abstract/X64/ArchDetSchedDomainTime_AI.thy @@ -8,7 +8,7 @@ theory ArchDetSchedDomainTime_AI imports DetSchedDomainTime_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming named_theorems DetSchedDomainTime_AI_assms @@ -55,7 +55,7 @@ global_interpretation DetSchedDomainTime_AI?: DetSchedDomainTime_AI case 1 show ?case by (unfold_locales; (fact DetSchedDomainTime_AI_assms)?) qed -context Arch begin global_naming X64 +context Arch begin arch_global_naming crunch arch_perform_invocation for domain_list_inv[wp, DetSchedDomainTime_AI_assms]: "\s. P (domain_list s)" diff --git a/proof/invariant-abstract/X64/ArchDetSchedSchedule_AI.thy b/proof/invariant-abstract/X64/ArchDetSchedSchedule_AI.thy index 40f301e03f..156c3f46df 100644 --- a/proof/invariant-abstract/X64/ArchDetSchedSchedule_AI.thy +++ b/proof/invariant-abstract/X64/ArchDetSchedSchedule_AI.thy @@ -8,7 +8,7 @@ theory ArchDetSchedSchedule_AI imports DetSchedSchedule_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming named_theorems DetSchedSchedule_AI_assms @@ -416,7 +416,7 @@ global_interpretation DetSchedSchedule_AI?: DetSchedSchedule_AI case 1 show ?case by (unfold_locales; (fact DetSchedSchedule_AI_assms)?) qed -context Arch begin global_naming X64 +context Arch begin arch_global_naming lemma handle_hyp_fault_valid_sched[wp, DetSchedSchedule_AI_assms]: "\valid_sched and invs and st_tcb_at active t and not_queued t and scheduler_act_not t diff --git a/proof/invariant-abstract/X64/ArchDeterministic_AI.thy b/proof/invariant-abstract/X64/ArchDeterministic_AI.thy index 9f10d70382..4b1cbd869f 100644 --- a/proof/invariant-abstract/X64/ArchDeterministic_AI.thy +++ b/proof/invariant-abstract/X64/ArchDeterministic_AI.thy @@ -8,7 +8,7 @@ theory ArchDeterministic_AI imports Deterministic_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming named_theorems Deterministic_AI_assms @@ -34,7 +34,7 @@ global_interpretation Deterministic_AI_1?: Deterministic_AI_1 case 1 show ?case by (unfold_locales; (fact Deterministic_AI_assms)?) qed -context Arch begin global_naming X64 +context Arch begin arch_global_naming crunch invoke_untyped for valid_list[wp]: valid_list diff --git a/proof/invariant-abstract/X64/ArchDetype_AI.thy b/proof/invariant-abstract/X64/ArchDetype_AI.thy index 17a3f8a37b..c23696d6fc 100644 --- a/proof/invariant-abstract/X64/ArchDetype_AI.thy +++ b/proof/invariant-abstract/X64/ArchDetype_AI.thy @@ -8,18 +8,18 @@ theory ArchDetype_AI imports Detype_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming -named_theorems Detype_AI_asms +named_theorems Detype_AI_assms -lemma valid_globals_irq_node[Detype_AI_asms]: +lemma valid_globals_irq_node[Detype_AI_assms]: "\ valid_global_refs s; cte_wp_at ((=) cap) ptr s \ \ interrupt_irq_node s irq \ cap_range cap" apply (erule(1) valid_global_refsD) apply (simp add: global_refs_def) done -lemma caps_of_state_ko[Detype_AI_asms]: +lemma caps_of_state_ko[Detype_AI_assms]: "valid_cap cap s \ is_untyped_cap cap \ cap_range cap = {} \ @@ -33,7 +33,7 @@ lemma caps_of_state_ko[Detype_AI_asms]: split: option.splits if_splits)+ done -lemma mapM_x_storeWord[Detype_AI_asms]: +lemma mapM_x_storeWord[Detype_AI_assms]: (* FIXME: taken from Retype_C.thy and adapted wrt. the missing intvl syntax. *) assumes al: "is_aligned ptr word_size_bits" shows "mapM_x (\x. storeWord (ptr + of_nat x * word_size) 0) [0..x. if x \ S then {} else state_hyp_refs_of s x)" by (rule ext, simp add: state_hyp_refs_of_def detype_def) -lemma valid_ioports_detype[Detype_AI_asms]: +lemma valid_ioports_detype[Detype_AI_assms]: "valid_ioports s \ valid_ioports (detype (untyped_range cap) s)" apply (clarsimp simp: valid_ioports_def all_ioports_issued_def ioports_no_overlap_def issued_ioports_def more_update.caps_of_state_update) apply (clarsimp simp: detype_def cap_ioports_def ran_def elim!: ranE split: if_splits cap.splits arch_cap.splits) @@ -121,7 +121,7 @@ interpretation Detype_AI?: Detype_AI proof goal_cases interpret Arch . case 1 show ?case - by (intro_locales; (unfold_locales; fact Detype_AI_asms)?) + by (intro_locales; (unfold_locales; fact Detype_AI_assms)?) qed context detype_locale_arch begin @@ -559,8 +559,8 @@ interpretation Detype_AI_2 Detype_AI_2.intro by blast -context begin interpretation Arch . -lemma delete_objects_invs[wp]: +(* generic consequence of architecture-specific details *) +lemma (in Arch) delete_objects_invs[wp]: "\(\s. \slot. cte_wp_at ((=) (cap.UntypedCap dev ptr bits f)) slot s \ descendants_range (cap.UntypedCap dev ptr bits f) slot s) and invs and ct_active\ @@ -580,6 +580,8 @@ lemma delete_objects_invs[wp]: apply (drule (1) cte_wp_valid_cap) apply (simp add: valid_cap_def cap_aligned_def word_size_bits_def untyped_min_bits_def) done -end + +requalify_facts Arch.delete_objects_invs +lemmas [wp] = delete_objects_invs end diff --git a/proof/invariant-abstract/X64/ArchEmptyFail_AI.thy b/proof/invariant-abstract/X64/ArchEmptyFail_AI.thy index ea504c99f4..f810fb6fa5 100644 --- a/proof/invariant-abstract/X64/ArchEmptyFail_AI.thy +++ b/proof/invariant-abstract/X64/ArchEmptyFail_AI.thy @@ -8,7 +8,7 @@ theory ArchEmptyFail_AI imports EmptyFail_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming named_theorems EmptyFail_AI_assms @@ -33,7 +33,7 @@ global_interpretation EmptyFail_AI_load_word?: EmptyFail_AI_load_word case 1 show ?case by (unfold_locales; (fact EmptyFail_AI_assms)?) qed -context Arch begin global_naming X64 +context Arch begin arch_global_naming crunch handle_fault for (empty_fail) empty_fail[wp, EmptyFail_AI_assms] @@ -141,7 +141,7 @@ global_interpretation EmptyFail_AI_derive_cap?: EmptyFail_AI_derive_cap case 1 show ?case by (unfold_locales; (fact EmptyFail_AI_assms)?) qed -context Arch begin global_naming X64 +context Arch begin arch_global_naming lemma flush_table_empty_fail[simp, wp]: "empty_fail (flush_table a b c d)" unfolding flush_table_def @@ -168,7 +168,7 @@ global_interpretation EmptyFail_AI_rec_del?: EmptyFail_AI_rec_del case 1 show ?case by (unfold_locales; (fact EmptyFail_AI_assms)?) qed -context Arch begin global_naming X64 +context Arch begin arch_global_naming crunch cap_delete, choose_thread for (empty_fail) empty_fail[wp, EmptyFail_AI_assms] @@ -192,7 +192,7 @@ global_interpretation EmptyFail_AI_schedule?: EmptyFail_AI_schedule case 1 show ?case by (unfold_locales; (fact EmptyFail_AI_assms)?) qed -context Arch begin global_naming X64 +context Arch begin arch_global_naming crunch possible_switch_to for (empty_fail) empty_fail[wp,EmptyFail_AI_assms] diff --git a/proof/invariant-abstract/X64/ArchFinalise_AI.thy b/proof/invariant-abstract/X64/ArchFinalise_AI.thy index 6c3089c7d5..1a380cd342 100644 --- a/proof/invariant-abstract/X64/ArchFinalise_AI.thy +++ b/proof/invariant-abstract/X64/ArchFinalise_AI.thy @@ -10,16 +10,16 @@ begin context Arch begin -named_theorems Finalise_AI_asms +named_theorems Finalise_AI_assms -lemma obj_at_not_live_valid_arch_cap_strg [Finalise_AI_asms]: +lemma obj_at_not_live_valid_arch_cap_strg [Finalise_AI_assms]: "(s \ ArchObjectCap cap \ aobj_ref cap = Some r) \ obj_at (\ko. \ live ko) r s" by (clarsimp simp: valid_cap_def obj_at_def a_type_arch_live live_def hyp_live_def split: arch_cap.split_asm if_splits) -global_naming X64 +arch_global_naming lemma valid_global_refs_asid_table_udapte [iff]: "valid_global_refs (s\arch_state := x64_asid_table_update f (arch_state s)\) = @@ -203,24 +203,22 @@ lemma unmap_page_tcb_cap_valid: apply (wp unmap_page_tcb_at hoare_vcg_ex_lift hoare_vcg_all_lift)+ done -global_naming Arch - -lemma (* replaceable_cdt_update *)[simp,Finalise_AI_asms]: +lemma (* replaceable_cdt_update *)[simp,Finalise_AI_assms]: "replaceable (cdt_update f s) = replaceable s" by (fastforce simp: replaceable_def tcb_cap_valid_def) -lemma (* replaceable_revokable_update *)[simp,Finalise_AI_asms]: +lemma (* replaceable_revokable_update *)[simp,Finalise_AI_assms]: "replaceable (is_original_cap_update f s) = replaceable s" by (fastforce simp: replaceable_def is_final_cap'_def2 tcb_cap_valid_def) -lemma (* replaceable_more_update *) [simp,Finalise_AI_asms]: +lemma (* replaceable_more_update *) [simp,Finalise_AI_assms]: "replaceable (trans_state f s) sl cap cap' = replaceable s sl cap cap'" by (simp add: replaceable_def) -lemma (* obj_ref_ofI *) [Finalise_AI_asms]: "obj_refs cap = {x} \ obj_ref_of cap = x" +lemma (* obj_ref_ofI *) [Finalise_AI_assms]: "obj_refs cap = {x} \ obj_ref_of cap = x" by (case_tac cap, simp_all) (rename_tac arch_cap, case_tac arch_cap, simp_all) -lemma (* empty_slot_invs *) [Finalise_AI_asms]: +lemma (* empty_slot_invs *) [Finalise_AI_assms]: "\\s. invs s \ cte_wp_at (replaceable s sl cap.NullCap) sl s \ emptyable sl s \ (info \ NullCap \ post_cap_delete_pre info ((caps_of_state s) (sl \ NullCap)))\ @@ -301,7 +299,7 @@ lemma (* empty_slot_invs *) [Finalise_AI_asms]: apply (simp add: is_final_cap'_def2 cte_wp_at_caps_of_state) done -lemma dom_tcb_cap_cases_lt_ARCH [Finalise_AI_asms]: +lemma dom_tcb_cap_cases_lt_ARCH [Finalise_AI_assms]: "dom tcb_cap_cases = {xs. length xs = 3 \ unat (of_bl xs :: machine_word) < 5}" apply (rule set_eqI, rule iffI) apply clarsimp @@ -311,7 +309,7 @@ lemma dom_tcb_cap_cases_lt_ARCH [Finalise_AI_asms]: apply (clarsimp simp: nat_to_cref_unat_of_bl'[simplified word_bits_def]) done -lemma (* unbind_notification_final *) [wp,Finalise_AI_asms]: +lemma (* unbind_notification_final *) [wp,Finalise_AI_assms]: "\is_final_cap' cap\ unbind_notification t \ \rv. is_final_cap' cap\" unfolding unbind_notification_def apply (wp final_cap_lift thread_set_caps_of_state_trivial hoare_drop_imps @@ -321,7 +319,7 @@ lemma (* unbind_notification_final *) [wp,Finalise_AI_asms]: crunch prepare_thread_delete for is_final_cap'[wp]: "is_final_cap' cap" -lemma (* finalise_cap_cases1 *)[Finalise_AI_asms]: +lemma (* finalise_cap_cases1 *)[Finalise_AI_assms]: "\\s. final \ is_final_cap' cap s \ cte_wp_at ((=) cap) slot s\ finalise_cap cap final @@ -353,7 +351,7 @@ lemma (* finalise_cap_cases1 *)[Finalise_AI_asms]: done crunch arch_finalise_cap, prepare_thread_delete - for typ_at_arch[wp,Finalise_AI_asms]: "\s. P (typ_at T p s)" + for typ_at_arch[wp,Finalise_AI_assms]: "\s. P (typ_at T p s)" (wp: crunch_wps simp: crunch_simps unless_def assertE_def ignore: maskInterrupt ) @@ -362,11 +360,11 @@ crunch prepare_thread_delete crunch prepare_thread_delete for tcb_at[wp]: "tcb_at p" crunch prepare_thread_delete - for cte_wp_at[wp, Finalise_AI_asms]: "\s. P (cte_wp_at P' p s)" + for cte_wp_at[wp, Finalise_AI_assms]: "\s. P (cte_wp_at P' p s)" crunch prepare_thread_delete - for irq_node[wp, Finalise_AI_asms]: "\s. P (interrupt_irq_node s)" + for irq_node[wp, Finalise_AI_assms]: "\s. P (interrupt_irq_node s)" crunch prepare_thread_delete - for caps_of_state[wp, Finalise_AI_asms]: "\s. P (caps_of_state s)" + for caps_of_state[wp, Finalise_AI_assms]: "\s. P (caps_of_state s)" crunch nativeThreadUsingFPU, switchFpuOwner for device_state_inv[wp]: "\ms. P (device_state ms)" @@ -395,7 +393,7 @@ crunch prepare_thread_delete for invs[wp]: invs (ignore: do_machine_op) -lemma (* finalise_cap_new_valid_cap *)[wp,Finalise_AI_asms]: +lemma (* finalise_cap_new_valid_cap *)[wp,Finalise_AI_assms]: "\valid_cap cap\ finalise_cap cap x \\rv. valid_cap (fst rv)\" apply (cases cap, simp_all) apply (wp suspend_valid_cap @@ -409,7 +407,7 @@ lemma (* finalise_cap_new_valid_cap *)[wp,Finalise_AI_asms]: split del: if_split|clarsimp|wpc)+ done -lemma (* arch_finalise_cap_invs *)[wp,Finalise_AI_asms]: +lemma (* arch_finalise_cap_invs *)[wp,Finalise_AI_assms]: "\invs and valid_cap (ArchObjectCap cap)\ arch_finalise_cap cap final \\rv. invs\" @@ -460,8 +458,7 @@ lemma arch_finalise_cap_replaceable[wp]: split: cap.splits arch_cap.splits option.splits vmpage_size.splits) done -global_naming Arch -lemma (* deleting_irq_handler_slot_not_irq_node *)[Finalise_AI_asms]: +lemma (* deleting_irq_handler_slot_not_irq_node *)[Finalise_AI_assms]: "\if_unsafe_then_cap and valid_global_refs and cte_wp_at (\cp. cap_irqs cp \ {}) sl\ deleting_irq_handler irq @@ -482,7 +479,7 @@ lemma (* deleting_irq_handler_slot_not_irq_node *)[Finalise_AI_asms]: apply (clarsimp simp: appropriate_cte_cap_def split: cap.split_asm) done -lemma no_cap_to_obj_with_diff_ref_finalI_ARCH[Finalise_AI_asms]: +lemma no_cap_to_obj_with_diff_ref_finalI_ARCH[Finalise_AI_assms]: "\ cte_wp_at ((=) cap) p s; is_final_cap' cap s; obj_refs cap' = obj_refs cap \ \ no_cap_to_obj_with_diff_ref cap' {p} s" @@ -504,7 +501,7 @@ lemma no_cap_to_obj_with_diff_ref_finalI_ARCH[Finalise_AI_asms]: gen_obj_refs_Int) done -lemma (* suspend_no_cap_to_obj_ref *)[wp,Finalise_AI_asms]: +lemma (* suspend_no_cap_to_obj_ref *)[wp,Finalise_AI_assms]: "\no_cap_to_obj_with_diff_ref cap S\ suspend t \\rv. no_cap_to_obj_with_diff_ref cap S\" @@ -535,13 +532,13 @@ crunch fpu_thread_delete for obj_at[wp]: "\s. P' (obj_at P p s)" (wp: whenE_wp simp: crunch_simps) -lemma (* fpu_thread_delete_no_cap_to_obj_ref *)[wp,Finalise_AI_asms]: +lemma (* fpu_thread_delete_no_cap_to_obj_ref *)[wp,Finalise_AI_assms]: "\no_cap_to_obj_with_diff_ref cap S\ fpu_thread_delete thread \\rv. no_cap_to_obj_with_diff_ref cap S\" by (wpsimp simp: no_cap_to_obj_with_diff_ref_def cte_wp_at_caps_of_state) -lemma finalise_cap_replaceable [Finalise_AI_asms]: +lemma finalise_cap_replaceable [Finalise_AI_assms]: "\\s. s \ cap \ x = is_final_cap' cap s \ valid_mdb s \ cte_wp_at ((=) cap) sl s \ valid_objs s \ sym_refs (state_refs_of s) \ (cap_irqs cap \ {} \ if_unsafe_then_cap s \ valid_global_refs s) @@ -593,7 +590,7 @@ lemma finalise_cap_replaceable [Finalise_AI_asms]: | simp add: valid_cap_simps is_nondevice_page_cap_simps)+) done -lemma (* deleting_irq_handler_cte_preserved *)[Finalise_AI_asms]: +lemma (* deleting_irq_handler_cte_preserved *)[Finalise_AI_assms]: assumes x: "\cap. P cap \ \ can_fast_finalise cap" shows "\cte_wp_at P p\ deleting_irq_handler irq \\rv. cte_wp_at P p\" apply (simp add: deleting_irq_handler_def) @@ -612,7 +609,7 @@ lemma set_asid_pool_cte_wp_at: crunch arch_finalise_cap - for cte_wp_at[wp,Finalise_AI_asms]: "\s. P (cte_wp_at P' p s)" + for cte_wp_at[wp,Finalise_AI_assms]: "\s. P (cte_wp_at P' p s)" (simp: crunch_simps assertE_def set_arch_obj_simps wp: set_aobject_cte_wp_at crunch_wps set_object_cte_at ignore: set_object) @@ -622,10 +619,10 @@ end interpretation Finalise_AI_1?: Finalise_AI_1 proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed -context Arch begin global_naming X64 +context Arch begin arch_global_naming lemma fast_finalise_replaceable[wp]: "\\s. s \ cap \ x = is_final_cap' cap s @@ -646,8 +643,7 @@ lemma fast_finalise_replaceable[wp]: apply (clarsimp simp: cap_irqs_def cap_irq_opt_def split: cap.split_asm) done -global_naming Arch -lemma (* cap_delete_one_invs *) [Finalise_AI_asms,wp]: +lemma (* cap_delete_one_invs *) [Finalise_AI_assms,wp]: "\invs and emptyable ptr\ cap_delete_one ptr \\rv. invs\" apply (simp add: cap_delete_one_def unless_def is_final_cap_def) apply (rule hoare_pre) @@ -661,10 +657,10 @@ end interpretation Finalise_AI_2?: Finalise_AI_2 proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed -context Arch begin global_naming X64 +context Arch begin arch_global_naming lemma flush_table_irq_node: "\\s. P (interrupt_irq_node s)\ flush_table a b c d \\_ s. P (interrupt_irq_node s)\" apply (simp add: flush_table_def) @@ -1175,11 +1171,12 @@ lemma invs_valid_arch_capsI: "invs s \ valid_arch_caps s" by (simp add: invs_def valid_state_def) -context Arch begin global_naming X64 (*FIXME: arch_split*) - +(* FIXME: move *) lemma all_Some_the_strg: "f b = None \ P (the (f b)) \ (\a. f b = Some a \ P a)" by auto +context Arch begin arch_global_naming + lemma vs_cap_ref_PageCap_Some_None[simp]: "(vs_cap_ref (ArchObjectCap (PageCap d p R typ sz (Some v))) = None) = False" by (case_tac sz; simp add: vs_cap_ref_simps split_def) @@ -1251,9 +1248,7 @@ crunch invalidate_page_structure_cache_asid, hw_asid_invalidate crunch do_machine_op for valid_asid_table[wp]: "\s. valid_asid_table (x64_asid_table (arch_state s)) s" -global_naming Arch - -lemma (* finalise_cap_invs *)[Finalise_AI_asms]: +lemma (* finalise_cap_invs *)[Finalise_AI_assms]: shows "\invs and cte_wp_at ((=) cap) slot\ finalise_cap cap x \\rv. invs\" apply (cases cap, simp_all split del: if_split) apply (wp cancel_all_ipc_invs cancel_all_signals_invs unbind_notification_invs @@ -1270,20 +1265,20 @@ lemma (* finalise_cap_invs *)[Finalise_AI_asms]: apply (auto dest: cte_wp_at_valid_objs_valid_cap) done -lemma (* finalise_cap_irq_node *)[Finalise_AI_asms]: +lemma (* finalise_cap_irq_node *)[Finalise_AI_assms]: "\\s. P (interrupt_irq_node s)\ finalise_cap a b \\_ s. P (interrupt_irq_node s)\" apply (case_tac a,simp_all) apply (wp | clarsimp)+ done -lemmas (*arch_finalise_cte_irq_node *) [wp,Finalise_AI_asms] +lemmas (*arch_finalise_cte_irq_node *) [wp,Finalise_AI_assms] = hoare_use_eq_irq_node [OF arch_finalise_cap_irq_node arch_finalise_cap_cte_wp_at] -lemma irq_node_global_refs_ARCH [Finalise_AI_asms]: +lemma irq_node_global_refs_ARCH [Finalise_AI_assms]: "interrupt_irq_node s irq \ global_refs s" by (simp add: global_refs_def) -lemma (* get_irq_slot_fast_finalisable *)[wp,Finalise_AI_asms]: +lemma (* get_irq_slot_fast_finalisable *)[wp,Finalise_AI_assms]: "\invs\ get_irq_slot irq \cte_wp_at can_fast_finalise\" apply (simp add: get_irq_slot_def) apply wp @@ -1305,12 +1300,12 @@ lemma (* get_irq_slot_fast_finalisable *)[wp,Finalise_AI_asms]: apply (clarsimp simp: cap_range_def) done -lemma (* replaceable_or_arch_update_same *) [Finalise_AI_asms]: +lemma (* replaceable_or_arch_update_same *) [Finalise_AI_assms]: "replaceable_or_arch_update s slot cap cap" by (clarsimp simp: replaceable_or_arch_update_def replaceable_def is_arch_update_def is_cap_simps) -lemma (* replace_cap_invs_arch_update *)[Finalise_AI_asms]: +lemma (* replace_cap_invs_arch_update *)[Finalise_AI_assms]: "\\s. cte_wp_at (replaceable_or_arch_update s p cap) p s \ invs s \ cap \ cap.NullCap @@ -1331,7 +1326,7 @@ lemma (* replace_cap_invs_arch_update *)[Finalise_AI_asms]: crunch hw_asid_invalidate for pred_tcb_at_P[wp]: "\s. P (pred_tcb_at proj Q p s)" -lemma dmo_tcb_cap_valid_ARCH [Finalise_AI_asms]: +lemma dmo_tcb_cap_valid_ARCH [Finalise_AI_assms]: "\\s. P (tcb_cap_valid cap ptr s)\ do_machine_op mop \\_ s. P (tcb_cap_valid cap ptr s)\" apply (simp add: tcb_cap_valid_def no_cap_to_obj_with_diff_ref_def) apply (rule hoare_pre) @@ -1340,7 +1335,7 @@ lemma dmo_tcb_cap_valid_ARCH [Finalise_AI_asms]: apply simp done -lemma (* dmo_replaceable_or_arch_update *) [Finalise_AI_asms,wp]: +lemma (* dmo_replaceable_or_arch_update *) [Finalise_AI_assms,wp]: "\\s. replaceable_or_arch_update s slot cap cap'\ do_machine_op mo \\r s. replaceable_or_arch_update s slot cap cap'\" @@ -1354,25 +1349,23 @@ lemma (* dmo_replaceable_or_arch_update *) [Finalise_AI_asms,wp]: end -context begin interpretation Arch . -requalify_consts replaceable_or_arch_update -end +arch_requalify_consts replaceable_or_arch_update interpretation Finalise_AI_3?: Finalise_AI_3 where replaceable_or_arch_update = replaceable_or_arch_update proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed interpretation Finalise_AI_4?: Finalise_AI_4 where replaceable_or_arch_update = replaceable_or_arch_update proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed -context Arch begin global_naming X64 +context Arch begin arch_global_naming lemma set_asid_pool_obj_at_ptr: "\\s. P (ArchObj (arch_kernel_obj.ASIDPool mp))\ @@ -1607,9 +1600,9 @@ crunch unmap_page_table, (wp: mapM_wp_inv mapM_x_wp' crunch_wps simp: crunch_simps set_arch_obj_simps ignore: set_object) -lemmas clearMemory_invs[wp, Finalise_AI_asms] = clearMemory_invs +lemmas clearMemory_invs[wp, Finalise_AI_assms] = clearMemory_invs -lemma valid_idle_has_null_cap_ARCH[Finalise_AI_asms]: +lemma valid_idle_has_null_cap_ARCH[Finalise_AI_assms]: "\ if_unsafe_then_cap s; valid_global_refs s; valid_idle s; valid_irq_node s\ \ caps_of_state s (idle_thread s, v) = Some cap \ cap = NullCap" @@ -1625,7 +1618,7 @@ lemma valid_idle_has_null_cap_ARCH[Finalise_AI_asms]: apply (drule_tac x=word in spec, simp) done -lemma (* zombie_cap_two_nonidles *)[Finalise_AI_asms]: +lemma (* zombie_cap_two_nonidles *)[Finalise_AI_assms]: "\ caps_of_state s ptr = Some (Zombie ptr' zbits n); invs s \ \ fst ptr \ idle_thread s \ ptr' \ idle_thread s" apply (frule valid_global_refsD2, clarsimp+) @@ -1674,7 +1667,7 @@ interpretation Finalise_AI_5?: Finalise_AI_5 where replaceable_or_arch_update = replaceable_or_arch_update proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact Finalise_AI_assms)?) qed end diff --git a/proof/invariant-abstract/X64/ArchInterruptAcc_AI.thy b/proof/invariant-abstract/X64/ArchInterruptAcc_AI.thy index 3c11e18bba..a43c92d343 100644 --- a/proof/invariant-abstract/X64/ArchInterruptAcc_AI.thy +++ b/proof/invariant-abstract/X64/ArchInterruptAcc_AI.thy @@ -12,7 +12,7 @@ theory ArchInterruptAcc_AI imports InterruptAcc_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming named_theorems InterruptAcc_AI_assms diff --git a/proof/invariant-abstract/X64/ArchInterrupt_AI.thy b/proof/invariant-abstract/X64/ArchInterrupt_AI.thy index 25468596be..494615744d 100644 --- a/proof/invariant-abstract/X64/ArchInterrupt_AI.thy +++ b/proof/invariant-abstract/X64/ArchInterrupt_AI.thy @@ -8,7 +8,7 @@ theory ArchInterrupt_AI imports Interrupt_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming primrec arch_irq_control_inv_valid_real :: "arch_irq_control_invocation \ 'a::state_ext state \ bool" where @@ -32,9 +32,9 @@ where defs arch_irq_control_inv_valid_def: "arch_irq_control_inv_valid \ arch_irq_control_inv_valid_real" -named_theorems Interrupt_AI_asms +named_theorems Interrupt_AI_assms -lemma (* decode_irq_control_invocation_inv *)[Interrupt_AI_asms]: +lemma (* decode_irq_control_invocation_inv *)[Interrupt_AI_assms]: "\P\ decode_irq_control_invocation label args slot caps \\rv. P\" apply (simp add: decode_irq_control_invocation_def Let_def arch_check_irq_def arch_decode_irq_control_invocation_def whenE_def split del: if_split) @@ -129,7 +129,7 @@ lemma arch_decode_irq_control_valid[wp]: done end -lemma (* decode_irq_control_valid *)[Interrupt_AI_asms]: +lemma (* decode_irq_control_valid *)[Interrupt_AI_assms]: "\\s. invs s \ (\cap \ set caps. s \ cap) \ (\cap \ set caps. is_cnode_cap cap \ (\r \ cte_refs cap (interrupt_irq_node s). ex_cte_cap_wp_to is_cnode_cap r s)) @@ -144,7 +144,7 @@ lemma (* decode_irq_control_valid *)[Interrupt_AI_asms]: | wp (once) hoare_drop_imps)+ done -lemma get_irq_slot_different_ARCH[Interrupt_AI_asms]: +lemma get_irq_slot_different_ARCH[Interrupt_AI_assms]: "\\s. valid_global_refs s \ ex_cte_cap_wp_to is_cnode_cap ptr s\ get_irq_slot irq \\rv s. rv \ ptr\" @@ -156,7 +156,7 @@ lemma get_irq_slot_different_ARCH[Interrupt_AI_asms]: apply (clarsimp simp: global_refs_def is_cap_simps cap_range_def) done -lemma is_derived_use_interrupt_ARCH[Interrupt_AI_asms]: +lemma is_derived_use_interrupt_ARCH[Interrupt_AI_assms]: "(is_ntfn_cap cap \ interrupt_derived cap cap') \ (is_derived m p cap cap')" apply (clarsimp simp: is_cap_simps) apply (clarsimp simp: interrupt_derived_def is_derived_def) @@ -164,7 +164,7 @@ lemma is_derived_use_interrupt_ARCH[Interrupt_AI_asms]: apply (simp add: is_cap_simps is_pt_cap_def vs_cap_ref_def) done -lemma maskInterrupt_invs_ARCH[Interrupt_AI_asms]: +lemma maskInterrupt_invs_ARCH[Interrupt_AI_assms]: "\invs and (\s. \b \ interrupt_states s irq \ IRQInactive)\ do_machine_op (maskInterrupt b irq) \\rv. invs\" @@ -174,7 +174,7 @@ lemma maskInterrupt_invs_ARCH[Interrupt_AI_asms]: valid_irq_states_but_def valid_irq_masks_but_def valid_machine_state_def cur_tcb_def valid_irq_states_def valid_irq_masks_def) done -lemma no_cap_to_obj_with_diff_IRQHandler_ARCH[Interrupt_AI_asms]: +lemma no_cap_to_obj_with_diff_IRQHandler_ARCH[Interrupt_AI_assms]: "no_cap_to_obj_with_diff_ref (IRQHandlerCap irq) S = \" by (rule ext, simp add: no_cap_to_obj_with_diff_ref_def cte_wp_at_caps_of_state @@ -183,7 +183,7 @@ lemma no_cap_to_obj_with_diff_IRQHandler_ARCH[Interrupt_AI_asms]: crunch do_machine_op for valid_cap: "valid_cap cap" -lemma (* set_irq_state_valid_cap *)[Interrupt_AI_asms]: +lemma (* set_irq_state_valid_cap *)[Interrupt_AI_assms]: "\valid_cap cap\ set_irq_state IRQSignal irq \\rv. valid_cap cap\" apply (clarsimp simp: set_irq_state_def) apply (wp do_machine_op_valid_cap) @@ -193,12 +193,12 @@ lemma (* set_irq_state_valid_cap *)[Interrupt_AI_asms]: done crunch set_irq_state - for valid_global_refs[Interrupt_AI_asms]: "valid_global_refs" + for valid_global_refs[Interrupt_AI_assms]: "valid_global_refs" crunch arch_invoke_irq_handler for typ_at[wp]: "\s. P (typ_at T p s)" -lemma invoke_irq_handler_invs'[Interrupt_AI_asms]: +lemma invoke_irq_handler_invs'[Interrupt_AI_assms]: assumes dmo_ex_inv[wp]: "\f. \invs and ex_inv\ do_machine_op f \\rv::unit. ex_inv\" assumes cap_insert_ex_inv[wp]: "\cap src dest. \ex_inv and invs and K (src \ dest)\ @@ -314,7 +314,7 @@ lemma arch_invoke_irq_control_invs[wp]: maxUserIRQ_def maxIRQ_def order.trans ex_cte_cap_to_cnode_always_appropriate_strg) -lemma (* invoke_irq_control_invs *) [Interrupt_AI_asms]: +lemma (* invoke_irq_control_invs *) [Interrupt_AI_assms]: "\invs and irq_control_inv_valid i\ invoke_irq_control i \\rv. invs\" apply (cases i, simp_all) apply (rule hoare_pre) @@ -331,7 +331,7 @@ lemma (* invoke_irq_control_invs *) [Interrupt_AI_asms]: crunch resetTimer for device_state_inv[wp]: "\ms. P (device_state ms)" -lemma resetTimer_invs_ARCH[Interrupt_AI_asms]: +lemma resetTimer_invs_ARCH[Interrupt_AI_assms]: "\invs\ do_machine_op resetTimer \\_. invs\" apply (wp dmo_invs) apply safe @@ -344,15 +344,15 @@ lemma resetTimer_invs_ARCH[Interrupt_AI_asms]: apply(erule use_valid, wp no_irq_resetTimer no_irq, assumption) done -lemma empty_fail_ackInterrupt_ARCH[Interrupt_AI_asms]: +lemma empty_fail_ackInterrupt_ARCH[Interrupt_AI_assms]: "empty_fail (ackInterrupt irq)" by (wp | simp add: ackInterrupt_def)+ -lemma empty_fail_maskInterrupt_ARCH[Interrupt_AI_asms]: +lemma empty_fail_maskInterrupt_ARCH[Interrupt_AI_assms]: "empty_fail (maskInterrupt f irq)" by (wp | simp add: maskInterrupt_def)+ -lemma (* handle_interrupt_invs *) [Interrupt_AI_asms]: +lemma (* handle_interrupt_invs *) [Interrupt_AI_assms]: "\invs\ handle_interrupt irq \\_. invs\" apply (simp add: handle_interrupt_def ) apply (rule conjI; rule impI) @@ -367,7 +367,7 @@ lemma (* handle_interrupt_invs *) [Interrupt_AI_asms]: apply (wp hoare_drop_imps resetTimer_invs_ARCH | simp add: get_irq_state_def handle_reserved_irq_def)+ done -lemma sts_arch_irq_control_inv_valid[wp, Interrupt_AI_asms]: +lemma sts_arch_irq_control_inv_valid[wp, Interrupt_AI_assms]: "\arch_irq_control_inv_valid i\ set_thread_state t st \\rv. arch_irq_control_inv_valid i\" @@ -387,7 +387,7 @@ end interpretation Interrupt_AI?: Interrupt_AI proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales, simp_all add: Interrupt_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales, simp_all add: Interrupt_AI_assms)?) qed end diff --git a/proof/invariant-abstract/X64/ArchInvariants_AI.thy b/proof/invariant-abstract/X64/ArchInvariants_AI.thy index 884b521be6..fe1f0dca2d 100644 --- a/proof/invariant-abstract/X64/ArchInvariants_AI.thy +++ b/proof/invariant-abstract/X64/ArchInvariants_AI.thy @@ -25,7 +25,7 @@ end_qualify \ \---------------------------------------------------------------------------\ section "X64-specific invariant definitions" -qualify X64_A (in Arch) +qualify X64 (in Arch) (* X64 has no interest for iarch_tcb (introduced for ARM_HYP) , and we consider no non-trivial predicates of iarch_tcb, so an unspecified typedecl seems appropriate. @@ -35,7 +35,7 @@ qualify X64_A (in Arch) typedecl iarch_tcb end_qualify -context Arch begin global_naming X64 +context Arch begin arch_global_naming definition arch_tcb_to_iarch_tcb :: "arch_tcb \ iarch_tcb" @@ -604,16 +604,15 @@ definition "second_level_tables \ arch_state.x64_global_pdpts" end -context begin interpretation Arch . -requalify_consts vs_lookup -end +(* needed for abbreviation *) +arch_requalify_consts vs_lookup abbreviation vs_lookup_abbr ("_ \ _" [80,80] 81) where "rs \ p \ \s. (rs,p) \ vs_lookup s" -context Arch begin global_naming X64 +context Arch begin arch_global_naming abbreviation is_reachable_abbr :: "obj_ref \ 'z::state_ext state \ bool" ("\\ _" [80] 81) where @@ -706,9 +705,8 @@ where end -context begin interpretation Arch . -requalify_consts vs_lookup_pages -end +(* needed for abbreviation *) +arch_requalify_consts vs_lookup_pages abbreviation vs_lookup_pages_abbr @@ -720,7 +718,7 @@ abbreviation "\\ p \ \s. \ref. (ref \ p) s" -context Arch begin global_naming X64 +context Arch begin arch_global_naming definition "vspace_obj_fun_lift \ arch_obj_fun_lift" @@ -1740,7 +1738,7 @@ lemma valid_ioports_update[iff]: end -context Arch begin global_naming X64 +context Arch begin arch_global_naming lemma global_refs_equiv: assumes "idle_thread s = idle_thread s'" @@ -3030,7 +3028,7 @@ lemma vs_cap_ref_eq_imp_table_cap_ref_eq: arch_cap_fun_lift_def split: cap.splits arch_cap.splits vmpage_size.splits option.splits) -lemma acap_rights_update_id [intro!, simp]: +lemma wf_acap_rights_update_id [intro!, simp]: "\wellformed_acap cap\ \ acap_rights_update (acap_rights cap) cap = cap" unfolding wellformed_acap_def acap_rights_update_def by (auto split: arch_cap.splits) diff --git a/proof/invariant-abstract/X64/ArchIpcCancel_AI.thy b/proof/invariant-abstract/X64/ArchIpcCancel_AI.thy index a9a291e562..369304e6e0 100644 --- a/proof/invariant-abstract/X64/ArchIpcCancel_AI.thy +++ b/proof/invariant-abstract/X64/ArchIpcCancel_AI.thy @@ -8,28 +8,28 @@ theory ArchIpcCancel_AI imports IpcCancel_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming -named_theorems IpcCancel_AI_asms +named_theorems IpcCancel_AI_assms crunch set_endpoint - for v_ker_map[wp,IpcCancel_AI_asms]: "valid_kernel_mappings" + for v_ker_map[wp,IpcCancel_AI_assms]: "valid_kernel_mappings" (ignore: set_object wp: set_object_v_ker_map crunch_wps) crunch set_endpoint - for eq_ker_map[wp,IpcCancel_AI_asms]: "equal_kernel_mappings" + for eq_ker_map[wp,IpcCancel_AI_assms]: "equal_kernel_mappings" (ignore: set_object wp: set_object_equal_mappings crunch_wps) crunch arch_post_cap_deletion - for typ_at[wp, IpcCancel_AI_asms]: "\s. P (typ_at T p s)" - and idle_thread[wp, IpcCancel_AI_asms]: "\s. P (idle_thread s)" + for typ_at[wp, IpcCancel_AI_assms]: "\s. P (typ_at T p s)" + and idle_thread[wp, IpcCancel_AI_assms]: "\s. P (idle_thread s)" end interpretation IpcCancel_AI?: IpcCancel_AI proof goal_cases interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; fact IpcCancel_AI_asms)?) + case 1 show ?case by (intro_locales; (unfold_locales; fact IpcCancel_AI_assms)?) qed end diff --git a/proof/invariant-abstract/X64/ArchIpc_AI.thy b/proof/invariant-abstract/X64/ArchIpc_AI.thy index 1a2c34122c..f3d5e977cb 100644 --- a/proof/invariant-abstract/X64/ArchIpc_AI.thy +++ b/proof/invariant-abstract/X64/ArchIpc_AI.thy @@ -8,7 +8,7 @@ theory ArchIpc_AI imports Ipc_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming named_theorems Ipc_AI_assms @@ -418,7 +418,7 @@ proof goal_cases case 1 show ?case by (unfold_locales; (fact Ipc_AI_assms)?) qed -context Arch begin global_naming X64 +context Arch begin arch_global_naming named_theorems Ipc_AI_cont_assms diff --git a/proof/invariant-abstract/X64/ArchKHeap_AI.thy b/proof/invariant-abstract/X64/ArchKHeap_AI.thy index 6b6c31b8b5..49b82438f1 100644 --- a/proof/invariant-abstract/X64/ArchKHeap_AI.thy +++ b/proof/invariant-abstract/X64/ArchKHeap_AI.thy @@ -8,7 +8,7 @@ theory ArchKHeap_AI imports KHeapPre_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming definition "non_vspace_obj \ non_arch_obj" definition "vspace_obj_pred \ arch_obj_pred" @@ -22,7 +22,7 @@ locale vspace_only_obj_pred = Arch + sublocale vspace_only_obj_pred < arch_only_obj_pred using vspace_only[unfolded vspace_obj_pred_def] by unfold_locales -context Arch begin global_naming X64 +context Arch begin arch_global_naming sublocale empty_table: vspace_only_obj_pred "empty_table S" for S by unfold_locales (simp add: vspace_obj_pred_def empty_table_def del: arch_obj_fun_lift_expand) diff --git a/proof/invariant-abstract/X64/ArchKernelInit_AI.thy b/proof/invariant-abstract/X64/ArchKernelInit_AI.thy index dc3f56312c..42bab0aa5b 100644 --- a/proof/invariant-abstract/X64/ArchKernelInit_AI.thy +++ b/proof/invariant-abstract/X64/ArchKernelInit_AI.thy @@ -14,7 +14,7 @@ imports Arch_AI begin -context Arch begin global_naming X64 (*FIXME: arch_split*) +context Arch begin arch_global_naming text \ Showing that there is a state that satisfies the abstract invariants. diff --git a/proof/invariant-abstract/X64/ArchLevityCatch_AI.thy b/proof/invariant-abstract/X64/ArchLevityCatch_AI.thy index 72b8a8cf0b..2c89221bc5 100644 --- a/proof/invariant-abstract/X64/ArchLevityCatch_AI.thy +++ b/proof/invariant-abstract/X64/ArchLevityCatch_AI.thy @@ -11,7 +11,7 @@ imports "Lib.SplitRule" begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming lemma asid_high_bits_of_shift : "asid_high_bits_of (ucast x << asid_low_bits) = x" diff --git a/proof/invariant-abstract/X64/ArchRetype_AI.thy b/proof/invariant-abstract/X64/ArchRetype_AI.thy index b7a36d083a..5b1b8d2679 100644 --- a/proof/invariant-abstract/X64/ArchRetype_AI.thy +++ b/proof/invariant-abstract/X64/ArchRetype_AI.thy @@ -13,7 +13,7 @@ theory ArchRetype_AI imports Retype_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming named_theorems Retype_AI_assms @@ -515,10 +515,7 @@ declare post_retype_invs_check_def[simp] end - -context begin interpretation Arch . -requalify_consts post_retype_invs_check -end +arch_requalify_consts post_retype_invs_check definition post_retype_invs :: "apiobject_type \ machine_word list \ 'z::state_ext state \ bool" @@ -534,14 +531,14 @@ global_interpretation Retype_AI_post_retype_invs?: Retype_AI_post_retype_invs by (unfold_locales; fact post_retype_invs_def) -context Arch begin global_naming X64 +context Arch begin arch_global_naming lemma init_arch_objects_invs_from_restricted: "\post_retype_invs new_type refs and (\s. global_refs s \ set refs = {}) and K (\ref \ set refs. is_aligned ref (obj_bits_api new_type obj_sz))\ - init_arch_objects new_type ptr bits obj_sz refs + init_arch_objects new_type dev ptr bits obj_sz refs \\_. invs\" apply (simp add: init_arch_objects_def) apply (rule hoare_pre) @@ -598,7 +595,7 @@ global_interpretation Retype_AI_slot_bits?: Retype_AI_slot_bits qed -context Arch begin global_naming X64 +context Arch begin arch_global_naming lemma valid_untyped_helper [Retype_AI_assms]: assumes valid_c : "s \ c" @@ -831,7 +828,7 @@ sublocale retype_region_proofs_gen?: retype_region_proofs_gen end -context Arch begin global_naming X64 (*FIXME: arch_split*) +context Arch begin arch_global_naming definition valid_vs_lookup2 :: "(vs_ref list \ machine_word) set \ (cslot_ptr \ cap) \ bool" @@ -961,10 +958,7 @@ where end -context begin interpretation Arch . -requalify_consts region_in_kernel_window -end - +arch_requalify_consts region_in_kernel_window lemma cap_range_respects_device_region_cong[cong]: "device_state (machine_state s) = device_state (machine_state s') @@ -1178,7 +1172,7 @@ lemmas post_retype_invs_axioms = retype_region_proofs_invs_axioms end -context Arch begin global_naming X64 +context Arch begin arch_global_naming named_theorems Retype_AI_assms' @@ -1211,7 +1205,7 @@ global_interpretation Retype_AI?: Retype_AI qed -context Arch begin global_naming X64 +context Arch begin arch_global_naming lemma retype_region_plain_invs: "\invs and caps_no_overlap ptr sz and pspace_no_overlap_range_cover ptr sz @@ -1293,7 +1287,7 @@ crunch init_arch_objects (wp: crunch_wps) lemma init_arch_objects_excap[wp]: - "\ex_cte_cap_wp_to P p\ init_arch_objects tp ptr bits us refs \\rv. ex_cte_cap_wp_to P p\" + "\ex_cte_cap_wp_to P p\ init_arch_objects tp dev ptr bits us refs \\rv. ex_cte_cap_wp_to P p\" by (wp ex_cte_cap_to_pres ) crunch init_arch_objects diff --git a/proof/invariant-abstract/X64/ArchSchedule_AI.thy b/proof/invariant-abstract/X64/ArchSchedule_AI.thy index 09ba73456b..ebb2caee51 100644 --- a/proof/invariant-abstract/X64/ArchSchedule_AI.thy +++ b/proof/invariant-abstract/X64/ArchSchedule_AI.thy @@ -8,11 +8,11 @@ theory ArchSchedule_AI imports Schedule_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming -named_theorems Schedule_AI_asms +named_theorems Schedule_AI_assms -lemma dmo_mapM_storeWord_0_invs[wp,Schedule_AI_asms]: +lemma dmo_mapM_storeWord_0_invs[wp,Schedule_AI_assms]: "valid invs (do_machine_op (mapM (\p. storeWord p 0) S)) (\_. invs)" apply (simp add: dom_mapM ef_storeWord) apply (rule mapM_UNIV_wp) @@ -28,27 +28,25 @@ lemma dmo_mapM_storeWord_0_invs[wp,Schedule_AI_asms]: apply (simp add: upto0_7_def word_bits_def split: if_splits) done -global_naming Arch - -lemma arch_stt_invs [wp,Schedule_AI_asms]: +lemma arch_stt_invs [wp,Schedule_AI_assms]: "\invs\ arch_switch_to_thread t' \\_. invs\" apply (simp add: arch_switch_to_thread_def) apply wp done -lemma arch_stt_tcb [wp,Schedule_AI_asms]: +lemma arch_stt_tcb [wp,Schedule_AI_assms]: "\tcb_at t'\ arch_switch_to_thread t' \\_. tcb_at t'\" apply (simp add: arch_switch_to_thread_def) apply (wp) done -lemma arch_stt_runnable[Schedule_AI_asms]: +lemma arch_stt_runnable[Schedule_AI_assms]: "\st_tcb_at runnable t\ arch_switch_to_thread t \\r . st_tcb_at runnable t\" apply (simp add: arch_switch_to_thread_def) apply wp done -lemma arch_stit_invs[wp, Schedule_AI_asms]: +lemma arch_stit_invs[wp, Schedule_AI_assms]: "\invs\ arch_switch_to_idle_thread \\r. invs\" by (wpsimp wp: svr_invs simp: arch_switch_to_idle_thread_def) @@ -66,20 +64,20 @@ crunch set_vm_root for ct[wp]: "\s. P (cur_thread s)" (wp: crunch_wps simp: crunch_simps) -lemma arch_stit_activatable[wp, Schedule_AI_asms]: +lemma arch_stit_activatable[wp, Schedule_AI_assms]: "\ct_in_state activatable\ arch_switch_to_idle_thread \\rv . ct_in_state activatable\" apply (clarsimp simp: arch_switch_to_idle_thread_def) apply (wpsimp simp: ct_in_state_def wp: ct_in_state_thread_state_lift) done -lemma stit_invs [wp,Schedule_AI_asms]: +lemma stit_invs [wp,Schedule_AI_assms]: "\invs\ switch_to_idle_thread \\rv. invs\" apply (simp add: switch_to_idle_thread_def) apply (wp sct_invs) apply (clarsimp simp: invs_def valid_state_def valid_idle_def pred_tcb_at_tcb_at) done -lemma stit_activatable[Schedule_AI_asms]: +lemma stit_activatable[Schedule_AI_assms]: "\invs\ switch_to_idle_thread \\rv . ct_in_state activatable\" apply (simp add: switch_to_idle_thread_def arch_switch_to_idle_thread_def) apply (wp | simp add: ct_in_state_def)+ @@ -87,7 +85,7 @@ lemma stit_activatable[Schedule_AI_asms]: elim!: pred_tcb_weaken_strongerE) done -lemma stt_invs [wp,Schedule_AI_asms]: +lemma stt_invs [wp,Schedule_AI_assms]: "\invs\ switch_to_thread t' \\_. invs\" apply (simp add: switch_to_thread_def) apply wp @@ -107,14 +105,14 @@ interpretation Schedule_AI_U?: Schedule_AI_U proof goal_cases interpret Arch . case 1 show ?case - by (intro_locales; (unfold_locales; fact Schedule_AI_asms)?) + by (intro_locales; (unfold_locales; fact Schedule_AI_assms)?) qed interpretation Schedule_AI?: Schedule_AI proof goal_cases interpret Arch . case 1 show ?case - by (intro_locales; (unfold_locales; fact Schedule_AI_asms)?) + by (intro_locales; (unfold_locales; fact Schedule_AI_assms)?) qed end diff --git a/proof/invariant-abstract/X64/ArchSyscall_AI.thy b/proof/invariant-abstract/X64/ArchSyscall_AI.thy index 072df8d9fe..9741ca1c0c 100644 --- a/proof/invariant-abstract/X64/ArchSyscall_AI.thy +++ b/proof/invariant-abstract/X64/ArchSyscall_AI.thy @@ -13,7 +13,7 @@ imports Syscall_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming named_theorems Syscall_AI_assms diff --git a/proof/invariant-abstract/X64/ArchTcbAcc_AI.thy b/proof/invariant-abstract/X64/ArchTcbAcc_AI.thy index eaef217f1a..0e99b89850 100644 --- a/proof/invariant-abstract/X64/ArchTcbAcc_AI.thy +++ b/proof/invariant-abstract/X64/ArchTcbAcc_AI.thy @@ -8,7 +8,7 @@ theory ArchTcbAcc_AI imports TcbAcc_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming named_theorems TcbAcc_AI_assms diff --git a/proof/invariant-abstract/X64/ArchTcb_AI.thy b/proof/invariant-abstract/X64/ArchTcb_AI.thy index c2fee80867..5e8098c8cb 100644 --- a/proof/invariant-abstract/X64/ArchTcb_AI.thy +++ b/proof/invariant-abstract/X64/ArchTcb_AI.thy @@ -8,19 +8,19 @@ theory ArchTcb_AI imports Tcb_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming -named_theorems Tcb_AI_asms +named_theorems Tcb_AI_assms -lemma activate_idle_invs[Tcb_AI_asms]: +lemma activate_idle_invs[Tcb_AI_assms]: "\invs and ct_idle\ arch_activate_idle_thread thread \\rv. invs and ct_idle\" by (simp add: arch_activate_idle_thread_def) -lemma empty_fail_getRegister [intro!, simp, Tcb_AI_asms]: +lemma empty_fail_getRegister [intro!, simp, Tcb_AI_assms]: "empty_fail (getRegister r)" by (simp add: getRegister_def) @@ -37,7 +37,7 @@ lemma same_object_also_valid: (* arch specific *) split: cap.split_asm arch_cap.split_asm option.splits)+) done -lemma same_object_obj_refs[Tcb_AI_asms]: +lemma same_object_obj_refs[Tcb_AI_assms]: "\ same_object_as cap cap' \ \ obj_refs cap = obj_refs cap'" apply (cases cap, simp_all add: same_object_as_def) @@ -141,13 +141,13 @@ lemma checked_insert_tcb_invs[wp]: (* arch specific *) done crunch arch_get_sanitise_register_info, arch_post_modify_registers - for tcb_at[wp, Tcb_AI_asms]: "tcb_at a" + for tcb_at[wp, Tcb_AI_assms]: "tcb_at a" crunch arch_get_sanitise_register_info, arch_post_modify_registers - for invs[wp, Tcb_AI_asms]: "invs" + for invs[wp, Tcb_AI_assms]: "invs" crunch arch_get_sanitise_register_info, arch_post_modify_registers - for ex_nonz_cap_to[wp, Tcb_AI_asms]: "ex_nonz_cap_to a" + for ex_nonz_cap_to[wp, Tcb_AI_assms]: "ex_nonz_cap_to a" -lemma finalise_cap_not_cte_wp_at[Tcb_AI_asms]: +lemma finalise_cap_not_cte_wp_at[Tcb_AI_assms]: assumes x: "P cap.NullCap" shows "\\s. \cp \ ran (caps_of_state s). P cp\ finalise_cap cap fin @@ -164,7 +164,7 @@ lemma finalise_cap_not_cte_wp_at[Tcb_AI_asms]: done -lemma table_cap_ref_max_free_index_upd[simp,Tcb_AI_asms]: +lemma table_cap_ref_max_free_index_upd[simp,Tcb_AI_assms]: "table_cap_ref (max_free_index_update cap) = table_cap_ref cap" by (simp add:free_index_update_def table_cap_ref_def split:cap.splits) @@ -175,10 +175,10 @@ global_interpretation Tcb_AI_1?: Tcb_AI_1 and is_cnode_or_valid_arch = is_cnode_or_valid_arch proof goal_cases interpret Arch . - case 1 show ?case by (unfold_locales; (fact Tcb_AI_asms)?) + case 1 show ?case by (unfold_locales; (fact Tcb_AI_assms)?) qed -context Arch begin global_naming X64 +context Arch begin arch_global_naming lemma use_no_cap_to_obj_asid_strg: (* arch specific *) "(cte_at p s \ no_cap_to_obj_dr_emp cap s \ valid_cap cap s \ invs s) @@ -194,7 +194,7 @@ lemma use_no_cap_to_obj_asid_strg: (* arch specific *) apply (fastforce simp: table_cap_ref_def valid_cap_simps wellformed_mapdata_def elim!: asid_low_high_bits)+ done -lemma cap_delete_no_cap_to_obj_asid[wp, Tcb_AI_asms]: +lemma cap_delete_no_cap_to_obj_asid[wp, Tcb_AI_assms]: "\no_cap_to_obj_dr_emp cap\ cap_delete slot \\rv. no_cap_to_obj_dr_emp cap\" @@ -207,7 +207,7 @@ lemma cap_delete_no_cap_to_obj_asid[wp, Tcb_AI_asms]: | rule obj_ref_none_no_asid)+ done -lemma tc_invs[Tcb_AI_asms]: +lemma tc_invs[Tcb_AI_assms]: "\invs and tcb_at a and (case_option \ (valid_cap o fst) e) and (case_option \ (valid_cap o fst) f) @@ -286,7 +286,7 @@ lemma check_valid_ipc_buffer_inv: (* arch_specific *) apply (wp | simp add: if_apply_def2 split del: if_split | wpcw)+ done -lemma check_valid_ipc_buffer_wp[Tcb_AI_asms]: +lemma check_valid_ipc_buffer_wp[Tcb_AI_assms]: "\\(s::'state_ext::state_ext state). is_arch_cap cap \ is_cnode_or_valid_arch cap \ valid_ipc_buffer_cap cap vptr \ is_aligned vptr msg_align_bits @@ -302,7 +302,7 @@ lemma check_valid_ipc_buffer_wp[Tcb_AI_asms]: valid_ipc_buffer_cap_def) done -lemma derive_no_cap_asid[wp,Tcb_AI_asms]: +lemma derive_no_cap_asid[wp,Tcb_AI_assms]: "\(no_cap_to_obj_with_diff_ref cap S)::'state_ext::state_ext state\bool\ derive_cap slot cap \\rv. no_cap_to_obj_with_diff_ref rv S\,-" @@ -316,7 +316,7 @@ lemma derive_no_cap_asid[wp,Tcb_AI_asms]: done -lemma decode_set_ipc_inv[wp,Tcb_AI_asms]: +lemma decode_set_ipc_inv[wp,Tcb_AI_assms]: "\P::'state_ext::state_ext state \ bool\ decode_set_ipc_buffer args cap slot excaps \\rv. P\" apply (simp add: decode_set_ipc_buffer_def whenE_def split_def @@ -325,7 +325,7 @@ lemma decode_set_ipc_inv[wp,Tcb_AI_asms]: apply simp done -lemma no_cap_to_obj_with_diff_ref_update_cap_data[Tcb_AI_asms]: +lemma no_cap_to_obj_with_diff_ref_update_cap_data[Tcb_AI_assms]: "no_cap_to_obj_with_diff_ref c S s \ no_cap_to_obj_with_diff_ref (update_cap_data P x c) S s" apply (case_tac "update_cap_data P x c = NullCap") @@ -342,7 +342,7 @@ lemma no_cap_to_obj_with_diff_ref_update_cap_data[Tcb_AI_asms]: done -lemma update_cap_valid[Tcb_AI_asms]: +lemma update_cap_valid[Tcb_AI_assms]: "valid_cap cap (s::'state_ext::state_ext state) \ valid_cap (case capdata of None \ cap_rights_update rs cap @@ -377,16 +377,11 @@ crunch invoke_tcb end -context begin interpretation Arch . -requalify_consts is_cnode_or_valid_arch -requalify_facts invoke_tcb_typ_at -end - global_interpretation Tcb_AI?: Tcb_AI where is_cnode_or_valid_arch = X64.is_cnode_or_valid_arch proof goal_cases interpret Arch . - case 1 show ?case by (unfold_locales; (fact Tcb_AI_asms)?) + case 1 show ?case by (unfold_locales; (fact Tcb_AI_assms)?) qed end diff --git a/proof/invariant-abstract/X64/ArchUntyped_AI.thy b/proof/invariant-abstract/X64/ArchUntyped_AI.thy index 34fd547d47..f7b98cce40 100644 --- a/proof/invariant-abstract/X64/ArchUntyped_AI.thy +++ b/proof/invariant-abstract/X64/ArchUntyped_AI.thy @@ -8,7 +8,7 @@ theory ArchUntyped_AI imports Untyped_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming named_theorems Untyped_AI_assms @@ -181,7 +181,7 @@ lemma retype_ret_valid_caps_aobj[Untyped_AI_assms]: -lemma copy_global_mappings_hoare_lift:(*FIXME: arch_split \ these do not seem to be used globally *) +lemma copy_global_mappings_hoare_lift:(*FIXME: arch-split \ these do not seem to be used globally *) assumes wp: "\ptr val. \Q\ store_pml4e ptr val \\rv. Q\" shows "\Q\ copy_global_mappings pd \\rv. Q\" apply (simp add: copy_global_mappings_def) @@ -190,7 +190,7 @@ lemma copy_global_mappings_hoare_lift:(*FIXME: arch_split \ these d lemma init_arch_objects_hoare_lift: assumes wp: "\ptr val. \P\ store_pml4e ptr val \\rv. P\" - shows "\P\ init_arch_objects tp ptr sz us adds \\rv. P\" + shows "\P\ init_arch_objects tp dev ptr sz us adds \\rv. P\" proof - have pres: "\P\ return () \\rv. P\" by (wp wp | simp)+ @@ -215,7 +215,7 @@ lemma cap_refs_in_kernel_windowD2: done lemma init_arch_objects_descendants_range[wp,Untyped_AI_assms]: - "\\(s::'state_ext::state_ext state). descendants_range x cref s \ init_arch_objects ty ptr n us y + "\\(s::'state_ext::state_ext state). descendants_range x cref s \ init_arch_objects ty dev ptr n us y \\rv s. descendants_range x cref s\" apply (simp add:descendants_range_def) apply (rule hoare_pre) @@ -230,7 +230,7 @@ lemma init_arch_objects_descendants_range[wp,Untyped_AI_assms]: lemma init_arch_objects_caps_overlap_reserved[wp,Untyped_AI_assms]: "\\(s::'state_ext::state_ext state). caps_overlap_reserved S s\ - init_arch_objects ty ptr n us y + init_arch_objects ty dev ptr n us y \\rv s. caps_overlap_reserved S s\" apply (simp add:caps_overlap_reserved_def) apply (rule hoare_pre) @@ -533,7 +533,7 @@ lemma init_arch_objects_nonempty_table[Untyped_AI_assms, wp]: "\(\s. \ (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s) \ valid_global_objs s \ valid_arch_state s \ pspace_aligned s) and K (\ref\set refs. is_aligned ref (obj_bits_api tp us))\ - init_arch_objects tp ptr bits us refs + init_arch_objects tp dev ptr bits us refs \\rv s. \ (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)\" apply (rule hoare_gen_asm) apply (simp add: init_arch_objects_def split del: if_split) diff --git a/proof/invariant-abstract/X64/ArchVSpaceEntries_AI.thy b/proof/invariant-abstract/X64/ArchVSpaceEntries_AI.thy index cd4e27b7e1..41ab59ae25 100644 --- a/proof/invariant-abstract/X64/ArchVSpaceEntries_AI.thy +++ b/proof/invariant-abstract/X64/ArchVSpaceEntries_AI.thy @@ -8,7 +8,7 @@ theory ArchVSpaceEntries_AI imports VSpaceEntries_AI begin -context Arch begin global_naming X64 (*FIXME: arch_split*) +context Arch begin arch_global_naming lemma a_type_pml4D: "a_type ko = AArch APageMapL4 \ \pm. ko = ArchObj (PageMapL4 pm)" @@ -528,7 +528,7 @@ lemma init_arch_objects_valid_vspace: "\valid_vspace_objs' and pspace_aligned and valid_arch_state and K (orefs = retype_addrs ptr type n us) and K (range_cover ptr sz (obj_bits_api type us) n)\ - init_arch_objects type ptr n obj_sz orefs + init_arch_objects type dev ptr n obj_sz orefs \\rv. valid_vspace_objs'\" apply (rule hoare_gen_asm)+ apply (simp add: init_arch_objects_def) diff --git a/proof/invariant-abstract/X64/ArchVSpaceLookup_AI.thy b/proof/invariant-abstract/X64/ArchVSpaceLookup_AI.thy index 3174453588..7722c5aee5 100644 --- a/proof/invariant-abstract/X64/ArchVSpaceLookup_AI.thy +++ b/proof/invariant-abstract/X64/ArchVSpaceLookup_AI.thy @@ -980,7 +980,7 @@ theorem khupd_graph_subset: qed end -context Arch begin global_naming X64 +context Arch begin arch_global_naming locale_abbrev "vs_lookup_leaf ptr s \ lookup_leaf ptr (vs_lookup1 s)" diff --git a/proof/invariant-abstract/X64/ArchVSpace_AI.thy b/proof/invariant-abstract/X64/ArchVSpace_AI.thy index d0dbed41ef..1deb72419e 100644 --- a/proof/invariant-abstract/X64/ArchVSpace_AI.thy +++ b/proof/invariant-abstract/X64/ArchVSpace_AI.thy @@ -13,7 +13,7 @@ theory ArchVSpace_AI imports VSpacePre_AI begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming (* FIXME: should go in Machine_AI, but needs dmo_invs from KHeap_AI. *) lemmas machine_op_lift_irq_masks = no_irq[OF no_irq_machine_op_lift] @@ -977,7 +977,7 @@ lemma set_cap_valid_pdpte_stronger: by (wp valid_pdpte_lift3 set_cap_typ_at) end -context Arch begin global_naming X64 +context Arch begin arch_global_naming (* FIXME: move *) context diff --git a/proof/invariant-abstract/X64/Machine_AI.thy b/proof/invariant-abstract/X64/Machine_AI.thy index ba58fb2e5e..6605696cf2 100644 --- a/proof/invariant-abstract/X64/Machine_AI.thy +++ b/proof/invariant-abstract/X64/Machine_AI.thy @@ -67,7 +67,7 @@ crunch_ignore (no_irq) (add: handleE' handleE handle_elseE forM forM_x zipWithM ignore_failure) -context Arch begin +context Arch begin arch_global_naming lemma det_getRegister: "det (getRegister x)" by (simp add: getRegister_def) @@ -454,14 +454,4 @@ lemma out32_ef[simp,wp]: "empty_fail (out32 port dat)" end end -context begin interpretation Arch . - -requalify_facts - det_getRegister - det_setRegister - det_getRestartPC - det_setNextPC - -end - end diff --git a/proof/refine/AARCH64/ADT_H.thy b/proof/refine/AARCH64/ADT_H.thy index 5f6824b914..5f0f9ed3c8 100644 --- a/proof/refine/AARCH64/ADT_H.thy +++ b/proof/refine/AARCH64/ADT_H.thy @@ -27,7 +27,7 @@ consts initBootFrames :: "machine_word list" initDataStart :: machine_word -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \ The construction of the abstract data type @@ -1325,7 +1325,7 @@ locale partial_sort_cdt = "pspace_distinct' s'" "valid_objs s" "valid_mdb s" "valid_list s" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma valid_list_2 : "valid_list_2 t m" apply (insert assms') @@ -1510,7 +1510,7 @@ lemma sort_cdt_list_correct: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition absCDTList where "absCDTList cnp h \ sort_cdt_list (absCDT cnp h) h" diff --git a/proof/refine/AARCH64/ArchAcc_R.thy b/proof/refine/AARCH64/ArchAcc_R.thy index b04ccfe1c9..8b574600a7 100644 --- a/proof/refine/AARCH64/ArchAcc_R.thy +++ b/proof/refine/AARCH64/ArchAcc_R.thy @@ -15,7 +15,7 @@ begin unbundle l4v_word_context -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare if_cong[cong] (* FIXME: if_cong *) diff --git a/proof/refine/AARCH64/Arch_R.thy b/proof/refine/AARCH64/Arch_R.thy index e7998f0d9e..ff4072cd66 100644 --- a/proof/refine/AARCH64/Arch_R.thy +++ b/proof/refine/AARCH64/Arch_R.thy @@ -17,7 +17,7 @@ unbundle l4v_word_context lemmas [datatype_schematic] = cap.sel list.sel(1) list.sel(3) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare arch_cap.sel [datatype_schematic] declare is_aligned_shiftl [intro!] diff --git a/proof/refine/AARCH64/Bits_R.thy b/proof/refine/AARCH64/Bits_R.thy index 8fd5064679..133289cbaa 100644 --- a/proof/refine/AARCH64/Bits_R.thy +++ b/proof/refine/AARCH64/Bits_R.thy @@ -22,7 +22,7 @@ crunch_ignore (add: lookupPTSlotFromLevel lookupPTFromLevel) end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma throwE_R: "\\\ throw f \P\,-" by (simp add: validE_R_def) wp diff --git a/proof/refine/AARCH64/CNodeInv_R.thy b/proof/refine/AARCH64/CNodeInv_R.thy index a94e19d200..f4379784f7 100644 --- a/proof/refine/AARCH64/CNodeInv_R.thy +++ b/proof/refine/AARCH64/CNodeInv_R.thy @@ -16,7 +16,7 @@ begin unbundle l4v_word_context -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec valid_cnode_inv' :: "Invocations_H.cnode_invocation \ kernel_state \ bool" @@ -4936,7 +4936,7 @@ lemma cteSwap_valid_pspace'[wp]: apply clarsimp+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch cteSwap for tcb_at[wp]: "tcb_at' t" @@ -6638,7 +6638,7 @@ lemmas threadSet_ctesCaps_of = cteCaps_of_ctes_of_lift[OF threadSet_ctes_of] lemmas storePTE_cteCaps_of[wp] = cteCaps_of_ctes_of_lift [OF storePTE_ctes] -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma vcpuSwitch_rvk_prog': "vcpuSwitch v \\s. revoke_progress_ord m (\x. map_option capToRPO (cteCaps_of s x))\" @@ -7895,7 +7895,7 @@ lemma (in mdb_move) m'_cap: context mdb_move begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma m_to_src: "m \ p \ src = (p \ 0 \ p = mdbPrev src_node)" @@ -8426,7 +8426,7 @@ qed end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteMove_iflive'[wp]: "\\s. if_live_then_nonz_cap' s @@ -8607,7 +8607,7 @@ crunch updateMDB for valid_bitmaps[wp]: valid_bitmaps (rule: valid_bitmaps_lift) -(* FIXME: arch_split *) +(* FIXME: arch-split *) lemma haskell_assert_inv: "haskell_assert Q L \P\" by wpsimp diff --git a/proof/refine/AARCH64/CSpace1_R.thy b/proof/refine/AARCH64/CSpace1_R.thy index d5cdc08076..8cff61483d 100644 --- a/proof/refine/AARCH64/CSpace1_R.thy +++ b/proof/refine/AARCH64/CSpace1_R.thy @@ -14,7 +14,7 @@ imports CSpace_I begin -context Arch begin global_naming AARCH64_A (*FIXME: arch_split*) +context Arch begin global_naming AARCH64_A (*FIXME: arch-split*) lemmas final_matters_def = final_matters_def[simplified final_matters_arch_def] @@ -25,7 +25,7 @@ lemmas final_matters_simps[simp] end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma isMDBParentOf_CTE1: "isMDBParentOf (CTE cap node) cte = @@ -2945,7 +2945,7 @@ locale masterCap = fixes cap cap' assumes master: "capMasterCap cap = capMasterCap cap'" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma isZombie [simp]: "isZombie cap' = isZombie cap" using master @@ -3534,7 +3534,7 @@ locale mdb_insert_sib = mdb_insert_der + (mdbRevocable_update (\a. isCapRevocable c' src_cap) (mdbPrev_update (\a. src) src_node))))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) (* If dest is inserted as sibling, src can not have had children. If it had had children, then dest_node which is just a derived copy @@ -3681,7 +3681,7 @@ lemma descendants: by (rule set_eqI) (simp add: descendants_of'_def parent_n_eq) end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma mdb_None: assumes F: "\p'. cte_map p \ descendants_of' p' m' \ False" assumes R: "cdt_relation (swp cte_at s) (cdt s) m'" @@ -4534,7 +4534,7 @@ locale mdb_inv_preserve = \ (\x. sameRegionAs x (cteCap cte)) = (\x. sameRegionAs x (cteCap cte'))" assumes mdb_next:"\p. mdb_next m p = mdb_next m' p" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma preserve_stuff: "valid_dlist m = valid_dlist m' \ ut_revocable' m = ut_revocable' m' @@ -5193,7 +5193,7 @@ lemma cte_map_inj_eq': apply (rule cte_map_inj_eq; fastforce) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_corres: notes split_paired_All[simp del] split_paired_Ex[simp del] trans_state_update'[symmetric,simp] @@ -7176,7 +7176,7 @@ lemma subtree_no_parent: shows "False" using assms by induct (auto simp: parentOf_def mdb_next_unfold) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ensureNoChildren_corres: "p' = cte_map p \ diff --git a/proof/refine/AARCH64/CSpace_I.thy b/proof/refine/AARCH64/CSpace_I.thy index dd25b23b52..c8b4b95256 100644 --- a/proof/refine/AARCH64/CSpace_I.thy +++ b/proof/refine/AARCH64/CSpace_I.thy @@ -13,7 +13,7 @@ theory CSpace_I imports ArchAcc_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma capUntypedPtr_simps [simp]: "capUntypedPtr (ThreadCap r) = r" @@ -1527,7 +1527,7 @@ lemma no_mdb_not_target: apply (simp add: no_mdb_def) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma valid_dlist_init: "\ valid_dlist m; m p = Some cte; no_mdb cte \ \ valid_dlist (m (p \ CTE cap initMDBNode))" @@ -1725,7 +1725,7 @@ lemma untyped_inc_init: apply (rule untypedRange_in_capRange)+ apply (simp add:Int_ac) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma valid_nullcaps_init: "\ valid_nullcaps m; cap \ NullCap \ \ valid_nullcaps (m(p \ CTE cap initMDBNode))" by (simp add: valid_nullcaps_def initMDBNode_def nullPointer_def) @@ -1785,7 +1785,7 @@ lemma distinct_zombies_copyE: lemmas distinct_zombies_sameE = distinct_zombies_copyE [where y=x and x=x for x, simplified, OF _ _ _ _ _] -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma capBits_Master: "capBits (capMasterCap cap) = capBits cap" by (clarsimp simp: capMasterCap_def split: capability.split arch_capability.split) diff --git a/proof/refine/AARCH64/CSpace_R.thy b/proof/refine/AARCH64/CSpace_R.thy index 8fb8c5a2fc..acabae6d98 100644 --- a/proof/refine/AARCH64/CSpace_R.thy +++ b/proof/refine/AARCH64/CSpace_R.thy @@ -54,7 +54,7 @@ locale mdb_move = modify_map n (mdbNext src_node) (cteMDBNode_update (mdbPrev_update (\_. dest)))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemmas src = m_p @@ -735,7 +735,7 @@ lemma set_cap_not_quite_corres': apply (fastforce simp: c p pspace_relations_def)+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteMove_corres: assumes cr: "cap_relation cap cap'" notes trans_state_update'[symmetric,simp] @@ -1122,7 +1122,7 @@ crunch cteInsert end context mdb_insert begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma n_src_dest: "n \ src \ dest" by (simp add: n_direct_eq) @@ -1648,7 +1648,7 @@ lemma is_derived_badge_derived': "is_derived' m src cap cap' \ badge_derived' cap cap'" by (simp add: is_derived'_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_mdb_chain_0: "\valid_mdb' and pspace_aligned' and pspace_distinct' and (\s. src \ dest) and @@ -4520,7 +4520,7 @@ locale mdb_insert_simple = mdb_insert + assumes simple: "is_simple_cap' c'" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma dest_no_parent_n: "n \ dest \ p = False" @@ -4714,7 +4714,7 @@ lemma maskedAsFull_revokable_safe_parent: apply (clarsimp simp:isCap_simps is_simple_cap'_def)+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_simple_corres: assumes "cap_relation c c'" "src' = cte_map src" "dest' = cte_map dest" @@ -5089,7 +5089,7 @@ locale mdb_insert_simple' = mdb_insert_simple + fixes n' defines "n' \ modify_map n (mdbNext src_node) (cteMDBNode_update (mdbPrev_update (\_. dest)))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma no_0_n' [intro!]: "no_0 n'" by (auto simp: n'_def) lemmas n_0_simps' [iff] = no_0_simps [OF no_0_n'] @@ -5786,7 +5786,7 @@ lemma updateCapFreeIndex_no_0: apply (clarsimp simp:cte_wp_at_ctes_of)+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_simple_mdb': "\valid_mdb' and pspace_aligned' and pspace_distinct' and (\s. src \ dest) and K (capAligned cap) and diff --git a/proof/refine/AARCH64/Detype_R.thy b/proof/refine/AARCH64/Detype_R.thy index 79d19372a7..cecc4b5bd0 100644 --- a/proof/refine/AARCH64/Detype_R.thy +++ b/proof/refine/AARCH64/Detype_R.thy @@ -9,7 +9,7 @@ theory Detype_R imports Retype_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \Establishing that the invariants are maintained when a region of memory is detyped, that is, @@ -87,7 +87,7 @@ lemma descendants_range_inD': done end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma descendants_range'_def2: "descendants_range' cap p = descendants_range_in' (capRange cap) p" @@ -465,7 +465,7 @@ lemma (in detype_locale') deletionIsSafe: and vu: "valid_untyped (cap.UntypedCap d base magnitude idx) s" shows "deletionIsSafe base magnitude s'" proof - - interpret Arch . (* FIXME: arch_split *) + interpret Arch . (* FIXME: arch-split *) note [simp del] = atLeastatMost_subset_iff atLeastLessThan_iff atLeastAtMost_iff Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex have "\t m r. \ptr. cte_wp_at ((=) (cap.ReplyCap t m r)) ptr s @@ -549,7 +549,7 @@ proof - thus ?thesis using cte by (auto simp: deletionIsSafe_def) qed -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \Invariant preservation across concrete deletion\ @@ -622,7 +622,7 @@ locale delete_locale = and al: "is_aligned base bits" and safe: "deletionIsSafe base bits s'" -context delete_locale begin interpretation Arch . (*FIXME: arch_split*) +context delete_locale begin interpretation Arch . (*FIXME: arch-split*) lemma valid_objs: "valid_objs' s'" and pa: "pspace_aligned' s'" @@ -855,7 +855,7 @@ lemma sym_refs_TCB_hyp_live': done end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* FIXME: generalizes lemma SubMonadLib.corres_submonad *) (* FIXME: generalizes lemma SubMonad_R.corres_machine_op *) @@ -1134,7 +1134,7 @@ lemma deleteObjects_corres: done end -context delete_locale begin interpretation Arch . (*FIXME: arch_split*) +context delete_locale begin interpretation Arch . (*FIXME: arch-split*) lemma live_idle_untyped_range': "ko_wp_at' live' p s' \ p = idle_thread_ptr \ p \ base_bits" @@ -1445,7 +1445,7 @@ using vds proof (simp add: invs'_def valid_state'_def valid_pspace'_def valid_mdb'_def valid_mdb_ctes_def, safe) - interpret Arch . (*FIXME: arch_split*) + interpret Arch . (*FIXME: arch-split*) let ?s = state' let ?ran = base_bits @@ -1818,7 +1818,7 @@ lemma doMachineOp_modify: apply (simp add: simpler_gets_def simpler_modify_def bind_def) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma deleteObjects_invs': "\cte_wp_at' (\c. cteCap c = UntypedCap d ptr bits idx) p @@ -2983,6 +2983,17 @@ lemma setCTE_doMachineOp_commute: apply (wp|clarsimp|fastforce)+ done +lemma setCTE_when_doMachineOp_commute: + assumes nf: "no_fail Q (doMachineOp x)" + shows "monad_commute (cte_at' dest and pspace_aligned' and pspace_distinct' and Q) + (setCTE dest cte) + (when P (doMachineOp x))" + apply (cases P; simp add: setCTE_doMachineOp_commute nf) + apply (rule monad_commute_guard_imp) + apply (rule return_commute[THEN commute_commute]) + apply simp + done + lemma placeNewObject_valid_arch_state: "\valid_arch_state' and pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) and @@ -3191,6 +3202,11 @@ lemma monad_commute_if_weak_r: apply (erule monad_commute_guard_imp,simp)+ done +crunch updatePTType + for cte_wp_at'[wp]: "\s. Q (cte_wp_at' P p s)" + and pspace_aligned'[wp]: pspace_aligned' + and pspace_distinct'[wp]: pspace_distinct' + lemma createObject_setCTE_commute: "monad_commute (cte_wp_at' (\_. True) src and @@ -3252,6 +3268,7 @@ lemma createObject_setCTE_commute: setCTE_modify_gsUserPages_commute[of \] modify_wp[of "%_. \"] setCTE_doMachineOp_commute + setCTE_when_doMachineOp_commute setCTE_placeNewObject_commute setCTE_updatePTType_commute monad_commute_if_weak_r @@ -3402,6 +3419,13 @@ lemma threadSet_gsUntypedZeroRanges_commute': apply (simp add: monad_commute_def exec_gets exec_modify) done +lemma dmo_gsUntypedZeroRanges_commute: + "monad_commute \ (modify (\s. s\gsUntypedZeroRanges := f (gsUntypedZeroRanges s)\)) + (doMachineOp m)" + apply (clarsimp simp: monad_commute_def doMachineOp_def) + apply monad_eq + by (auto simp: select_f_def) + lemma createObject_gsUntypedZeroRanges_commute: "monad_commute \ @@ -3420,7 +3444,7 @@ lemma createObject_gsUntypedZeroRanges_commute: createObjects_gsUntypedZeroRanges_commute'[THEN commute_commute] return_commute return_commute[THEN commute_commute] threadSet_gsUntypedZeroRanges_commute'[THEN commute_commute] - monad_commute_gsUntyped_updatePTType + monad_commute_gsUntyped_updatePTType dmo_gsUntypedZeroRanges_commute split: option.split prod.split cong: if_cong)+ apply (simp add: curDomain_def monad_commute_def exec_modify exec_gets) done @@ -4200,8 +4224,8 @@ lemma dmo'_when_fail_comm: (* FIXME: move *) lemma dmo'_gets_ksPSpace_comm: - "doMachineOp f >>= (\_. gets ksPSpace >>= m) = - gets ksPSpace >>= (\x. doMachineOp f >>= (\_. m x))" + "doMachineOp f >>= (\y. gets ksPSpace >>= m y) = + gets ksPSpace >>= (\x. doMachineOp f >>= (\y. m y x))" apply (rule ext) apply (clarsimp simp: doMachineOp_def simpler_modify_def simpler_gets_def return_def select_f_def bind_def split_def image_def) @@ -4235,14 +4259,15 @@ proof - done qed -lemma dmo'_createObjects'_comm: +lemma dmo'_createObjects'_commute: assumes ef: "empty_fail f" - shows "do _ \ doMachineOp f; x \ createObjects' ptr n obj us; m x od = - do x \ createObjects' ptr n obj us; _ \ doMachineOp f; m x od" - apply (simp add: createObjects'_def bind_assoc split_def unless_def - alignError_def dmo'_when_fail_comm[OF ef] - dmo'_gets_ksPSpace_comm - dmo'_ksPSpace_update_comm'[OF ef, symmetric]) + shows "monad_commute \ (doMachineOp f) (createObjects' ptr n obj us)" + apply (clarsimp simp: createObjects'_def bind_assoc split_def unless_def + alignError_def monad_commute_def + dmo'_when_fail_comm[OF ef] + dmo'_gets_ksPSpace_comm + dmo'_ksPSpace_update_comm'[OF ef, symmetric]) + apply (rule_tac x=s in fun_cong) apply (rule arg_cong_bind1) apply (rule arg_cong_bind1) apply (rename_tac u w) @@ -4251,27 +4276,25 @@ lemma dmo'_createObjects'_comm: apply (simp add: assert_into_when dmo'_when_fail_comm[OF ef]) done -lemma dmo'_gsUserPages_upd_comm: - assumes "empty_fail f" - shows "doMachineOp f >>= (\x. modify (gsUserPages_update g) >>= (\_. m x)) = - modify (gsUserPages_update g) >>= (\_. doMachineOp f >>= m)" -proof - - have ksMachineState_ksPSpace_update: - "\s. ksMachineState (gsUserPages_update g s) = ksMachineState s" - by simp - have updates_independent: - "\f. gsUserPages_update g \ ksMachineState_update f = - ksMachineState_update f \ gsUserPages_update g" - by (rule ext) simp - from assms - show ?thesis - apply (simp add: doMachineOp_def split_def bind_assoc) - apply (simp add: gets_modify_comm2[OF ksMachineState_ksPSpace_update]) - apply (rule arg_cong_bind1) - apply (simp add: empty_fail_def select_f_walk[OF empty_fail_modify] - modify_modify_bind updates_independent) - done -qed +lemmas map_dmo'_createObjects'_comm = dmo'_createObjects'_commute[THEN mapM_x_commute_T] + +lemma dmo'_ksArchState_upd_comm: + "monad_commute \ (doMachineOp m) (modify (\s. ksArchState_update (f (ksArchState s)) s))" + apply (clarsimp simp: monad_commute_def doMachineOp_def) + apply monad_eq + apply (auto simp add: select_f_def) + done + +lemmas map_dmo'_ksArchState_upd_comm = dmo'_ksArchState_upd_comm[THEN mapM_x_commute_T] + +lemma dmo'_gsUserPages_upd_commute: + "monad_commute \ (doMachineOp f) (modify (gsUserPages_update g))" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc) + apply monad_eq + apply (auto simp: select_f_def) + done + +lemmas dmo'_gsUserPages_upd_map_commute = dmo'_gsUserPages_upd_commute[THEN mapM_x_commute_T] lemma rewrite_step: assumes rewrite: "\s. P s \ f s = f' s" @@ -4670,7 +4693,6 @@ proof - apply (rule arg_cong2[where f=gsCNodes_update, OF ext refl]) apply (rule ext) apply simp - apply (in_case "HugePageObject") apply (simp add: Arch_createNewCaps_def Retype_H.createObject_def createObjects_def bind_assoc @@ -4682,20 +4704,23 @@ proof - getObjectSize_def objBits_simps)[6] apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def bit_simps - add.commute append) + add.commute append mapM_x_append mapM_x_singleton) apply ((subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+)[1] + apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def getObjectSize_def objBits_simps)[6] apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def - pageBits_def add.commute append) + pageBits_def add.commute append mapM_x_append mapM_x_singleton) apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+ apply (in_case "VSpaceObject") @@ -4706,8 +4731,11 @@ proof - getObjectSize_def bit_simps objBits_simps ptBits_def)+)[6] apply (simp add: bind_assoc placeNewObject_def2) apply (simp add: field_simps updatePTType_def bind_assoc gets_modify_def - getObjectSize_def placeNewObject_def2 objBits_simps append) + getObjectSize_def placeNewObject_def2 objBits_simps append mapM_x_append + mapM_x_singleton) apply (subst ksArchState_update ksArchState_upd_createObjects'_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF map_dmo'_ksArchState_upd_comm] | simp add: modify_modify_bind o_def | simp only: o_def cong: if_cong)+ apply (rule bind_apply_cong, simp) @@ -4731,20 +4759,22 @@ proof - apply (simp_all add: field_simps shiftl_t2n bit_simps getObjectSize_def objBits_simps)[6] apply (simp add: bind_assoc placeNewObject_def2 objBits_simps bit_simps - getObjectSize_def add.commute append) + getObjectSize_def add.commute append mapM_x_append mapM_x_singleton) apply ((subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+)[1] apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def AARCH64_H.getObjectSize_def objBits_simps)[6] apply (simp add: bind_assoc placeNewObject_def2 objBits_simps AARCH64_H.getObjectSize_def - pageBits_def add.commute append) + pageBits_def add.commute append mapM_x_append mapM_x_singleton) apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+ apply (in_case "LargePageObject") @@ -4756,19 +4786,21 @@ proof - apply (simp_all add: field_simps shiftl_t2n pageBits_def getObjectSize_def objBits_simps)[6] apply (simp add: bind_assoc placeNewObject_def2 objBits_simps bit_simps - getObjectSize_def add.commute append) + getObjectSize_def add.commute append mapM_x_append mapM_x_singleton) apply ((subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+)[1] apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def AARCH64_H.getObjectSize_def objBits_simps)[6] apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def bit_simps add.commute append) + getObjectSize_def bit_simps add.commute append mapM_x_append mapM_x_singleton) apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+ apply (in_case "PageTableObject") @@ -4779,8 +4811,11 @@ proof - getObjectSize_def bit_simps objBits_simps ptBits_def)+)[6] apply (simp add: bind_assoc placeNewObject_def2) apply (simp add: field_simps updatePTType_def bind_assoc gets_modify_def - getObjectSize_def placeNewObject_def2 objBits_simps append) + getObjectSize_def placeNewObject_def2 objBits_simps append mapM_x_append + mapM_x_singleton) apply (subst ksArchState_update ksArchState_upd_createObjects'_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF map_dmo'_ksArchState_upd_comm] | simp add: modify_modify_bind o_def | simp only: o_def cong: if_cong)+ apply (rule bind_apply_cong, simp) @@ -5029,19 +5064,20 @@ lemma ArchCreateObject_pspace_no_overlap': (ptr + (of_nat n << APIType_capBits ty userSize)) userSize d \\archCap. pspace_no_overlap' (ptr + (1 + of_nat n << APIType_capBits ty userSize)) sz\" - apply (rule hoare_pre) - apply (clarsimp simp:AARCH64_H.createObject_def) - apply wpc - apply (wp doMachineOp_psp_no_overlap - createObjects'_pspace_no_overlap2 hoare_when_weak_wp - createObjects'_psp_aligned[where sz = sz] - createObjects'_psp_distinct[where sz = sz] - | simp add: placeNewObject_def2 word_shiftl_add_distrib - | simp add: placeNewObject_def2 word_shiftl_add_distrib - | simp add: placeNewDataObject_def placeNewObject_def2 word_shiftl_add_distrib - field_simps split del: if_split - | clarsimp simp add: add.assoc[symmetric],wp createObjects'_pspace_no_overlap2[where n =0 and sz = sz,simplified] - | clarsimp simp add: APIType_capBits_def objBits_simps pageBits_def)+ + supply if_split[split del] + apply (clarsimp simp:AARCH64_H.createObject_def) + apply wpc + apply (wp doMachineOp_psp_no_overlap + createObjects'_pspace_no_overlap2 + createObjects'_psp_aligned[where sz = sz] + createObjects'_psp_distinct[where sz = sz] + | simp add: placeNewObject_def2 word_shiftl_add_distrib + | simp add: placeNewObject_def2 word_shiftl_add_distrib + | simp add: placeNewDataObject_def placeNewObject_def2 word_shiftl_add_distrib + field_simps + | clarsimp simp add: add.assoc[symmetric], + wp createObjects'_pspace_no_overlap2[where n =0 and sz = sz,simplified] + | clarsimp simp add: APIType_capBits_def objBits_simps pageBits_def)+ apply (clarsimp simp: conj_comms) apply (frule(1) range_cover_no_0[where p = n]) apply simp @@ -5070,6 +5106,7 @@ lemma ArchCreateObject_pspace_no_overlap': apply (intro conjI allI) apply (clarsimp simp: field_simps word_bits_conv APIType_capBits_def shiftl_t2n objBits_simps bit_simps + split: if_split | rule conjI | erule range_cover_le,simp)+ done diff --git a/proof/refine/AARCH64/EmptyFail.thy b/proof/refine/AARCH64/EmptyFail.thy index 3744f2b4a7..eb6618b07b 100644 --- a/proof/refine/AARCH64/EmptyFail.thy +++ b/proof/refine/AARCH64/EmptyFail.thy @@ -66,7 +66,7 @@ lemma empty_fail_getSlotCap [intro!, wp, simp]: "empty_fail (getSlotCap a)" unfolding getSlotCap_def by fastforce -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma empty_fail_getObject: assumes "\b c d. empty_fail (loadObject x b c d::'a :: pspace_storable kernel)" diff --git a/proof/refine/AARCH64/EmptyFail_H.thy b/proof/refine/AARCH64/EmptyFail_H.thy index 16853a5bcd..36a9322797 100644 --- a/proof/refine/AARCH64/EmptyFail_H.thy +++ b/proof/refine/AARCH64/EmptyFail_H.thy @@ -14,7 +14,7 @@ crunch_ignore (empty_fail) CSpaceDecls_H.resolveAddressBits doMachineOp suspend restart schedule) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas forM_empty_fail[intro!, wp, simp] = empty_fail_mapM[simplified forM_def[symmetric]] lemmas forM_x_empty_fail[intro!, wp, simp] = empty_fail_mapM_x[simplified forM_x_def[symmetric]] diff --git a/proof/refine/AARCH64/Finalise_R.thy b/proof/refine/AARCH64/Finalise_R.thy index 3cdb22b01a..282c581fc2 100644 --- a/proof/refine/AARCH64/Finalise_R.thy +++ b/proof/refine/AARCH64/Finalise_R.thy @@ -12,7 +12,7 @@ imports Retype_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare doUnbindNotification_def[simp] @@ -187,7 +187,7 @@ locale mdb_empty = slot (cteCap_update (%_. capability.NullCap))) slot (cteMDBNode_update (const nullMDBNode))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemmas m_slot_prev = m_p_prev lemmas m_slot_next = m_p_next @@ -1416,7 +1416,7 @@ lemma deletedIRQHandler_irqs_masked'[wp]: apply (simp add: irqs_masked'_def) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch emptySlot for irqs_masked'[wp]: "irqs_masked'" @@ -2056,7 +2056,7 @@ lemma (in vmdb) isFinal_untypedParent: sameObjectAs_sym) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma no_fail_isFinalCapability [wp]: "no_fail (valid_mdb' and cte_wp_at' ((=) cte) p) (isFinalCapability cte)" @@ -3234,7 +3234,7 @@ lemma suspend_tcbSchedNext_tcbSchedPrev_None: unfolding suspend_def by (wpsimp wp: hoare_drop_imps tcbSchedDequeue_tcbSchedNext_tcbSchedPrev_None_obj_at') -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma archThreadSet_tcbSchedPrevNext[wp]: "archThreadSet f t' \obj_at' (\tcb. P (tcbSchedNext tcb) (tcbSchedPrev tcb)) t\" @@ -3368,7 +3368,7 @@ lemma suspend_cte_wp_at': | simp add: x)+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch deleteASIDPool for cte_wp_at'[wp]: "cte_wp_at' P p" @@ -3714,7 +3714,7 @@ lemmas getCTE_no_0_obj'_helper = getCTE_inv hoare_strengthen_post[where Q'="\_. no_0_obj'" and P=no_0_obj' and f="getCTE slot" for slot] -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch invalidateTLBByASID for nosch[wp]: "\s. P (ksSchedulerAction s)" @@ -3784,7 +3784,7 @@ lemma (in delete_one) deletingIRQHandler_corres: apply (clarsimp simp: cte_wp_at_ctes_of) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma sym_refs_vcpu_tcb: (* FIXME: move to AInvs *) "\ vcpus_of s v = Some vcpu; vcpu_tcb vcpu = Some t; sym_refs (state_hyp_refs_of s) \ \ @@ -4035,7 +4035,7 @@ lemma finaliseCap_corres: apply (rule corres_guard_imp [OF arch_finaliseCap_corres], (fastforce simp: valid_sched_def)+) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma threadSet_ct_idle_or_in_cur_domain': "\ct_idle_or_in_cur_domain' and (\s. \tcb. tcbDomain tcb = ksCurDomain s \ tcbDomain (F tcb) = ksCurDomain s)\ diff --git a/proof/refine/AARCH64/Init_R.thy b/proof/refine/AARCH64/Init_R.thy index ce9e5cbc2b..b75793a303 100644 --- a/proof/refine/AARCH64/Init_R.thy +++ b/proof/refine/AARCH64/Init_R.thy @@ -11,7 +11,7 @@ imports begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* This provides a very simple witness that the state relation used in the first refinement proof is diff --git a/proof/refine/AARCH64/InterruptAcc_R.thy b/proof/refine/AARCH64/InterruptAcc_R.thy index a377906d78..0892d66ab5 100644 --- a/proof/refine/AARCH64/InterruptAcc_R.thy +++ b/proof/refine/AARCH64/InterruptAcc_R.thy @@ -19,7 +19,7 @@ lemma getIRQSlot_corres: ucast_nat_def shiftl_t2n) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setIRQState_corres: "irq_state_relation state state' \ diff --git a/proof/refine/AARCH64/Interrupt_R.thy b/proof/refine/AARCH64/Interrupt_R.thy index cc5585adab..407e022f64 100644 --- a/proof/refine/AARCH64/Interrupt_R.thy +++ b/proof/refine/AARCH64/Interrupt_R.thy @@ -15,7 +15,7 @@ begin context Arch begin -(*FIXME: arch_split: move up *) +(*FIXME: arch-split: move up *) requalify_types irqcontrol_invocation @@ -23,11 +23,11 @@ lemmas [crunch_def] = decodeIRQControlInvocation_def performIRQControl_def context begin global_naming global -(*FIXME: arch_split: move up *) +(*FIXME: arch-split: move up *) requalify_types Invocations_H.irqcontrol_invocation -(*FIXME: arch_split*) +(*FIXME: arch-split*) requalify_facts Interrupt_H.decodeIRQControlInvocation_def Interrupt_H.performIRQControl_def @@ -88,7 +88,7 @@ where ex_cte_cap_to' ptr and real_cte_at' ptr and (Not o irq_issued' irq) and K (irq \ maxIRQ))" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma decodeIRQHandlerInvocation_corres: "\ list_all2 cap_relation (map fst caps) (map fst caps'); diff --git a/proof/refine/AARCH64/Invariants_H.thy b/proof/refine/AARCH64/Invariants_H.thy index f03c85e5f1..c952717536 100644 --- a/proof/refine/AARCH64/Invariants_H.thy +++ b/proof/refine/AARCH64/Invariants_H.thy @@ -279,7 +279,7 @@ definition live' :: "kernel_object \ bool" where | KOKernelData => False | KOArch ako => hyp_live' ko" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec azobj_refs' :: "arch_capability \ obj_ref set" where "azobj_refs' (ASIDPoolCap _ _) = {}" @@ -1271,7 +1271,7 @@ locale mdb_order = mdb_next + \ \---------------------------------------------------------------------------\ section "Alternate split rules for preserving subgoal order" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ntfn_splits[split]: " P (case ntfn of Structures_H.ntfn.IdleNtfn \ f1 | Structures_H.ntfn.ActiveNtfn x \ f2 x @@ -2968,7 +2968,7 @@ lemma le_maxDomain_eq_less_numDomains: by (auto simp: Kernel_Config.numDomains_def maxDomain_def word_le_nat_alt) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma page_table_pte_atI': "\ page_table_at' pt_t p s; i \ mask (ptTranslationBits pt_t) \ \ @@ -3126,7 +3126,7 @@ lemma vms_sch_act_update'[iff]: valid_machine_state' s" by (simp add: valid_machine_state'_def ) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas bit_simps' = pteBits_def asidHighBits_def asidPoolBits_def asid_low_bits_def asid_high_bits_def bit_simps diff --git a/proof/refine/AARCH64/Invocations_R.thy b/proof/refine/AARCH64/Invocations_R.thy index 0bc901c2ef..7d92a816dc 100644 --- a/proof/refine/AARCH64/Invocations_R.thy +++ b/proof/refine/AARCH64/Invocations_R.thy @@ -8,7 +8,7 @@ theory Invocations_R imports Bits_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma invocationType_eq[simp]: "invocationType = invocation_type" diff --git a/proof/refine/AARCH64/IpcCancel_R.thy b/proof/refine/AARCH64/IpcCancel_R.thy index 3321c4a9aa..ae185783fc 100644 --- a/proof/refine/AARCH64/IpcCancel_R.thy +++ b/proof/refine/AARCH64/IpcCancel_R.thy @@ -10,7 +10,7 @@ imports Schedule_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch cancelAllIPC for aligned'[wp]: pspace_aligned' @@ -338,7 +338,7 @@ lemma cte_map_tcb_2: "cte_map (t, tcb_cnode_index 2) = t + 2*2^cte_level_bits" by (simp add: cte_map_def tcb_cnode_index_def to_bl_1 shiftl_t2n) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cte_wp_at_master_reply_cap_to_ex_rights: "cte_wp_at (is_master_reply_cap_to t) ptr @@ -512,7 +512,7 @@ lemma (in delete_one) cancelIPC_ReplyCap_corres: od) od)" proof - - interpret Arch . (*FIXME: arch_split*) + interpret Arch . (*FIXME: arch-split*) show ?thesis apply (simp add: reply_cancel_ipc_def getThreadReplySlot_def locateSlot_conv liftM_def tcbReplySlot_def @@ -645,7 +645,7 @@ crunch setNotification lemma sch_act_simple_not_t[simp]: "sch_act_simple s \ sch_act_not t s" by (clarsimp simp: sch_act_simple_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch setNotification for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers @@ -2030,7 +2030,7 @@ lemma cancelAll_unlive_helper: apply (clarsimp elim!: ko_wp_at'_weakenE) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setObject_ko_wp_at': fixes v :: "'a :: pspace_storable" assumes x: "\v :: 'a. updateObject v = updateObject_default v" diff --git a/proof/refine/AARCH64/Ipc_R.thy b/proof/refine/AARCH64/Ipc_R.thy index 6d1f0ba0f0..89fe5e8fbe 100644 --- a/proof/refine/AARCH64/Ipc_R.thy +++ b/proof/refine/AARCH64/Ipc_R.thy @@ -9,7 +9,7 @@ theory Ipc_R imports Finalise_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas lookup_slot_wrapper_defs'[simp] = lookupSourceSlot_def lookupTargetSlot_def lookupPivotSlot_def diff --git a/proof/refine/AARCH64/KHeap_R.thy b/proof/refine/AARCH64/KHeap_R.thy index eb08cf3dbf..cfc92c72d6 100644 --- a/proof/refine/AARCH64/KHeap_R.thy +++ b/proof/refine/AARCH64/KHeap_R.thy @@ -21,7 +21,7 @@ lemma koTypeOf_injectKO: apply (simp add: project_koType[symmetric]) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setObject_modify_variable_size: fixes v :: "'a :: pspace_storable" shows @@ -94,7 +94,7 @@ end translations (type) "'a kernel" <=(type) "kernel_state \ ('a \ kernel_state) set \ bool" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma no_fail_loadObject_default [wp]: "no_fail (\s. \obj. projectKO_opt ko = Some (obj::'a) \ diff --git a/proof/refine/AARCH64/Machine_R.thy b/proof/refine/AARCH64/Machine_R.thy index 34709d376a..13cce73011 100644 --- a/proof/refine/AARCH64/Machine_R.thy +++ b/proof/refine/AARCH64/Machine_R.thy @@ -22,7 +22,7 @@ lemma irq_state_independent_HI[intro!, simp]: \ irq_state_independent_H P" by (simp add: irq_state_independent_H_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma dmo_getirq_inv[wp]: "irq_state_independent_H P \ \P\ doMachineOp (getActiveIRQ in_kernel) \\rv. P\" diff --git a/proof/refine/AARCH64/PageTableDuplicates.thy b/proof/refine/AARCH64/PageTableDuplicates.thy index 7cb59a2c13..455ca3cde8 100644 --- a/proof/refine/AARCH64/PageTableDuplicates.thy +++ b/proof/refine/AARCH64/PageTableDuplicates.thy @@ -8,7 +8,7 @@ theory PageTableDuplicates imports Syscall_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma doMachineOp_ksPSpace_inv[wp]: "\\s. P (ksPSpace s)\ doMachineOp f \\ya s. P (ksPSpace s)\" diff --git a/proof/refine/AARCH64/Refine.thy b/proof/refine/AARCH64/Refine.thy index ea34ea6b8f..fa4ebe573b 100644 --- a/proof/refine/AARCH64/Refine.thy +++ b/proof/refine/AARCH64/Refine.thy @@ -17,7 +17,7 @@ imports PageTableDuplicates begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \User memory content is the same on both levels\ lemma typ_at_AUserDataI: diff --git a/proof/refine/AARCH64/Retype_R.thy b/proof/refine/AARCH64/Retype_R.thy index 9d642869eb..6625f1857f 100644 --- a/proof/refine/AARCH64/Retype_R.thy +++ b/proof/refine/AARCH64/Retype_R.thy @@ -13,7 +13,7 @@ theory Retype_R imports VSpace_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition APIType_map2 :: "kernel_object + AARCH64_H.object_type \ Structures_A.apiobject_type" @@ -1172,7 +1172,7 @@ end global_interpretation update_gs: PSpace_update_eq "update_gs ty us ptrs" by (simp add: PSpace_update_eq_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ksMachineState_update_gs[simp]: "ksMachineState (update_gs tp us addrs s) = ksMachineState s" @@ -1684,7 +1684,7 @@ end interpretation retype_region2_ext_extended: is_extended "retype_region2_ext ptrs type" by (unfold_locales; wp) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "retype_region2_extra_ext ptrs type \ @@ -1703,7 +1703,7 @@ end interpretation retype_region2_extra_ext_extended: is_extended "retype_region2_extra_ext ptrs type" by (unfold_locales; wp) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition retype_region2 :: "obj_ref \ nat \ nat \ Structures_A.apiobject_type \ bool \ (obj_ref list,'z::state_ext) s_monad" @@ -2436,14 +2436,17 @@ proof - split: AARCH64_H.object_type.splits) apply (in_case "HugePageObject") - apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) - apply (wp createObjects_aligned2 createObjects_nonzero' - cwo_ret'[where bs="2 * ptTranslationBits NormalPT_T", simplified] - | simp add: objBits_if_dev pageBits_def ptr range_cover_n_wb add.commute)+ + apply (subst doMachineOp_mapM_x[unfolded o_def, simplified, symmetric], simp) + apply (wp hoare_vcg_op_lift doMachineOp_typ_ats) + apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) + apply (wp createObjects_aligned2 createObjects_nonzero' + cwo_ret'[where bs="2 * ptTranslationBits NormalPT_T", simplified] + | simp add: objBits_if_dev pageBits_def ptr range_cover_n_wb add.commute)+ apply (simp add:pageBits_def ptr word_bits_def) apply (in_case "VSpaceObject") - apply wp + apply (subst doMachineOp_mapM_x[unfolded o_def, simplified, symmetric], simp) + apply (wp hoare_vcg_op_lift doMachineOp_typ_ats) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits) apply (rule hoare_chain) apply (rule hoare_vcg_conj_lift) @@ -2464,7 +2467,8 @@ proof - apply clarsimp apply (in_case "SmallPageObject") - apply wp + apply (subst doMachineOp_mapM_x[unfolded o_def, simplified, symmetric], simp) + apply (wp hoare_vcg_op_lift doMachineOp_typ_ats) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply (wp createObjects_aligned2 createObjects_nonzero' cwo_ret'[where bs=0, simplified] @@ -2472,7 +2476,8 @@ proof - apply (simp add:pageBits_def ptr word_bits_def) apply (in_case \LargePageObject\) - apply wp + apply (subst doMachineOp_mapM_x[unfolded o_def, simplified, symmetric], simp) + apply (wp hoare_vcg_op_lift doMachineOp_typ_ats) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply (wp createObjects_aligned2 createObjects_nonzero' cwo_ret'[where bs="ptTranslationBits NormalPT_T", simplified] @@ -2480,7 +2485,8 @@ proof - apply (simp add:pageBits_def ptr word_bits_def) apply (in_case \PageTableObject\) - apply wp + apply (subst doMachineOp_mapM_x[unfolded o_def, simplified, symmetric], simp) + apply (wp hoare_vcg_op_lift doMachineOp_typ_ats) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits) apply (rule hoare_chain) apply (rule hoare_vcg_conj_lift) @@ -2745,9 +2751,9 @@ lemma corres_retype: done lemma init_arch_objects_APIType_map2: - "init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs = + "init_arch_objects (APIType_map2 (Inr ty)) dev ptr bits sz refs = (case ty of APIObjectType _ \ return () - | _ \ init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs)" + | _ \ init_arch_objects (APIType_map2 (Inr ty)) dev ptr bits sz refs)" apply (clarsimp split: AARCH64_H.object_type.split) apply (simp add: init_arch_objects_def APIType_map2_def split: apiobject_type.split) @@ -2805,7 +2811,7 @@ locale retype_mdb = vmdb + defines "n \ \p. if P p then Some makeObject else m p" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma no_0_n: "no_0 n" using no_0 by (simp add: no_0_def n_def 0) @@ -3137,7 +3143,7 @@ lemma caps_no_overlapD'': apply blast done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma valid_untyped'_helper: assumes valid : "valid_cap' c s" @@ -4643,6 +4649,9 @@ lemma createObjects_pspace_domain_valid: apply (simp add: objBits_def) done +crunch doMachineOp + for pspace_domain_valid[wp]: pspace_domain_valid + lemma createNewCaps_pspace_domain_valid[wp]: "\pspace_domain_valid and K ({ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1} \ kernel_data_refs = {} @@ -5372,11 +5381,6 @@ lemma createObjects_Not_tcbQueued: apply (auto simp: obj_at'_def project_inject objBitsKO_def objBits_def makeObject_tcb) done -lemma init_arch_objects_APIType_map2_noop: - "init_arch_objects (APIType_map2 tp) ptr n m addrs = return ()" - apply (simp add: init_arch_objects_def APIType_map2_def) - done - lemma data_page_relation_retype: "obj_relation_retype (ArchObj (DataPage False pgsz)) KOUserData" "obj_relation_retype (ArchObj (DataPage True pgsz)) KOUserDataDevice" @@ -5385,6 +5389,45 @@ lemma data_page_relation_retype: apply (clarsimp simp: image_def)+ done +lemma init_arch_objects_APIType_map2_VCPU_noop: + "init_arch_objects (APIType_map2 (Inr VCPUObject)) dev ptr n m addrs = return ()" + apply (simp add: init_arch_objects_def APIType_map2_def) + done + +lemma regroup_createObjects_dmo_userPages: + "(do + addrs <- createObjects y n ko sz; + _ <- modify (\ks. ks\gsUserPages := g ks addrs\); + _ <- when P (mapM_x (\addr. doMachineOp (m addr)) addrs); + return (f addrs) + od) = (do + (addrs, faddrs) <- (do + addrs <- createObjects y n ko sz; + _ <- modify (\ks. ks\gsUserPages := g ks addrs\); + return (addrs, f addrs) + od); + _ <- when P (mapM_x (\addr. doMachineOp (m addr)) addrs); + return faddrs + od)" + by (simp add: bind_assoc) + +lemma regroup_createObjects_dmo_gsPTTypes: + "(do + addrs <- createObjects y n ko sz; + _ <- modify (\ks. ks\ksArchState := gsPTTypes_update (g ks addrs) (ksArchState ks)\); + _ <- mapM_x (\addr. doMachineOp (m addr)) addrs; + return (f addrs) + od) = (do + (addrs, faddrs) <- (do + addrs <- createObjects y n ko sz; + _ <- modify (\ks. ks\ksArchState := gsPTTypes_update (g ks addrs) (ksArchState ks)\); + return (addrs, f addrs) + od); + _ <- mapM_x (\addr. doMachineOp (m addr)) addrs; + return faddrs + od)" + by (simp add: bind_assoc) + lemma corres_retype_region_createNewCaps: "corres ((\r r'. length r = length r' \ list_all2 cap_relation r r') \ map (\ref. default_cap (APIType_map2 (Inr ty)) ref us dev)) @@ -5397,7 +5440,7 @@ lemma corres_retype_region_createNewCaps: \ valid_pspace' s \ valid_arch_state' s \ range_cover y sz (obj_bits_api (APIType_map2 (Inr ty)) us) n \ n\ 0) (do x \ retype_region y n us (APIType_map2 (Inr ty)) dev :: obj_ref list det_ext_monad; - init_arch_objects (APIType_map2 (Inr ty)) y n us x; + init_arch_objects (APIType_map2 (Inr ty)) dev y n us x; return x od) (createNewCaps ty y n us dev)" apply (rule_tac F="range_cover y sz (obj_bits_api (APIType_map2 (Inr ty)) us) n @@ -5496,90 +5539,134 @@ lemma corres_retype_region_createNewCaps: apply (subst retype_region2_extra_ext_trivial) apply (simp add: APIType_map2_def) apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI; - clarsimp simp: obj_bits_api_def3 APIType_map2_def objBits_simps ext - default_object_def default_arch_object_def makeObjectKO_def - data_page_relation_retype bit_simps - elim!: range_cover.aligned; - assumption) - apply fastforce+ - apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def - list_all2_map1 list_all2_map2 list_all2_same) + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst regroup_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI; + clarsimp simp: obj_bits_api_def3 APIType_map2_def objBits_simps ext + default_object_def default_arch_object_def makeObjectKO_def + data_page_relation_retype bit_simps + elim!: range_cover.aligned; + assumption) + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x') + apply corres + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] apply (in_case \VSpaceObject\) - apply (subst retype_region2_extra_ext_trivial, simp add: APIType_map2_def) - apply (simp add: corres_liftM2_simp[unfolded liftM_def]) + apply (subst retype_region2_extra_ext_trivial) + apply (simp add: APIType_map2_def) + apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst regroup_createObjects_dmo_gsPTTypes) apply (rule corres_guard_imp) - apply (simp add: init_arch_objects_APIType_map2_noop) - apply (rule corres_rel_imp) - apply (rule corres_retype_update_gsI; - (simp add: APIType_map2_def objBits_simps makeObjectKO_def obj_bits_api_def - range_cover.aligned default_arch_object_def pt_bits_def)?) - apply (rule vsroot_relation_retype) - apply (rule ext)+ - apply (rename_tac s, case_tac s, rename_tac arch machine, case_tac arch) - apply (fastforce simp: update_gs_def) - apply (clarsimp simp: list_all2_map1 list_all2_map2 list_all2_same - APIType_map2_def arch_default_cap_def) - apply fastforce+ + apply (rule corres_split) + apply (rule corres_retype_update_gsI; + (simp add: APIType_map2_def objBits_simps makeObjectKO_def obj_bits_api_def + range_cover.aligned default_arch_object_def pt_bits_def)?) + apply (rule vsroot_relation_retype) + apply (rule ext)+ + apply (rename_tac s, case_tac s, rename_tac arch machine, case_tac arch) + apply (fastforce simp: update_gs_def) + apply (simp add: APIType_map2_def vs_apiobj_size_def table_size_def pt_bits_def) + apply (rule corres_split, rule corres_mapM_x') + apply corres + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: arch_default_cap_def list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] apply (in_case \SmallPageObject\) apply (subst retype_region2_extra_ext_trivial) apply (simp add: APIType_map2_def) apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI; - clarsimp simp: obj_bits_api_def3 APIType_map2_def objBits_simps ext - default_object_def default_arch_object_def makeObjectKO_def - data_page_relation_retype - elim!: range_cover.aligned; - assumption) - apply fastforce+ - apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def - list_all2_map1 list_all2_map2 list_all2_same) + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst regroup_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI; + clarsimp simp: obj_bits_api_def3 APIType_map2_def objBits_simps ext + default_object_def default_arch_object_def makeObjectKO_def + data_page_relation_retype bit_simps + elim!: range_cover.aligned; + assumption) + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x') + apply corres + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] apply (in_case \LargePageObject\) apply (subst retype_region2_extra_ext_trivial) apply (simp add: APIType_map2_def) apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI; - clarsimp simp: obj_bits_api_def3 APIType_map2_def objBits_simps ext - default_object_def default_arch_object_def makeObjectKO_def - data_page_relation_retype - elim!: range_cover.aligned; - assumption) - apply fastforce+ - apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def - list_all2_map1 list_all2_map2 list_all2_same) + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst regroup_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI; + clarsimp simp: obj_bits_api_def3 APIType_map2_def objBits_simps ext + default_object_def default_arch_object_def makeObjectKO_def + data_page_relation_retype bit_simps + elim!: range_cover.aligned; + assumption) + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x') + apply corres + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] apply (in_case \PageTableObject\) apply (subst retype_region2_ext_retype_region) apply (subst retype_region2_extra_ext_trivial, simp add: APIType_map2_def) apply (simp_all add: corres_liftM2_simp[unfolded liftM_def]) + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst regroup_createObjects_dmo_gsPTTypes) apply (rule corres_guard_imp) - apply (simp add: init_arch_objects_APIType_map2_noop) - apply (rule corres_rel_imp) - apply (rule corres_retype_update_gsI; - (simp add: APIType_map2_def objBits_simps makeObjectKO_def obj_bits_api_def - range_cover.aligned default_arch_object_def pt_bits_def)?) - apply (rule pagetable_relation_retype) - apply (rule ext)+ - apply (rename_tac s, case_tac s, rename_tac arch machine, case_tac arch) - apply (fastforce simp: update_gs_def) - apply (clarsimp simp: list_all2_map1 list_all2_map2 list_all2_same - APIType_map2_def arch_default_cap_def) - apply fastforce+ + apply (rule corres_split) + apply (rule corres_retype_update_gsI; + (simp add: APIType_map2_def objBits_simps makeObjectKO_def obj_bits_api_def + range_cover.aligned default_arch_object_def pt_bits_def)?) + apply (rule pagetable_relation_retype) + apply (rule ext)+ + apply (rename_tac s, case_tac s, rename_tac arch machine, case_tac arch) + apply (fastforce simp: update_gs_def) + apply (simp add: APIType_map2_def vs_apiobj_size_def table_size_def pt_bits_def) + apply (rule corres_split, rule corres_mapM_x') + apply corres + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (clarsimp simp: list_all2_map1 list_all2_map2 list_all2_same + APIType_map2_def arch_default_cap_def) + apply ((wpsimp split_del: if_split)+)[6] apply (in_case \VCPUObject\) apply (subst retype_region2_ext_retype_region) apply (subst retype_region2_extra_ext_trivial) apply (simp add: APIType_map2_def) apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) + apply (simp add: init_arch_objects_APIType_map2_VCPU_noop split del: if_split) apply (rule corres_guard_imp) apply (rule corres_retype[where 'a = vcpu], simp_all add: obj_bits_api_def objBits_simps pageBits_def default_arch_object_def diff --git a/proof/refine/AARCH64/Schedule_R.thy b/proof/refine/AARCH64/Schedule_R.thy index 0f31f50b4b..091798dacf 100644 --- a/proof/refine/AARCH64/Schedule_R.thy +++ b/proof/refine/AARCH64/Schedule_R.thy @@ -9,7 +9,7 @@ theory Schedule_R imports VSpace_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare hoare_weak_lift_imp[wp_split del] diff --git a/proof/refine/AARCH64/SubMonad_R.thy b/proof/refine/AARCH64/SubMonad_R.thy index 985284603c..f5ab382e32 100644 --- a/proof/refine/AARCH64/SubMonad_R.thy +++ b/proof/refine/AARCH64/SubMonad_R.thy @@ -44,7 +44,7 @@ lemma doMachineOp_mapM_x: done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "asUser_fetch \ \t s. case (ksPSpace s t) of Some (KOTCB tcb) \ (atcbContextGet o tcbArch) tcb diff --git a/proof/refine/AARCH64/Syscall_R.thy b/proof/refine/AARCH64/Syscall_R.thy index 92b31ca04f..8a5061f324 100644 --- a/proof/refine/AARCH64/Syscall_R.thy +++ b/proof/refine/AARCH64/Syscall_R.thy @@ -13,7 +13,7 @@ theory Syscall_R imports Tcb_R Arch_R Interrupt_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* syscall has 5 sections: m_fault h_fault m_error h_error m_finalise @@ -535,7 +535,7 @@ crunch InterruptDecls_H.invokeIRQHandler for typ_at'[wp]: "\s. P (typ_at' T p s)" lemmas invokeIRQHandler_typ_ats[wp] = - typ_at_lifts [OF InterruptDecls_H_invokeIRQHandler_typ_at'] + typ_at_lifts [OF invokeIRQHandler_typ_at'] crunch setDomain for tcb_at'[wp]: "tcb_at' tptr" diff --git a/proof/refine/AARCH64/TcbAcc_R.thy b/proof/refine/AARCH64/TcbAcc_R.thy index ee1063afae..4520609f36 100644 --- a/proof/refine/AARCH64/TcbAcc_R.thy +++ b/proof/refine/AARCH64/TcbAcc_R.thy @@ -9,7 +9,7 @@ theory TcbAcc_R imports CSpace_R ArchMove_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare if_weak_cong [cong] declare hoare_in_monad_post[wp] diff --git a/proof/refine/AARCH64/Tcb_R.thy b/proof/refine/AARCH64/Tcb_R.thy index 506b267cf8..d303b7c184 100644 --- a/proof/refine/AARCH64/Tcb_R.thy +++ b/proof/refine/AARCH64/Tcb_R.thy @@ -9,7 +9,7 @@ theory Tcb_R imports CNodeInv_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma asUser_setNextPC_corres: "corres dc (tcb_at t and invs) (tcb_at' t and invs') @@ -1604,7 +1604,7 @@ end consts copyregsets_map :: "arch_copy_register_sets \ Arch.copy_register_sets" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec tcbinv_relation :: "tcb_invocation \ tcbinvocation \ bool" diff --git a/proof/refine/AARCH64/Untyped_R.thy b/proof/refine/AARCH64/Untyped_R.thy index 5ab6f6043a..d9966e08cf 100644 --- a/proof/refine/AARCH64/Untyped_R.thy +++ b/proof/refine/AARCH64/Untyped_R.thy @@ -13,7 +13,7 @@ begin unbundle l4v_word_context -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec untypinv_relation :: "Invocations_A.untyped_invocation \ @@ -974,7 +974,7 @@ locale mdb_insert_again = context mdb_insert_again begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemmas parent = mdb_ptr_parent.m_p lemmas site = mdb_ptr_site.m_p @@ -1362,7 +1362,7 @@ crunch create_cap_ext crunch create_cap_ext for work_units_completed[wp]: "\s. P (work_units_completed s)" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma updateNewFreeIndex_noop_psp_corres: "corres_underlying {(s, s'). pspace_relations (ekheap s) (kheap s) (ksPSpace s')} False True @@ -1696,7 +1696,7 @@ locale mdb_insert_again_all = mdb_insert_again_child + fixes n' defines "n' \ modify_map n (mdbNext parent_node) (cteMDBNode_update (mdbPrev_update (\a. site)))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma no_0_n' [simp]: "no_0 n'" using no_0_n by (simp add: n'_def) @@ -2672,7 +2672,7 @@ lemma caps_overlap_reserved'_D: apply fastforce done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma insertNewCap_valid_mdb: "\valid_mdb' and valid_objs' and K (slot \ p) and caps_overlap_reserved' (untypedRange cap) and @@ -3872,7 +3872,7 @@ lemma cte_wp_at': "cte_wp_at' (\cte. cteCap cte = capability.UntypedCap using vui by (auto simp: cte_wp_at_ctes_of) -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma idx_cases: "((\ reset \ idx \ unat (ptr - (ptr && ~~ mask sz))) \ reset \ ptr = ptr && ~~ mask sz)" @@ -4035,7 +4035,7 @@ lemma idx_le_new_offs: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma valid_sched_etcbs[elim!]: "valid_sched_2 queues ekh sa cdom kh ct it \ valid_etcbs_2 ekh kh" by (simp add: valid_sched_def) @@ -4225,7 +4225,7 @@ lemma ex_tupI: "P (fst x) (snd x) \ \a b. P a b" by blast -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma resetUntypedCap_corres: "untypinv_relation ui ui' @@ -4432,7 +4432,7 @@ lemma ex_cte_cap_wp_to_irq_state_independent_H[simp]: "irq_state_independent_H (ex_cte_cap_wp_to' P slot)" by (simp add: ex_cte_cap_wp_to'_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma updateFreeIndex_ctes_of: "\\s. P (modify_map (ctes_of s) ptr (cteCap_update (capFreeIndex_update (\_. idx))))\ @@ -4657,7 +4657,7 @@ lemma (in range_cover) funky_aligned: defs canonicalAddressAssert_def: "canonicalAddressAssert \ AARCH64.canonical_address" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma inv_untyped_corres': "\ untypinv_relation ui ui' \ \ diff --git a/proof/refine/AARCH64/VSpace_R.thy b/proof/refine/AARCH64/VSpace_R.thy index 8c9711ad8b..5d955a122c 100644 --- a/proof/refine/AARCH64/VSpace_R.thy +++ b/proof/refine/AARCH64/VSpace_R.thy @@ -17,7 +17,7 @@ lemma cteCaps_of_ctes_of_lift: "(\P. \\s. P (ctes_of s)\ f \\_ s. P (ctes_of s)\) \ \\s. P (cteCaps_of s) \ f \\_ s. P (cteCaps_of s)\" unfolding cteCaps_of_def . -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "vspace_at_asid' vs asid \ \s. \ap pool entry. diff --git a/proof/refine/AARCH64/orphanage/Orphanage.thy b/proof/refine/AARCH64/orphanage/Orphanage.thy index ad6b472205..8e6994926e 100644 --- a/proof/refine/AARCH64/orphanage/Orphanage.thy +++ b/proof/refine/AARCH64/orphanage/Orphanage.thy @@ -14,7 +14,7 @@ text \ or about to be switched to, or be in a scheduling queue. \ -(*FIXME: arch_split: move up? *) +(*FIXME: arch-split: move up? *) context Arch begin requalify_facts @@ -30,7 +30,7 @@ requalify_facts end end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition is_active_thread_state :: "thread_state \ bool" diff --git a/proof/refine/ARM/ADT_H.thy b/proof/refine/ARM/ADT_H.thy index e73d29034d..be082dd7f3 100644 --- a/proof/refine/ARM/ADT_H.thy +++ b/proof/refine/ARM/ADT_H.thy @@ -33,7 +33,7 @@ consts initBootFrames :: "word32 list" initDataStart :: word32 -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \ The construction of the abstract data type @@ -1396,7 +1396,7 @@ locale partial_sort_cdt = partial_sort "\ x y. m' \ cte_map begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma valid_list_2 : "valid_list_2 t m" apply (insert assms') @@ -1593,7 +1593,7 @@ lemma sort_cdt_list_correct: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition absCDTList where "absCDTList cnp h \ sort_cdt_list (absCDT cnp h) h" diff --git a/proof/refine/ARM/ArchAcc_R.thy b/proof/refine/ARM/ArchAcc_R.thy index b8eeb52b8e..c65929564c 100644 --- a/proof/refine/ARM/ArchAcc_R.thy +++ b/proof/refine/ARM/ArchAcc_R.thy @@ -26,7 +26,7 @@ method simp_to_elim = (drule fun_all, elim allE impE) end -context Arch begin global_naming ARM_A (*FIXME: arch_split*) +context Arch begin global_naming ARM_A (*FIXME: arch-split*) lemma asid_pool_at_ko: "asid_pool_at p s \ \pool. ko_at (ArchObj (ARM_A.ASIDPool pool)) p s" @@ -77,7 +77,7 @@ lemmas storePDE_valid_pspace'[wp] = end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) method readObject_arch_obj_at'_method = clarsimp simp: readObject_def obind_def omonad_defs split_def loadObject_default_def obj_at'_def @@ -1189,7 +1189,7 @@ end sublocale Arch < copyGlobalMappings: typ_at_all_props' "copyGlobalMappings newPD" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma arch_cap_rights_update: "acap_relation c c' \ diff --git a/proof/refine/ARM/Arch_R.thy b/proof/refine/ARM/Arch_R.thy index 5197f7c394..1331ff00e5 100644 --- a/proof/refine/ARM/Arch_R.thy +++ b/proof/refine/ARM/Arch_R.thy @@ -15,7 +15,7 @@ begin unbundle l4v_word_context -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare is_aligned_shiftl [intro!] declare is_aligned_shiftr [intro!] @@ -869,7 +869,7 @@ shows apply (drule dom_hd_assocsD) apply (simp add: select_ext_fa[simplified free_asid_select_def] free_asid_select_def o_def returnOk_liftE[symmetric] - split del: if_split) + split del: if_split) apply (thin_tac "fst a \ b \ P" for a b P) apply (case_tac "isUntypedCap a \ capBlockSize a = objBits (makeObject::asidpool) \ \ capIsDevice a") diff --git a/proof/refine/ARM/Bits_R.thy b/proof/refine/ARM/Bits_R.thy index 26192f09c8..46e35b53dc 100644 --- a/proof/refine/ARM/Bits_R.thy +++ b/proof/refine/ARM/Bits_R.thy @@ -23,7 +23,7 @@ crunch_ignore (add: setNextPC getRestartPC assertDerived throw_on_false getObject setObject updateObject loadObject ifM andM orM whenM whileM haskell_assert) -context Arch begin (*FIXME: arch_split*) +context Arch begin (*FIXME: arch-split*) crunch_ignore (add: invalidateLocalTLB_ASID invalidateLocalTLB_VAASID @@ -34,7 +34,7 @@ crunch_ignore (add: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma throwE_R: "\\\ throw f \P\,-" by (simp add: validE_R_def) wp diff --git a/proof/refine/ARM/CNodeInv_R.thy b/proof/refine/ARM/CNodeInv_R.thy index 44035c0cb7..827877ebf7 100644 --- a/proof/refine/ARM/CNodeInv_R.thy +++ b/proof/refine/ARM/CNodeInv_R.thy @@ -15,7 +15,7 @@ begin unbundle l4v_word_context -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec valid_cnode_inv' :: "Invocations_H.cnode_invocation \ kernel_state \ bool" @@ -4897,7 +4897,7 @@ lemma cteSwap_valid_pspace'[wp]: apply clarsimp+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch cteSwap for tcb_at [wp]: "tcb_at' t" @@ -6512,7 +6512,7 @@ lemma cteDelete_sch_act_simple: apply simp+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch "Arch.finaliseCap", unbindMaybeNotification, prepareThreadDelete, schedContextMaybeUnbindNtfn, cleanReply @@ -6628,6 +6628,11 @@ lemmas cancelAllSignals_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF cancelAllSi lemmas emptySlot_rvk_prog' = emptySlot_rvk_prog[unfolded o_def] lemmas threadSet_ctesCaps_of = ctes_of_cteCaps_of_lift[OF threadSet_ctes_of] +lemmas storePTE_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF storePTE_ctes] +lemmas storePDE_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF storePDE_ctes] + +context begin interpretation Arch . (*FIXME: arch-split*) + context notes option.case_cong_weak[cong] begin @@ -6875,7 +6880,7 @@ lemmas rec_del_concrete_unfold = rec_del_concrete.simps red_zombie_will_fail.simps if_True if_False ball_simps simp_thms -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cap_relation_removables: "\ cap_relation cap cap'; isNullCap cap' \ isZombie cap'; @@ -6940,7 +6945,7 @@ lemmas finaliseSlot_typ_ats[wp] = typ_at_lifts[OF finaliseSlot_typ_at'] lemmas rec_del_valid_list_irq_state_independent[wp] = rec_del_preservation[OF cap_swap_for_delete_valid_list set_cap_valid_list empty_slot_valid_list finalise_cap_valid_list preemption_point_valid_list] -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma rec_del_corres: "\C \ rec_del_concrete args. @@ -7868,7 +7873,7 @@ lemma (in mdb_move) m'_cap: context mdb_move begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma m_to_src: "m \ p \ src = (p \ 0 \ p = mdbPrev src_node)" @@ -8387,7 +8392,7 @@ qed end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteMove_iflive'[wp]: "\\s. if_live_then_nonz_cap' s @@ -8564,7 +8569,7 @@ crunch updateMDB for valid_bitmaps[wp]: valid_bitmaps (rule: valid_bitmaps_lift) -(* FIXME: arch_split *) +(* FIXME: arch-split *) lemma haskell_assert_inv: "haskell_assert Q L \P\" by wpsimp @@ -8626,7 +8631,7 @@ lemmas finalise_slot_corres' simplified, folded finalise_slot_def] for slot exp lemmas finalise_slot_corres = use_spec_corres [OF finalise_slot_corres'] -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cap_relation_same: "\ cap_relation cap cap'; cap_relation cap cap'' \ diff --git a/proof/refine/ARM/CSpace1_R.thy b/proof/refine/ARM/CSpace1_R.thy index ffed3d374e..54caa6daa6 100644 --- a/proof/refine/ARM/CSpace1_R.thy +++ b/proof/refine/ARM/CSpace1_R.thy @@ -13,7 +13,7 @@ imports CSpace_I begin -context Arch begin global_naming ARM_A (*FIXME: arch_split*) +context Arch begin global_naming ARM_A (*FIXME: arch-split*) lemmas final_matters_def = final_matters_def[simplified final_matters_arch_def] @@ -24,7 +24,7 @@ lemmas final_matters_simps[simp] end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma isMDBParentOf_CTE1: "isMDBParentOf (CTE cap node) cte = @@ -926,7 +926,7 @@ abbreviation abbreviation "revokable' a b \ global.isCapRevocable b a" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare arch_is_cap_revocable_def[simp] ARM_H.isCapRevocable_def[simp] @@ -2756,7 +2756,7 @@ locale masterCap = fixes cap cap' assumes master: "capMasterCap cap = capMasterCap cap'" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma isZombie [simp]: "isZombie cap' = isZombie cap" using master @@ -3339,7 +3339,7 @@ locale mdb_insert_sib = mdb_insert_der + (mdbRevocable_update (\a. revokable' src_cap c') (mdbPrev_update (\a. src) src_node))))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) (* If dest is inserted as sibling, src can not have had children. If it had had children, then dest_node which is just a derived copy @@ -3486,7 +3486,7 @@ lemma descendants: by (rule set_eqI) (simp add: descendants_of'_def parent_n_eq) end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma mdb_None: assumes F: "\p'. cte_map p \ descendants_of' p' m' \ False" assumes R: "cdt_relation (swp cte_at s) (cdt s) m'" @@ -4333,7 +4333,7 @@ locale mdb_inv_preserve = \ (\x. sameRegionAs x (cteCap cte)) = (\x. sameRegionAs x (cteCap cte'))" assumes mdb_next:"\p. mdb_next m p = mdb_next m' p" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma preserve_stuff: "valid_dlist m = valid_dlist m' \ ut_revocable' m = ut_revocable' m' @@ -4946,7 +4946,7 @@ lemma cte_map_inj_eq': \ p = p'" by (rule cte_map_inj_eq; fastforce) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_corres: notes split_paired_All[simp del] split_paired_Ex[simp del] trans_state_update'[symmetric,simp] @@ -6891,7 +6891,7 @@ lemma subtree_no_parent: shows "False" using assms by induct (auto simp: parentOf_def mdb_next_unfold) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ensureNoChildren_corres: "p' = cte_map p \ diff --git a/proof/refine/ARM/CSpace_I.thy b/proof/refine/ARM/CSpace_I.thy index fe2cfdbb77..d5fb5dd0d6 100644 --- a/proof/refine/ARM/CSpace_I.thy +++ b/proof/refine/ARM/CSpace_I.thy @@ -12,7 +12,7 @@ theory CSpace_I imports ArchAcc_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas capUntypedPtr_simps[simp] = capUntypedPtr_def[split_simps capability.split, simplified PPtr_def id_def] lemmas arch_capUntypedPtr_simps[simp] = ARM_H.capUntypedPtr_def[split_simps arch_capability.split, simplified PPtr_def id_def] @@ -1484,7 +1484,7 @@ lemma no_mdb_not_target: apply (simp add: no_mdb_def) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma valid_dlist_init: "\ valid_dlist m; m p = Some cte; no_mdb cte \ \ valid_dlist (m (p \ CTE cap initMDBNode))" @@ -1682,7 +1682,7 @@ lemma untyped_inc_init: apply (rule untypedRange_in_capRange)+ apply (simp add:Int_ac) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma valid_nullcaps_init: "\ valid_nullcaps m; cap \ NullCap \ \ valid_nullcaps (m(p \ CTE cap initMDBNode))" by (simp add: valid_nullcaps_def initMDBNode_def nullPointer_def) @@ -1742,7 +1742,7 @@ lemma distinct_zombies_copyE: lemmas distinct_zombies_sameE = distinct_zombies_copyE [where y=x and x=x for x, simplified, OF _ _ _ _ _] -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma capBits_Master: "capBits (capMasterCap cap) = capBits cap" by (clarsimp simp: capMasterCap_def split: capability.split arch_capability.split) diff --git a/proof/refine/ARM/CSpace_R.thy b/proof/refine/ARM/CSpace_R.thy index f19d6f755e..9424227d2a 100644 --- a/proof/refine/ARM/CSpace_R.thy +++ b/proof/refine/ARM/CSpace_R.thy @@ -51,7 +51,7 @@ locale mdb_move = modify_map n (mdbNext src_node) (cteMDBNode_update (mdbPrev_update (\_. dest)))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemmas src = m_p @@ -730,16 +730,12 @@ lemma set_cap_not_quite_corres': domain_index t = ksDomScheduleIdx t' \ domain_list t = ksDomSchedule t' \ cur_domain t = ksCurDomain t' \ - domain_time t = ksDomainTime t' \ - consumed_time t = ksConsumedTime t' \ - cur_time t = ksCurTime t' \ - cur_sc t = ksCurSc t' \ - reprogram_timer t = ksReprogramTimer t' \ - sc_replies_of t = sc_replies_of s" - using cr - by (rule set_cap_not_quite_corres; fastforce simp: c p) - -context begin interpretation Arch . (*FIXME: arch_split*) + domain_time t = ksDomainTime t'" + apply (rule set_cap_not_quite_corres) + using cr + apply (fastforce simp: c p pspace_relations_def)+ + done +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteMove_corres: assumes cr: "cap_relation cap cap'" notes trans_state_update'[symmetric,simp] @@ -1135,7 +1131,7 @@ crunch cteInsert context mdb_insert begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma n_src_dest: "n \ src \ dest" by (simp add: n_direct_eq) @@ -1655,7 +1651,7 @@ lemma untyped_inc_prev_update: lemma is_derived_badge_derived': "is_derived' m src cap cap' \ badge_derived' cap cap'" by (simp add: is_derived'_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_mdb_chain_0: "\valid_mdb' and pspace_aligned' and pspace_distinct' and (\s. src \ dest) and (\s. cte_wp_at' (is_derived' (ctes_of s) src cap \ cteCap) src s)\ @@ -4104,7 +4100,7 @@ locale mdb_insert_simple = mdb_insert + assumes safe_parent: "safe_parent_for' m src c'" assumes simple: "is_simple_cap' c'" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma dest_no_parent_n: "n \ dest \ p = False" using src simple safe_parent @@ -4294,7 +4290,7 @@ lemma maskedAsFull_revokable_safe_parent: apply (clarsimp simp:isCap_simps is_simple_cap'_def)+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_simple_corres: assumes "cap_relation c c'" "src' = cte_map src" "dest' = cte_map dest" notes trans_state_update'[symmetric,simp] @@ -4677,7 +4673,7 @@ locale mdb_insert_simple' = mdb_insert_simple + fixes n' defines "n' \ modify_map n (mdbNext src_node) (cteMDBNode_update (mdbPrev_update (\_. dest)))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma no_0_n' [intro!]: "no_0 n'" by (auto simp: n'_def) lemmas n_0_simps' [iff] = no_0_simps [OF no_0_n'] @@ -5341,7 +5337,7 @@ lemma mdb: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_simple_mdb': "\valid_mdb' and pspace_aligned' and pspace_distinct' and (\s. src \ dest) and K (capAligned cap) and (\s. safe_parent_for' (ctes_of s) src cap) and K (is_simple_cap' cap) \ diff --git a/proof/refine/ARM/Detype_R.thy b/proof/refine/ARM/Detype_R.thy index 9a5c89de16..0bb16e10c2 100644 --- a/proof/refine/ARM/Detype_R.thy +++ b/proof/refine/ARM/Detype_R.thy @@ -9,7 +9,7 @@ theory Detype_R imports Retype_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "descendants_range_in' S p \ @@ -83,7 +83,7 @@ lemma descendants_range_inD': done end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma descendants_range'_def2: "descendants_range' cap p = descendants_range_in' (capRange cap) p" @@ -448,7 +448,7 @@ end locale detype_locale' = detype_locale + constrains s::"det_state" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \Invariant preservation across concrete deletion\ @@ -503,7 +503,7 @@ locale delete_locale = context delete_locale begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma valid_objs: "valid_objs' s'" and vreplies: "valid_replies' s'" and pspace: "valid_pspace' s'" @@ -647,13 +647,21 @@ lemma objRefs_notrange: assumes asms: "ctes_of s' p = Some c" "\ isUntypedCap (cteCap c)" shows "capRange (cteCap c) \ base_bits = {}" proof - - from cap obtain node - where ctes_of: "ctes_of s' ptr = Some (CTE (UntypedCap d base bits idx) node)" - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (case_tac cte, simp) - done - - show ?thesis using asms cap + interpret Arch . (* FIXME: arch-split *) + note [simp del] = atLeastatMost_subset_iff atLeastLessThan_iff atLeastAtMost_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex + have "\t m r. \ptr. cte_wp_at ((=) (cap.ReplyCap t m r)) ptr s + \ t \ {base .. base + 2 ^ magnitude - 1}" + by (fastforce dest!: valid_cap2 simp: cap obj_reply_refs_def) + hence "\ptr t m r. cte_wp_at ((=) (cap.ReplyCap t m r)) ptr s + \ t \ {base .. base + 2 ^ magnitude - 1}" + by (fastforce simp del: split_paired_All) + hence "\t. t \ {base .. base + 2 ^ magnitude - 1} \ + (\ptr m r. \ cte_wp_at ((=) (cap.ReplyCap t m r)) ptr s)" + by fastforce + hence cte: "\t. t \ {base .. base + 2 ^ magnitude - 1} \ + (\ptr m r. \ cte_wp_at' (\cte. cteCap cte = ReplyCap t m r) ptr s')" + unfolding deletionIsSafe_def apply - apply (rule ccontr) apply (drule untyped_mdbD' [OF ctes_of _ _ _ _ umdb]) @@ -709,7 +717,7 @@ lemma deletionIsSafe_holds: and vu: "valid_untyped (cap.UntypedCap d base bits idx) s" shows "deletionIsSafe base bits s'" proof - - interpret Arch . (* FIXME: arch_split *) + interpret Arch . (* FIXME: arch-split *) have arch: "\ ko p. \ ksPSpace s' p = Some (KOArch ko); p \ {base..base + 2 ^ bits - 1} \ \ 6 \ bits" @@ -760,9 +768,7 @@ proof - done qed -end - -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \Invariant preservation across concrete deletion\ @@ -813,7 +819,7 @@ locale delete_locale = and al: "is_aligned base bits" and safe: "deletionIsSafe base bits s'" -context delete_locale begin interpretation Arch . (*FIXME: arch_split*) +context delete_locale begin interpretation Arch . (*FIXME: arch-split*) lemma valid_objs: "valid_objs' s'" and pa: "pspace_aligned' s'" @@ -1028,7 +1034,7 @@ lemma refs_notRange: done end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ksASIDMapSafeI: "\ (s,s') \ state_relation; invs s; pspace_aligned' s' \ pspace_distinct' s' \ @@ -1338,69 +1344,7 @@ lemma deleteObjects_corres: done end -context delete_locale -begin -interpretation Arch . (*FIXME: arch_split*) - -lemma live_idle_untyped_range': - "\ ko_wp_at' P p s' \ p = idle_thread_ptr \ p = idle_sc_ptr; \ko. P ko \ live' ko \ - \ p \ base_bits" - apply (case_tac "ko_wp_at' P p s'") - apply (drule if_live_then_nonz_capE'[OF iflive ko_wp_at'_weakenE]) - apply simp - apply (erule ex_nonz_cap_notRange) - apply clarsimp - apply (insert invs_valid_global'[OF invs] cap valid_idle' - idle_is_global[where s = s]) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (drule (1) valid_global_refsD') - apply (clarsimp simp: valid_idle'_def) - using atLeastAtMost_iff apply (simp add: p_assoc_help) - by fastforce - -lemma untyped_range_live_idle': - "p \ base_bits \ \ (ko_wp_at' live' p s' \ p = idle_thread_ptr \ p = idle_sc_ptr)" - using live_idle_untyped_range' by blast - -lemma refs_of': - "\ko p. ko_wp_at' ((=) (injectKOS ko)) p s' \ sym_refs (state_refs_of' s') - \ refs_of' (injectKOS ko) \ (UNIV - base_bits \ UNIV)" - apply (case_tac "p = idle_sc_ptr \ p = idle_thread_ptr") - apply (insert valid_idle') - apply (clarsimp simp: valid_idle'_def) - apply (elim disjE) - apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs) - using live_idle_untyped_range' apply simp - apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs idle_tcb'_def) - using live_idle_untyped_range' apply simp - apply (prop_tac "ko_at' ko p s'") - apply (fastforce simp: ko_wp_at'_def obj_at'_def projectKOs project_inject) - apply (frule sym_refs_ko_atD') - apply (fastforce intro: refs_of_live' dest!: live_notRange)+ - done - -lemma list_refs_of_replies_live': - "\ (x, tp) \ list_refs_of_replies' s' p; pspace_aligned' s'; pspace_distinct' s'; pspace_bounded' s' \ - \ ko_wp_at' live' p s'" - apply (clarsimp simp: ko_wp_at'_def list_refs_of_replies'_def list_refs_of_reply'_def pspace_bounded'_def - pspace_aligned'_def pspace_distinct'_def get_refs_def projectKOs - split: option.splits - elim!: opt_mapE) - by (metis live_reply'_def not_in_domIff option.discI option.sel)+ - -lemma replyPrev_list_refs_of_replies: - "\ko_at' reply p s'; replyPrev reply = Some reply_ptr\ - \ (reply_ptr, ReplyPrev) \ list_refs_of_replies' s' p" - by (clarsimp simp: list_refs_of_replies'_def list_refs_of_reply'_def opt_map_def projectKOs - obj_at'_def - split: option.splits) - -lemma replyNext_list_refs_of_replies: - "\ko_at' reply p s'; replyNext reply = Some next_ptr; next_ptr = Next reply_ptr\ - \ (reply_ptr, ReplyNext) \ list_refs_of_replies' s' p" - by (clarsimp simp: list_refs_of_replies'_def list_refs_of_reply'_def opt_map_def projectKOs - obj_at'_def - split: option.splits) +context delete_locale begin interpretation Arch . (*FIXME: arch-split*) lemma live_idle_untyped_range': "ko_wp_at' live' p s' \ p = idle_thread_ptr \ p \ base_bits" @@ -1802,7 +1746,7 @@ using vds proof (simp add: invs'_def valid_pspace'_def (* FIXME: do not simp here *) valid_mdb'_def valid_mdb_ctes_def, safe) - interpret Arch . (*FIXME: arch_split*) + interpret Arch . (*FIXME: arch-split*) let ?s = state' let ?ran = base_bits @@ -2163,8 +2107,7 @@ lemma doMachineOp_modify: apply (rule ext) apply (simp add: simpler_gets_def simpler_modify_def bind_def) done - -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma deleteObjects_invs': "\cte_wp_at' (\c. cteCap c = UntypedCap d ptr bits idx) p and invs' and ct_active' and sch_act_simple @@ -3674,6 +3617,17 @@ lemma setCTE_doMachineOp_commute: apply (wp|clarsimp|fastforce)+ done +lemma setCTE_when_doMachineOp_commute: + assumes nf: "no_fail Q (doMachineOp x)" + shows "monad_commute (cte_at' dest and pspace_aligned' and pspace_distinct' and Q) + (setCTE dest cte) + (when P (doMachineOp x))" + apply (cases P; simp add: setCTE_doMachineOp_commute nf) + apply (rule monad_commute_guard_imp) + apply (rule return_commute[THEN commute_commute]) + apply simp + done + lemma placeNewObject_valid_arch_state: "\valid_arch_state' and pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) and @@ -3936,6 +3890,7 @@ lemma createObject_setCTE_commute: setCTE_modify_gsUserPages_commute[of \] modify_wp[of "%_. \"] setCTE_doMachineOp_commute + setCTE_when_doMachineOp_commute setCTE_placeNewObject_commute monad_commute_if_weak_r copyGlobalMappings_setCTE_commute[THEN commute_commute] @@ -4115,6 +4070,13 @@ lemma copyGlobalMappings_gsUntypedZeroRanges_commute': apply simp done +lemma dmo_gsUntypedZeroRanges_commute: + "monad_commute \ (modify (\s. s\gsUntypedZeroRanges := f (gsUntypedZeroRanges s)\)) + (doMachineOp m)" + apply (clarsimp simp: monad_commute_def doMachineOp_def) + apply monad_eq + by (auto simp: select_f_def) + lemma createObject_gsUntypedZeroRanges_commute: "monad_commute \ @@ -4945,26 +4907,97 @@ lemma doMachineOp_ksArchState_commute: apply clarsimp+ done +lemma doMachineOp_ksPSpace: + "monad_commute \ (doMachineOp f) (gets ksPSpace)" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc) + apply monad_eq + apply (auto simp add: select_f_def) + done + +lemma doMachineOp_assert_opt: + "empty_fail f \ monad_commute \ (doMachineOp f) (assert_opt m)" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc) + apply monad_eq + apply (force simp add: select_f_def empty_fail_def) + done + +lemma doMachineOp_assert: + "empty_fail f \ monad_commute \ (doMachineOp f) (assert P)" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc) + apply monad_eq + apply (force simp add: select_f_def empty_fail_def) + done + +lemma doMachineOp_projectKO_pde: + "empty_fail f \ monad_commute \ (doMachineOp f) (projectKO ko :: pde kernel)" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc projectKO_def) + apply monad_eq + by (force split: option.splits simp: fail_def return_def select_f_def empty_fail_def) + +lemma doMachineOp_alignCheck: + "empty_fail f \ monad_commute \ (doMachineOp f) (alignCheck ko n)" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc alignCheck_def split_def + alignError_def unless_def) + apply monad_eq + by (force simp: select_f_def empty_fail_def) + +lemma doMachineOp_magnitudeCheck: + "empty_fail f \ monad_commute \ (doMachineOp f) (magnitudeCheck x y n)" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc magnitudeCheck_def split_def) + apply monad_eq + apply (force simp: select_f_def empty_fail_def return_def when_def fail_def split: option.splits) + done + +lemma doMachineOp_storePDE_commute_T: + "empty_fail f \ monad_commute \ (doMachineOp f) (storePDE src pde)" + apply (clarsimp simp: storePDE_def setObject_def updateObject_default_def bind_assoc split_def) + apply (rule monad_commute_guard_imp) + apply (rule monad_commute_split [OF _ doMachineOp_ksPSpace]) + apply (rule monad_commute_split [OF _ doMachineOp_assert_opt]) + apply (rule monad_commute_split [OF _ doMachineOp_assert]) + apply (rule monad_commute_split [OF _ doMachineOp_projectKO_pde]) + apply (rule monad_commute_split [OF _ doMachineOp_alignCheck]) + apply (rule monad_commute_split [OF _ doMachineOp_magnitudeCheck]) + apply (rule doMachineOp_upd_heap_commute) + apply (assumption | wp)+ + apply simp + done + +lemma getPDE_doMachineOp_commute_T: + "empty_fail f \ monad_commute \ (doMachineOp f) (getObject src :: pde kernel)" + apply (clarsimp simp: storePDE_def getObject_def loadObject_default_def bind_assoc split_def) + apply (rule monad_commute_guard_imp) + apply (rule monad_commute_split [OF _ doMachineOp_ksPSpace]) + apply (rule monad_commute_split [OF _ doMachineOp_assert_opt]) + apply (rule monad_commute_split [OF _ doMachineOp_assert]) + apply (rule monad_commute_split [OF _ doMachineOp_projectKO_pde]) + apply (rule monad_commute_split [OF _ doMachineOp_alignCheck]) + apply (rule monad_commute_split [OF _ doMachineOp_magnitudeCheck]) + apply (rule commute_commute, rule return_commute) + apply (assumption | wp)+ + apply simp + done + lemma doMachineOp_copyGlobalMapping_commute: - "monad_commute (valid_arch_state' and page_directory_at' r) - (doMachineOp f) (copyGlobalMappings r)" - apply (clarsimp simp:copyGlobalMappings_def) + "empty_fail f \ monad_commute \ (doMachineOp f) (copyGlobalMappings r)" + apply (clarsimp simp: copyGlobalMappings_def) apply (rule monad_commute_guard_imp) apply (rule monad_commute_split) - apply (rule mapM_x_commute[where f = id]) - apply (rule monad_commute_split[OF _ getPDE_doMachineOp_commute]) - apply (rule doMachineOp_storePDE_commute) - apply wp+ - apply clarsimp + apply (rule commute_commute, rule mapM_x_commute_T) + apply (rule commute_commute) + apply (rule monad_commute_guard_imp) + apply (rule monad_commute_split[OF _ getPDE_doMachineOp_commute_T]) + apply (rule doMachineOp_storePDE_commute_T) + apply (assumption | wp)+ + apply simp apply (rule doMachineOp_ksArchState_commute) apply wp apply clarsimp - apply (clarsimp simp: valid_arch_state'_def page_directory_at'_def objBits_simps archObjSize_def - pdBits_def pageBits_def) - apply (drule le_m1_iff_lt[where x = "(0x1000::word32)",simplified,THEN iffD1]) - apply (clarsimp simp: pdeBits_def) done +lemmas mapM_doMachineOp_copyGlobalMapping_commute = + doMachineOp_copyGlobalMapping_commute[THEN mapM_x_commute_T] + lemma createObjects'_page_directory_at': "\K (range_cover ptr sz 14 (Suc n)) and pspace_aligned' and pspace_distinct' and pspace_bounded' and pspace_no_overlap' ptr sz\ @@ -5160,6 +5193,85 @@ proof - done qed +lemma dmo'_when_fail_comm: + assumes "empty_fail f" + shows "doMachineOp f >>= (\x. when P fail >>= (\_. m x)) = + when P fail >>= (\_. doMachineOp f >>= m)" + apply (rule ext) + apply (cut_tac ef_dmo'[OF assms]) + apply (auto simp add: empty_fail_def when_def fail_def return_def + bind_def split_def image_def, fastforce) + done + +lemma dmo'_gets_ksPSpace_comm: + "doMachineOp f >>= (\y. gets ksPSpace >>= m y) = + gets ksPSpace >>= (\x. doMachineOp f >>= (\y. m y x))" + apply (rule ext) + apply (clarsimp simp: doMachineOp_def simpler_modify_def simpler_gets_def + return_def select_f_def bind_def split_def image_def + cong: SUP_cong_simp) + apply (rule conjI; clarsimp) + apply (rule equalityI; clarsimp; + rule exI, rule conjI[rotated], assumption, + (rule exI)+, + rule conjI, rule bexI, rule refl, assumption, fastforce) + apply (rule iffI; clarsimp; + (rule exI)+, + rule conjI, + erule bexI[rotated], rule refl, + fastforce dest: prod_injects)+ + done + +lemma dmo'_ksPSpace_update_comm': + assumes "empty_fail f" + shows "doMachineOp f >>= (\x. modify (ksPSpace_update g) >>= (\_. m x)) = + modify (ksPSpace_update g) >>= (\_. doMachineOp f >>= m)" +proof - + have ksMachineState_ksPSpace_update: + "\s. ksMachineState (ksPSpace_update g s) = ksMachineState s" + by simp + have updates_independent: + "\f. ksPSpace_update g \ ksMachineState_update f = + ksMachineState_update f \ ksPSpace_update g" + by (rule ext) simp + from assms + show ?thesis + apply (simp add: doMachineOp_def split_def bind_assoc) + apply (simp add: gets_modify_comm2[OF ksMachineState_ksPSpace_update]) + apply (rule arg_cong_bind1) + apply (simp add: empty_fail_def select_f_walk[OF empty_fail_modify] + modify_modify_bind updates_independent) + done +qed + +lemma dmo'_createObjects'_commute: + assumes ef: "empty_fail f" + shows "monad_commute \ (doMachineOp f) (createObjects' ptr n obj us)" + apply (clarsimp simp: createObjects'_def bind_assoc split_def unless_def + alignError_def monad_commute_def + dmo'_when_fail_comm[OF ef] + dmo'_gets_ksPSpace_comm + dmo'_ksPSpace_update_comm'[OF ef, symmetric]) + apply (rule_tac x=s in fun_cong) + apply (rule arg_cong_bind1) + apply (rule arg_cong_bind1) + apply (rename_tac u w) + apply (case_tac "fst (lookupAround2 (ptr + of_nat (shiftL n (objBitsKO obj + + us) - Suc 0)) w)", clarsimp+) + apply (simp add: assert_into_when dmo'_when_fail_comm[OF ef]) + done + +lemmas map_dmo'_createObjects'_comm = dmo'_createObjects'_commute[THEN mapM_x_commute_T] + +lemma dmo'_gsUserPages_upd_commute: + "monad_commute \ (doMachineOp f) (modify (gsUserPages_update g))" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc) + apply monad_eq + apply (auto simp: select_f_def) + done + +lemmas dmo'_gsUserPages_upd_map_commute = dmo'_gsUserPages_upd_commute[THEN mapM_x_commute_T] + lemma new_cap_addrs_def2: "n < 2 ^ 32 \ new_cap_addrs (Suc n) ptr obj @@ -5395,242 +5507,193 @@ proof - placeNewObject_def2 scBits_simps)+)[2] \ \SmallPageObject\ apply (simp add: Arch_createNewCaps_def - Retype_H.createObject_def createObjects_def bind_assoc - ARM_H.toAPIType_def ARM_H.toAPIType_def + Retype_H.createObject_def createObjects_def bind_assoc toAPIType_def ARM_H.createObject_def placeNewDataObject_def) apply (intro conjI impI) + (* device *) apply (subst monad_eq, rule createObjects_Cons) - apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_H.getObjectSize_def - objBits_simps)[7] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_H.getObjectSize_def + apply (simp_all add: field_simps shiftl_t2n pageBits_def + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def pageBits_def add.commute append) apply ((subst gsUserPages_update gsCNodes_update - gsUserPages_upd_createObjects'_comm - | simp add: modify_modify_bind o_def)+)[1] - apply (subst monad_eq, rule createObjects_Cons) + gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] + | simp add: modify_modify_bind o_def)+)[1] + (* not device *) + apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_H.getObjectSize_def - objBits_simps)[7] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_H.getObjectSize_def - pageBits_def add.commute append) - apply (subst gsUserPages_update gsCNodes_update + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def + pageBits_def add.commute append mapM_x_append mapM_x_singleton) + apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm - | simp add: modify_modify_bind o_def)+ + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] + | simp add: modify_modify_bind o_def)+ \ \LargePageObject\ apply (simp add: Arch_createNewCaps_def - Retype_H.createObject_def createObjects_def bind_assoc - ARM_H.toAPIType_def ARM_H.toAPIType_def + Retype_H.createObject_def createObjects_def bind_assoc toAPIType_def ARM_H.createObject_def placeNewDataObject_def) apply (intro conjI impI) + (* device *) apply (subst monad_eq, rule createObjects_Cons) - apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_H.getObjectSize_def - objBits_simps)[7] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_H.getObjectSize_def + apply (simp_all add: field_simps shiftl_t2n pageBits_def + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def pageBits_def add.commute append) apply ((subst gsUserPages_update gsCNodes_update - gsUserPages_upd_createObjects'_comm - | simp add: modify_modify_bind o_def)+)[1] + gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] + | simp add: modify_modify_bind o_def)+)[1] + (* not device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - ARM_H.getObjectSize_def objBits_simps)[7] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - ARM_H.getObjectSize_def - pageBits_def add.commute append) + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def + pageBits_def add.commute append mapM_x_append mapM_x_singleton) apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+ - \ \SectionObject\ + \ \SectionObject\ apply (simp add: Arch_createNewCaps_def - Retype_H.createObject_def createObjects_def bind_assoc - toAPIType_def ARM_H.toAPIType_def + Retype_H.createObject_def createObjects_def bind_assoc toAPIType_def ARM_H.createObject_def placeNewDataObject_def) apply (intro conjI impI) + (* device *) apply (subst monad_eq, rule createObjects_Cons) - apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_H.getObjectSize_def - objBits_simps)[7] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_H.getObjectSize_def + apply (simp_all add: field_simps shiftl_t2n pageBits_def + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def pageBits_def add.commute append) apply ((subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+)[1] + (* not device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - ARM_H.getObjectSize_def objBits_simps)[7] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - ARM_H.getObjectSize_def - pageBits_def add.commute append) + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def + pageBits_def add.commute append mapM_x_append mapM_x_singleton) apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+ \ \SuperSectionObject\ apply (simp add: Arch_createNewCaps_def - Retype_H.createObject_def createObjects_def bind_assoc - toAPIType_def ARM_H.toAPIType_def + Retype_H.createObject_def createObjects_def bind_assoc toAPIType_def ARM_H.createObject_def placeNewDataObject_def) apply (intro conjI impI) + (* device *) apply (subst monad_eq, rule createObjects_Cons) - apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_H.getObjectSize_def - objBits_simps)[7] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_H.getObjectSize_def + apply (simp_all add: field_simps shiftl_t2n pageBits_def + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def pageBits_def add.commute append) apply ((subst gsUserPages_update gsCNodes_update - gsUserPages_upd_createObjects'_comm - | simp add: modify_modify_bind o_def)+)[1] + gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] + | simp add: modify_modify_bind o_def)+)[1] + (* not device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - ARM_H.getObjectSize_def objBits_simps)[7] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - ARM_H.getObjectSize_def - pageBits_def add.commute append) + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def + pageBits_def add.commute append mapM_x_append mapM_x_singleton) apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+ \ \PageTableObject\ - apply (simp add:Arch_createNewCaps_def Retype_H.createObject_def - createObjects_def bind_assoc ARM_H.toAPIType_def - ARM_H.createObject_def) - apply (subst monad_eq,rule createObjects_Cons) - apply ((simp add: field_simps shiftl_t2n pageBits_def archObjSize_def - getObjectSize_def ARM_H.getObjectSize_def - objBits_simps ptBits_def)+)[7] - apply (simp add:bind_assoc placeNewObject_def2) - apply (simp add: pageBits_def field_simps - getObjectSize_def ptBits_def archObjSize_def - ARM_H.getObjectSize_def placeNewObject_def2 - objBits_simps append) - -\ \PageDirectoryObject\ - apply (simp add:Arch_createNewCaps_def Retype_H.createObject_def - createObjects_def bind_assoc ARM_H.toAPIType_def - ARM_H.createObject_def) - apply (subgoal_tac "distinct (map (\n. ptr + (n << 14)) [0.e.((of_nat n)::word32)])") - prefer 2 - apply (clarsimp simp: objBits_simps archObjSize_def pdBits_def pageBits_def - ARM_H.getObjectSize_def) - apply (subst upto_enum_word) - apply (clarsimp simp:distinct_map) - apply (frule range_cover.range_cover_n_le) - apply (frule range_cover.range_cover_n_less) - apply (rule conjI) - apply (clarsimp simp:inj_on_def) - apply (rule ccontr) - apply (erule_tac bnd = "2^(word_bits - 14)" in shift_distinct_helper[rotated 3]) - apply simp - apply (simp add:word_bits_def) - apply (erule less_le_trans[OF word_of_nat_less]) - apply (simp add: word_of_nat_le word_bits_def pdeBits_def) - apply (erule less_le_trans[OF word_of_nat_less]) - apply (simp add:word_of_nat_le word_bits_def pdeBits_def) - apply (frule range_cover.unat_of_nat_n[OF range_cover_le[where n = n]]) - apply simp - apply (rule ccontr) - apply simp - apply (drule of_nat_inj32[THEN iffD1,rotated -1]) - apply (simp_all add: word_bits_def)[3] - apply (clarsimp) - apply (erule_tac bnd = "2^(word_bits - 14)" in shift_distinct_helper[rotated 3]) - apply simp - apply (simp add:word_bits_def) - apply (simp add:word_of_nat_less word_bits_def pdeBits_def) - apply (erule less_le_trans[OF word_of_nat_less]) - apply (simp add:word_of_nat_le word_bits_def pdeBits_def) - apply (rule ccontr) - apply (frule range_cover.unat_of_nat_n[OF range_cover_le[where n = n]]) - apply simp - apply simp - apply (drule of_nat_inj32[THEN iffD1,rotated -1]) - apply (simp_all add: word_bits_def)[3] - apply (subst monad_eq,rule createObjects_Cons) - apply ((simp add: field_simps shiftl_t2n pageBits_def archObjSize_def - ARM_H.getObjectSize_def pdBits_def - objBits_simps ptBits_def)+)[7] - apply (simp add:objBits_simps archObjSize_def pdBits_def pageBits_def ARM_H.getObjectSize_def) - apply (simp add:bind_assoc) - apply (simp add: placeNewObject_def2[where val = "makeObject::ARM_H.pde",simplified,symmetric]) - apply (rule_tac Q = "\r s. valid_arch_state' s \ - (\x\of_nat n. page_directory_at' (ptr + (x << 14)) s) \ Q s" for Q in monad_eq_split) - apply (rule sym) - apply (subst bind_assoc[symmetric]) - apply (subst monad_commute_simple) - apply (rule commute_commute[OF monad_commute_split]) - apply (rule placeNewObject_doMachineOp_commute) - apply (rule mapM_x_commute[where f = id]) - apply (rule placeNewObject_copyGlobalMapping_commute) - apply (rule hoare_pre) - apply (wp copyGlobalMappings_pspace_no_overlap' mapM_x_wp'| clarsimp simp: pdeBits_def)+ - apply (clarsimp simp:objBits_simps archObjSize_def pdBits_def pageBits_def word_bits_conv) - apply assumption (* resolve assumption , yuck *) - apply (simp add:append mapM_x_append bind_assoc pdeBits_def) - apply (rule monad_eq_split[where Q = "\ r s. pspace_aligned' s \ pspace_distinct' s - \ valid_arch_state' s \ (\r \ of_nat n. page_directory_at' (ptr + (r << 14)) s) - \ page_directory_at' (ptr + ((1 + of_nat n) << 14)) s"]) - apply (rule monad_eq_split[where Q = "\ r s. pspace_aligned' s \ pspace_distinct' s - \ valid_arch_state' s \ (\r \ of_nat n. page_directory_at' (ptr + (r << 14)) s) - \ page_directory_at' (ptr + ((1 + of_nat n) << 14)) s"]) - apply (subst monad_commute_simple) - apply (rule doMachineOp_copyGlobalMapping_commute) - apply (clarsimp simp:field_simps) - apply (simp add:field_simps mapM_x_singleton) - apply (rule monad_eq_split[where Q = "\ r s. pspace_aligned' s \ pspace_distinct' s - \ valid_arch_state' s \ page_directory_at' (ptr + (1 + of_nat n << 14)) s"]) - apply (subst doMachineOp_bind) - apply (wp empty_fail_mapM_x empty_fail_cleanCacheRange_PoU)+ - apply (simp add:bind_assoc objBits_simps field_simps archObjSize_def shiftL_nat) - apply wp - apply simp - apply (rule mapM_x_wp') - apply (rule hoare_pre) - apply (wp copyGlobalMappings_pspace_no_overlap' | clarsimp)+ - apply (clarsimp simp:page_directory_at'_def) - apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift) - apply ((clarsimp simp:page_directory_at'_def)+)[2] - apply (wp placeNewObject_pspace_aligned' placeNewObject_pspace_distinct') - apply (simp add:placeNewObject_def2 field_simps) - apply (rule hoare_vcg_conj_lift) - apply (rule createObjects'_wp_subst) - apply (wp createObjects_valid_arch[where sz = 14]) - apply (rule hoare_vcg_conj_lift) - apply (clarsimp simp:page_directory_at'_def) - apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift createObjects'_typ_at[where sz = 14]) - apply (rule hoare_strengthen_post[OF createObjects'_page_directory_at'[where sz = 14]]) - apply simp - apply (clarsimp simp:objBits_simps page_directory_at'_def pdeBits_def - field_simps archObjSize_def word_bits_conv range_cover_full - aligned_add_aligned range_cover.aligned is_aligned_shiftl_self) - apply (simp add: pdeBits_def) - apply (frule pspace_no_overlap'_le2[where ptr' = "(ptr + (1 + of_nat n << 14))"]) - apply (subst shiftl_t2n,subst mult.commute, subst suc_of_nat) - apply (rule order_trans[OF range_cover_bound,where n1 = "1 + n"]) - apply (erule range_cover_le,simp) - apply simp - apply (rule word_sub_1_le) - apply (drule(1) range_cover_no_0[where p = "n+1"]) - apply simp - apply simp - apply (erule(1) range_cover_tail_mask) - apply (rule hoare_vcg_conj_lift) - apply (rule createObjects'_wp_subst) - apply (wp createObjects_valid_arch[where sz = sz]) - apply (wp createObjects'_page_directory_at'[where sz = sz] - createObjects'_psp_aligned[where sz = sz] - createObjects'_psp_bounded[where sz = sz] - createObjects'_psp_distinct[where sz = sz] hoare_vcg_imp_lift - createObjects'_pspace_no_overlap[where sz = sz] - | simp add:objBits_simps archObjSize_def field_simps pdeBits_def)+ - apply (drule range_cover_le[where n = "Suc n"]) - apply simp - apply (clarsimp simp:word_bits_def valid_pspace'_def) - apply (clarsimp simp:aligned_add_aligned[OF range_cover.aligned] is_aligned_shiftl_self word_bits_def)+ - done + apply (simp add: Arch_createNewCaps_def Retype_H.createObject_def createObjects_def bind_assoc + ARM_H.toAPIType_def ARM_H.createObject_def) + apply (subst monad_eq, rule createObjects_Cons) + apply ((simp add: field_simps shiftl_t2n archObjSize_def + getObjectSize_def objBits_simps ptBits_def)+)[6] + apply (simp add: bind_assoc placeNewObject_def2) + apply (simp add: field_simps bind_assoc gets_modify_def + getObjectSize_def placeNewObject_def2 objBits_simps append mapM_x_append + mapM_x_singleton archObjSize_def) + apply (subst monad_commute_simple'[OF map_dmo'_createObjects'_comm] + | simp add: modify_modify_bind o_def + | simp only: o_def cong: if_cong)+ + apply (simp add: pteBits_def ptBits_def) + + \ \PageDirectoryObject\ + apply (simp add: Arch_createNewCaps_def toAPIType_def bind_assoc + createObjects_def createObject_def ARM_H.createObject_def) + apply (subst monad_eq, rule createObjects_Cons; simp?) + apply (simp add: objBits_simps getObjectSize_def archObjSize_def pdeBits_def pdBits_def) + apply (simp add: getObjectSize_def placeNewObject_def2 objBits_simps append mapM_x_append + mapM_x_singleton bind_assoc archObjSize_def pdBits_def pdeBits_def) + apply (subst monad_commute_simple'[OF map_dmo'_createObjects'_comm] + | simp add: modify_modify_bind o_def + | simp only: o_def cong: if_cong)+ + apply (simp add: placeNewObject_def2[where val = "makeObject::ARM_H.pde",simplified,symmetric]) + apply (rule_tac Q = "\r s. valid_arch_state' s \ + (\x\of_nat n. page_directory_at' (ptr + (x << 14)) s) \ Q s" for Q + in monad_eq_split) + apply (subst monad_commute_simple) + apply (rule mapM_x_commute[where f=id]) + apply (rule placeNewObject_copyGlobalMapping_commute) + apply (wp copyGlobalMappings_pspace_no_overlap') + apply clarsimp + apply (clarsimp simp:objBits_simps archObjSize_def pdBits_def pageBits_def word_bits_conv) + apply (erule TrueE) (* resolve schematic assumption P *) + apply assumption (* resolve schematic assumption Q *) + apply clarsimp + apply (subst monad_commute_simple'[OF mapM_doMachineOp_copyGlobalMapping_commute], simp) + apply (simp add: field_simps) + apply (wpsimp wp: createObjects'_wp_subst[OF createObjects_valid_arch] hoare_vcg_const_imp_lift + createObjects'_page_directory_at'[where sz=sz] + createObjects'_psp_aligned[where sz=sz] + createObjects'_psp_distinct[where sz=sz] + createObjects'_pspace_no_overlap[where sz=sz] + simp: field_simps pdeBits_def objBits_simps archObjSize_def) + apply clarsimp + apply (drule range_cover_le[where n = "Suc n"], simp) + apply (rule conjI, assumption) + apply (clarsimp simp: objBits_simps archObjSize_def pdeBits_def word_bits_def cong: conj_cong) + apply (clarsimp simp: aligned_add_aligned[OF range_cover.aligned] is_aligned_shiftl_self) + (* distinct (map (\n. ptr + (n << 14)) [0 .e. word_of_nat n]) *) + apply (subst upto_enum_word) + apply (clarsimp simp:distinct_map) + apply (frule range_cover.range_cover_n_le) + apply (frule range_cover.range_cover_n_less) + apply (rule conjI) + apply (clarsimp simp:inj_on_def) + apply (rule ccontr) + apply (erule_tac bnd = "2^(word_bits - 14)" in shift_distinct_helper[rotated 3]) + apply simp + apply (simp add:word_bits_def) + apply (erule less_le_trans[OF word_of_nat_less]) + apply (simp add: word_of_nat_le word_bits_def pdeBits_def) + apply (erule less_le_trans[OF word_of_nat_less]) + apply (simp add:word_of_nat_le word_bits_def pdeBits_def) + apply (frule range_cover.unat_of_nat_n[OF range_cover_le[where n = n]]) + apply simp + apply (rule ccontr) + apply simp + apply (drule of_nat_inj32[THEN iffD1,rotated -1]) + apply (simp_all add: word_bits_def)[3] + apply (clarsimp) + apply (erule_tac bnd = "2^(word_bits - 14)" in shift_distinct_helper[rotated 3]) + apply simp + apply (simp add:word_bits_def) + apply (simp add:word_of_nat_less word_bits_def pdeBits_def) + apply (erule less_le_trans[OF word_of_nat_less]) + apply (simp add:word_of_nat_le word_bits_def pdeBits_def) + apply (rule ccontr) + apply (frule range_cover.unat_of_nat_n[OF range_cover_le[where n = n]]) + apply simp + apply simp + apply (drule of_nat_inj32[THEN iffD1,rotated -1]; simp add: word_bits_def) + done qed lemma createObject_def2: @@ -5855,22 +5918,20 @@ lemma ArchCreateObject_pspace_no_overlap': (ptr + (of_nat n << APIType_capBits ty userSize)) userSize d \\archCap. pspace_no_overlap' (ptr + (1 + of_nat n << APIType_capBits ty userSize)) sz\" - apply (rule hoare_pre) - apply (clarsimp simp:ARM_H.createObject_def) - apply wpc - apply (wp doMachineOp_psp_no_overlap - createObjects'_pspace_no_overlap2 hoare_when_weak_wp - copyGlobalMappings_pspace_no_overlap' - createObjects'_psp_aligned[where sz = sz] - createObjects'_psp_distinct[where sz = sz] - createObjects'_psp_bounded[where sz = sz] - | simp add: placeNewObject_def2 word_shiftl_add_distrib - | simp add: placeNewObject_def2 word_shiftl_add_distrib - | simp add: placeNewDataObject_def placeNewObject_def2 word_shiftl_add_distrib - field_simps split del: if_split - | clarsimp simp add: add.assoc[symmetric],wp createObjects'_pspace_no_overlap2[where n =0 and sz = sz,simplified] - | clarsimp simp add: APIType_capBits_def objBits_simps pageBits_def)+ - + supply if_split[split del] + apply (clarsimp simp:ARM_H.createObject_def) + apply wpc + apply (wp doMachineOp_psp_no_overlap + createObjects'_pspace_no_overlap2 + createObjects'_psp_aligned[where sz = sz] + createObjects'_psp_distinct[where sz = sz] + copyGlobalMappings_pspace_no_overlap' + | simp add: placeNewObject_def2 word_shiftl_add_distrib + | simp add: placeNewDataObject_def placeNewObject_def2 word_shiftl_add_distrib + field_simps + | clarsimp simp add: add.assoc[symmetric], + wp createObjects'_pspace_no_overlap2[where n =0 and sz = sz,simplified] + | clarsimp simp add: APIType_capBits_def objBits_simps pageBits_def)+ apply (clarsimp simp: conj_comms) apply (frule(1) range_cover_no_0[where p = n]) apply simp @@ -5886,7 +5947,7 @@ lemma ArchCreateObject_pspace_no_overlap': apply simp apply (frule pspace_no_overlap'_le2) apply (rule range_cover_compare_offset) - apply simp+ + apply simp+ apply (clarsimp simp:word_shiftl_add_distrib ,simp add:field_simps) apply (clarsimp simp:add.assoc[symmetric]) diff --git a/proof/refine/ARM/EmptyFail.thy b/proof/refine/ARM/EmptyFail.thy index 259d293eb3..cf27c5adec 100644 --- a/proof/refine/ARM/EmptyFail.thy +++ b/proof/refine/ARM/EmptyFail.thy @@ -50,7 +50,7 @@ lemma empty_fail_getSlotCap [intro!, wp, simp]: "empty_fail (getSlotCap a)" unfolding getSlotCap_def by fastforce -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma empty_fail_getObject: "empty_fail (getObject x :: 'a :: pspace_storable kernel)" diff --git a/proof/refine/ARM/EmptyFail_H.thy b/proof/refine/ARM/EmptyFail_H.thy index 3468e6b262..094db907f7 100644 --- a/proof/refine/ARM/EmptyFail_H.thy +++ b/proof/refine/ARM/EmptyFail_H.thy @@ -13,7 +13,7 @@ crunch_ignore (empty_fail) CSpaceDecls_H.resolveAddressBits doMachineOp suspend restart schedule) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas forM_empty_fail[intro!, wp, simp] = empty_fail_mapM[simplified forM_def[symmetric]] lemmas forM_x_empty_fail[intro!, wp, simp] = empty_fail_mapM_x[simplified forM_x_def[symmetric]] diff --git a/proof/refine/ARM/Finalise_R.thy b/proof/refine/ARM/Finalise_R.thy index 7d7f44acc0..4944bb81c8 100644 --- a/proof/refine/ARM/Finalise_R.thy +++ b/proof/refine/ARM/Finalise_R.thy @@ -10,7 +10,7 @@ imports InterruptAcc_R Retype_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare doUnbindNotification_def[simp] @@ -72,7 +72,7 @@ crunch clearUntypedFreeIndex global_interpretation clearUntypedFreeIndex: typ_at_all_props' "clearUntypedFreeIndex slot" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch postCapDeletion for tcb_at'[wp]: "tcb_at' t" @@ -191,7 +191,7 @@ locale mdb_empty = slot (cteCap_update (%_. capability.NullCap))) slot (cteMDBNode_update (const nullMDBNode))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemmas m_slot_prev = m_p_prev lemmas m_slot_next = m_p_next @@ -1358,13 +1358,7 @@ lemma deletedIRQHandler_irqs_masked'[wp]: apply (simp add: irqs_masked'_def) done -context begin interpretation Arch . (*FIXME: arch_split*) - -lemma setObject_cte_irq_masked'[wp]: - "setObject p (v::cte) \irqs_masked'\" - unfolding setObject_def - by (wpsimp simp: irqs_masked'_def Ball_def wp: hoare_vcg_all_lift hoare_vcg_imp_lift' updateObject_cte_inv) - +context begin interpretation Arch . (*FIXME: arch-split*) crunch emptySlot for irqs_masked'[wp]: "irqs_masked'" @@ -1957,7 +1951,7 @@ lemma (in vmdb) isFinal_untypedParent: sameObjectAs_sym) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma no_fail_isFinalCapability [wp]: "no_fail (valid_mdb' and cte_wp_at' ((=) cte) p) (isFinalCapability cte)" @@ -2187,7 +2181,7 @@ lemma finaliseCap_cases[wp]: apply (auto simp add: isCap_simps cap_has_cleanup'_def) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch finaliseCap for aligned'[wp]: "pspace_aligned'" @@ -2338,7 +2332,7 @@ crunch replyRemove and pspace_bounded'[wp]: pspace_bounded' (simp: crunch_simps) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch replyRemove, handleFaultReply for ex_nonz_cap_to'[wp]: "ex_nonz_cap_to' ptr" @@ -2762,7 +2756,7 @@ lemma finaliseCap_True_invs'[wp]: apply clarsimp done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch flushSpace for invs'[wp]: "invs'" (ignore: doMachineOp) @@ -2829,7 +2823,7 @@ end sublocale Arch < flushSpace: typ_at_all_props' "flushSpace asid" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma deleteASID_invs'[wp]: "\invs'\ deleteASID asid pd \\rv. invs'\" @@ -3688,7 +3682,7 @@ lemma suspend_cte_wp_at': apply (wpsimp wp: hoare_vcg_imp_lift hoare_disjI2[where Q'="\_. cte_wp_at' a b" for a b]) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch deleteASIDPool for cte_wp_at'[wp]: "cte_wp_at' P p" @@ -4283,7 +4277,7 @@ lemma finaliseCap_cte_cap_wp_to[wp]: global_interpretation unbindNotification: typ_at_all_props' "unbindNotification tcb" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma finaliseCap_valid_cap[wp]: "\valid_cap' cap\ finaliseCap cap final flag \\rv. valid_cap' (fst rv)\" @@ -4291,8 +4285,16 @@ lemma finaliseCap_valid_cap[wp]: getThreadCSpaceRoot ARM_H.finaliseCap_def cong: if_cong split del: if_split) - apply wpsimp - by (auto simp: valid_cap'_def isCap_simps capAligned_def objBits_simps shiftL_nat) + apply (rule hoare_pre) + apply (wp | simp only: valid_NullCap o_def fst_conv | wpc)+ + apply simp + apply (intro conjI impI) + apply (clarsimp simp: valid_cap'_def isCap_simps capAligned_def + objBits_simps shiftL_nat)+ + done + + +context begin interpretation Arch . (*FIXME: arch-split*) crunch "Arch.finaliseCap" for nosch[wp]: "\s. P (ksSchedulerAction s)" @@ -4349,7 +4351,7 @@ lemma (in delete_one) deletingIRQHandler_corres: apply (clarsimp simp: cte_wp_at_ctes_of) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma arch_finaliseCap_corres: "\ final_matters' (ArchObjectCap cap') \ final = final'; acap_relation cap cap' \ @@ -4918,7 +4920,7 @@ lemma can_fast_finalise_finaliseCap: = do finaliseCap cap final True; return (NullCap, NullCap) od" by (cases cap; simp add: finaliseCap_def isCap_simps) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma finaliseCap_corres: "\ final_matters' cap' \ final = final'; cap_relation cap cap'; @@ -5007,7 +5009,7 @@ lemma finaliseCap_corres: apply (clarsimp split del: if_split simp: o_def) apply (rule corres_guard_imp [OF arch_finaliseCap_corres], (fastforce simp: valid_sched_def)+)[1] done - +context begin interpretation Arch . (*FIXME: arch-split*) lemma arch_recycleCap_improve_cases: "\ \ isPageCap cap; \ isPageTableCap cap; \ isPageDirectoryCap cap; \ isASIDControlCap cap \ \ (if isASIDPoolCap cap then v else undefined) = v" @@ -5058,7 +5060,7 @@ end sublocale Arch < invalidateTLBByASID: typ_at_all_props' "invalidateTLBByASID asid" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch invalidateTLBByASID for cteCaps_of: "\s. P (cteCaps_of s)" diff --git a/proof/refine/ARM/Init_R.thy b/proof/refine/ARM/Init_R.thy index b1e31d437d..a1b428f49d 100644 --- a/proof/refine/ARM/Init_R.thy +++ b/proof/refine/ARM/Init_R.thy @@ -10,7 +10,7 @@ imports begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* This provides a very simple witness that the state relation used in the first refinement proof is diff --git a/proof/refine/ARM/InterruptAcc_R.thy b/proof/refine/ARM/InterruptAcc_R.thy index 00f0cc8d94..b86145d7c6 100644 --- a/proof/refine/ARM/InterruptAcc_R.thy +++ b/proof/refine/ARM/InterruptAcc_R.thy @@ -19,7 +19,7 @@ lemma getIRQSlot_corres: done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setIRQState_corres: "irq_state_relation state state' \ diff --git a/proof/refine/ARM/Interrupt_R.thy b/proof/refine/ARM/Interrupt_R.thy index 2b763c0d48..50a52ee6ea 100644 --- a/proof/refine/ARM/Interrupt_R.thy +++ b/proof/refine/ARM/Interrupt_R.thy @@ -14,7 +14,7 @@ begin context Arch begin -(*FIXME: arch_split: move up *) +(*FIXME: arch-split: move up *) requalify_types irqcontrol_invocation @@ -22,11 +22,11 @@ lemmas [crunch_def] = decodeIRQControlInvocation_def performIRQControl_def context begin global_naming global -(*FIXME: arch_split: move up *) +(*FIXME: arch-split: move up *) requalify_types Invocations_H.irqcontrol_invocation -(*FIXME: arch_split*) +(*FIXME: arch-split*) requalify_facts Interrupt_H.decodeIRQControlInvocation_def Interrupt_H.performIRQControl_def @@ -90,7 +90,7 @@ where ex_cte_cap_to' ptr and real_cte_at' ptr and (Not o irq_issued' irq) and K (irq \ maxIRQ))" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma decodeIRQHandlerInvocation_corres: "\ list_all2 cap_relation (map fst caps) (map fst caps'); diff --git a/proof/refine/ARM/Invariants_H.thy b/proof/refine/ARM/Invariants_H.thy index 52ea6db418..e412ce35bb 100644 --- a/proof/refine/ARM/Invariants_H.thy +++ b/proof/refine/ARM/Invariants_H.thy @@ -51,7 +51,7 @@ lemma le_maxDomain_eq_less_numDomains: by (auto simp: Kernel_Config.numDomains_def maxDomain_def word_le_nat_alt) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) \ \---------------------------------------------------------------------------\ section "Invariants on Executable Spec" @@ -499,7 +499,7 @@ where section "Valid caps and objects (Haskell)" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec acapBits :: "arch_capability \ nat" where @@ -555,7 +555,7 @@ definition -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition page_table_at' :: "word32 \ kernel_state \ bool" @@ -1586,7 +1586,7 @@ locale mdb_order = mdb_next + \ \---------------------------------------------------------------------------\ section "Alternate split rules for preserving subgoal order" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ntfn_splits[split]: " P (case ntfn of Structures_H.ntfn.IdleNtfn \ f1 | Structures_H.ntfn.ActiveNtfn x \ f2 x @@ -3553,8 +3553,7 @@ lemma ex_cte_cap_to'_pres: apply assumption apply simp done - -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma page_directory_pde_atI': "\ page_directory_at' p s; x < 2 ^ pageBits \ \ pde_at' (p + (x << 2)) s" by (simp add: page_directory_at'_def pageBits_def) @@ -3729,8 +3728,7 @@ lemma vms_sch_act_update'[iff]: "valid_machine_state' (ksSchedulerAction_update f s) = valid_machine_state' s" by (simp add: valid_machine_state'_def ) - -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma objBitsT_simps: "objBitsT EndpointT = epSizeBits" "objBitsT NotificationT = ntfnSizeBits" diff --git a/proof/refine/ARM/Invocations_R.thy b/proof/refine/ARM/Invocations_R.thy index 60ffad1ed0..5f49d06d96 100644 --- a/proof/refine/ARM/Invocations_R.thy +++ b/proof/refine/ARM/Invocations_R.thy @@ -8,7 +8,7 @@ theory Invocations_R imports Invariants_H begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma invocationType_eq[simp]: "invocationType = invocation_type" diff --git a/proof/refine/ARM/IpcCancel_R.thy b/proof/refine/ARM/IpcCancel_R.thy index 96eb259c72..e80019b3d7 100644 --- a/proof/refine/ARM/IpcCancel_R.thy +++ b/proof/refine/ARM/IpcCancel_R.thy @@ -10,8 +10,7 @@ imports Reply_R "Lib.SimpStrategy" begin - -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch cancelAllIPC for aligned'[wp]: pspace_aligned' @@ -435,7 +434,7 @@ lemma cte_map_tcb_2: "cte_map (t, tcb_cnode_index 2) = t + 2*2^cte_level_bits" by (simp add: cte_map_def tcb_cnode_index_def to_bl_1) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma reply_mdbNext_is_descendantD: assumes sr: "(s, s') \ state_relation" @@ -475,505 +474,36 @@ locale delete_one = delete_one_conc + delete_one_abs + (invs' and cte_at' (cte_map ptr)) (cap_delete_one ptr) (cteDeleteOne (cte_map ptr))" -lemma gbep_ret': - "\ st = BlockedOnReceive epPtr r d \ st = BlockedOnSend epPtr p1 p2 p3 p4 \ - \ getBlockingObject st = return epPtr" - by (auto simp add: getBlockingObject_def epBlocked_def assert_opt_def) - -lemma replySC_None_not_head: - "replySC reply = None \ \ isHead (replyNext reply)" - by (fastforce simp: isHead_def getHeadScPtr_def split: reply_next.split_asm option.split_asm) - -lemma sr_inv_sc_with_reply_None_helper: - "\ isHead (replyNext reply') \ - sr_inv - (valid_objs and pspace_aligned and pspace_distinct and valid_replies and - st_tcb_at ((=) (Structures_A.thread_state.BlockedOnReply rp)) t and - (\s. sym_refs (state_refs_of s)) and (\s. sc_with_reply rp s = None) and reply_at rp) - (valid_objs' and valid_release_queue_iff and - (\s'. sym_refs (list_refs_of_replies' s')) and - (\s. sym_refs (state_refs_of' s)) and ko_at' reply' rp and - ((\s'. sc_with_reply' rp s' = None) and pspace_aligned' and pspace_distinct' and pspace_bounded')) - (do y <- - do y <- - when (\y. replyNext reply' = Some y) - (updateReply (theReplyNextPtr (replyNext reply')) - (replyPrev_update Map.empty)); - when (\y. replyPrev reply' = Some y) - (updateReply (the (replyPrev reply')) - (replyNext_update Map.empty)) - od; - cleanReply rp - od)" - apply (case_tac "replyNext reply'"; simp add: getHeadScPtr_def isHead_def split: reply_next.splits ) - (* replyNext reply' = None *) - apply (case_tac "replyPrev reply'"; simp) - (* replyNext reply' = None & replyPrev reply' = None *) - apply (rule sr_inv_imp) - apply (rule cleanReply_sr_inv[where P=\ and P'=\]) - apply simp - apply simp - (* replyNext reply' = None & replyPrev reply' = Some prv_rp *) - apply (rename_tac prv_rp) - apply (rule sr_inv_bind) - apply (rule sr_inv_imp) - apply (rule cleanReply_sr_inv[where P=\ and P'="valid_objs' and valid_release_queue_iff - and reply_at' rp"]) - apply simp - apply simp - apply (rule updateReply_sr_inv) - apply (fastforce simp: reply_relation_def opt_map_red obj_at'_def projectKOs - dest!: sym_refs_replyNext_replyPrev_sym[where rp'=rp, THEN iffD2]) - apply clarsimp - apply (frule_tac rp=prv_rp in sc_replies_relation_sc_with_reply_None) - apply simp - apply (clarsimp simp: obj_at'_def projectKOs opt_map_red) - apply (erule (7) sc_with_reply_replyPrev_None) - apply (clarsimp simp: obj_at'_def projectKOs opt_map_red)+ - apply (fastforce simp: projectKO_opt_sc obj_at'_def opt_map_red projectKOs) - apply (wpsimp wp: updateReply_valid_objs' simp: valid_reply'_def obj_at'_def) - (* replyNext reply' = Some nxt_rp *) - apply (rename_tac nxt_rp) - apply (case_tac "replyPrev reply'"; simp) - (* replyNext reply' = Some nxt_rp & replyPrev reply' = None *) - apply (rule sr_inv_bind) - apply (rule sr_inv_imp) - apply (rule cleanReply_sr_inv[where P=\ and P'="valid_objs' and valid_release_queue_iff - and reply_at' rp"]) - apply simp - apply simp - apply (rule updateReply_sr_inv) - apply (clarsimp simp: reply_relation_def) - apply (clarsimp simp: projectKO_opt_sc obj_at'_def opt_map_red projectKOs sc_replies_relation_def) - apply (rename_tac nreply') - apply (rule heap_path_heap_upd_not_in, simp) - apply (rename_tac scp replies) - apply (drule_tac x=scp and y=replies in spec2, simp) - apply (prop_tac "rp \ set replies") - apply (drule_tac sc=scp in valid_replies_sc_with_reply_None, simp) - apply (clarsimp simp: sc_replies_sc_at_def obj_at_def is_reply sc_replies_of_scs_def - scs_of_kh_def map_project_def - elim!: opt_mapE) - apply (erule (1) heap_ls_prev_not_in) - apply (fastforce elim!: sym_refs_replyNext_replyPrev_sym[THEN iffD1] simp: opt_map_red) - apply (wpsimp wp: updateReply_valid_objs' simp: valid_reply'_def obj_at'_def) - (* replyNext reply' = Some nxt_rp & replyPrev reply' = Some prv_rp *) - apply (rename_tac prv_rp) - apply (rule_tac Q="valid_objs and pspace_aligned and pspace_distinct and valid_replies - and (\s. sym_refs (state_refs_of s)) - and (\s. sc_with_reply rp s = None) - and (\s. sc_with_reply prv_rp s = None) - and (\s. sc_with_reply nxt_rp s = None) - and reply_at rp" - and Q'="valid_objs' and valid_release_queue_iff and reply_at' rp - and pspace_aligned' and pspace_distinct' - and reply_at' prv_rp and reply_at' nxt_rp - and (\s'. sc_with_reply' rp s' = None) - and (\s'. sc_with_reply' prv_rp s' = None) - and (\s'. sc_with_reply' nxt_rp s' = None) - and (\s'. sym_refs (state_refs_of' s')) - and (\s'. replyPrevs_of s' nxt_rp = Some rp) - and (\s'. replyNexts_of s' prv_rp = Some rp)" - in sr_inv_stronger_imp) - apply (rule sr_inv_bind) - apply (rule sr_inv_imp) - apply (rule cleanReply_sr_inv[where P=\ and P'="valid_objs' and valid_release_queue_iff - and reply_at' rp"]) - apply simp - apply simp - apply (rule sr_inv_bind) - apply (rule sr_inv_imp) - apply (rule updateReply_sr_inv_next[simplified]) - apply simp - apply simp - apply (rule sr_inv_imp) - apply (rule updateReply_sr_inv_prev[simplified]) - apply simp+ - apply wpsimp - apply (wpsimp wp: updateReply_valid_objs' simp: valid_reply'_def) - apply clarsimp - apply (rule conjI) - apply (fastforce simp: obj_at'_def projectKOs opt_map_red - elim!: state_relationE sc_with_reply_replyPrev_None sc_with_reply_replyNext_None) - apply (fastforce simp: obj_at'_def projectKOs opt_map_red - elim!: state_relationE sc_with_reply_replyNext_None) - apply (prop_tac"sc_with_reply prv_rp s = None \ sc_with_reply nxt_rp s = None") - apply (rule conjI) - apply (fastforce simp: obj_at'_def projectKOs opt_map_red - elim!: state_relationE sc_with_reply_replyPrev_None sc_with_reply_replyNext_None) - apply (fastforce simp: obj_at'_def projectKOs opt_map_red - elim!: state_relationE sc_with_reply_replyNext_None) - apply (erule state_relationE) - apply (clarsimp simp: sc_replies_relation_sc_with_reply_cross_eq) - apply (rule conjI) - apply (clarsimp simp: obj_at'_def projectKOs) - apply (frule (1) reply_ko_at_valid_objs_valid_reply') - apply (clarsimp simp: valid_reply'_def valid_bound_obj'_def) - apply (fastforce simp: obj_at'_def projectKOs opt_map_red - elim!: sym_refs_replyNext_replyPrev_sym[THEN iffD1] - sym_refs_replyNext_replyPrev_sym[THEN iffD2]) - done - -lemma no_fail_sc_wtih_reply_None_helper: - "\ isHead (replyNext reply') \ - no_fail - (\s'. (s, s') \ state_relation \ - (valid_objs' and valid_release_queue_iff and - (\s'. sym_refs (list_refs_of_replies' s')) and - (\s. sym_refs (state_refs_of' s)) and - ko_at' reply' rp and - ((\s'. sc_with_reply' rp s' = None) and - pspace_aligned' and pspace_distinct' and pspace_bounded')) - s') - (do y <- - do y <- - when (\y. replyNext reply' = Some y) - (updateReply (theReplyNextPtr (replyNext reply')) - (replyPrev_update Map.empty)); - when (\y. replyPrev reply' = Some y) - (updateReply (the (replyPrev reply')) - (replyNext_update Map.empty)) - od; - cleanReply rp - od)" - apply (case_tac "replyNext reply'"; simp split del: if_split) - apply wpsimp - apply (frule (1) reply_ko_at_valid_objs_valid_reply') - apply (clarsimp simp: obj_at'_def projectKOs valid_reply'_def) - apply (rename_tac nextr; case_tac nextr; simp add: isHead_def) - apply (case_tac "replyPrev reply'"; simp) - apply (wpsimp; - frule (1) reply_ko_at_valid_objs_valid_reply'; - clarsimp simp: obj_at'_def projectKOs valid_reply'_def)+ - done - -lemma replyRemoveTCB_corres: - "corres dc (valid_objs and pspace_aligned and pspace_distinct and valid_replies - and st_tcb_at ((=) (Structures_A.thread_state.BlockedOnReply rp)) t and (\s. sym_refs (state_refs_of s))) - (valid_objs' and valid_release_queue_iff and (\s'. sym_refs (list_refs_of_replies' s'))) - (reply_remove_tcb t rp) (replyRemoveTCB t)" - (is "corres _ ?abs_guard ?conc_guard _ _") - apply add_sym_refs - apply (rule_tac Q="st_tcb_at' ((=) (thread_state.BlockedOnReply (Some rp))) t" in corres_cross_add_guard) - apply (fastforce dest!: st_tcb_at_coerce_concrete elim!: pred_tcb'_weakenE) - apply (clarsimp simp: reply_remove_tcb_def replyRemoveTCB_def isReply_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getThreadState_corres]) - apply (rule corres_assert_gen_asm_l) - apply (rule corres_assert_gen_asm2) - apply (rule corres_assert_opt_assume) - apply (case_tac state; simp) - apply (drule sym[of rp], simp) - apply (rule_tac P'="?conc_guard and (\s'. sym_refs (state_refs_of' s')) and reply_at' rp" - and P="?abs_guard" in corres_symb_exec_r) - (* get sc_with_reply *) - apply (rule corres_symb_exec_l) - apply (rename_tac reply' sc_opt) - apply (rule_tac P="?abs_guard and (\s. sc_with_reply rp s = sc_opt) and reply_at rp" - and P'="?conc_guard and (\s. sym_refs (state_refs_of' s)) and ko_at' reply' rp" - in corres_inst) - apply (rule_tac Q="(\s'. sc_with_reply' rp s' = sc_opt) and pspace_aligned' - and pspace_distinct' and pspace_bounded'" - in corres_cross_add_guard) - apply (frule pspace_relation_pspace_bounded'[OF state_relation_pspace_relation]) - apply (fastforce simp: sc_replies_relation_sc_with_reply_cross_eq - dest!: state_relationD pspace_distinct_cross dest: pspace_aligned_cross) - apply (case_tac sc_opt; simp split del: if_split add: bind_assoc) - - (** sc_with_reply rp s = None **) - apply (rule_tac F="replySC reply' = None" in corres_req) - apply (fastforce dest!: sc_with_reply_None_reply_sc_reply_at dest: replySCs_of_cross - simp: obj_at'_def projectKOs opt_map_red) - apply (clarsimp simp: replySC_None_not_head) - subgoal for reply' - apply (simp only: bind_assoc[symmetric]) - apply (rule corres_symb_exec_r_sr) - apply (rule corres_guard_imp) - apply (rule replyUnlinkTcb_corres[simplified dc_def]) - apply (clarsimp dest!: valid_objs_valid_tcbs) - apply (frule (1) st_tcb_reply_state_refs) - apply (clarsimp simp: pred_tcb_at_def obj_at_def is_tcb is_reply reply_tcb_reply_at_def) - apply simp - apply (erule sr_inv_sc_with_reply_None_helper) - apply (wpsimp wp: updateReply_valid_objs' simp: valid_reply'_def obj_at'_def) - apply (fastforce elim!: reply_ko_at_valid_objs_valid_reply') - apply (erule no_fail_sc_wtih_reply_None_helper) - done - - (** sc_with_reply \ None : rp is in a reply stack **) - apply (rename_tac scp) - apply (rule_tac F="replyNext reply' \ None" in corres_req) - apply clarsimp - apply (prop_tac "sc_at scp s") - apply (fastforce dest!: sc_with_reply_SomeD1 - simp: sc_replies_sc_at_def obj_at_def is_sc_obj_def - elim: valid_sched_context_size_objsI) - apply (prop_tac "sc_at' scp s'") - apply (fastforce dest!: state_relationD sc_at_cross) - apply (drule sc_with_reply'_SomeD, clarsimp) - apply (case_tac "hd xs = rp") - apply (drule heap_path_head, clarsimp) - apply (drule (3) sym_refs_scReplies) - apply (clarsimp simp: obj_at'_def projectKOs sym_heap_def elim!: opt_mapE) - - apply (frule (1) heap_path_takeWhile_lookup_next) - apply (frule heap_path_head, clarsimp) - apply (prop_tac "takeWhile ((\) rp) xs = hd xs # tl (takeWhile ((\) rp) xs)") - apply (case_tac xs; simp) - apply (simp del: heap_path.simps) - apply (drule_tac p1="hd xs" and ps1="tl (takeWhile ((\) rp) xs)" - in sym_refs_reply_heap_path_doubly_linked_Nexts_rev[where p'=rp, THEN iffD1]) - apply clarsimp - apply (case_tac "rev (tl (takeWhile ((\) rp) xs))"; - clarsimp simp: obj_at'_def projectKOs elim!: opt_mapE) - apply (clarsimp simp: liftM_def bind_assoc split del: if_split) - apply (rename_tac next_reply) - apply (rule_tac Q="\x. ?abs_guard - and (\s. \n. kheap s scp = Some (Structures_A.SchedContext x n)) - and (\s. sc_with_reply rp s = Some scp) - and K (rp \ set (sc_replies x))" - in corres_symb_exec_l) - apply (rename_tac sc) - apply (rule_tac Q="(\s'. scReplies_of s' scp = hd_opt (sc_replies sc)) and sc_at' scp" - in corres_cross_add_guard) - apply (clarsimp; rule conjI) - apply (frule state_relation_sc_replies_relation) - apply (frule sc_replies_relation_scReplies_of[symmetric]) - apply (fastforce dest!: sc_at_cross valid_objs_valid_sched_context_size - simp: obj_at_def is_sc_obj_def obj_at'_def) - apply (fastforce dest!: sc_at_cross valid_objs_valid_sched_context_size - simp: obj_at_def is_sc_obj_def state_relation_def obj_at'_def - projectKOs opt_map_def) - apply (clarsimp simp: sc_replies_of_scs_def map_project_def opt_map_def - scs_of_kh_def) - apply (fastforce dest!: state_relation_pspace_relation sc_at_cross - valid_objs_valid_sched_context_size - simp: obj_at_def is_sc_obj) - apply (rule corres_gen_asm') - apply (rule corres_symb_exec_l) - apply (rename_tac replysc) - apply (rule_tac P="?abs_guard and (\s. sc_with_reply rp s = Some scp) - and obj_at (\ko. \n. ko = Structures_A.SchedContext sc n) scp - and reply_sc_reply_at ((=) replysc) rp" - in corres_inst) - apply (rename_tac replysc) - apply (rule_tac F="replySC reply' = replysc" in corres_req) - apply (fastforce dest!: replySCs_of_cross simp: obj_at'_def projectKOs opt_map_red) - apply (case_tac "hd (sc_replies sc) = rp"; simp split del: if_split) - - (* hd (sc_replies sc) = rp & replysc = Some scp: rp is at the head of the queue *) - (* i.e. replyNext reply' *) - apply (rule corres_guard_imp) - apply (rule corres_assert_gen_asm_l2) - apply (simp add: getHeadScPtr_def isHead_def neq_conv[symmetric] split: reply_next.splits) - apply (rule corres_split[OF setSchedContext_scReply_update_None_corres[simplified dc_def]]) - apply (rule_tac Q =\ and - P'="valid_objs' and valid_release_queue_iff and ko_at' reply' rp" and - Q'="(\s'. \prp. replyPrev reply' = Some prp - \ replyNexts_of s' prp = Some rp)" - in corres_inst_add) - apply (rule corres_symb_exec_r_sr) - apply (rule corres_guard_imp) - apply (rule corres_split[OF cleanReply_sc_with_reply_None_corres]) - apply (rule replyUnlinkTcb_corres[simplified dc_def]) - apply wpsimp - apply wpsimp - apply simp - apply simp - apply (clarsimp cong: conj_cong) - apply (case_tac "replyPrev reply'"; simp) - apply (rename_tac prev_rp) - apply (rule sr_inv_imp) - apply (rule_tac P =\ and - P'=" (\s'. \prp. replyPrev reply' = Some prp - \ replyNexts_of s' prev_rp = Some rp)" - in updateReply_sr_inv) - apply (clarsimp simp: reply_relation_def projectKOs obj_at'_def obj_at_def - elim!: opt_mapE) - apply clarsimp - apply (drule_tac rp=prev_rp in sc_replies_relation_replyNext_update, simp) - apply simp - apply simp - apply clarsimp - apply wpsimp - apply wpsimp - apply (clarsimp dest!: reply_ko_at_valid_objs_valid_reply' simp: valid_reply'_def) - apply simp - apply (wpsimp wp: sc_replies_update_takeWhile_sc_with_reply - sc_replies_update_takeWhile_valid_replies) - apply (wpsimp wp: scReply_update_empty_sc_with_reply') - apply clarsimp - apply (frule_tac reply_ptr=rp and sc_ptr= scp and list="tl (sc_replies sc)" - in sym_refs_reply_sc_reply_at) - apply (clarsimp simp: sc_replies_sc_at_def obj_at_def is_reply) - apply (metis list.sel(1) list.sel(3) list.set_cases) - apply (clarsimp simp: getHeadScPtr_def reply_sc_reply_at_def obj_at_def is_reply - split: reply_next.splits) - apply (frule (1) st_tcb_reply_state_refs) - apply (clarsimp dest!: valid_objs_valid_tcbs - simp: obj_at_def is_reply reply_tcb_reply_at_def) - apply (clarsimp simp: opt_map_red opt_map_def split: option.splits) - apply (rule context_conjI; clarsimp simp: vs_heap_simps obj_at_def) - apply (intro conjI) - apply (metis list.sel(1) list.set_cases) - apply (clarsimp simp: pred_tcb_at_def obj_at_def) - apply clarsimp - apply (rule conjI) - apply (clarsimp dest!: sc_ko_at_valid_objs_valid_sc' - simp: valid_sched_context'_def valid_sched_context_size'_def - objBits_simps) - apply (erule sym_refs_replyNext_replyPrev_sym[THEN iffD2]) - apply (clarsimp simp: opt_map_red obj_at'_def projectKOs) - apply (frule (3) sym_refs_scReplies) - apply (clarsimp simp: hd_opt_def projectKOs opt_map_red sym_heap_def - split: list.split_asm) - apply (clarsimp simp: opt_map_red obj_at'_def projectKOs split: reply_next.splits) - - (* rp is in the middle of the reply stack *) - (* hd (sc_replies sc) \ rp & rp \ set (sc_replies sc) *) - apply (rule corres_guard_imp) - apply (rule_tac Q="valid_objs' and valid_release_queue_iff and ko_at' reply' rp - and (\s'. sym_refs (list_refs_of_replies' s')) and sc_at' scp - and (\s'. sym_refs (state_refs_of' s')) - and (\s'. sc_with_reply' rp s' = Some scp) - and (\s'. scReplies_of s' scp = hd_opt (sc_replies sc)) - and (\s'. \prp. replyPrev reply' = Some prp - \ replyNexts_of s' prp = Some rp)" - in corres_assert_gen_asm_l) - apply (simp split del: if_split) - apply (clarsimp simp: getHeadScPtr_def isHead_def neq_conv[symmetric] - split: reply_next.splits) - apply (rename_tac nxt_rp) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split - [OF updateReply_replyPrev_takeWhile_middle_corres]) - apply simp - apply simp - apply (rule_tac P ="?abs_guard and reply_sc_reply_at ((=) None) rp" and - Q ="\s. sc_with_reply rp s = None" and - P'="valid_objs' and valid_release_queue_iff - and ko_at' reply' rp and sc_at' scp" and - Q'="(\s'. \prp. replyPrev reply' = Some prp - \ replyNexts_of s' prp = Some rp)" - in corres_inst_add) - apply (rule corres_symb_exec_r_sr) - apply (rule corres_guard_imp) - apply (rule corres_split[OF cleanReply_sc_with_reply_None_corres]) - apply (rule replyUnlinkTcb_corres[simplified dc_def]) - apply wpsimp - apply wpsimp - apply clarsimp - apply (frule (1) st_tcb_reply_state_refs, frule valid_objs_valid_tcbs) - apply (fastforce simp: obj_at_def is_reply reply_tcb_reply_at_def pred_tcb_at_def) - apply simp - apply (clarsimp cong: conj_cong) - apply (case_tac "replyPrev reply'"; simp) - apply (rename_tac prev_rp) - apply (rule sr_inv_imp) - apply (rule_tac P =\ and - P'=" (\s'. \prp. replyPrev reply' = Some prp - \ replyNexts_of s' prev_rp = Some rp)" - in updateReply_sr_inv) - apply (clarsimp simp: reply_relation_def projectKOs obj_at'_def obj_at_def - elim!: opt_mapE) - apply clarsimp - apply (drule_tac rp=prev_rp in sc_replies_relation_replyNext_update, simp) - apply simp - apply simp - apply clarsimp - apply wpsimp - apply wpsimp - apply (clarsimp dest!: reply_ko_at_valid_objs_valid_reply' - simp: valid_reply'_def) - apply (wpsimp wp: sc_replies_update_takeWhile_sc_with_reply - sc_replies_update_takeWhile_middle_sym_refs - sc_replies_update_takeWhile_valid_replies) - apply (wpsimp wp: updateReply_valid_objs' updateReply_ko_at'_other) - apply (clarsimp cong: conj_cong) - apply simp - apply (clarsimp simp: valid_reply'_def) - apply (rule context_conjI) - apply (clarsimp simp: obj_at'_def projectKOs opt_map_red) - apply (clarsimp simp: obj_at_def del: opt_mapE) - apply (frule (1) valid_sched_context_objsI) - apply (clarsimp simp: valid_sched_context_def del: opt_mapE) - apply (frule (4) next_reply_in_sc_replies[OF state_relation_sc_replies_relation]) - apply (fastforce dest!: state_relationD pspace_aligned_cross pspace_distinct_cross) - apply (fastforce dest!: state_relationD pspace_distinct_cross) - apply (fastforce dest!: state_relationD pspace_relation_pspace_bounded') - apply (clarsimp simp: obj_at'_def) - apply (clarsimp simp: vs_heap_simps) - apply clarsimp - apply (rule conjI) - apply (clarsimp simp: list_all_iff dest!: set_takeWhileD) - apply (drule (2) sc_replies_middle_reply_sc_None) - apply (clarsimp simp: vs_heap_simps obj_at_def elim!: opt_mapE) - apply (fastforce simp: obj_at_def is_sc_obj_def elim!: valid_sched_context_size_objsI) - apply (erule reply_sc_reply_at) - apply (clarsimp simp: reply_sc_reply_at_def obj_at_def) - apply (fastforce elim!: sym_refs_replyNext_replyPrev_sym[THEN iffD2] - simp: opt_map_red obj_at'_def projectKOs) - apply (wpsimp simp: get_sk_obj_ref_def wp: get_reply_exs_valid) - apply (fastforce dest!: Reply_or_Receive_reply_at[rotated] simp: obj_at_def is_reply) - apply simp - apply (wpsimp wp: get_sk_obj_ref_wp) - apply (clarsimp simp: obj_at_def reply_sc_reply_at_def) - apply (wpsimp simp: get_sk_obj_ref_def get_simple_ko_def obj_at_def - wp: get_object_wp) - apply (prop_tac "reply_at rp s") - apply (fastforce dest!: st_tcb_at_valid_st2 simp: valid_tcb_state_def) - apply (fastforce simp: obj_at_def is_reply partial_inv_def a_type_def) - apply (wpsimp wp: get_sched_context_exs_valid) - apply (drule sc_with_reply_SomeD) - apply (wpsimp simp: is_sc_obj_def - | clarsimp split: Structures_A.kernel_object.splits)+ - apply (fastforce dest!: sc_with_reply_SomeD1 simp: sc_replies_sc_at_def obj_at_def) - apply (wpsimp wp: get_sched_context_no_fail) - apply (fastforce dest!: sc_with_reply_SomeD elim!: valid_sched_context_size_objsI - simp: obj_at_def is_sc_obj_def) - apply wpsimp - apply wpsimp - apply (fastforce dest!: st_tcb_at_valid_st2 simp: valid_tcb_state_def) - apply wpsimp - apply (wpsimp wp: get_reply_inv' wp_del: getReply_wp) - apply (wpsimp simp: getReply_def) - apply clarsimp - apply wpsimp - apply wpsimp - apply clarsimp - apply (wpsimp wp: gts_wp) - apply wpsimp - apply (clarsimp simp: st_tcb_at_tcb_at pred_tcb_at_def obj_at_def is_tcb) - apply clarsimp - apply (rule context_conjI; clarsimp) - apply (prop_tac "reply_at' rp s") - apply (fastforce dest: tcb_in_valid_state' simp: valid_tcb_state'_def) - apply (clarsimp, rule conjI) - using fold_list_refs_of_replies' apply metis - apply (clarsimp simp: st_tcb_at'_def obj_at'_def projectKOs) - apply (rename_tac tcb reply) - apply (case_tac "tcbState tcb"; simp) - done - -lemma setSchedContext_pop_head_corres: - "\ replyNext reply' = Some (Head ptr) \ \ - corres dc - ((\s. (sc_replies_of s |> hd_opt) ptr = Some rp) - and valid_objs and pspace_aligned and pspace_distinct) - (ko_at' reply' rp) - (update_sched_context ptr (sc_replies_update tl)) - (do sc' \ getSchedContext ptr; - setSchedContext ptr (scReply_update (\_. replyPrev reply') sc') - od)" - supply opt_mapE[elim!] - apply (rule_tac Q="sc_at' ptr" in corres_cross_add_guard) - apply (fastforce dest!: state_relationD simp: obj_at_def is_sc_obj_def vs_heap_simps - elim!: sc_at_cross valid_objs_valid_sched_context_size) - apply (rule_tac Q="pspace_aligned' and pspace_distinct'" in corres_cross_add_guard) - apply (fastforce dest!: state_relationD elim!: pspace_aligned_cross pspace_distinct_cross) - apply (rule_tac Q="\s'. scReplies_of s' ptr = Some rp" in corres_cross_add_guard) - apply (subst sc_replies_relation_scReplies_of[symmetric, OF state_relation_sc_replies_relation]) - apply simp +lemma (in delete_one) cancelIPC_ReplyCap_corres: + "corres dc (einvs and st_tcb_at awaiting_reply t) + (invs' and st_tcb_at' awaiting_reply' t) + (reply_cancel_ipc t) + (do y \ threadSet (\tcb. tcb \ tcbFault := None \) t; + slot \ getThreadReplySlot t; + callerCap \ liftM (mdbNext \ cteMDBNode) (getCTE slot); + when (callerCap \ nullPointer) (do + y \ stateAssert (capHasProperty callerCap (\cap. isReplyCap cap + \ \ capReplyMaster cap)) + []; + cteDeleteOne callerCap + od) + od)" + proof - + interpret Arch . (*FIXME: arch-split*) + show ?thesis + apply (simp add: reply_cancel_ipc_def getThreadReplySlot_def + locateSlot_conv liftM_def tcbReplySlot_def + del: split_paired_Ex) + apply (rule_tac Q="\_. invs and valid_list and valid_sched and st_tcb_at awaiting_reply t" + and Q'="\_. invs' and st_tcb_at' awaiting_reply' t" + in corres_underlying_split) + apply (rule corres_guard_imp) + apply (rule threadset_corresT; simp?) + apply (simp add: tcb_relation_def fault_rel_optionation_def) + apply (simp add: tcb_cap_cases_def) + apply (simp add: tcb_cte_cases_def) + apply (simp add: exst_same_def) + apply (fastforce simp: st_tcb_at_tcb_at) apply clarsimp apply (fastforce simp: opt_map_red dest!: sc_at'_cross[OF state_relation_pspace_relation]) apply (clarsimp simp: opt_map_red obj_at_simps)+ @@ -1756,7 +1286,7 @@ declare cart_singleton_empty2[simp] lemma sch_act_simple_not_t[simp]: "sch_act_simple s \ sch_act_not t s" by (clarsimp simp: sch_act_simple_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch setNotification for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers @@ -3341,6 +2871,64 @@ lemma cancelAllSignals_st_tcb_at: lemmas cancelAllSignals_makes_simple[wp] = cancelAllSignals_st_tcb_at [where P=simple', simplified] +lemma threadSet_not_tcb[wp]: + "\ko_wp_at' (\x. P x \ (projectKO_opt x = (None :: tcb option))) p\ + threadSet f t + \\rv. ko_wp_at' (\x. P x \ (projectKO_opt x = (None :: tcb option))) p\" + by (clarsimp simp: threadSet_def valid_def getObject_def + setObject_def in_monad loadObject_default_def + ko_wp_at'_def projectKOs split_def in_magnitude_check + objBits_simps' updateObject_default_def + ps_clear_upd projectKO_opt_tcb) + +lemma setThreadState_not_tcb[wp]: + "\ko_wp_at' (\x. P x \ (projectKO_opt x = (None :: tcb option))) p\ + setThreadState st t + \\rv. ko_wp_at' (\x. P x \ (projectKO_opt x = (None :: tcb option))) p\" + by (wpsimp wp: isRunnable_inv threadGet_wp hoare_drop_imps + simp: setThreadState_def setQueue_def + rescheduleRequired_def tcbSchedEnqueue_def tcbQueuePrepend_def + unless_def bitmap_fun_defs)+ + +lemma tcbSchedEnqueue_unlive: + "\ko_wp_at' (\x. \ live' x \ (projectKO_opt x = (None :: tcb option))) p + and tcb_at' t\ + tcbSchedEnqueue t + \\_. ko_wp_at' (\x. \ live' x \ (projectKO_opt x = (None :: tcb option))) p\" + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_def) + apply (wp | simp add: setQueue_def bitmap_fun_defs)+ + done + +lemma cancelAll_unlive_helper: + "\\s. (\x\set xs. tcb_at' x s) \ + ko_wp_at' (\x. \ live' x \ (projectKO_opt x = (None :: tcb option))) p s\ + mapM_x (\t. do + y \ setThreadState Structures_H.thread_state.Restart t; + tcbSchedEnqueue t + od) xs + \\rv. ko_wp_at' (Not \ live') p\" + apply (rule hoare_strengthen_post) + apply (rule mapM_x_wp') + apply (rule hoare_pre) + apply (wp tcbSchedEnqueue_unlive hoare_vcg_const_Ball_lift) + apply clarsimp + apply (clarsimp elim!: ko_wp_at'_weakenE) + done + +context begin interpretation Arch . (*FIXME: arch-split*) +lemma setObject_ko_wp_at': + fixes v :: "'a :: pspace_storable" + assumes x: "\v :: 'a. updateObject v = updateObject_default v" + assumes n: "\v :: 'a. objBits v = n" + assumes v: "(1 :: word32) < 2 ^ n" + shows + "\\s. P (injectKO v)\ setObject p v \\rv. ko_wp_at' P p\" + by (clarsimp simp: setObject_def valid_def in_monad + ko_wp_at'_def x split_def n + updateObject_default_def + objBits_def[symmetric] ps_clear_upd + in_magnitude_check v projectKOs) + lemma threadSet_unlive_other: "\ko_wp_at' (Not \ live') p and K (p \ t)\ threadSet f t @@ -3383,7 +2971,7 @@ lemma setThreadState_unlive_other: apply (fastforce simp: ko_wp_at'_def obj_at'_def) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma possibleSwitchTo_unlive_other: "\ko_wp_at' (Not \ live') p and sch_act_not p and K (p \ t)\ diff --git a/proof/refine/ARM/Ipc_R.thy b/proof/refine/ARM/Ipc_R.thy index ba0494f88c..5cbc1f26b3 100644 --- a/proof/refine/ARM/Ipc_R.thy +++ b/proof/refine/ARM/Ipc_R.thy @@ -8,7 +8,7 @@ theory Ipc_R imports Finalise_R Reply_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas lookup_slot_wrapper_defs'[simp] = lookupSourceSlot_def lookupTargetSlot_def lookupPivotSlot_def @@ -363,7 +363,7 @@ lemma maskedAsFull_null_cap[simp]: "(capability.NullCap = maskedAsFull x y) = (x = capability.NullCap)" by (case_tac x, auto simp:maskedAsFull_def isCap_simps ) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma maskCapRights_eq_null: "(RetypeDecls_H.maskCapRights r xa = capability.NullCap) = @@ -1082,7 +1082,7 @@ crunch transferCaps global_interpretation transferCaps: typ_at_all_props' "transferCaps info caps endpoint receiver receiveBuffer" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma isIRQControlCap_mask [simp]: "isIRQControlCap (maskCapRights R c) = isIRQControlCap c" @@ -1159,7 +1159,7 @@ crunch copyMRs global_interpretation copyMRs: typ_at_all_props' "copyMRs s sb r rb n" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma copy_mrs_invs'[wp]: "\ invs' and tcb_at' s and tcb_at' r \ copyMRs s sb r rb n \\rv. invs' \" @@ -1496,7 +1496,7 @@ lemma msgFromLookupFailure_map[simp]: = msg_from_lookup_failure lf" by (cases lf, simp_all add: lookup_failure_map_def msgFromLookupFailure_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma asUser_getRestartPC_corres: "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ @@ -1581,7 +1581,7 @@ lemmas threadget_fault_corres = and f = tcb_fault and f' = tcbFault, simplified tcb_relation_def, simplified] -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch make_fault_msg for in_user_Frame[wp]: "in_user_frame buffer" @@ -1720,7 +1720,7 @@ end global_interpretation doIPCTransfer: typ_at_all_props' "doIPCTransfer s e b g r" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas dit_irq_node'[wp] = valid_irq_node_lift [OF doIPCTransfer_irq_node' doIPCTransfer_typ_at'] @@ -1925,7 +1925,7 @@ crunch handleFaultReply crunch handleFaultReply for tcb_in_cur_domain'[wp]: "tcb_in_cur_domain' t" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch handleFaultReply for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" @@ -2745,7 +2745,7 @@ global_interpretation maybeReturnSc: typ_at_all_props' "maybeReturnSc ntfnPtr tc global_interpretation setMessageInfo: typ_at_all_props' "setMessageInfo t info" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch cancel_ipc for cur[wp]: "cur_tcb" @@ -5139,7 +5139,7 @@ lemma cteInsert_cap_to': apply (clarsimp simp: cte_wp_at_ctes_of)+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch setExtraBadge, doIPCTransfer for cap_to'[wp]: "ex_nonz_cap_to' p" diff --git a/proof/refine/ARM/KHeap_R.thy b/proof/refine/ARM/KHeap_R.thy index ca287174fe..742ddc895a 100644 --- a/proof/refine/ARM/KHeap_R.thy +++ b/proof/refine/ARM/KHeap_R.thy @@ -75,7 +75,7 @@ abbreviation (input) where "set_obj' ptr obj s \ set_ko' ptr (injectKO obj) s" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ovalid_readObject[wp]: assumes R: @@ -128,30 +128,24 @@ lemma obj_at_getObject: declare projectKO_inv [wp] lemma getObject_inv: - "\P\ getObject p \\(rv :: 'a :: pspace_storable). P\" - unfolding getObject_def by wpsimp + assumes x: "\p q n ko. \P\ loadObject p q n ko \\(rv :: 'a :: pspace_storable). P\" + shows "\P\ getObject p \\(rv :: 'a :: pspace_storable). P\" + by (simp add: getObject_def split_def | wp x)+ + +lemma getObject_inv_tcb [wp]: "\P\ getObject l \\(rv :: Structures_H.tcb). P\" + apply (rule getObject_inv) + apply simp + apply (rule loadObject_default_inv) + done +end +(* FIXME: this should go somewhere in spec *) +translations + (type) "'a kernel" <=(type) "kernel_state \ ('a \ kernel_state) set \ bool" + +context begin interpretation Arch . (*FIXME: arch-split*) -lemma getObject_tcb_inv [wp]: "\P\ getObject l \\(rv :: Structures_H.tcb). P\" - by (rule getObject_inv) - -lemma loadObject_default_Some [simp]: - "\projectKO_opt ko = Some (obj::'a); - is_aligned p (objBits obj); objBits obj < word_bits; - case_option True (\x. 2 ^ (objBits obj) \ x - p) n; q = p\ - \ bound (loadObject_default p q n ko s:: ('a::pre_storable) option)" - by (clarsimp simp: loadObject_default_def split_def projectKO_def obind_def - alignCheck_def alignError_def magnitudeCheck_def projectKOs - read_alignCheck_def read_alignError_def read_magnitudeCheck_def - unless_def gets_the_def is_aligned_mask omonad_defs - split: option.splits) simp - -lemmas loadObject_default_Some'[simp, intro!] = loadObject_default_Some[simplified] -lemmas loadObject_default_Some''[simp, intro!] - = loadObject_default_Some[where p=p and s=s and n="snd (lookupAround2 p (ksPSpace s))" for p s, - simplified] - -lemma no_ofail_loadObject_default [simp]: - "no_ofail (\s. \obj. projectKO_opt ko = Some (obj::'a) \ objBits obj < word_bits \ +lemma no_fail_loadObject_default [wp]: + "no_fail (\s. \obj. projectKO_opt ko = Some (obj::'a) \ is_aligned p (objBits obj) \ q = p \ case_option True (\x. 2 ^ (objBits obj) \ x - p) n) (loadObject_default p q n ko :: ('a::pre_storable) kernel_r)" @@ -580,7 +574,7 @@ local @{typ reply}, @{typ endpoint}, - (*FIXME: arch_split*) + (*FIXME: arch-split*) @{typ asidpool}, @{typ pte}, @{typ pde} @@ -674,7 +668,7 @@ lemma setObject_typ_at'[wp]: global_interpretation setObject: typ_at_all_props' "setObject p v" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setObject_cte_wp_at2': assumes x: "\x n tcb s t. \ t \ fst (updateObject v (KOTCB tcb) ptr x n s); Q s; @@ -948,7 +942,7 @@ end end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma pspace_dom_update: "\ ps ptr = Some x; a_type x = a_type v \ \ pspace_dom (ps(ptr \ v)) = pspace_dom ps" @@ -2813,7 +2807,7 @@ interpretation setBoundNotification: pspace_only' "setBoundNotification ntfnPtr by (simp add: setBoundNotification_def threadSet_pspace_only') -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas setNotification_cap_to'[wp] = ex_cte_cap_to'_pres [OF set_ntfn'.cte_wp_at' set_ntfn'.ksInterruptState] @@ -3208,7 +3202,7 @@ crunch doMachineOp and pde_mappings'[wp]: "valid_pde_mappings'" and ko_wp_at'[wp]: "\s. P (ko_wp_at' T p s)" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas bit_simps' = pteBits_def asidHighBits_def asid_low_bits_def asid_high_bits_def minSchedContextBits_def @@ -3546,7 +3540,7 @@ lemma ep_queued_st_tcb_at': (* cross lemmas *) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma pspace_aligned_cross: "\ pspace_aligned s; pspace_relation (kheap s) (ksPSpace s') \ \ pspace_aligned' s'" @@ -4385,7 +4379,7 @@ lemma set_refills_is_active_sc2[wp]: (* updateSchedContext *) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma state_relation_sc_update: assumes diff --git a/proof/refine/ARM/LevityCatch.thy b/proof/refine/ARM/LevityCatch.thy index 72c64a908d..6fa5087131 100644 --- a/proof/refine/ARM/LevityCatch.thy +++ b/proof/refine/ARM/LevityCatch.thy @@ -20,9 +20,11 @@ lemma read_magnitudeCheck_assert: lemma magnitudeCheck_assert: "magnitudeCheck x y n = assert (case y of None \ True | Some z \ 1 << n \ z - x)" - by (simp add: magnitudeCheck_def read_magnitudeCheck_assert) - -context begin interpretation Arch . (*FIXME: arch_split*) + apply (simp add: magnitudeCheck_def assert_def when_def + split: option.split) + apply fastforce + done +context begin interpretation Arch . (*FIXME: arch-split*) lemmas makeObject_simps = makeObject_endpoint makeObject_notification makeObject_cte makeObject_tcb makeObject_user_data makeObject_pde makeObject_pte @@ -59,7 +61,7 @@ lemma updateObject_default_inv: "\P\ updateObject_default obj ko x y n \\rv. P\" unfolding updateObject_default_def by (simp, wp magnitudeCheck_inv alignCheck_inv projectKO_inv, simp) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma to_from_apiType [simp]: "toAPIType (fromAPIType x) = Some x" by (cases x) (auto simp add: fromAPIType_def ARM_H.fromAPIType_def toAPIType_def ARM_H.toAPIType_def) diff --git a/proof/refine/ARM/Machine_R.thy b/proof/refine/ARM/Machine_R.thy index 5fbb392db2..a2a6161dc1 100644 --- a/proof/refine/ARM/Machine_R.thy +++ b/proof/refine/ARM/Machine_R.thy @@ -22,32 +22,7 @@ lemma irq_state_independent_HI[intro!, simp]: \ irq_state_independent_H P" by (simp add: irq_state_independent_H_def) -definition "getCurrentTime_independent_H (P :: kernel_state \ bool) - \ \f s. P s \ - P (s\ksMachineState := - ksMachineState s\last_machine_time := - f (last_machine_time (ksMachineState s)) (time_state (ksMachineState s))\\)" - -lemma getCurrentTime_independent_HI[intro!, simp]: - "\\s f. - P (s\ksMachineState - := (ksMachineState s)\last_machine_time := - f (last_machine_time (ksMachineState s)) (time_state (ksMachineState s))\\) - = P s\ - \ getCurrentTime_independent_H P" - by (simp add: getCurrentTime_independent_H_def) - -definition "time_state_independent_H (P :: kernel_state \ bool) - \ \f s. P s \ - P (s\ksMachineState := ksMachineState s\time_state := f (time_state (ksMachineState s))\\)" - -lemma time_state_independent_HI[intro!, simp]: - "\\s f. P (s\ksMachineState := ksMachineState s\time_state := f (time_state (ksMachineState s))\\) - = P s\ - \ time_state_independent_H P" - by (simp add: time_state_independent_H_def) - -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma dmo_getirq_inv[wp]: "irq_state_independent_H P \ \P\ doMachineOp (getActiveIRQ in_kernel) \\rv. P\" diff --git a/proof/refine/ARM/PageTableDuplicates.thy b/proof/refine/ARM/PageTableDuplicates.thy index 5162dd9fc6..ee9714781b 100644 --- a/proof/refine/ARM/PageTableDuplicates.thy +++ b/proof/refine/ARM/PageTableDuplicates.thy @@ -9,7 +9,7 @@ theory PageTableDuplicates imports Syscall_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma set_ep_valid_duplicate' [wp]: "\\s. vs_valid_duplicates' (ksPSpace s)\ diff --git a/proof/refine/ARM/Refine.thy b/proof/refine/ARM/Refine.thy index 89474fd975..351a69c8e5 100644 --- a/proof/refine/ARM/Refine.thy +++ b/proof/refine/ARM/Refine.thy @@ -16,7 +16,7 @@ imports PageTableDuplicates begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \User memory content is the same on both levels\ lemma typ_at_AUserDataI: diff --git a/proof/refine/ARM/Retype_R.thy b/proof/refine/ARM/Retype_R.thy index f19da22b7c..6dc6ad5e3e 100644 --- a/proof/refine/ARM/Retype_R.thy +++ b/proof/refine/ARM/Retype_R.thy @@ -12,7 +12,7 @@ theory Retype_R imports VSpace_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition APIType_map2 :: "kernel_object + ARM_H.object_type \ Structures_A.apiobject_type" @@ -1181,7 +1181,7 @@ end global_interpretation update_gs: PSpace_update_eq "update_gs ty us ptrs" by (simp add: PSpace_update_eq_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ksReadyQueues_update_gs[simp]: "ksReadyQueues (update_gs tp us addrs s) = ksReadyQueues s" @@ -1592,8 +1592,169 @@ lemma retype_state_relation: qed lemma new_cap_addrs_fold': - "1 \ n \ map (\n. ptr + (n << objBitsKO ko)) [0.e.n - 1] = new_cap_addrs (unat n) ptr ko" - by (clarsimp simp: new_cap_addrs_def ptr_add_def upto_enum_red' shiftl_t2n power_add field_simps) + "1 \ n \ + map (\n. ptr + (n << objBitsKO ko)) [0.e.n - 1] = + new_cap_addrs (unat n) ptr ko" + by (clarsimp simp:new_cap_addrs_def ptr_add_def upto_enum_red' + shiftl_t2n power_add field_simps) + +lemma objBitsKO_gt_0: "0 < objBitsKO ko" + apply (case_tac ko) + apply (simp_all add: objBits_simps' pageBits_def) + apply (rename_tac arch_kernel_object) + apply (case_tac arch_kernel_object) + apply (simp_all add:archObjSize_def pageBits_def pteBits_def pdeBits_def) + done + +lemma kheap_ekheap_double_gets: + "(\rv erv rv'. \pspace_relation rv rv'; ekheap_relation erv rv'\ + \ corres r (R rv erv) (R' rv') (b rv erv) (d rv')) \ + corres r (\s. R (kheap s) (ekheap s) s) (\s. R' (ksPSpace s) s) + (do x \ gets kheap; xa \ gets ekheap; b x xa od) (gets ksPSpace >>= d)" + apply (rule corres_symb_exec_l) + apply (rule corres_guard_imp) + apply (rule_tac r'= "\erv rv'. ekheap_relation erv rv' \ pspace_relation x rv'" + in corres_split) + apply (subst corres_gets[where P="\s. x = kheap s" and P'=\]) + apply clarsimp + apply (simp add: state_relation_def) + apply clarsimp + apply assumption + apply (wp gets_exs_valid | simp)+ + done + +(* + +Split out the extended operation that sets the etcb domains. + +This allows the existing corres proofs in this file to more-or-less go +through as they stand. + +A more principled fix would be to change the abstract spec and +generalise init_arch_objects to initialise other object types. + +*) + +definition retype_region2_ext :: "obj_ref list \ Structures_A.apiobject_type \ unit det_ext_monad" where + "retype_region2_ext ptrs type \ modify (\s. ekheap_update (foldr (\p ekh. (ekh(p := default_ext type default_domain))) ptrs) s)" + +crunch retype_region2_ext + for all_but_exst[wp]: "all_but_exst P" +crunch retype_region2_ext + for (empty_fail) empty_fail[wp] + +end + +interpretation retype_region2_ext_extended: is_extended "retype_region2_ext ptrs type" + by (unfold_locales; wp) + +context begin interpretation Arch . (*FIXME: arch-split*) + +definition + "retype_region2_extra_ext ptrs type \ + when (type = Structures_A.TCBObject) (do + cdom \ gets cur_domain; + mapM_x (ethread_set (\tcb. tcb\tcb_domain := cdom\)) ptrs + od)" + +crunch retype_region2_extra_ext + for all_but_exst[wp]: "all_but_exst P" (wp: mapM_x_wp) +crunch retype_region2_extra_ext + for (empty_fail) empty_fail[wp] (wp: mapM_x_wp) + +end + +interpretation retype_region2_extra_ext_extended: is_extended "retype_region2_extra_ext ptrs type" + by (unfold_locales; wp) + +context begin interpretation Arch . (*FIXME: arch-split*) + +definition + retype_region2 :: "obj_ref \ nat \ nat \ Structures_A.apiobject_type \ bool \ (obj_ref list,'z::state_ext) s_monad" +where + "retype_region2 ptr numObjects o_bits type dev \ do + obj_size \ return $ 2 ^ obj_bits_api type o_bits; + ptrs \ return $ map (\p. ptr_add ptr (p * obj_size)) [0..< numObjects]; + when (type \ Structures_A.Untyped) (do + kh \ gets kheap; + kh' \ return $ foldr (\p kh. kh(p \ default_object type dev o_bits)) ptrs kh; + do_extended_op (retype_region2_ext ptrs type); + modify $ kheap_update (K kh') + od); + return $ ptrs + od" + +lemma retype_region_ext_modify_kheap_futz: + "(retype_region2_extra_ext ptrs type :: (unit, det_ext) s_monad) >>= (\_. modify (kheap_update f)) + = (modify (kheap_update f) >>= (\_. retype_region2_extra_ext ptrs type))" + apply (clarsimp simp: retype_region_ext_def retype_region2_ext_def retype_region2_extra_ext_def when_def bind_assoc) + apply (subst oblivious_modify_swap) + defer + apply (simp add: bind_assoc) + apply (rule oblivious_bind) + apply simp + apply (rule oblivious_mapM_x) + apply (clarsimp simp: ethread_set_def set_eobject_def) + apply (rule oblivious_bind) + apply (simp add: gets_the_def) + apply (rule oblivious_bind) + apply (clarsimp simp: get_etcb_def) + apply simp + apply (simp add: modify_def[symmetric]) +done + +lemmas retype_region_ext_modify_kheap_futz' = + fun_cong[OF arg_cong[where f=Nondet_Monad.bind, + OF retype_region_ext_modify_kheap_futz[symmetric]], simplified bind_assoc] + +lemma foldr_upd_app_if_eta_futz: + "foldr (\p ps. ps(p \ f p)) as = (\g x. if x \ set as then Some (f x) else g x)" +apply (rule ext) +apply (rule foldr_upd_app_if) +done + +lemma modify_ekheap_update_comp_futz: + "modify (ekheap_update (f \ g)) = modify (ekheap_update g) >>= (K (modify (ekheap_update f)))" +by (simp add: o_def modify_def bind_def gets_def get_def put_def) + +lemma mapM_x_modify_futz: + assumes "\ptr\set ptrs. ekheap s ptr \ None" + shows "mapM_x (ethread_set F) (rev ptrs) s + = modify (ekheap_update (foldr (\p ekh. ekh(p := Some (F (the (ekh p))))) ptrs)) s" (is "?lhs ptrs s = ?rhs ptrs s") +using assms +proof(induct ptrs arbitrary: s) + case Nil thus ?case by (simp add: mapM_x_Nil return_def simpler_modify_def) +next + case (Cons ptr ptrs s) + have "?rhs (ptr # ptrs) s + = (do modify (ekheap_update (foldr (\p ekh. ekh(p \ F (the (ekh p)))) ptrs)); + modify (ekheap_update (\ekh. ekh(ptr \ F (the (ekh ptr))))) + od) s" + by (simp only: foldr_Cons modify_ekheap_update_comp_futz) simp + also have "... = (do ?lhs ptrs; + modify (ekheap_update (\ekh. ekh(ptr \ F (the (ekh ptr))))) + od) s" + apply (rule monad_eq_split_tail) + apply simp + apply (rule Cons.hyps[symmetric]) + using Cons.prems + apply force + done + also have "... = ?lhs (ptr # ptrs) s" + apply (simp add: mapM_x_append mapM_x_singleton) + apply (rule monad_eq_split2[OF refl, where + P="\s. \ptr\set (ptr # ptrs). ekheap s ptr \ None" + and Q="\_ s. ekheap s ptr \ None"]) + apply (simp add: ethread_set_def + assert_opt_def get_etcb_def gets_the_def gets_def get_def modify_def put_def set_eobject_def + bind_def fail_def return_def split_def + split: option.splits) + apply ((wp mapM_x_wp[OF _ subset_refl] | simp add: ethread_set_def set_eobject_def)+)[1] + using Cons.prems + apply force + done + finally show ?case by (rule sym) +qed lemma objBitsKO_gt_0: "0 < (objBitsKO ko)" apply (case_tac ko; simp add: objBits_simps' pageBits_def bit_simps') @@ -2198,7 +2359,7 @@ proof - split: ARM_H.object_type.splits) \ \SmallPageObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply (wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified] @@ -2206,7 +2367,7 @@ proof - | simp add: objBits_if_dev pageBits_def ptr range_cover_n_wb)+ apply (simp add:pageBits_def ptr word_bits_def) \ \LargePageObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply (wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified] @@ -2215,7 +2376,7 @@ proof - apply (simp add:pageBits_def ptr word_bits_def) \ \SectionObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply (wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified] @@ -2224,7 +2385,7 @@ proof - apply (simp add:pageBits_def ptr word_bits_def) \ \SuperSectionObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply (wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified] @@ -2233,7 +2394,7 @@ proof - apply (simp add:pageBits_def ptr word_bits_def) \ \PageTableObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits) apply (simp only: imp_conv_disj page_table_at'_def typ_at_to_obj_at_arches) @@ -2253,8 +2414,7 @@ proof - pdeBits_def pteBits_def) apply clarsimp \ \PageDirectoryObject\ - apply (wp hoare_vcg_const_Ball_lift) - apply (wp mapM_x_wp' ) + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits) apply (simp only: imp_conv_disj page_directory_at'_def typ_at_to_obj_at_arches) @@ -2565,9 +2725,9 @@ lemma corres_retype: by auto lemma init_arch_objects_APIType_map2: - "init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs = + "init_arch_objects (APIType_map2 (Inr ty)) dev ptr bits sz refs = (case ty of APIObjectType _ \ return () - | _ \ init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs)" + | _ \ init_arch_objects (APIType_map2 (Inr ty)) dev ptr bits sz refs)" apply (clarsimp split: ARM_H.object_type.split) apply (simp add: init_arch_objects_def APIType_map2_def split: apiobject_type.split) @@ -2693,7 +2853,7 @@ locale retype_mdb = vmdb + assumes 0: "\P 0" defines "n \ \p. if P p then Some makeObject else m p" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma no_0_n: "no_0 n" using no_0 by (simp add: no_0_def n_def 0) @@ -3016,7 +3176,7 @@ lemma caps_no_overlapD'': apply blast done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma valid_untyped'_helper: assumes valid : "valid_cap' c s" and cte_at : "cte_wp_at' (\cap. cteCap cap = c) q s" @@ -4311,7 +4471,7 @@ crunch createNewCaps for ksArch[wp]: "\s. P (ksArchState s)" (simp: crunch_simps unless_def wp: crunch_wps) crunch createNewCaps - for gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" + for gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" (simp: crunch_simps unless_def wp: crunch_wps updateObject_default_inv) lemma createNewCaps_global_refs': @@ -4486,7 +4646,9 @@ lemma createNewCaps_pde_mappings'[wp]: split del: if_split cong: option.case_cong object_type.case_cong) apply (rule hoare_pre) - apply (wp mapM_x_copyGlobalMappings_pde_mappings' | wpc + apply (wp mapM_x_copyGlobalMappings_pde_mappings' + mapM_x_wp'[where f="\r. doMachineOp (m r)" for m] + | wpc | simp split del: if_split)+ apply (rule_tac P="range_cover ptr sz (APIType_capBits ty us) n \ n\ 0" in hoare_gen_asm) apply (rule hoare_strengthen_post) @@ -4805,6 +4967,9 @@ crunch copyGlobalMappings, doMachineOp for pspace_domain_valid[wp]: "pspace_domain_valid" (wp: crunch_wps) +crunch doMachineOp + for pspace_domain_valid[wp]: pspace_domain_valid + lemma createNewCaps_pspace_domain_valid[wp]: "\pspace_domain_valid and K ({ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1} \ kernel_data_refs = {} @@ -5456,15 +5621,6 @@ lemma createObjects_tcb_at': apply (auto simp: obj_at'_def projectKOs project_inject objBitsKO_def objBits_def makeObject_tcb) done -lemma init_arch_objects_APIType_map2_noop: - "tp \ Inr PageDirectoryObject - \ init_arch_objects (APIType_map2 tp) ptr n m addrs - = return ()" - apply (simp add: init_arch_objects_def APIType_map2_def) - apply (cases tp, simp_all split: kernel_object.split arch_kernel_object.split - object_type.split apiobject_type.split) - done - lemma data_page_relation_retype: "obj_relation_retype (ArchObj (DataPage False pgsz)) KOUserData" "obj_relation_retype (ArchObj (DataPage True pgsz)) KOUserDataDevice" @@ -5474,6 +5630,23 @@ lemma data_page_relation_retype: apply (clarsimp simp: image_def)+ done +lemma regroup_createObjects_dmo_userPages: + "(do + addrs <- createObjects y n ko sz; + _ <- modify (\ks. ks\gsUserPages := g ks addrs\); + _ <- when P (mapM_x (\addr. doMachineOp (m addr)) addrs); + return (f addrs) + od) = (do + (addrs, faddrs) <- (do + addrs <- createObjects y n ko sz; + _ <- modify (\ks. ks\gsUserPages := g ks addrs\); + return (addrs, f addrs) + od); + _ <- when P (mapM_x (\addr. doMachineOp (m addr)) addrs); + return faddrs + od)" + by (simp add: bind_assoc) + lemma corres_retype_region_createNewCaps: "corres ((\r r'. length r = length r' \ list_all2 cap_relation r r') \ map (\ref. default_cap (APIType_map2 (Inr ty)) ref us dev)) @@ -5488,7 +5661,7 @@ lemma corres_retype_region_createNewCaps: \ valid_pspace' s \ valid_arch_state' s \ range_cover y sz (obj_bits_api (APIType_map2 (Inr ty)) us) n \ n\ 0) (do x \ retype_region y n us (APIType_map2 (Inr ty)) dev :: obj_ref list det_ext_monad; - init_arch_objects (APIType_map2 (Inr ty)) y n us x; + init_arch_objects (APIType_map2 (Inr ty)) dev y n us x; return x od) (createNewCaps ty y n us dev)" apply (rule_tac F="range_cover y sz @@ -5589,86 +5762,146 @@ lemma corres_retype_region_createNewCaps: apply (simp add: liftM_def[symmetric] split del: if_split) apply (rule corres_rel_imp) apply (rule corres_guard_imp) - apply (rule corres_retype[where 'a = reply], - simp_all add: obj_bits_api_def objBits_simps' pageBits_def - APIType_map2_def makeObjectKO_def - reply_relation_retype)[1] - apply ((simp add: range_cover_def APIType_map2_def - list_all2_same list_all2_map1 list_all2_map2)+)[4] + apply (rule corres_retype_update_gsI, + simp_all add: obj_bits_api_def objBits_simps' pageBits_def + APIType_map2_def makeObjectKO_def slot_bits_def + field_simps ext)[1] + apply (simp add: range_cover_def) + apply (rule captable_relation_retype,simp add: range_cover_def word_bits_def) + apply simp + apply simp + apply (clarsimp simp: list_all2_same list_all2_map1 list_all2_map2 + objBits_simps allRights_def APIType_map2_def + split del: if_split) \ \SmallPageObject\ + apply (subst retype_region2_extra_ext_trivial) + apply (simp add: APIType_map2_def) apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI, - simp_all add: APIType_map2_def makeObjectKO_def - arch_default_cap_def obj_bits_api_def - default_object_def default_arch_object_def pageBits_def - ext objBits_simps range_cover.aligned, - simp_all add: data_page_relation_retype)[1] - apply simp+ - apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def - vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same) - \ \LargePageObject\ - apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst regroup_createObjects_dmo_userPages) apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI, - simp_all add: APIType_map2_def makeObjectKO_def - arch_default_cap_def obj_bits_api_def - default_object_def default_arch_object_def pageBits_def - ext objBits_simps range_cover.aligned, - simp_all add: data_page_relation_retype)[1] - apply simp+ - apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def - vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same) + apply (rule corres_split) + apply (rule corres_retype_update_gsI, + simp_all add: APIType_map2_def makeObjectKO_def + arch_default_cap_def obj_bits_api_def3 + default_object_def default_arch_object_def pageBits_def + ext objBits_simps range_cover.aligned, + simp_all add: data_page_relation_retype)[1] + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] + \ \LargePageObject\ + apply (subst retype_region2_extra_ext_trivial) + apply (simp add: APIType_map2_def) + apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst regroup_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI, + simp_all add: APIType_map2_def makeObjectKO_def + arch_default_cap_def obj_bits_api_def3 + default_object_def default_arch_object_def pageBits_def + ext objBits_simps range_cover.aligned, + simp_all add: data_page_relation_retype)[1] + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] \ \SectionObject\ + apply (subst retype_region2_extra_ext_trivial) + apply (simp add: APIType_map2_def) apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI, - simp_all add: APIType_map2_def makeObjectKO_def - arch_default_cap_def obj_bits_api_def - default_object_def default_arch_object_def pageBits_def - ext objBits_simps range_cover.aligned, - simp_all add: data_page_relation_retype)[1] - apply simp+ - apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def - vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same) + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst regroup_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI, + simp_all add: APIType_map2_def makeObjectKO_def + arch_default_cap_def obj_bits_api_def3 + default_object_def default_arch_object_def pageBits_def + ext objBits_simps range_cover.aligned, + simp_all add: data_page_relation_retype)[1] + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] \ \SuperSectionObject\ apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI, - simp_all add: APIType_map2_def makeObjectKO_def - arch_default_cap_def obj_bits_api_def - default_object_def default_arch_object_def pageBits_def - ext objBits_simps range_cover.aligned, - simp_all add: data_page_relation_retype)[1] - apply simp+ - apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def - vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same) + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst regroup_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI, + simp_all add: APIType_map2_def makeObjectKO_def + arch_default_cap_def obj_bits_api_def3 + default_object_def default_arch_object_def pageBits_def + ext objBits_simps range_cover.aligned, + simp_all add: data_page_relation_retype)[1] + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] \ \PageTable\ - apply (simp_all add: corres_liftM2_simp[unfolded liftM_def]) + apply (subst retype_region2_extra_ext_trivial) + apply (simp add: APIType_map2_def) + apply (simp add: corres_liftM2_simp[unfolded liftM_def]) + apply (simp add: init_arch_objects_def bind_assoc split del: if_split) apply (rule corres_guard_imp) - apply (simp add: init_arch_objects_APIType_map2_noop) - apply (rule corres_rel_imp) - apply (rule corres_retype[where 'a =pte], - simp_all add: APIType_map2_def obj_bits_api_def - default_arch_object_def objBits_simps - archObjSize_def ptBits_def pageBits_def - pteBits_def pdeBits_def - makeObjectKO_def range_cover.aligned)[1] - apply (rule pagetable_relation_retype) - apply (wp | simp)+ - apply (clarsimp simp: list_all2_map1 list_all2_map2 list_all2_same - - APIType_map2_def arch_default_cap_def) - apply simp+ + apply (rule corres_split) + apply (rule corres_retype[where 'a =pte], + simp_all add: APIType_map2_def obj_bits_api_def + default_arch_object_def objBits_simps + archObjSize_def ptBits_def pteBits_def + makeObjectKO_def range_cover.aligned)[1] + apply (rule pagetable_relation_retype) + apply (clarsimp simp: APIType_map2_def vs_apiobj_size_def + pt_bits_def ptBits_def pageBits_def pteBits_def) + apply (rule corres_split) + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply corres + apply (clarsimp simp: list_all2_map1 list_all2_map2 list_all2_same + APIType_map2_def arch_default_cap_def) + apply ((wpsimp split_del: if_split)+)[6] \ \PageDirectory\ + apply (simp add: bind_assoc) apply (rule corres_guard_imp) apply (rule corres_split_eqr) apply (rule corres_retype[where ty = "Inr PageDirectoryObject" and 'a = pde @@ -5680,87 +5913,71 @@ lemma corres_retype_region_createNewCaps: makeObjectKO_def)[1] apply (simp add: range_cover_def)+ apply (rule pagedirectory_relation_retype) - apply (simp add: init_arch_objects_def APIType_map2_def - bind_assoc) - apply (rule corres_split_nor) - apply (simp add: mapM_x_mapM) - apply (rule corres_underlying_split[where r' = dc]) - apply (rule_tac Q="\xs s. (\x \ set xs. page_directory_at x s) - \ valid_arch_state s \ pspace_aligned s" - and Q'="\xs s. (\x \ set xs. page_directory_at' x s) \ valid_arch_state' s" - in corres_mapM_list_all2[where r'=dc and S="(=)"]) - apply simp+ - apply (rule corres_guard_imp, rule copyGlobalMappings_corres) - apply simp+ - apply (wp hoare_vcg_const_Ball_lift | simp)+ - apply (simp add: list_all2_same) - apply (rule corres_return[where P =\ and P'=\,THEN iffD2]) - apply simp - apply wp+ - apply (simp add: liftM_def[symmetric] o_def list_all2_map1 - list_all2_map2 list_all2_same - arch_default_cap_def mapM_x_mapM) - apply (simp add: dc_def[symmetric]) - apply (rule corres_machine_op) - apply (rule corres_Id) - apply (simp add: shiftl_t2n shiftL_nat - pdBits_def ptBits_def pageBits_def pt_bits_def) - defer - apply simp - apply (simp add: mapM_discarded[where g = "return ()",simplified,symmetric]) - apply (rule no_fail_pre) - apply (wp no_fail_mapM|clarsimp)+ + apply (rename_tac pds) + apply (simp add: init_arch_objects_def bind_assoc APIType_map2_def + vs_apiobj_size_def pdBits_eq + split del: if_split) + apply (rule corres_split) + apply (rule_tac P="valid_arch_state and valid_etcbs and pspace_aligned and + (\s. \pd \ set pds. typ_at (AArch APageDirectory) pd s)" and + P'="valid_arch_state' and (\s. \pd \ set pds. page_directory_at' pd s)" + in corres_mapM_x') + apply (clarsimp, rule corres_guard_imp, rule copyGlobalMappings_corres; simp) + apply (wpsimp wp: hoare_vcg_op_lift)+ + apply (rule corres_split, rule corres_mapM_x', rule corres_machine_op) + apply (clarsimp cong: corres_weak_cong) + apply (rule corres_underlying_trivial_dc) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: list_all2_map1 list_all2_map2 list_all2_same arch_default_cap_def) + apply (wpsimp wp: retype_region_valid_arch retype_region_aligned)+ + apply (rule hoare_post_imp) + prefer 2 apply (rule hoare_vcg_conj_lift) - apply (rule hoare_post_imp) - prefer 2 - apply (rule hoare_vcg_conj_lift) - apply (rule retype_region_obj_at) - apply (simp add: APIType_map2_def) - apply (subst APIType_map2_def, simp) - apply (rule retype_region_ret) - apply (clarsimp simp: retype_addrs_def obj_bits_api_def APIType_map2_def - default_arch_object_def default_object_def) - apply (clarsimp simp: obj_at_def a_type_def) - apply (wp retype_region_valid_arch retype_region_aligned|simp)+ - apply (clarsimp simp: objBits_simps retype_addrs_def obj_bits_api_def - APIType_map2_def default_arch_object_def default_object_def) + apply (rule retype_region_obj_at) + apply (simp add: APIType_map2_def) + apply (simp add: APIType_map2_def) + apply (rule retype_region_ret) + apply (clarsimp simp: retype_addrs_def obj_bits_api_def APIType_map2_def + default_arch_object_def default_object_def obj_at_def a_type_def) + apply (wpsimp wp: createObjects_valid_arch) + apply (rule hoare_post_imp) + prefer 2 apply (rule hoare_vcg_conj_lift) - apply (rule hoare_post_imp) - prefer 2 - apply (rule hoare_vcg_conj_lift) - apply (rule createObjects_ko_at[where sz = sz and 'a = pde]) - apply (simp add: objBits_simps archObjSize_def pdBits_def - pteBits_def pdeBits_def - pageBits_def page_directory_at'_def)+ - apply (simp add: projectKOs) - apply (rule createObjects_aligned) - apply (simp add: objBits_simps archObjSize_def pdBits_def - pageBits_def page_directory_at'_def)+ - apply (simp add: range_cover_def pteBits_def pdeBits_def) - apply (rule le_less_trans[OF range_cover.range_cover_n_le(2) power_strict_increasing]) - apply simp - apply (clarsimp simp: range_cover_def word_bits_def) - apply arith+ - apply (simp add: objBits_simps archObjSize_def pdBits_def - pageBits_def page_directory_at'_def)+ - apply (simp add: range_cover_def word_bits_def pteBits_def pdeBits_def) - apply clarsimp - apply (drule (1) bspec)+ - apply (simp add: objBits_simps retype_addrs_def obj_bits_api_def pdBits_def pageBits_def - ptBits_def APIType_map2_def default_arch_object_def default_object_def - archObjSize_def) - apply (clarsimp simp: objBits_simps archObjSize_def pdBits_def - pageBits_def page_directory_at'_def - pteBits_def pdeBits_def) - apply (drule_tac x = ya in spec) - apply (clarsimp simp:typ_at'_def obj_at'_real_def) - apply (erule ko_wp_at'_weakenE) - apply (clarsimp simp: projectKOs) - apply (wp createObjects_valid_arch) - apply (auto simp: objBits_simps retype_addrs_def obj_bits_api_def pdBits_def pageBits_def ptBits_def - APIType_map2_def default_arch_object_def default_object_def archObjSize_def - pteBits_def pdeBits_def - pd_bits_def fromIntegral_def toInteger_nat fromInteger_nat) + apply (rule createObjects_ko_at[where sz = sz and 'a = pde]) + apply (simp add: objBits_simps archObjSize_def pdBits_def + pteBits_def pdeBits_def APIType_map2_def + obj_bits_api_def default_arch_object_def projectKOs + pageBits_def page_directory_at'_def)+ + apply (rule createObjects_aligned) + apply (simp add: objBits_simps archObjSize_def pdBits_def + pageBits_def page_directory_at'_def)+ + apply (simp add: range_cover_def pteBits_def pdeBits_def) + apply (rule le_less_trans[OF range_cover.range_cover_n_le(2) power_strict_increasing]) + apply simp + apply (clarsimp simp: range_cover_def word_bits_def) + apply arith+ + apply (simp add: objBits_simps archObjSize_def pdBits_def + pageBits_def page_directory_at'_def)+ + apply (simp add: word_bits_def pteBits_def pdeBits_def) + apply clarsimp + apply (drule (1) bspec)+ + apply (simp add: objBits_simps retype_addrs_def obj_bits_api_def pdBits_def pageBits_def + ptBits_def APIType_map2_def default_arch_object_def default_object_def + archObjSize_def) + apply (clarsimp simp: objBits_simps archObjSize_def pdBits_def + pageBits_def page_directory_at'_def + pteBits_def pdeBits_def) + apply (rename_tac offset) + apply (drule_tac x = offset in spec) + apply (clarsimp simp:typ_at'_def obj_at'_real_def) + apply (erule ko_wp_at'_weakenE) + apply (clarsimp simp: projectKOs) + apply (auto simp: objBits_simps retype_addrs_def obj_bits_api_def pdBits_def pageBits_def + APIType_map2_def default_arch_object_def default_object_def archObjSize_def + pteBits_def pdeBits_def ptBits_def + pd_bits_def fromIntegral_def toInteger_nat fromInteger_nat) done end diff --git a/proof/refine/ARM/SchedContextInv_R.thy b/proof/refine/ARM/SchedContextInv_R.thy index 4fb2d8cd92..8700c9fa0e 100644 --- a/proof/refine/ARM/SchedContextInv_R.thy +++ b/proof/refine/ARM/SchedContextInv_R.thy @@ -11,7 +11,7 @@ begin global_interpretation schedContextCompleteYieldTo: typ_at_all_props' "schedContextCompleteYieldTo scp" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec valid_sc_inv' :: "sched_context_invocation \ kernel_state \ bool" where "valid_sc_inv' (InvokeSchedContextConsumed scptr args) = diff --git a/proof/refine/ARM/SchedContext_R.thy b/proof/refine/ARM/SchedContext_R.thy index 90e87133c7..0611509537 100644 --- a/proof/refine/ARM/SchedContext_R.thy +++ b/proof/refine/ARM/SchedContext_R.thy @@ -163,7 +163,7 @@ lemma updateSchedContext_invs'_indep: apply (frule (1) invs'_ko_at_valid_sched_context', simp) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma schedContextUpdateConsumed_corres: "corres (=) (sc_at scp) (sc_at' scp) @@ -826,7 +826,7 @@ lemma readRefillReady_no_ofail[wp]: apply (wpsimp wp: no_ofail_readCurTime) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma get_sc_released_corres: "corres (=) (active_scs_valid and sc_at sc_ptr) (valid_objs' and sc_at' sc_ptr) diff --git a/proof/refine/ARM/Schedule_R.thy b/proof/refine/ARM/Schedule_R.thy index d385b0f81c..95fc80cf4f 100644 --- a/proof/refine/ARM/Schedule_R.thy +++ b/proof/refine/ARM/Schedule_R.thy @@ -8,11 +8,7 @@ theory Schedule_R imports SchedContext_R InterruptAcc_R begin -crunch scReleased, getReprogramTimer, getCurTime, getRefills, getReleaseQueue, refillSufficient, - refillReady, isRoundRobin - for inv[wp]: P - -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare hoare_weak_lift_imp[wp_split del] @@ -119,7 +115,7 @@ global_interpretation refillUpdate: typ_at_all_props' "refillUpdate scPtr newPe global_interpretation updateSchedContext: typ_at_all_props' "updateSchedContext scPtr f" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma findM_awesome': assumes x: "\x xs. suffix (x # xs) xs' \ diff --git a/proof/refine/ARM/StateRelation.thy b/proof/refine/ARM/StateRelation.thy index e81f395e71..40f033640c 100644 --- a/proof/refine/ARM/StateRelation.thy +++ b/proof/refine/ARM/StateRelation.thy @@ -12,7 +12,7 @@ theory StateRelation imports InvariantUpdates_H begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition cte_map :: "cslot_ptr \ word32" where diff --git a/proof/refine/ARM/SubMonad_R.thy b/proof/refine/ARM/SubMonad_R.thy index 5692bc4060..f2459a0ed6 100644 --- a/proof/refine/ARM/SubMonad_R.thy +++ b/proof/refine/ARM/SubMonad_R.thy @@ -47,7 +47,7 @@ lemma doMachineOp_mapM_x: done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "asUser_fetch \ \t s. case (ksPSpace s t) of Some (KOTCB tcb) \ (atcbContextGet o tcbArch) tcb diff --git a/proof/refine/ARM/Syscall_R.thy b/proof/refine/ARM/Syscall_R.thy index d4a9721271..5e1daf67fd 100644 --- a/proof/refine/ARM/Syscall_R.thy +++ b/proof/refine/ARM/Syscall_R.thy @@ -12,7 +12,7 @@ theory Syscall_R imports Tcb_R Arch_R Interrupt_R SchedContextInv_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* syscall has 5 sections: m_fault h_fault m_error h_error m_finalise @@ -504,7 +504,8 @@ crunch restart, bindNotification, performTransfer, invokeTCB, doReplyTransfer, wp: crunch_wps checkCap_inv hoare_vcg_all_lift ignore: checkCapAt) -end +lemmas invokeIRQHandler_typ_ats[wp] = + typ_at_lifts [OF invokeIRQHandler_typ_at'] global_interpretation invokeTCB: typ_at_all_props' "invokeTCB i" by typ_at_props' @@ -548,7 +549,7 @@ lemma sts_mcpriority_tcb_at'[wp]: crunch setThreadState for valid_ipc_buffer_ptr'[wp]: "valid_ipc_buffer_ptr' buf" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma sts_valid_inv'[wp]: "setThreadState st t \valid_invocation' i\" @@ -1949,7 +1950,7 @@ end global_interpretation refillResetRR: typ_at_all_props' "refillResetRR scPtr" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma refillResetRR_invs'[wp]: "refillResetRR scp \invs'\" diff --git a/proof/refine/ARM/TcbAcc_R.thy b/proof/refine/ARM/TcbAcc_R.thy index a40ce993bf..35d8c6c30d 100644 --- a/proof/refine/ARM/TcbAcc_R.thy +++ b/proof/refine/ARM/TcbAcc_R.thy @@ -9,7 +9,7 @@ theory TcbAcc_R imports CSpace_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare if_weak_cong [cong] declare hoare_in_monad_post[wp] @@ -1579,7 +1579,7 @@ lemma no_fail_asUser [wp]: apply (wpsimp wp: hoare_drop_imps no_fail_threadGet)+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma asUser_setRegister_corres: "corres dc (tcb_at t and pspace_aligned and pspace_distinct) \ @@ -3349,7 +3349,7 @@ lemma threadGet_const: apply (clarsimp simp: obj_at'_def) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) schematic_goal l2BitmapSize_def': (* arch specific consequence *) "l2BitmapSize = numeral ?X" diff --git a/proof/refine/ARM/Tcb_R.thy b/proof/refine/ARM/Tcb_R.thy index 8ff36f6915..97c90110dd 100644 --- a/proof/refine/ARM/Tcb_R.thy +++ b/proof/refine/ARM/Tcb_R.thy @@ -8,7 +8,7 @@ theory Tcb_R imports CNodeInv_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma asUser_setNextPC_corres: "corres dc (tcb_at t and invs) (tcb_at' t and invs') @@ -1091,7 +1091,7 @@ termination recursive apply simp done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cte_map_tcb_0: "cte_map (t, tcb_cnode_index 0) = t" @@ -1481,7 +1481,7 @@ end consts copyregsets_map :: "arch_copy_register_sets \ Arch.copy_register_sets" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec tcbinv_relation :: "tcb_invocation \ tcbinvocation \ bool" diff --git a/proof/refine/ARM/Untyped_R.thy b/proof/refine/ARM/Untyped_R.thy index cbaac7a76d..b14b747d35 100644 --- a/proof/refine/ARM/Untyped_R.thy +++ b/proof/refine/ARM/Untyped_R.thy @@ -9,7 +9,7 @@ theory Untyped_R imports Detype_R Invocations_R InterruptAcc_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec untypinv_relation :: "Invocations_A.untyped_invocation \ @@ -1000,7 +1000,7 @@ locale mdb_insert_again = context mdb_insert_again begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemmas parent = mdb_ptr_parent.m_p lemmas site = mdb_ptr_site.m_p @@ -1389,7 +1389,7 @@ crunch create_cap_ext and work_units_completed[wp]: "\s. P (work_units_completed s)" (ignore_del: create_cap_ext) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma updateNewFreeIndex_noop_psp_corres: "corres_underlying {(s, s'). pspace_relations (ekheap s) (kheap s) (ksPSpace s')} False True @@ -1700,7 +1700,7 @@ locale mdb_insert_again_all = mdb_insert_again_child + fixes n' defines "n' \ modify_map n (mdbNext parent_node) (cteMDBNode_update (mdbPrev_update (\a. site)))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma no_0_n' [simp]: "no_0 n'" using no_0_n by (simp add: n'_def) @@ -2661,7 +2661,7 @@ lemma caps_overlap_reserved'_D: apply (erule(2) impE) apply fastforce done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma insertNewCap_valid_mdb: "\valid_mdb' and valid_objs' and K (slot \ p) and caps_overlap_reserved' (untypedRange cap) and @@ -2707,7 +2707,7 @@ end global_interpretation updateNewFreeIndex: typ_at_all_props' "updateNewFreeIndex slot" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma updateNewFreeIndex_valid_objs[wp]: "\valid_objs'\ updateNewFreeIndex slot \\_. valid_objs'\" @@ -3884,7 +3884,7 @@ lemma cte_wp_at': "cte_wp_at' (\cte. cteCap cte = capability.UntypedCap "\x\set slots. ex_cte_cap_wp_to' (\_. True) x s" using vui by (auto simp: cte_wp_at_ctes_of) -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma idx_cases: "((\ reset \ idx \ unat (ptr - (ptr && ~~ mask sz))) \ reset \ ptr = ptr && ~~ mask sz)" @@ -4028,7 +4028,7 @@ lemma idx_le_new_offs: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch deleteObjects for ksIdleThread[wp]: "\s. P (ksIdleThread s)" @@ -4179,7 +4179,7 @@ lemma ex_tupI: "P (fst x) (snd x) \ \a b. P a b" by blast -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* mostly stuff about PPtr/fromPPtr, which seems pretty soft *) lemma resetUntypedCap_corres: @@ -4414,7 +4414,7 @@ lemma ex_cte_cap_wp_to_irq_state_independent_H[simp]: "irq_state_independent_H (ex_cte_cap_wp_to' P slot)" by (simp add: ex_cte_cap_wp_to'_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma updateFreeIndex_ctes_of: "\\s. P (modify_map (ctes_of s) ptr (cteCap_update (capFreeIndex_update (\_. idx))))\ @@ -4636,7 +4636,7 @@ lemma (in range_cover) funky_aligned: apply simp done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) defs archOverlap_def: "archOverlap \ \_ _. False" diff --git a/proof/refine/ARM/VSpace_R.thy b/proof/refine/ARM/VSpace_R.thy index 05e30ec0f8..c690f98c7e 100644 --- a/proof/refine/ARM/VSpace_R.thy +++ b/proof/refine/ARM/VSpace_R.thy @@ -12,8 +12,7 @@ theory VSpace_R imports TcbAcc_R begin - -context Arch begin global_naming ARM (*FIXME: arch_split*) +context Arch begin global_naming ARM (*FIXME: arch-split*) (*FIXME: move to ainvs*) lemmas store_pte_typ_ats[wp] = store_pte_typ_ats abs_atyp_at_lifts[OF store_pte_typ_at] @@ -21,7 +20,7 @@ lemmas store_pde_typ_ats[wp] = store_pde_typ_ats abs_atyp_at_lifts[OF store_pde_ end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "pd_at_asid' pd asid \ \s. \ap pool. @@ -1102,7 +1101,7 @@ sublocale Arch < loadHWASID: typ_at_all_props' "loadHWASID asid" sublocale Arch < setVMRootForFlush: typ_at_all_props' "setVMRootForFlush pd asid" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch setVMRootForFlush for aligned'[wp]: pspace_aligned' @@ -1333,7 +1332,7 @@ sublocale Arch < flushPage: typ_at_all_props' "flushPage arg1 pd asid vptr" sublocale Arch < findPDForASID: typ_at_all_props' "findPDForASID asid" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch unmapPageTable for aligned'[wp]: "pspace_aligned'" @@ -2055,7 +2054,7 @@ crunch setMRs global_interpretation setMRs: typ_at_all_props' "setMRs thread buffer data" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma set_mrs_invs'[wp]: "\ invs' and tcb_at' receiver \ setMRs receiver recv_buf mrs \\rv. invs' \" @@ -2361,7 +2360,7 @@ end sublocale Arch < unmapPageTable: typ_at_all_props' "unmapPageTable asid vaddr pt" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma performPageTableInvocation_corres: "page_table_invocation_map pti pti' \ @@ -2632,7 +2631,7 @@ sublocale Arch < performASIDPoolInvocation: typ_at_all_props' "performASIDPoolIn sublocale Arch < unmapPage: typ_at_all_props' "unmapPage magnitude asid vptr ptr" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma dmo_ct[wp]: "\\s. P (ksCurThread s)\ doMachineOp m \\rv s. P (ksCurThread s)\" diff --git a/proof/refine/ARM/orphanage/Orphanage.thy b/proof/refine/ARM/orphanage/Orphanage.thy index b4a61208b5..1f9fd83b4c 100644 --- a/proof/refine/ARM/orphanage/Orphanage.thy +++ b/proof/refine/ARM/orphanage/Orphanage.thy @@ -14,7 +14,7 @@ text \ or about to be switched to, or be in a scheduling queue. \ -(*FIXME: arch_split: move up? *) +(*FIXME: arch-split: move up? *) context Arch begin requalify_facts @@ -30,7 +30,7 @@ requalify_facts end end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition is_active_thread_state :: "thread_state \ bool" @@ -1797,11 +1797,11 @@ lemma invokeIRQControl_no_orphans [wp]: apply (wp | clarsimp)+ done -lemma invokeIRQHandler_no_orphans [wp]: +lemma arch_invokeIRQHandler_no_orphans[wp]: "\ \s. no_orphans s \ invs' s \ - invokeIRQHandler i + ARM_H.invokeIRQHandler i \ \reply s. no_orphans s \" - apply (cases i, simp_all add: invokeIRQHandler_def) + apply (cases i, simp_all add: ARM_H.invokeIRQHandler_def) apply (wp | clarsimp | fastforce)+ done @@ -1939,7 +1939,7 @@ lemma setDomain_no_orphans [wp]: apply (fastforce simp: tcb_at_typ_at' is_active_tcb_ptr_runnable') done -crunch InterruptDecls_H.invokeIRQHandler +crunch invokeIRQHandler for no_orphans[wp]: no_orphans lemma performInvocation_no_orphans [wp]: diff --git a/proof/refine/ARM_HYP/ADT_H.thy b/proof/refine/ARM_HYP/ADT_H.thy index 5deb5ff44c..e8730c4a1f 100644 --- a/proof/refine/ARM_HYP/ADT_H.thy +++ b/proof/refine/ARM_HYP/ADT_H.thy @@ -28,7 +28,7 @@ consts initBootFrames :: "word32 list" initDataStart :: word32 -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \ The construction of the abstract data type @@ -72,40 +72,40 @@ lemma vm_rights_of_vmrights_map_id[simp]: definition absPageTable :: "(word32 \ Structures_H.kernel_object) \ obj_ref \ - 9 word \ ARM_A.pte" + 9 word \ ARM_HYP_A.pte" where "absPageTable h a \ %offs. case (h (a + (ucast offs << 3))) of - Some (KOArch (KOPTE (ARM_HYP_H.InvalidPTE))) \ ARM_A.InvalidPTE + Some (KOArch (KOPTE (ARM_HYP_H.InvalidPTE))) \ ARM_HYP_A.InvalidPTE | Some (KOArch (KOPTE (ARM_HYP_H.LargePagePTE p c xn rights))) \ if is_aligned offs 4 then - ARM_A.LargePagePTE p + ARM_HYP_A.LargePagePTE p {x. c & x=PageCacheable | xn & x=XNever} (vm_rights_of rights) - else ARM_A.InvalidPTE + else ARM_HYP_A.InvalidPTE | Some (KOArch (KOPTE (ARM_HYP_H.SmallPagePTE p c xn rights))) \ - ARM_A.SmallPagePTE p {x. c & x=PageCacheable | + ARM_HYP_A.SmallPagePTE p {x. c & x=PageCacheable | xn & x=XNever} (vm_rights_of rights)" definition absPageDirectory :: "(word32 \ Structures_H.kernel_object) \ obj_ref \ - 11 word \ ARM_A.pde" + 11 word \ ARM_HYP_A.pde" where "absPageDirectory h a \ %offs. case (h (a + (ucast offs << 3))) of - Some (KOArch (KOPDE (ARM_HYP_H.InvalidPDE))) \ ARM_A.InvalidPDE + Some (KOArch (KOPDE (ARM_HYP_H.InvalidPDE))) \ ARM_HYP_A.InvalidPDE | Some (KOArch (KOPDE (ARM_HYP_H.PageTablePDE p))) \ - ARM_A.PageTablePDE p + ARM_HYP_A.PageTablePDE p | Some (KOArch (KOPDE (ARM_HYP_H.SectionPDE p c xn rights))) \ - ARM_A.SectionPDE p {x. c & x=PageCacheable | + ARM_HYP_A.SectionPDE p {x. c & x=PageCacheable | xn & x=XNever} (vm_rights_of rights) | Some (KOArch (KOPDE (ARM_HYP_H.SuperSectionPDE p c xn rights))) \ if is_aligned offs 4 then - ARM_A.SuperSectionPDE p + ARM_HYP_A.SuperSectionPDE p {x. c & x=PageCacheable | xn & x=XNever} (vm_rights_of rights) - else ARM_A.InvalidPDE" + else ARM_HYP_A.InvalidPDE" definition absVGIC :: "gicvcpuinterface \ gic_vcpu_interface" @@ -125,7 +125,7 @@ definition "absHeapArch h a \ %ako. (case ako of KOASIDPool (ARM_HYP_H.ASIDPool ap) \ - Some (ARM_A.ASIDPool (\w. ap (ucast w))) + Some (ARM_HYP_A.ASIDPool (\w. ap (ucast w))) | KOPTE _ \ if is_aligned a pt_bits then Some (PageTable (absPageTable h a)) else None @@ -258,10 +258,10 @@ lemma LookupFailureMap_lookup_failure_map: primrec ArchFaultMap :: "Fault_H.arch_fault \ ExceptionTypes_A.arch_fault" where - "ArchFaultMap (ArchFault_H.ARM_HYP_H.arch_fault.VMFault p m) = Machine_A.ARM_A.arch_fault.VMFault p m" -| "ArchFaultMap (ArchFault_H.ARM_HYP_H.arch_fault.VCPUFault w) = Machine_A.ARM_A.arch_fault.VCPUFault w" -| "ArchFaultMap (ArchFault_H.ARM_HYP_H.arch_fault.VGICMaintenance m) = Machine_A.ARM_A.arch_fault.VGICMaintenance m" -| "ArchFaultMap (ArchFault_H.ARM_HYP_H.arch_fault.VPPIEvent irq) = Machine_A.ARM_A.arch_fault.VPPIEvent irq" + "ArchFaultMap (ArchFault_H.ARM_HYP_H.arch_fault.VMFault p m) = Machine_A.ARM_HYP_A.arch_fault.VMFault p m" +| "ArchFaultMap (ArchFault_H.ARM_HYP_H.arch_fault.VCPUFault w) = Machine_A.ARM_HYP_A.arch_fault.VCPUFault w" +| "ArchFaultMap (ArchFault_H.ARM_HYP_H.arch_fault.VGICMaintenance m) = Machine_A.ARM_HYP_A.arch_fault.VGICMaintenance m" +| "ArchFaultMap (ArchFault_H.ARM_HYP_H.arch_fault.VPPIEvent irq) = Machine_A.ARM_HYP_A.arch_fault.VPPIEvent irq" primrec @@ -703,10 +703,10 @@ proof - apply (erule_tac x=offs in allE) apply (rename_tac pte') apply (case_tac pte', simp_all add: pte_relation_aligned_def vspace_bits_defs)[1] - apply (clarsimp split: ARM_A.pte.splits) + apply (clarsimp split: ARM_HYP_A.pte.splits) apply (rule set_eqI, clarsimp) apply (case_tac x, simp_all)[1] - apply (clarsimp split: ARM_A.pte.splits) + apply (clarsimp split: ARM_HYP_A.pte.splits) apply (rule set_eqI, clarsimp) apply (case_tac x, simp_all)[1] apply (clarsimp simp add: pde_relation_def) @@ -746,10 +746,10 @@ proof - apply (erule_tac x=offs in allE) apply (rename_tac pde') apply (case_tac pde', simp_all add: pde_relation_aligned_def)[1] - apply (clarsimp split: ARM_A.pde.splits)+ + apply (clarsimp split: ARM_HYP_A.pde.splits)+ apply (rule set_eqI, clarsimp) apply (case_tac x, simp_all)[1] - apply (clarsimp split: ARM_A.pde.splits) + apply (clarsimp split: ARM_HYP_A.pde.splits) apply (rule set_eqI, clarsimp) apply (case_tac x, simp_all)[1] apply (clarsimp simp add: pde_relation_def split: if_split_asm) @@ -811,7 +811,7 @@ shows apply (erule(1) obj_relation_cutsE) apply (clarsimp simp: other_obj_relation_def split: Structures_A.kernel_object.split_asm if_split_asm - ARM_A.arch_kernel_obj.split_asm)+ + ARM_HYP_A.arch_kernel_obj.split_asm)+ done text \The following function can be used to reverse cte_map.\ @@ -1293,7 +1293,7 @@ locale partial_sort_cdt = partial_sort "\ x y. m' \ cte_map begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma valid_list_2 : "valid_list_2 t m" apply (insert assms') @@ -1490,7 +1490,7 @@ lemma sort_cdt_list_correct: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition absCDTList where "absCDTList cnp h \ sort_cdt_list (absCDT cnp h) h" diff --git a/proof/refine/ARM_HYP/ArchAcc_R.thy b/proof/refine/ARM_HYP/ArchAcc_R.thy index a0543aeab5..5fbcdd397e 100644 --- a/proof/refine/ARM_HYP/ArchAcc_R.thy +++ b/proof/refine/ARM_HYP/ArchAcc_R.thy @@ -26,10 +26,10 @@ method simp_to_elim = (drule fun_all, elim allE impE) end -context Arch begin global_naming ARM_A (*FIXME: arch_split*) +context Arch begin global_naming ARM_HYP_A (*FIXME: arch-split*) lemma asid_pool_at_ko: - "asid_pool_at p s \ \pool. ko_at (ArchObj (ARM_A.ASIDPool pool)) p s" + "asid_pool_at p s \ \pool. ko_at (ArchObj (ARM_HYP_A.ASIDPool pool)) p s" apply (clarsimp simp: obj_at_def a_type_def) apply (case_tac ko, simp_all split: if_split_asm) apply (rename_tac arch_kernel_obj) @@ -45,7 +45,7 @@ lemmas valid_vspace_obj_elims[rule_format, elim!] = end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (*FIXME move *) @@ -559,7 +559,7 @@ lemma get_master_pde_corres [@lift_corres_args, corres]: apply (clarsimp simp: exec_gets pde_at_def obj_at_def vspace_bits_defs mask_lower_twice2) apply (clarsimp simp: isSuperSection_def') apply (clarsimp simp: pde_relation_aligned_def is_aligned_neg_mask is_aligned_shiftr) - apply (clarsimp split: ARM_A.pde.splits) + apply (clarsimp split: ARM_HYP_A.pde.splits) apply (auto simp: master_pde_relation_def vmsz_aligned'_def return_def vspace_bits_defs)[1] apply (clarsimp simp: get_pde_def and_not_mask_twice get_pd_def bind_assoc get_object_def) apply (clarsimp simp: exec_gets pde_at_def obj_at_def vspace_bits_defs mask_lower_twice2) @@ -822,7 +822,7 @@ lemma get_master_pte_corres [corres]: apply (clarsimp simp: exec_gets pte_at_def obj_at_def vspace_bits_defs mask_lower_twice2) apply (clarsimp simp: isLargePage_def') apply (clarsimp simp: pte_relation_aligned_def is_aligned_neg_mask is_aligned_shiftr) - apply (clarsimp split: ARM_A.pte.splits) + apply (clarsimp split: ARM_HYP_A.pte.splits) apply (auto simp: master_pte_relation_def vmsz_aligned'_def return_def vspace_bits_defs)[1] apply (clarsimp simp: get_pte_def and_not_mask_twice get_pt_def bind_assoc get_object_def) apply (clarsimp simp: exec_gets pte_at_def obj_at_def vspace_bits_defs mask_lower_twice2) @@ -1211,7 +1211,7 @@ lemmas get_pde_wp_valid = hoare_add_post'[OF get_pde_valid get_pde_wp] lemma page_table_at_lift: "\s s'. (s, s') \ state_relation \ (ptrFromPAddr ptr) = ptr' \ - (pspace_aligned s \ valid_pde (ARM_A.PageTablePDE ptr) s) \ + (pspace_aligned s \ valid_pde (ARM_HYP_A.PageTablePDE ptr) s) \ pspace_distinct' s' \ page_table_at' ptr' s'" by (fastforce intro!: page_table_at_state_relation) @@ -1319,7 +1319,7 @@ definition "vmattributes_map \ \R. VMAttributes (PageCacheable \ R) False (XNever \ R)" definition - mapping_map :: "ARM_A.pte \ word32 list + ARM_A.pde \ word32 list \ + mapping_map :: "ARM_HYP_A.pte \ word32 list + ARM_HYP_A.pde \ word32 list \ ARM_HYP_H.pte \ word32 list + ARM_HYP_H.pde \ word32 list \ bool" where "mapping_map \ pte_relation' \ (=) \ pde_relation' \ (=)" @@ -1338,7 +1338,7 @@ lemma createMappingEntries_corres [corres]: by (cases pgsz; corresKsimp simp: vmattributes_map_def) lemma pte_relation'_Invalid_inv [simp]: - "pte_relation' x ARM_HYP_H.pte.InvalidPTE = (x = ARM_A.pte.InvalidPTE)" + "pte_relation' x ARM_HYP_H.pte.InvalidPTE = (x = ARM_HYP_A.pte.InvalidPTE)" by (cases x) auto fun pte_vmsz_aligned' where diff --git a/proof/refine/ARM_HYP/Arch_R.thy b/proof/refine/ARM_HYP/Arch_R.thy index 7e4d1f4092..1783cdcf7e 100644 --- a/proof/refine/ARM_HYP/Arch_R.thy +++ b/proof/refine/ARM_HYP/Arch_R.thy @@ -15,14 +15,14 @@ begin unbundle l4v_word_context -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare is_aligned_shiftl [intro!] declare is_aligned_shiftr [intro!] definition "asid_ci_map i \ - case i of ARM_A.MakePool frame slot parent base \ + case i of ARM_HYP_A.MakePool frame slot parent base \ ARM_HYP_H.MakePool frame (cte_map slot) (cte_map parent) base" definition @@ -516,7 +516,7 @@ lemma flush_type_map: flush_type_map (label_to_flush_type (invocation_type (mi_label mi)))" by (clarsimp simp: label_to_flush_type_def labelToFlushType_def flush_type_map_def ARM_HYP_H.isPageFlushLabel_def ARM_HYP_H.isPDFlushLabel_def - split: ARM_A.flush_type.splits invocation_label.splits arch_invocation_label.splits) + split: ARM_HYP_A.flush_type.splits invocation_label.splits arch_invocation_label.splits) lemma resolveVAddr_corres: "\ is_aligned pd pd_bits; vaddr < kernel_base \ \ @@ -582,7 +582,7 @@ lemma decodeARMPageFlush_corres: throwError ExceptionTypes_A.syscall_error.IllegalOperation; returnOk $ arch_invocation.InvokePage $ - ARM_A.page_invocation.PageFlush \ \Must use word in hyp mode.\ + ARM_HYP_A.page_invocation.PageFlush \ \Must use word in hyp mode.\ (label_to_flush_type (invocation_type (mi_label mi))) (start + word) (end + word - 1) pstart pd asid odE @@ -634,11 +634,11 @@ lemma vs_refs_pages_ptI: done lemmas vs_refs_pages_pt_largeI - = vs_refs_pages_ptI[where pte="ARM_A.pte.LargePagePTE x y z" for x y z, + = vs_refs_pages_ptI[where pte="ARM_HYP_A.pte.LargePagePTE x y z" for x y z, unfolded pte_ref_pages_def, simplified, OF _ refl] lemmas vs_refs_pages_pt_smallI - = vs_refs_pages_ptI[where pte="ARM_A.pte.SmallPagePTE x y z" for x y z, + = vs_refs_pages_ptI[where pte="ARM_HYP_A.pte.SmallPagePTE x y z" for x y z, unfolded pte_ref_pages_def, simplified, OF _ refl] lemma vs_refs_pages_pdI: @@ -650,11 +650,11 @@ lemma vs_refs_pages_pdI: done lemmas vs_refs_pages_pd_sectionI - = vs_refs_pages_pdI[where pde="ARM_A.pde.SectionPDE x y z" for x y z, + = vs_refs_pages_pdI[where pde="ARM_HYP_A.pde.SectionPDE x y z" for x y z, unfolded pde_ref_pages_def, simplified, OF _ refl] lemmas vs_refs_pages_pd_supersectionI - = vs_refs_pages_pdI[where pde="ARM_A.pde.SuperSectionPDE x y z" for x y z, + = vs_refs_pages_pdI[where pde="ARM_HYP_A.pde.SuperSectionPDE x y z" for x y z, unfolded pde_ref_pages_def, simplified, OF _ refl] lemma get_master_pde_sp: diff --git a/proof/refine/ARM_HYP/Bits_R.thy b/proof/refine/ARM_HYP/Bits_R.thy index 67b738cbce..861e7b95be 100644 --- a/proof/refine/ARM_HYP/Bits_R.thy +++ b/proof/refine/ARM_HYP/Bits_R.thy @@ -22,7 +22,7 @@ crunch_ignore (add: empty_on_failure emptyOnFailure clearMemoryVM null_cap_on_failure setNextPC getRestartPC assertDerived throw_on_false getObject setObject updateObject loadObject) -context Arch begin (*FIXME: arch_split*) +context Arch begin (*FIXME: arch-split*) crunch_ignore (add: invalidateLocalTLB_ASID invalidateLocalTLB_VAASID @@ -33,7 +33,7 @@ crunch_ignore (add: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma withoutFailure_wp [wp]: "\P\ f \Q\ \ \P\ withoutFailure f \Q\,\E\" diff --git a/proof/refine/ARM_HYP/CNodeInv_R.thy b/proof/refine/ARM_HYP/CNodeInv_R.thy index 769ecc7d35..2c724fffce 100644 --- a/proof/refine/ARM_HYP/CNodeInv_R.thy +++ b/proof/refine/ARM_HYP/CNodeInv_R.thy @@ -15,7 +15,7 @@ begin unbundle l4v_word_context -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec valid_cnode_inv' :: "Invocations_H.cnode_invocation \ kernel_state \ bool" @@ -4954,7 +4954,7 @@ lemma cteSwap_valid_pspace'[wp]: apply clarsimp+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch cteSwap for tcb_at[wp]: "tcb_at' t" @@ -6701,7 +6701,7 @@ lemmas threadSet_ctesCaps_of = ctes_of_cteCaps_of_lift[OF threadSet_ctes_of] lemmas storePTE_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF storePTE_ctes] lemmas storePDE_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF storePDE_ctes] -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma vcpuSwitch_rvk_prog': "vcpuSwitch v \\s. revoke_progress_ord m (\x. map_option capToRPO (cteCaps_of s x))\" @@ -7944,7 +7944,7 @@ lemma (in mdb_move) m'_cap: context mdb_move begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma m_to_src: "m \ p \ src = (p \ 0 \ p = mdbPrev src_node)" @@ -8476,7 +8476,7 @@ qed end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteMove_iflive'[wp]: "\\s. if_live_then_nonz_cap' s @@ -8653,7 +8653,7 @@ crunch updateMDB for valid_bitmaps[wp]: valid_bitmaps (rule: valid_bitmaps_lift) -(* FIXME: arch_split *) +(* FIXME: arch-split *) lemma haskell_assert_inv: "haskell_assert Q L \P\" by wpsimp diff --git a/proof/refine/ARM_HYP/CSpace1_R.thy b/proof/refine/ARM_HYP/CSpace1_R.thy index 7fb5d57412..f463c8469a 100644 --- a/proof/refine/ARM_HYP/CSpace1_R.thy +++ b/proof/refine/ARM_HYP/CSpace1_R.thy @@ -14,7 +14,7 @@ imports "AInvs.ArchDetSchedSchedule_AI" begin -context Arch begin global_naming ARM_A (*FIXME: arch_split*) +context Arch begin global_naming ARM_HYP_A (*FIXME: arch-split*) lemmas final_matters_def = final_matters_def[simplified final_matters_arch_def] @@ -25,7 +25,7 @@ lemmas final_matters_simps[simp] end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma isMDBParentOf_CTE1: "isMDBParentOf (CTE cap node) cte = @@ -1626,7 +1626,7 @@ lemma other_obj_relation_KOCTE[simp]: "\ other_obj_relation ko (KOCTE cte)" by (simp add: other_obj_relation_def split: Structures_A.kernel_object.splits - ARM_A.arch_kernel_obj.splits) + ARM_HYP_A.arch_kernel_obj.splits) lemma cte_map_pulls_tcb_to_abstract: "\ y = cte_map z; pspace_relation (kheap s) (ksPSpace s'); @@ -1639,7 +1639,7 @@ lemma cte_map_pulls_tcb_to_abstract: apply (erule(1) obj_relation_cutsE; clarsimp simp: other_obj_relation_def split: Structures_A.kernel_object.split_asm - ARM_A.arch_kernel_obj.split_asm if_split_asm) + ARM_HYP_A.arch_kernel_obj.split_asm if_split_asm) apply (drule tcb_cases_related2) apply clarsimp apply (frule(1) cte_wp_at_tcbI [OF _ _ TrueI, where t="(a, b)" for a b, simplified]) @@ -1955,7 +1955,7 @@ lemma pspace_relation_cte_wp_atI': apply clarsimp apply (simp add: other_obj_relation_def split: Structures_A.kernel_object.split_asm - ARM_A.arch_kernel_obj.split_asm) + ARM_HYP_A.arch_kernel_obj.split_asm) done lemma pspace_relation_cte_wp_atI: @@ -2570,7 +2570,7 @@ lemma updateMDB_pspace_relation: apply (rule pspace_dom_relatedE, assumption+) apply (rule obj_relation_cutsE, assumption+; clarsimp split: Structures_A.kernel_object.split_asm - ARM_A.arch_kernel_obj.split_asm if_split_asm + ARM_HYP_A.arch_kernel_obj.split_asm if_split_asm simp: other_obj_relation_def) apply (frule(1) tcb_cte_cases_aligned_helpers(1)) apply (frule(1) tcb_cte_cases_aligned_helpers(2)) @@ -2981,7 +2981,7 @@ locale masterCap = fixes cap cap' assumes master: "capMasterCap cap = capMasterCap cap'" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma isZombie [simp]: "isZombie cap' = isZombie cap" using master @@ -3567,7 +3567,7 @@ locale mdb_insert_sib = mdb_insert_der + (mdbRevocable_update (\a. revokable' src_cap c') (mdbPrev_update (\a. src) src_node))))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) (* If dest is inserted as sibling, src can not have had children. If it had had children, then dest_node which is just a derived copy @@ -3714,7 +3714,7 @@ lemma descendants: by (rule set_eqI) (simp add: descendants_of'_def parent_n_eq) end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma mdb_None: assumes F: "\p'. cte_map p \ descendants_of' p' m' \ False" assumes R: "cdt_relation (swp cte_at s) (cdt s) m'" @@ -4572,7 +4572,7 @@ locale mdb_inv_preserve = \ (\x. sameRegionAs x (cteCap cte)) = (\x. sameRegionAs x (cteCap cte'))" assumes mdb_next:"\p. mdb_next m p = mdb_next m' p" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma preserve_stuff: "valid_dlist m = valid_dlist m' \ ut_revocable' m = ut_revocable' m' @@ -5231,7 +5231,7 @@ lemma cte_map_inj_eq': apply (rule cte_map_inj_eq; fastforce) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_corres: notes split_paired_All[simp del] split_paired_Ex[simp del] trans_state_update'[symmetric,simp] @@ -7231,7 +7231,7 @@ lemma subtree_no_parent: shows "False" using assms by induct (auto simp: parentOf_def mdb_next_unfold) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ensureNoChildren_corres: "p' = cte_map p \ diff --git a/proof/refine/ARM_HYP/CSpace_I.thy b/proof/refine/ARM_HYP/CSpace_I.thy index 8a0e634f9d..67d7ac0e47 100644 --- a/proof/refine/ARM_HYP/CSpace_I.thy +++ b/proof/refine/ARM_HYP/CSpace_I.thy @@ -12,7 +12,7 @@ theory CSpace_I imports ArchAcc_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma capUntypedPtr_simps [simp]: "capUntypedPtr (ThreadCap r) = r" @@ -1558,7 +1558,7 @@ lemma no_mdb_not_target: apply (simp add: no_mdb_def) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma valid_dlist_init: "\ valid_dlist m; m p = Some cte; no_mdb cte \ \ valid_dlist (m (p \ CTE cap initMDBNode))" @@ -1756,7 +1756,7 @@ lemma untyped_inc_init: apply (rule untypedRange_in_capRange)+ apply (simp add:Int_ac) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma valid_nullcaps_init: "\ valid_nullcaps m; cap \ NullCap \ \ valid_nullcaps (m(p \ CTE cap initMDBNode))" by (simp add: valid_nullcaps_def initMDBNode_def nullPointer_def) @@ -1816,7 +1816,7 @@ lemma distinct_zombies_copyE: lemmas distinct_zombies_sameE = distinct_zombies_copyE [where y=x and x=x for x, simplified, OF _ _ _ _ _] -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma capBits_Master: "capBits (capMasterCap cap) = capBits cap" by (clarsimp simp: capMasterCap_def split: capability.split arch_capability.split) diff --git a/proof/refine/ARM_HYP/CSpace_R.thy b/proof/refine/ARM_HYP/CSpace_R.thy index 35de818ba2..60c84b0d21 100644 --- a/proof/refine/ARM_HYP/CSpace_R.thy +++ b/proof/refine/ARM_HYP/CSpace_R.thy @@ -53,7 +53,7 @@ locale mdb_move = modify_map n (mdbNext src_node) (cteMDBNode_update (mdbPrev_update (\_. dest)))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemmas src = m_p @@ -733,7 +733,7 @@ lemma set_cap_not_quite_corres': using cr apply (fastforce simp: c p pspace_relations_def)+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteMove_corres: assumes cr: "cap_relation cap cap'" notes trans_state_update'[symmetric,simp] @@ -1129,7 +1129,7 @@ crunch cteInsert end context mdb_insert begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma n_src_dest: "n \ src \ dest" by (simp add: n_direct_eq) @@ -1649,7 +1649,7 @@ lemma untyped_inc_prev_update: lemma is_derived_badge_derived': "is_derived' m src cap cap' \ badge_derived' cap cap'" by (simp add: is_derived'_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_mdb_chain_0: "\valid_mdb' and pspace_aligned' and pspace_distinct' and (\s. src \ dest) and (\s. cte_wp_at' (is_derived' (ctes_of s) src cap \ cteCap) src s)\ @@ -4569,7 +4569,7 @@ locale mdb_insert_simple = mdb_insert + assumes safe_parent: "safe_parent_for' m src c'" assumes simple: "is_simple_cap' c'" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma dest_no_parent_n: "n \ dest \ p = False" using src simple safe_parent @@ -4759,7 +4759,7 @@ lemma maskedAsFull_revokable_safe_parent: apply (clarsimp simp:isCap_simps is_simple_cap'_def)+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_simple_corres: assumes "cap_relation c c'" "src' = cte_map src" "dest' = cte_map dest" notes trans_state_update'[symmetric,simp] @@ -5133,7 +5133,7 @@ locale mdb_insert_simple' = mdb_insert_simple + fixes n' defines "n' \ modify_map n (mdbNext src_node) (cteMDBNode_update (mdbPrev_update (\_. dest)))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma no_0_n' [intro!]: "no_0 n'" by (auto simp: n'_def) lemmas n_0_simps' [iff] = no_0_simps [OF no_0_n'] @@ -5833,7 +5833,7 @@ lemma updateCapFreeIndex_no_0: apply (clarsimp simp:cte_wp_at_ctes_of)+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_simple_mdb': "\valid_mdb' and pspace_aligned' and pspace_distinct' and (\s. src \ dest) and K (capAligned cap) and (\s. safe_parent_for' (ctes_of s) src cap) and K (is_simple_cap' cap) \ diff --git a/proof/refine/ARM_HYP/Detype_R.thy b/proof/refine/ARM_HYP/Detype_R.thy index d882ae8f71..ba0eee9eff 100644 --- a/proof/refine/ARM_HYP/Detype_R.thy +++ b/proof/refine/ARM_HYP/Detype_R.thy @@ -8,7 +8,7 @@ theory Detype_R imports Retype_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \Establishing that the invariants are maintained when a region of memory is detyped, that is, @@ -86,7 +86,7 @@ lemma descendants_range_inD': done end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma descendants_range'_def2: "descendants_range' cap p = descendants_range_in' (capRange cap) p" @@ -449,7 +449,7 @@ lemma (in detype_locale') deletionIsSafe: and vu: "valid_untyped (cap.UntypedCap d base magnitude idx) s" shows "deletionIsSafe base magnitude s'" proof - - interpret Arch . (* FIXME: arch_split *) + interpret Arch . (* FIXME: arch-split *) note blah[simp del] = atLeastatMost_subset_iff atLeastLessThan_iff Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex atLeastAtMost_iff @@ -530,7 +530,7 @@ proof - thus ?thesis using cte by (auto simp: deletionIsSafe_def) qed -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \Invariant preservation across concrete deletion\ @@ -603,7 +603,7 @@ locale delete_locale = and al: "is_aligned base bits" and safe: "deletionIsSafe base bits s'" -context delete_locale begin interpretation Arch . (*FIXME: arch_split*) +context delete_locale begin interpretation Arch . (*FIXME: arch-split*) lemma valid_objs: "valid_objs' s'" and pa: "pspace_aligned' s'" @@ -847,7 +847,7 @@ lemma sym_refs_TCB_hyp_live': done end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ksASIDMapSafeI: "\ (s,s') \ state_relation; invs s; pspace_aligned' s' \ pspace_distinct' s' \ @@ -1116,7 +1116,7 @@ lemma deleteObjects_corres: done end -context delete_locale begin interpretation Arch . (*FIXME: arch_split*) +context delete_locale begin interpretation Arch . (*FIXME: arch-split*) lemma live_idle_untyped_range': "ko_wp_at' live' p s' \ p = idle_thread_ptr \ p \ base_bits" @@ -1445,7 +1445,7 @@ using vds proof (simp add: invs'_def valid_state'_def valid_pspace'_def valid_mdb'_def valid_mdb_ctes_def, safe) - interpret Arch . (*FIXME: arch_split*) + interpret Arch . (*FIXME: arch-split*) let ?s = state' let ?ran = base_bits @@ -1823,7 +1823,7 @@ lemma doMachineOp_modify: apply (rule ext) apply (simp add: simpler_gets_def simpler_modify_def bind_def) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma deleteObjects_invs': "\cte_wp_at' (\c. cteCap c = UntypedCap d ptr bits idx) p and invs' and ct_active' and sch_act_simple @@ -3230,6 +3230,17 @@ lemma setCTE_doMachineOp_commute: apply (wp|clarsimp|fastforce)+ done +lemma setCTE_when_doMachineOp_commute: + assumes nf: "no_fail Q (doMachineOp x)" + shows "monad_commute (cte_at' dest and pspace_aligned' and pspace_distinct' and Q) + (setCTE dest cte) + (when P (doMachineOp x))" + apply (cases P; simp add: setCTE_doMachineOp_commute nf) + apply (rule monad_commute_guard_imp) + apply (rule return_commute[THEN commute_commute]) + apply simp + done + lemma placeNewObject_valid_arch_state: "\valid_arch_state' and pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) and @@ -3520,6 +3531,7 @@ lemma createObject_setCTE_commute: setCTE_modify_gsUserPages_commute[of \] modify_wp[of "%_. \"] setCTE_doMachineOp_commute + setCTE_when_doMachineOp_commute setCTE_placeNewObject_commute monad_commute_if_weak_r copyGlobalMappings_setCTE_commute[THEN commute_commute] @@ -3677,6 +3689,13 @@ lemma copyGlobalMappings_gsUntypedZeroRanges_commute': (modify (\s. s \ gsUntypedZeroRanges := f (gsUntypedZeroRanges s) \ ))" by (simp add: copyGlobalMappings_def monad_commute_guard_imp return_commute) +lemma dmo_gsUntypedZeroRanges_commute: + "monad_commute \ (modify (\s. s\gsUntypedZeroRanges := f (gsUntypedZeroRanges s)\)) + (doMachineOp m)" + apply (clarsimp simp: monad_commute_def doMachineOp_def) + apply monad_eq + by (auto simp: select_f_def) + lemma createObject_gsUntypedZeroRanges_commute: "monad_commute \ @@ -4572,8 +4591,8 @@ lemma dmo'_when_fail_comm: (* FIXME: move *) lemma dmo'_gets_ksPSpace_comm: - "doMachineOp f >>= (\_. gets ksPSpace >>= m) = - gets ksPSpace >>= (\x. doMachineOp f >>= (\_. m x))" + "doMachineOp f >>= (\y. gets ksPSpace >>= m y) = + gets ksPSpace >>= (\x. doMachineOp f >>= (\y. m y x))" apply (rule ext) apply (clarsimp simp: doMachineOp_def simpler_modify_def simpler_gets_def return_def select_f_def bind_def split_def image_def @@ -4612,14 +4631,15 @@ proof - done qed -lemma dmo'_createObjects'_comm: +lemma dmo'_createObjects'_commute: assumes ef: "empty_fail f" - shows "do _ \ doMachineOp f; x \ createObjects' ptr n obj us; m x od = - do x \ createObjects' ptr n obj us; _ \ doMachineOp f; m x od" - apply (simp add: createObjects'_def bind_assoc split_def unless_def - alignError_def dmo'_when_fail_comm[OF ef] - dmo'_gets_ksPSpace_comm - dmo'_ksPSpace_update_comm'[OF ef, symmetric]) + shows "monad_commute \ (doMachineOp f) (createObjects' ptr n obj us)" + apply (clarsimp simp: createObjects'_def bind_assoc split_def unless_def + alignError_def monad_commute_def + dmo'_when_fail_comm[OF ef] + dmo'_gets_ksPSpace_comm + dmo'_ksPSpace_update_comm'[OF ef, symmetric]) + apply (rule_tac x=s in fun_cong) apply (rule arg_cong_bind1) apply (rule arg_cong_bind1) apply (rename_tac u w) @@ -4628,27 +4648,16 @@ lemma dmo'_createObjects'_comm: apply (simp add: assert_into_when dmo'_when_fail_comm[OF ef]) done -lemma dmo'_gsUserPages_upd_comm: - assumes "empty_fail f" - shows "doMachineOp f >>= (\x. modify (gsUserPages_update g) >>= (\_. m x)) = - modify (gsUserPages_update g) >>= (\_. doMachineOp f >>= m)" -proof - - have ksMachineState_ksPSpace_update: - "\s. ksMachineState (gsUserPages_update g s) = ksMachineState s" - by simp - have updates_independent: - "\f. gsUserPages_update g \ ksMachineState_update f = - ksMachineState_update f \ gsUserPages_update g" - by (rule ext) simp - from assms - show ?thesis - apply (simp add: doMachineOp_def split_def bind_assoc) - apply (simp add: gets_modify_comm2[OF ksMachineState_ksPSpace_update]) - apply (rule arg_cong_bind1) - apply (simp add: empty_fail_def select_f_walk[OF empty_fail_modify] - modify_modify_bind updates_independent) - done -qed +lemmas map_dmo'_createObjects'_comm = dmo'_createObjects'_commute[THEN mapM_x_commute_T] + +lemma dmo'_gsUserPages_upd_commute: + "monad_commute \ (doMachineOp f) (modify (gsUserPages_update g))" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc) + apply monad_eq + apply (auto simp: select_f_def) + done + +lemmas dmo'_gsUserPages_upd_map_commute = dmo'_gsUserPages_upd_commute[THEN mapM_x_commute_T] lemma rewrite_step: assumes rewrite: "\s. P s \ f s = f' s" @@ -4843,6 +4852,13 @@ lemma createTCBs_tcb_at': apply (simp add: objBits_simps shiftl_t2n) done +lemma mapM_x_copyGlobalMappings_noop: + "mapM_x copyGlobalMappings xs = return ()" + apply (induct xs) + apply (simp add: mapM_x_Nil) + apply (simp add: mapM_x_Cons copyGlobalMappings_def) + done + lemma createNewCaps_Cons: assumes cover:"range_cover ptr sz (Types_H.getObjectSize ty us) (Suc (Suc n))" and "valid_pspace' s" "valid_arch_state' s" @@ -5052,259 +5068,141 @@ proof - \ \SmallPageObject\ apply (simp add: Arch_createNewCaps_def - Retype_H.createObject_def createObjects_def bind_assoc - ARM_HYP_H.toAPIType_def ARM_HYP_H.toAPIType_def + Retype_H.createObject_def createObjects_def bind_assoc toAPIType_def ARM_HYP_H.createObject_def placeNewDataObject_def) apply (intro conjI impI) + (* device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_HYP_H.getObjectSize_def - objBits_simps)[6] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_HYP_H.getObjectSize_def + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def pageBits_def add.commute append) - apply ((subst gsUserPages_update gsCNodes_update - gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm - | simp add: modify_modify_bind o_def)+)[1] + apply ((subst gsUserPages_update gsCNodes_update + gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] + | simp add: modify_modify_bind o_def)+)[1] + (* not device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_HYP_H.getObjectSize_def - objBits_simps)[6] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_HYP_H.getObjectSize_def - pageBits_def add.commute append) + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def + pageBits_def add.commute append mapM_x_append mapM_x_singleton) apply (subst gsUserPages_update gsCNodes_update - gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm - | simp add: modify_modify_bind o_def)+ + gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] + | simp add: modify_modify_bind o_def)+ \ \LargePageObject\ - apply (simp add: Arch_createNewCaps_def - Retype_H.createObject_def createObjects_def bind_assoc - ARM_HYP_H.toAPIType_def ARM_HYP_H.toAPIType_def - ARM_HYP_H.createObject_def placeNewDataObject_def) + apply (simp add: Arch_createNewCaps_def Retype_H.createObject_def createObjects_def bind_assoc + ARM_HYP_H.toAPIType_def ARM_HYP_H.createObject_def placeNewDataObject_def) apply (intro conjI impI) + (* device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_HYP_H.getObjectSize_def - objBits_simps)[6] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_HYP_H.getObjectSize_def + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def pageBits_def add.commute append) apply ((subst gsUserPages_update gsCNodes_update - gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm - | simp add: modify_modify_bind o_def)+)[1] + gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] + | simp add: modify_modify_bind o_def)+)[1] + (* not device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - ARM_HYP_H.getObjectSize_def objBits_simps)[6] + ARM_HYP_H.getObjectSize_def objBits_simps)[6] apply (simp add: bind_assoc placeNewObject_def2 objBits_simps ARM_HYP_H.getObjectSize_def - pageBits_def add.commute append) + pageBits_def add.commute append mapM_x_append mapM_x_singleton) apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+ \ \SectionObject\ - apply (simp add: Arch_createNewCaps_def - Retype_H.createObject_def createObjects_def bind_assoc - toAPIType_def ARM_HYP_H.toAPIType_def - ARM_HYP_H.createObject_def placeNewDataObject_def) + apply (simp add: Arch_createNewCaps_def Retype_H.createObject_def createObjects_def bind_assoc + toAPIType_def ARM_HYP_H.createObject_def placeNewDataObject_def) apply (intro conjI impI) + (* device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_HYP_H.getObjectSize_def - objBits_simps)[6] + getObjectSize_def objBits_simps)[6] apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_HYP_H.getObjectSize_def - pageBits_def add.commute append) + getObjectSize_def pageBits_def add.commute append) apply ((subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+)[1] + (* not device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - ARM_HYP_H.getObjectSize_def objBits_simps)[6] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - ARM_HYP_H.getObjectSize_def - pageBits_def add.commute append) + ARM_HYP_H.getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps ARM_HYP_H.getObjectSize_def + pageBits_def add.commute append mapM_x_append mapM_x_singleton) apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+ \ \SuperSectionObject\ - apply (simp add: Arch_createNewCaps_def - Retype_H.createObject_def createObjects_def bind_assoc - toAPIType_def ARM_HYP_H.toAPIType_def - ARM_HYP_H.createObject_def placeNewDataObject_def) + apply (simp add: Arch_createNewCaps_def Retype_H.createObject_def createObjects_def bind_assoc + toAPIType_def ARM_HYP_H.createObject_def placeNewDataObject_def) apply (intro conjI impI) + (* device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_HYP_H.getObjectSize_def - objBits_simps)[6] + getObjectSize_def objBits_simps)[6] apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_HYP_H.getObjectSize_def - pageBits_def add.commute append) + getObjectSize_def pageBits_def add.commute append) apply ((subst gsUserPages_update gsCNodes_update - gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm - | simp add: modify_modify_bind o_def)+)[1] + gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] + | simp add: modify_modify_bind o_def)+)[1] + (* not device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - ARM_HYP_H.getObjectSize_def objBits_simps)[6] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - ARM_HYP_H.getObjectSize_def - pageBits_def add.commute append) + ARM_HYP_H.getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps pageBits_def + ARM_HYP_H.getObjectSize_def add.commute append mapM_x_append mapM_x_singleton) apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm - dmo'_createObjects'_comm dmo'_gsUserPages_upd_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+ - \ \PageTableObject\ - apply (simp add:Arch_createNewCaps_def Retype_H.createObject_def - createObjects_def bind_assoc ARM_HYP_H.toAPIType_def - ARM_HYP_H.createObject_def) - apply (subst monad_eq,rule createObjects_Cons) - apply ((simp add: field_simps shiftl_t2n archObjSize_def - getObjectSize_def ARM_HYP_H.getObjectSize_def - objBits_simps vspace_bits_defs)+)[6] - apply (simp add:bind_assoc placeNewObject_def2) - apply (simp add: field_simps - getObjectSize_def vspace_bits_defs archObjSize_def - ARM_HYP_H.getObjectSize_def placeNewObject_def2 - objBits_simps append) - -\ \PageDirectoryObject\ - apply (simp add:Arch_createNewCaps_def Retype_H.createObject_def - createObjects_def bind_assoc ARM_HYP_H.toAPIType_def - ARM_HYP_H.createObject_def) - apply (subgoal_tac "distinct (map (\n. ptr + (n << 14)) [0.e.((of_nat n)::word32)])") - prefer 2 - apply (clarsimp simp: objBits_simps archObjSize_def vspace_bits_defs - ARM_HYP_H.getObjectSize_def) - apply (subst upto_enum_word) - apply (clarsimp simp:distinct_map) - apply (frule range_cover.range_cover_n_le) - apply (frule range_cover.range_cover_n_less) - apply (rule conjI) - apply (clarsimp simp:inj_on_def) - apply (rule ccontr) - apply (erule_tac bnd = "2^(word_bits - 14)" in shift_distinct_helper[rotated 3]) - apply simp - apply (simp add:word_bits_def) - apply (erule less_le_trans[OF word_of_nat_less]) - apply (simp add: word_of_nat_le word_bits_def) - apply (erule less_le_trans[OF word_of_nat_less]) - apply (simp add:word_of_nat_le word_bits_def) - apply (frule range_cover.unat_of_nat_n[OF range_cover_le[where n = n]]) - apply simp - apply (rule ccontr) - apply simp - apply (drule of_nat_inj32[THEN iffD1,rotated -1]) - apply (simp_all add: word_bits_def)[3] - apply (clarsimp) - apply (erule_tac bnd = "2^(word_bits - 14)" in shift_distinct_helper[rotated 3]) - apply simp - apply (simp add:word_bits_def) - apply (simp add:word_of_nat_less word_bits_def) - apply (erule less_le_trans[OF word_of_nat_less]) - apply (simp add:word_of_nat_le word_bits_def) - apply (rule ccontr) - apply (frule range_cover.unat_of_nat_n[OF range_cover_le[where n = n]]) - apply simp - apply simp - apply (drule of_nat_inj32[THEN iffD1,rotated -1]) - apply (simp_all add: word_bits_def)[3] - apply (subst monad_eq,rule createObjects_Cons) - apply ((simp add: field_simps shiftl_t2n vspace_bits_defs archObjSize_def - ARM_HYP_H.getObjectSize_def - objBits_simps ptBits_def)+)[6] - apply (simp add:objBits_simps archObjSize_def vspace_bits_defs ARM_HYP_H.getObjectSize_def) - apply (simp add:bind_assoc) - apply (simp add: placeNewObject_def2[where val = "makeObject::ARM_HYP_H.pde",simplified,symmetric]) - apply (rule_tac Q = "\r s. valid_arch_state' s \ - (\x\of_nat n. page_directory_at' (ptr + (x << 14)) s) \ Q s" for Q in monad_eq_split) - apply (rule sym) - apply (subst bind_assoc[symmetric]) - apply (subst monad_commute_simple) - apply (rule commute_commute[OF monad_commute_split]) - apply (rule placeNewObject_doMachineOp_commute) - apply (rule mapM_x_commute[where f = id]) - apply (rule placeNewObject_copyGlobalMapping_commute) - apply (wp copyGlobalMappings_pspace_no_overlap' mapM_x_wp'| clarsimp)+ - apply (clarsimp simp:objBits_simps archObjSize_def vspace_bits_defs word_bits_conv) - apply assumption (* resolve assumption , yuck *) - apply (simp add:append mapM_x_append bind_assoc) - apply (rule monad_eq_split[where Q = "\ r s. pspace_aligned' s \ pspace_distinct' s - \ valid_arch_state' s \ (\r \ of_nat n. page_directory_at' (ptr + (r << 14)) s) - \ page_directory_at' (ptr + ((1 + of_nat n) << 14)) s"]) - apply (rule monad_eq_split[where Q = "\ r s. pspace_aligned' s \ pspace_distinct' s - \ valid_arch_state' s \ (\r \ of_nat n. page_directory_at' (ptr + (r << 14)) s) - \ page_directory_at' (ptr + ((1 + of_nat n) << 14)) s"]) - apply (subst monad_commute_simple) - apply (rule doMachineOp_copyGlobalMapping_commute) - apply (clarsimp simp:field_simps) - apply (simp add:field_simps mapM_x_singleton) - apply (rule monad_eq_split[where Q = "\ r s. pspace_aligned' s \ pspace_distinct' s - \ valid_arch_state' s \ page_directory_at' (ptr + (1 + of_nat n << 14)) s"]) - apply (subst doMachineOp_bind) - apply (wp empty_fail_mapM_x empty_fail_cleanCacheRange_PoU)+ - apply (simp add:bind_assoc objBits_simps field_simps archObjSize_def shiftL_nat) - apply wp - apply simp - apply (rule mapM_x_wp') - apply (rule hoare_pre) - apply (wp copyGlobalMappings_pspace_no_overlap' | clarsimp)+ - apply (clarsimp simp:page_directory_at'_def) - apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift) - apply ((clarsimp simp:page_directory_at'_def)+)[2] - apply (wp placeNewObject_pspace_aligned' placeNewObject_pspace_distinct') - apply (simp add:placeNewObject_def2 field_simps) - apply (rule hoare_vcg_conj_lift) - apply (rule createObjects'_wp_subst) - apply (wp createObjects_valid_arch[where sz = 14]) - apply (rule hoare_vcg_conj_lift) - apply (clarsimp simp:page_directory_at'_def) - apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift createObjects'_typ_at[where sz = 14]) - apply (rule hoare_strengthen_post[OF createObjects'_page_directory_at'[where sz = 14]]) - apply simp - apply (clarsimp simp:objBits_simps page_directory_at'_def vspace_bits_defs - field_simps archObjSize_def word_bits_conv range_cover_full - aligned_add_aligned range_cover.aligned is_aligned_shiftl_self) - apply (frule pspace_no_overlap'_le2[where ptr' = "(ptr + (1 + of_nat n << 14))"]) - apply (subst shiftl_t2n,subst mult.commute, subst suc_of_nat) - apply (rule order_trans[OF range_cover_bound,where n1 = "1 + n"]) - apply (erule range_cover_le,simp) - apply simp - apply (rule word_sub_1_le) - apply (drule(1) range_cover_no_0[where p = "n+1"]) - apply simp - apply simp - apply (erule(1) range_cover_tail_mask) - apply (rule hoare_vcg_conj_lift) - apply (rule createObjects'_wp_subst) - apply (wp createObjects_valid_arch[where sz = sz]) - apply (wp createObjects'_page_directory_at'[where sz = sz] - createObjects'_psp_aligned[where sz = sz] - createObjects'_psp_distinct[where sz = sz] hoare_vcg_imp_lift - createObjects'_pspace_no_overlap[where sz = sz] - | simp add:objBits_simps archObjSize_def vspace_bits_defs field_simps)+ - apply (drule range_cover_le[where n = "Suc n"]) - apply simp - apply (clarsimp simp:word_bits_def valid_pspace'_def vspace_bits_defs) - apply (clarsimp simp:aligned_add_aligned[OF range_cover.aligned] is_aligned_shiftl_self word_bits_def vspace_bits_defs)+ -\ \VCPUObject\ - apply (simp add: Arch_createNewCaps_def - Retype_H.createObject_def createObjects_def bind_assoc - ARM_HYP_H.toAPIType_def ARM_HYP_H.toAPIType_def - ARM_HYP_H.createObject_def placeNewDataObject_def) - apply (subst monad_eq, rule createObjects_Cons) - apply (simp_all add: field_simps shiftl_t2n vcpu_bits_def vspace_bits_defs - getObjectSize_def ARM_HYP_H.getObjectSize_def archObjSize_def - objBits_simps)[7] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_HYP_H.getObjectSize_def - vcpu_bits_def pageBits_def add.commute append) - done + \ \PageTableObject\ + apply (simp add: Arch_createNewCaps_def Retype_H.createObject_def createObjects_def bind_assoc + ARM_HYP_H.toAPIType_def ARM_HYP_H.createObject_def) + apply (subst monad_eq, rule createObjects_Cons) + apply ((simp add: field_simps shiftl_t2n vspace_bits_defs archObjSize_def + getObjectSize_def objBits_simps ptBits_def)+)[6] + apply (simp add: bind_assoc placeNewObject_def2) + apply (simp add: field_simps bind_assoc gets_modify_def + getObjectSize_def placeNewObject_def2 objBits_simps append mapM_x_append + mapM_x_singleton archObjSize_def) + apply (subst monad_commute_simple'[OF map_dmo'_createObjects'_comm] + | simp add: modify_modify_bind o_def + | simp only: o_def cong: if_cong)+ + apply (simp add: vspace_bits_defs) + \ \PageDirectoryObject\ + apply (simp add: Arch_createNewCaps_def toAPIType_def bind_assoc + createObjects_def createObject_def ARM_HYP_H.createObject_def) + apply (subst monad_eq, rule createObjects_Cons; simp?) + apply (simp add: objBits_simps getObjectSize_def archObjSize_def vspace_bits_defs) + apply (simp add: getObjectSize_def placeNewObject_def2 objBits_simps append mapM_x_append + bind_assoc mapM_x_singleton archObjSize_def) + apply (simp add: mapM_x_copyGlobalMappings_noop copyGlobalMappings_def) + apply (subst monad_commute_simple'[OF map_dmo'_createObjects'_comm] + | simp add: modify_modify_bind o_def + | simp only: o_def cong: if_cong)+ + apply (simp add: vspace_bits_defs field_simps) + \ \VCPUObject\ + apply (simp add: Arch_createNewCaps_def Retype_H.createObject_def createObjects_def bind_assoc + ARM_HYP_H.toAPIType_def ARM_HYP_H.createObject_def placeNewDataObject_def) + apply (subst monad_eq, rule createObjects_Cons) + apply (simp_all add: field_simps shiftl_t2n vcpu_bits_def vspace_bits_defs + getObjectSize_def archObjSize_def objBits_simps)[7] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps + getObjectSize_def vcpu_bits_def pageBits_def add.commute append) + done qed lemma createObject_def2: @@ -5525,21 +5423,20 @@ lemma ArchCreateObject_pspace_no_overlap': (ptr + (of_nat n << APIType_capBits ty userSize)) userSize d \\archCap. pspace_no_overlap' (ptr + (1 + of_nat n << APIType_capBits ty userSize)) sz\" - apply (rule hoare_pre) - apply (clarsimp simp:ARM_HYP_H.createObject_def) - apply wpc + supply if_split[split del] + apply (clarsimp simp:ARM_HYP_H.createObject_def) + apply wpc apply (wp doMachineOp_psp_no_overlap - createObjects'_pspace_no_overlap2 hoare_when_weak_wp - copyGlobalMappings_pspace_no_overlap' - createObjects'_psp_aligned[where sz = sz] - createObjects'_psp_distinct[where sz = sz] - | simp add: placeNewObject_def2 word_shiftl_add_distrib - | simp add: placeNewObject_def2 word_shiftl_add_distrib - | simp add: placeNewDataObject_def placeNewObject_def2 word_shiftl_add_distrib - field_simps split del: if_splits - | clarsimp simp add: add.assoc[symmetric],wp createObjects'_pspace_no_overlap2[where n =0 and sz = sz,simplified] - | clarsimp simp add: APIType_capBits_def objBits_simps pageBits_def)+ - + createObjects'_pspace_no_overlap2 + createObjects'_psp_aligned[where sz = sz] + createObjects'_psp_distinct[where sz = sz] + | simp add: placeNewObject_def2 word_shiftl_add_distrib + | simp add: copyGlobalMappings_def + | simp add: placeNewDataObject_def placeNewObject_def2 word_shiftl_add_distrib + field_simps + | clarsimp simp add: add.assoc[symmetric], + wp createObjects'_pspace_no_overlap2[where n =0 and sz = sz,simplified] + | clarsimp simp add: APIType_capBits_def objBits_simps pageBits_def)+ apply (clarsimp simp: conj_comms) apply (frule(1) range_cover_no_0[where p = n]) apply simp @@ -5555,7 +5452,7 @@ lemma ArchCreateObject_pspace_no_overlap': apply simp apply (frule pspace_no_overlap'_le2) apply (rule range_cover_compare_offset) - apply simp+ + apply simp+ apply (clarsimp simp:word_shiftl_add_distrib ,simp add:field_simps) apply (clarsimp simp:add.assoc[symmetric]) @@ -5566,9 +5463,9 @@ lemma ArchCreateObject_pspace_no_overlap': apply (metis numeral_2_eq_2) apply (simp add:shiftl_t2n field_simps) apply (intro conjI allI) - apply (clarsimp simp: field_simps word_bits_conv archObjSize_def vspace_bits_defs - APIType_capBits_def shiftl_t2n objBits_simps - | rule conjI | erule range_cover_le,simp)+ + apply (clarsimp simp: field_simps word_bits_conv archObjSize_def vspace_bits_defs + APIType_capBits_def shiftl_t2n objBits_simps + | rule conjI | erule range_cover_le,simp)+ done lemma to_from_apiTypeD: "toAPIType ty = Some x \ ty = fromAPIType x" diff --git a/proof/refine/ARM_HYP/EmptyFail.thy b/proof/refine/ARM_HYP/EmptyFail.thy index 741a9ba837..9db1629920 100644 --- a/proof/refine/ARM_HYP/EmptyFail.thy +++ b/proof/refine/ARM_HYP/EmptyFail.thy @@ -62,7 +62,7 @@ lemma empty_fail_getSlotCap [intro!, wp, simp]: "empty_fail (getSlotCap a)" unfolding getSlotCap_def by fastforce -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma empty_fail_getObject: assumes "\b c d. empty_fail (loadObject x b c d::'a :: pspace_storable kernel)" diff --git a/proof/refine/ARM_HYP/EmptyFail_H.thy b/proof/refine/ARM_HYP/EmptyFail_H.thy index 477cfbf436..49f3728936 100644 --- a/proof/refine/ARM_HYP/EmptyFail_H.thy +++ b/proof/refine/ARM_HYP/EmptyFail_H.thy @@ -13,7 +13,7 @@ crunch_ignore (empty_fail) CSpaceDecls_H.resolveAddressBits doMachineOp suspend restart schedule) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas forM_empty_fail[intro!, wp, simp] = empty_fail_mapM[simplified forM_def[symmetric]] lemmas forM_x_empty_fail[intro!, wp, simp] = empty_fail_mapM_x[simplified forM_x_def[symmetric]] diff --git a/proof/refine/ARM_HYP/Finalise_R.thy b/proof/refine/ARM_HYP/Finalise_R.thy index 6a29f383d0..2e28a9c57a 100644 --- a/proof/refine/ARM_HYP/Finalise_R.thy +++ b/proof/refine/ARM_HYP/Finalise_R.thy @@ -10,7 +10,7 @@ imports InterruptAcc_R Retype_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare doUnbindNotification_def[simp] @@ -187,7 +187,7 @@ locale mdb_empty = slot (cteCap_update (%_. capability.NullCap))) slot (cteMDBNode_update (const nullMDBNode))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemmas m_slot_prev = m_p_prev lemmas m_slot_next = m_p_next @@ -1392,7 +1392,7 @@ lemma deletedIRQHandler_irqs_masked'[wp]: apply (simp add: irqs_masked'_def) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch emptySlot for irqs_masked'[wp]: "irqs_masked'" @@ -2028,7 +2028,7 @@ lemma (in vmdb) isFinal_untypedParent: sameObjectAs_sym) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma no_fail_isFinalCapability [wp]: "no_fail (valid_mdb' and cte_wp_at' ((=) cte) p) (isFinalCapability cte)" @@ -3274,7 +3274,7 @@ lemma suspend_tcbSchedNext_tcbSchedPrev_None: unfolding suspend_def by (wpsimp wp: hoare_drop_imps tcbSchedDequeue_tcbSchedNext_tcbSchedPrev_None_obj_at') -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma archThreadSet_tcbSchedPrevNext[wp]: "archThreadSet f t' \obj_at' (\tcb. P (tcbSchedNext tcb) (tcbSchedPrev tcb)) t\" @@ -3404,7 +3404,7 @@ lemma suspend_cte_wp_at': | simp add: x)+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch deleteASIDPool for cte_wp_at'[wp]: "cte_wp_at' P p" @@ -3742,7 +3742,7 @@ lemma finaliseCap_valid_cap[wp]: done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch dissociateVCPUTCB for nosch[wp]: "\s. P (ksSchedulerAction s)" @@ -3809,7 +3809,7 @@ lemma (in delete_one) deletingIRQHandler_corres: apply (clarsimp simp: cte_wp_at_ctes_of) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma sym_refs_vcpu_tcb: "\ ko_at (ArchObj (VCPU vcpu)) v s; vcpu_tcb vcpu = Some t; sym_refs (state_hyp_refs_of s) \ \ @@ -4015,7 +4015,7 @@ lemmas getCTE_no_0_obj'_helper = getCTE_inv hoare_strengthen_post[where Q'="\_. no_0_obj'" and P=no_0_obj' and f="getCTE slot" for slot] -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) context notes option.case_cong_weak[cong] begin @@ -4087,7 +4087,7 @@ lemma finaliseCap_corres: apply (rule corres_guard_imp [OF arch_finaliseCap_corres], (fastforce simp: valid_sched_def)+) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma arch_recycleCap_improve_cases: "\ \ isPageCap cap; \ isPageTableCap cap; \ isPageDirectoryCap cap;\ isVCPUCap cap; \ isASIDControlCap cap \ \ (if isASIDPoolCap cap then v else undefined) = v" diff --git a/proof/refine/ARM_HYP/Init_R.thy b/proof/refine/ARM_HYP/Init_R.thy index 589a07a9a6..9bf155484b 100644 --- a/proof/refine/ARM_HYP/Init_R.thy +++ b/proof/refine/ARM_HYP/Init_R.thy @@ -10,7 +10,7 @@ imports begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* This provides a very simple witness that the state relation used in the first refinement proof is diff --git a/proof/refine/ARM_HYP/InterruptAcc_R.thy b/proof/refine/ARM_HYP/InterruptAcc_R.thy index 7868482bdb..810b681f05 100644 --- a/proof/refine/ARM_HYP/InterruptAcc_R.thy +++ b/proof/refine/ARM_HYP/InterruptAcc_R.thy @@ -23,7 +23,7 @@ crunch get_irq_slot crunch getIRQSlot for inv[wp]: "P" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setIRQState_corres: "irq_state_relation state state' \ diff --git a/proof/refine/ARM_HYP/Interrupt_R.thy b/proof/refine/ARM_HYP/Interrupt_R.thy index 91a901b911..7f4654c7ef 100644 --- a/proof/refine/ARM_HYP/Interrupt_R.thy +++ b/proof/refine/ARM_HYP/Interrupt_R.thy @@ -14,7 +14,7 @@ begin context Arch begin -(*FIXME: arch_split: move up *) +(*FIXME: arch-split: move up *) requalify_types irqcontrol_invocation @@ -22,11 +22,11 @@ lemmas [crunch_def] = decodeIRQControlInvocation_def performIRQControl_def context begin global_naming global -(*FIXME: arch_split: move up *) +(*FIXME: arch-split: move up *) requalify_types Invocations_H.irqcontrol_invocation -(*FIXME: arch_split*) +(*FIXME: arch-split*) requalify_facts Interrupt_H.decodeIRQControlInvocation_def Interrupt_H.performIRQControl_def @@ -48,7 +48,7 @@ consts primrec arch_irq_control_inv_relation :: "arch_irq_control_invocation \ Arch.irqcontrol_invocation \ bool" where - "arch_irq_control_inv_relation (ARM_A.ArchIRQControlIssue i ptr1 ptr2 t) x = + "arch_irq_control_inv_relation (ARM_HYP_A.ArchIRQControlIssue i ptr1 ptr2 t) x = (x = ARM_HYP_H.IssueIRQHandler i (cte_map ptr1) (cte_map ptr2) t)" primrec @@ -90,7 +90,7 @@ where ex_cte_cap_to' ptr and real_cte_at' ptr and (Not o irq_issued' irq) and K (irq \ maxIRQ))" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma decodeIRQHandlerInvocation_corres: "\ list_all2 cap_relation (map fst caps) (map fst caps'); @@ -696,7 +696,7 @@ lemma timerTick_corres: lemma corres_return_VGICMaintenance [corres]: "corres ((=) o arch_fault_map) (K (a=b)) \ - (return (ARM_A.VGICMaintenance a)) (return (ARM_HYP_H.VGICMaintenance b))" + (return (ARM_HYP_A.VGICMaintenance a)) (return (ARM_HYP_H.VGICMaintenance b))" by simp lemma corres_gets_numlistregs [corres]: @@ -783,8 +783,8 @@ crunch vgicUpdateLR and ksCurThread[wp]: "\s. P (ksCurThread s)" lemma virqSetEOIIRQEN_eq[simp]: - "ARM_HYP_H.virqSetEOIIRQEN = ARM_A.virqSetEOIIRQEN" - unfolding virqSetEOIIRQEN_def ARM_A.virqSetEOIIRQEN_def + "ARM_HYP_H.virqSetEOIIRQEN = ARM_HYP_A.virqSetEOIIRQEN" + unfolding virqSetEOIIRQEN_def ARM_HYP_A.virqSetEOIIRQEN_def by (rule ext) auto lemma vgic_maintenance_corres [corres]: @@ -923,7 +923,7 @@ lemma vppiEvent_corres: apply (rule_tac Q'="\rv. tcb_at rv and einvs and (\_. valid_fault (ExceptionTypes_A.fault.ArchFault - (ARM_A.VPPIEvent irq)))" + (ARM_HYP_A.VPPIEvent irq)))" in hoare_post_imp) apply (clarsimp cong: imp_cong conj_cong simp: not_pred_tcb runnable_eq pred_conj_def) apply (strengthen st_tcb_ex_cap'[where P=active], diff --git a/proof/refine/ARM_HYP/Invariants_H.thy b/proof/refine/ARM_HYP/Invariants_H.thy index 60be16f4ba..0ccf609978 100644 --- a/proof/refine/ARM_HYP/Invariants_H.thy +++ b/proof/refine/ARM_HYP/Invariants_H.thy @@ -48,7 +48,7 @@ lemma le_maxDomain_eq_less_numDomains: by (auto simp: Kernel_Config.numDomains_def maxDomain_def word_le_nat_alt) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) \ \---------------------------------------------------------------------------\ section "Invariants on Executable Spec" @@ -341,7 +341,7 @@ where | KOKernelData => False | KOArch ako => hyp_live' ko" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec azobj_refs' :: "arch_capability \ word32 set" where @@ -427,7 +427,7 @@ where section "Valid caps and objects (Haskell)" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec acapBits :: "arch_capability \ nat" where @@ -484,7 +484,7 @@ definition -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition page_table_at' :: "word32 \ kernel_state \ bool" @@ -1527,7 +1527,7 @@ locale mdb_order = mdb_next + \ \---------------------------------------------------------------------------\ section "Alternate split rules for preserving subgoal order" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ntfn_splits[split]: " P (case ntfn of Structures_H.ntfn.IdleNtfn \ f1 | Structures_H.ntfn.ActiveNtfn x \ f2 x @@ -3272,7 +3272,7 @@ lemma ex_cte_cap_to'_pres: apply assumption apply simp done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma page_directory_pde_atI': "\ page_directory_at' p s; x < 2 ^ (pdBits - pdeBits) \ \ pde_at' (p + (x << pdeBits)) s" by (simp add: page_directory_at'_def pageBits_def pdBits_def pdeBits_def) @@ -3431,7 +3431,7 @@ lemma vms_sch_act_update'[iff]: "valid_machine_state' (ksSchedulerAction_update f s) = valid_machine_state' s" by (simp add: valid_machine_state'_def ) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma objBitsT_simps: "objBitsT EndpointT = epSizeBits" "objBitsT NotificationT = ntfnSizeBits" diff --git a/proof/refine/ARM_HYP/Invocations_R.thy b/proof/refine/ARM_HYP/Invocations_R.thy index 60ffad1ed0..5f49d06d96 100644 --- a/proof/refine/ARM_HYP/Invocations_R.thy +++ b/proof/refine/ARM_HYP/Invocations_R.thy @@ -8,7 +8,7 @@ theory Invocations_R imports Invariants_H begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma invocationType_eq[simp]: "invocationType = invocation_type" diff --git a/proof/refine/ARM_HYP/IpcCancel_R.thy b/proof/refine/ARM_HYP/IpcCancel_R.thy index 4c780afdf5..de1545c6c4 100644 --- a/proof/refine/ARM_HYP/IpcCancel_R.thy +++ b/proof/refine/ARM_HYP/IpcCancel_R.thy @@ -9,7 +9,7 @@ imports Schedule_R "Lib.SimpStrategy" begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch cancelAllIPC for aligned'[wp]: pspace_aligned' @@ -351,7 +351,7 @@ lemma cte_map_tcb_2: "cte_map (t, tcb_cnode_index 2) = t + 2*2^cte_level_bits" by (simp add: cte_map_def tcb_cnode_index_def to_bl_1) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cte_wp_at_master_reply_cap_to_ex_rights: "cte_wp_at (is_master_reply_cap_to t) ptr @@ -525,7 +525,7 @@ lemma (in delete_one) cancelIPC_ReplyCap_corres: od) od)" proof - - interpret Arch . (*FIXME: arch_split*) + interpret Arch . (*FIXME: arch-split*) show ?thesis apply (simp add: reply_cancel_ipc_def getThreadReplySlot_def locateSlot_conv liftM_def tcbReplySlot_def @@ -658,7 +658,7 @@ crunch setNotification lemma sch_act_simple_not_t[simp]: "sch_act_simple s \ sch_act_not t s" by (clarsimp simp: sch_act_simple_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch setNotification for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers @@ -2064,7 +2064,7 @@ lemma cancelAll_unlive_helper: apply (clarsimp elim!: ko_wp_at'_weakenE) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setObject_ko_wp_at': fixes v :: "'a :: pspace_storable" assumes x: "\v :: 'a. updateObject v = updateObject_default v" diff --git a/proof/refine/ARM_HYP/Ipc_R.thy b/proof/refine/ARM_HYP/Ipc_R.thy index 8c9671f1a8..2d754dcad3 100644 --- a/proof/refine/ARM_HYP/Ipc_R.thy +++ b/proof/refine/ARM_HYP/Ipc_R.thy @@ -8,7 +8,7 @@ theory Ipc_R imports Finalise_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas lookup_slot_wrapper_defs'[simp] = lookupSourceSlot_def lookupTargetSlot_def lookupPivotSlot_def @@ -19,7 +19,7 @@ lemma getMessageInfo_corres: apply (rule corres_guard_imp) apply (unfold get_message_info_def getMessageInfo_def fun_app_def) apply (simp add: ARM_HYP_H.msgInfoRegister_def - ARM_HYP.msgInfoRegister_def ARM_A.msg_info_register_def) + ARM_HYP.msgInfoRegister_def ARM_HYP_A.msg_info_register_def) apply (rule corres_split_eqr[OF asUser_getRegister_corres]) apply (rule corres_trivial, simp add: message_info_from_data_eqv) apply (wp | simp)+ diff --git a/proof/refine/ARM_HYP/KHeap_R.thy b/proof/refine/ARM_HYP/KHeap_R.thy index 132cb376d7..e37ba0469c 100644 --- a/proof/refine/ARM_HYP/KHeap_R.thy +++ b/proof/refine/ARM_HYP/KHeap_R.thy @@ -21,7 +21,7 @@ lemma koTypeOf_injectKO: apply (simp add: project_koType[symmetric]) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setObject_modify_variable_size: fixes v :: "'a :: pspace_storable" shows @@ -94,7 +94,7 @@ end translations (type) "'a kernel" <=(type) "kernel_state \ ('a \ kernel_state) set \ bool" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma no_fail_loadObject_default [wp]: "no_fail (\s. \obj. projectKO_opt ko = Some (obj::'a) \ @@ -1035,7 +1035,7 @@ lemma obj_relation_cut_same_type: pte_relation_def pde_relation_def split: Structures_A.kernel_object.split_asm if_split_asm Structures_H.kernel_object.split_asm - ARM_A.arch_kernel_obj.split_asm arch_kernel_object.split_asm) + ARM_HYP_A.arch_kernel_obj.split_asm arch_kernel_object.split_asm) done definition exst_same :: "Structures_H.tcb \ Structures_H.tcb \ bool" diff --git a/proof/refine/ARM_HYP/LevityCatch.thy b/proof/refine/ARM_HYP/LevityCatch.thy index 064702ca9d..fa85e23ea1 100644 --- a/proof/refine/ARM_HYP/LevityCatch.thy +++ b/proof/refine/ARM_HYP/LevityCatch.thy @@ -20,7 +20,7 @@ lemma magnitudeCheck_assert: split: option.split) apply fastforce done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas makeObject_simps = makeObject_endpoint makeObject_notification makeObject_cte makeObject_tcb makeObject_user_data makeObject_pde makeObject_pte @@ -55,7 +55,7 @@ lemma updateObject_default_inv: "\P\ updateObject_default obj ko x y n \\rv. P\" unfolding updateObject_default_def by (simp, wp magnitudeCheck_inv alignCheck_inv projectKO_inv, simp) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma to_from_apiType [simp]: "toAPIType (fromAPIType x) = Some x" by (cases x) (auto simp add: fromAPIType_def ARM_HYP_H.fromAPIType_def toAPIType_def ARM_HYP_H.toAPIType_def) diff --git a/proof/refine/ARM_HYP/Machine_R.thy b/proof/refine/ARM_HYP/Machine_R.thy index 4dfc5cef08..76ffc6375b 100644 --- a/proof/refine/ARM_HYP/Machine_R.thy +++ b/proof/refine/ARM_HYP/Machine_R.thy @@ -22,7 +22,7 @@ lemma irq_state_independent_HI[intro!, simp]: \ irq_state_independent_H P" by (simp add: irq_state_independent_H_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma dmo_getirq_inv[wp]: "irq_state_independent_H P \ \P\ doMachineOp (getActiveIRQ in_kernel) \\rv. P\" diff --git a/proof/refine/ARM_HYP/PageTableDuplicates.thy b/proof/refine/ARM_HYP/PageTableDuplicates.thy index 15d72ae7b9..28035b3ced 100644 --- a/proof/refine/ARM_HYP/PageTableDuplicates.thy +++ b/proof/refine/ARM_HYP/PageTableDuplicates.thy @@ -8,7 +8,7 @@ theory PageTableDuplicates imports Syscall_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma set_ntfn_valid_duplicate' [wp]: "\\s. vs_valid_duplicates' (ksPSpace s)\ diff --git a/proof/refine/ARM_HYP/Refine.thy b/proof/refine/ARM_HYP/Refine.thy index 4767fe0de3..2854ae9318 100644 --- a/proof/refine/ARM_HYP/Refine.thy +++ b/proof/refine/ARM_HYP/Refine.thy @@ -16,7 +16,7 @@ imports PageTableDuplicates begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \User memory content is the same on both levels\ lemma typ_at_AUserDataI: diff --git a/proof/refine/ARM_HYP/Retype_R.thy b/proof/refine/ARM_HYP/Retype_R.thy index 1d53e02770..1f911ade1a 100644 --- a/proof/refine/ARM_HYP/Retype_R.thy +++ b/proof/refine/ARM_HYP/Retype_R.thy @@ -12,7 +12,7 @@ theory Retype_R imports VSpace_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition APIType_map2 :: "kernel_object + ARM_HYP_H.object_type \ Structures_A.apiobject_type" @@ -29,8 +29,8 @@ where | Inr SectionObject \ ArchObject SectionObj | Inr SuperSectionObject \ ArchObject SuperSectionObj | Inl (KOArch (KOASIDPool _)) \ ArchObject ASIDPoolObj -\ \ | Inl (KOArch (KOVCPU _)) \ ArchObject ARM_A.VCPUObj\ \ \inl? inr?\ - | Inr VCPUObject \ ArchObject ARM_A.VCPUObj \ \inl? inr?\ +\ \ | Inl (KOArch (KOVCPU _)) \ ArchObject ARM_HYP_A.VCPUObj\ \ \inl? inr?\ + | Inr VCPUObject \ ArchObject ARM_HYP_A.VCPUObj \ \inl? inr?\ | _ \ ArchObject SmallPageObj" lemma placeNewObject_def2: @@ -1176,7 +1176,7 @@ end global_interpretation update_gs: PSpace_update_eq "update_gs ty us ptrs" by (simp add: PSpace_update_eq_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma update_gs_id: "tp \ no_gs_types \ update_gs tp us addrs = id" @@ -1628,7 +1628,7 @@ end interpretation retype_region2_ext_extended: is_extended "retype_region2_ext ptrs type" by (unfold_locales; wp) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "retype_region2_extra_ext ptrs type \ @@ -1647,7 +1647,7 @@ end interpretation retype_region2_extra_ext_extended: is_extended "retype_region2_extra_ext ptrs type" by (unfold_locales; wp) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition retype_region2 :: "obj_ref \ nat \ nat \ Structures_A.apiobject_type \ bool \ (obj_ref list,'z::state_ext) s_monad" @@ -2375,7 +2375,7 @@ proof - apply (clarsimp simp: ARM_HYP_H.toAPIType_def APIType_capBits_def split: ARM_HYP_H.object_type.splits) \ \SmallPageObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply ((wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified] @@ -2383,7 +2383,7 @@ proof - | simp add: objBits_if_dev pageBits_def ptr range_cover_n_wb)+) apply (simp add:pageBits_def ptr word_bits_def) \ \LargePageObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply (wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified] @@ -2392,7 +2392,7 @@ proof - apply (simp add:pageBits_def ptr word_bits_def) \ \SectionObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply (wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified] @@ -2401,7 +2401,7 @@ proof - apply (simp add: pageBits_def ptr word_bits_def) \ \SuperSectionObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply (wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified] @@ -2410,7 +2410,7 @@ proof - apply (simp add:pageBits_def ptr word_bits_def) \ \PageTableObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits) apply (simp only: imp_conv_disj page_table_at'_def typ_at_to_obj_at_arches) @@ -2427,8 +2427,7 @@ proof - apply (clarsimp simp: objBits_simps archObjSize_def vspace_bits_defs) apply clarsimp \ \PageDirectoryObject\ - apply (wp hoare_vcg_const_Ball_lift) - apply (wp mapM_x_wp' ) + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits) apply (simp only: imp_conv_disj page_directory_at'_def typ_at_to_obj_at_arches) @@ -2692,9 +2691,9 @@ lemma corres_retype: done lemma init_arch_objects_APIType_map2: - "init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs = + "init_arch_objects (APIType_map2 (Inr ty)) dev ptr bits sz refs = (case ty of APIObjectType _ \ return () - | _ \ init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs)" + | _ \ init_arch_objects (APIType_map2 (Inr ty)) dev ptr bits sz refs)" apply (clarsimp split: ARM_HYP_H.object_type.split) apply (simp add: init_arch_objects_def APIType_map2_def split: apiobject_type.split) @@ -2796,7 +2795,7 @@ locale retype_mdb = vmdb + assumes 0: "\P 0" defines "n \ \p. if P p then Some makeObject else m p" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma no_0_n: "no_0 n" using no_0 by (simp add: no_0_def n_def 0) @@ -3127,7 +3126,7 @@ lemma caps_no_overlapD'': apply blast done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma valid_untyped'_helper: assumes valid : "valid_cap' c s" and cte_at : "cte_wp_at' (\cap. cteCap cap = c) q s" @@ -4369,9 +4368,6 @@ lemma createNewCaps_idle'[wp]: crunch createNewCaps for ksArch[wp]: "\s. P (ksArchState s)" (simp: crunch_simps unless_def wp: crunch_wps) -crunch createNewCaps - for it[wp]: "\s. P (ksIdleThread s)" - (simp: crunch_simps unless_def wp: crunch_wps updateObject_default_inv) crunch createNewCaps for gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" (simp: crunch_simps unless_def wp: crunch_wps updateObject_default_inv) @@ -4497,7 +4493,9 @@ lemma createNewCaps_pde_mappings'[wp]: split del: if_split cong: option.case_cong object_type.case_cong) apply (rule hoare_pre) - apply (wp mapM_x_copyGlobalMappings_pde_mappings' | wpc + apply (wp mapM_x_copyGlobalMappings_pde_mappings' + mapM_x_wp'[where f="\r. doMachineOp (m r)" for m] + | wpc | simp split del: if_split)+ apply (rule_tac P="range_cover ptr sz (APIType_capBits ty us) n \ n\ 0" in hoare_gen_asm) apply (rule hoare_strengthen_post) @@ -4801,6 +4799,9 @@ crunch copyGlobalMappings, doMachineOp for pspace_domain_valid[wp]: "pspace_domain_valid" (wp: crunch_wps) +crunch doMachineOp + for pspace_domain_valid[wp]: pspace_domain_valid + lemma createNewCaps_pspace_domain_valid[wp]: "\pspace_domain_valid and K ({ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1} \ kernel_data_refs = {} @@ -5543,15 +5544,6 @@ lemma createObjects_Not_tcbQueued: apply (auto simp: obj_at'_def projectKOs project_inject objBitsKO_def objBits_def makeObject_tcb) done -lemma init_arch_objects_APIType_map2_noop: - "tp \ Inr PageDirectoryObject - \ init_arch_objects (APIType_map2 tp) ptr n m addrs - = return ()" - apply (simp add: init_arch_objects_def APIType_map2_def) - apply (cases tp, simp_all split: kernel_object.split arch_kernel_object.split - object_type.split apiobject_type.split) - done - lemma data_page_relation_retype: "obj_relation_retype (ArchObj (DataPage False pgsz)) KOUserData" "obj_relation_retype (ArchObj (DataPage True pgsz)) KOUserDataDevice" @@ -5561,6 +5553,28 @@ lemma data_page_relation_retype: apply (clarsimp simp: image_def)+ done +lemma init_arch_objects_APIType_map2_VCPU_noop: + "init_arch_objects (APIType_map2 (Inr VCPUObject)) dev ptr n m addrs = return ()" + apply (simp add: init_arch_objects_def APIType_map2_def) + done + +lemma regroup_createObjects_dmo_userPages: + "(do + addrs <- createObjects y n ko sz; + _ <- modify (\ks. ks\gsUserPages := g ks addrs\); + _ <- when P (mapM_x (\addr. doMachineOp (m addr)) addrs); + return (f addrs) + od) = (do + (addrs, faddrs) <- (do + addrs <- createObjects y n ko sz; + _ <- modify (\ks. ks\gsUserPages := g ks addrs\); + return (addrs, f addrs) + od); + _ <- when P (mapM_x (\addr. doMachineOp (m addr)) addrs); + return faddrs + od)" + by (simp add: bind_assoc) + lemma corres_retype_region_createNewCaps: "corres ((\r r'. length r = length r' \ list_all2 cap_relation r r') \ map (\ref. default_cap (APIType_map2 (Inr ty)) ref us dev)) @@ -5573,7 +5587,7 @@ lemma corres_retype_region_createNewCaps: \ valid_pspace' s \ valid_arch_state' s \ range_cover y sz (obj_bits_api (APIType_map2 (Inr ty)) us) n \ n\ 0) (do x \ retype_region y n us (APIType_map2 (Inr ty)) dev :: obj_ref list det_ext_monad; - init_arch_objects (APIType_map2 (Inr ty)) y n us x; + init_arch_objects (APIType_map2 (Inr ty)) dev y n us x; return x od) (createNewCaps ty y n us dev)" apply (rule_tac F="range_cover y sz @@ -5677,89 +5691,137 @@ lemma corres_retype_region_createNewCaps: apply (clarsimp simp: list_all2_same list_all2_map1 list_all2_map2 objBits_simps allRights_def APIType_map2_def split del: if_split) - \ \SmallPageObject\ + \ \SmallPageObject\ + apply (subst retype_region2_extra_ext_trivial) + apply (simp add: APIType_map2_def) + apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst regroup_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI, + simp_all add: APIType_map2_def makeObjectKO_def + arch_default_cap_def obj_bits_api_def3 + default_object_def default_arch_object_def pageBits_def + ext objBits_simps range_cover.aligned, + simp_all add: data_page_relation_retype)[1] + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] + \ \LargePageObject\ apply (subst retype_region2_extra_ext_trivial) apply (simp add: APIType_map2_def) apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI, - simp_all add: APIType_map2_def makeObjectKO_def - arch_default_cap_def obj_bits_api_def3 - default_object_def default_arch_object_def pageBits_def - ext objBits_simps range_cover.aligned, - simp_all add: data_page_relation_retype)[1] - apply simp+ - apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def - vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same) - \ \LargePageObject\ + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst regroup_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI, + simp_all add: APIType_map2_def makeObjectKO_def + arch_default_cap_def obj_bits_api_def3 + default_object_def default_arch_object_def pageBits_def + ext objBits_simps range_cover.aligned, + simp_all add: data_page_relation_retype)[1] + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] + \ \SectionObject\ apply (subst retype_region2_extra_ext_trivial) apply (simp add: APIType_map2_def) apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI, - simp_all add: APIType_map2_def makeObjectKO_def - arch_default_cap_def obj_bits_api_def3 - default_object_def default_arch_object_def pageBits_def - ext objBits_simps range_cover.aligned, - simp_all add: data_page_relation_retype)[1] - apply simp+ - apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def - vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same) - \ \SectionObject\ + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst regroup_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI, + simp_all add: APIType_map2_def makeObjectKO_def + arch_default_cap_def obj_bits_api_def3 + default_object_def default_arch_object_def pageBits_def + ext objBits_simps range_cover.aligned, + simp_all add: data_page_relation_retype)[1] + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] + \ \SuperSectionObject\ apply (subst retype_region2_extra_ext_trivial) apply (simp add: APIType_map2_def) apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI, - simp_all add: APIType_map2_def makeObjectKO_def - arch_default_cap_def obj_bits_api_def3 - default_object_def default_arch_object_def pageBits_def - ext objBits_simps range_cover.aligned, - simp_all add: data_page_relation_retype)[1] - apply simp+ - apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def - vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same) - \ \SuperSectionObject\ + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst regroup_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI, + simp_all add: APIType_map2_def makeObjectKO_def + arch_default_cap_def obj_bits_api_def3 + default_object_def default_arch_object_def pageBits_def + ext objBits_simps range_cover.aligned, + simp_all add: data_page_relation_retype)[1] + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] + \ \PageTable\ apply (subst retype_region2_extra_ext_trivial) apply (simp add: APIType_map2_def) - apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI, - simp_all add: APIType_map2_def makeObjectKO_def - arch_default_cap_def obj_bits_api_def3 - default_object_def default_arch_object_def pageBits_def - ext objBits_simps range_cover.aligned, - simp_all add: data_page_relation_retype)[1] - apply simp+ - apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def - vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same) - \ \PageTable\ - apply (subst retype_region2_extra_ext_trivial) - apply (simp add: APIType_map2_def) - apply (simp_all add: corres_liftM2_simp[unfolded liftM_def]) - apply (rule corres_guard_imp) - apply (simp add: init_arch_objects_APIType_map2_noop) - apply (rule corres_rel_imp) - apply (rule corres_retype[where 'a =pte], - simp_all add: APIType_map2_def obj_bits_api_def - default_arch_object_def objBits_simps - archObjSize_def vspace_bits_defs - makeObjectKO_def range_cover.aligned)[1] - apply (rule pagetable_relation_retype) - apply (wp | simp)+ - apply (clarsimp simp: list_all2_map1 list_all2_map2 list_all2_same - APIType_map2_def arch_default_cap_def) - apply simp+ + apply (simp add: corres_liftM2_simp[unfolded liftM_def]) + apply (simp add: init_arch_objects_def split del: if_split) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype[where 'a =pte], + simp_all add: APIType_map2_def obj_bits_api_def + default_arch_object_def objBits_simps + archObjSize_def vspace_bits_defs + makeObjectKO_def range_cover.aligned)[1] + apply (rule pagetable_relation_retype) + apply (clarsimp simp: APIType_map2_def vs_apiobj_size_def) + apply (rule corres_split) + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply corres + apply (clarsimp simp: list_all2_map1 list_all2_map2 list_all2_same + APIType_map2_def arch_default_cap_def) + apply ((wpsimp split_del: if_split)+)[6] defer - \ \PageDirectory\ + \ \PageDirectory\ + apply (simp only: bind_assoc) apply (rule corres_guard_imp) apply (rule corres_split_eqr) apply (rule corres_retype[where ty = "Inr PageDirectoryObject" and 'a = pde @@ -5787,18 +5849,14 @@ lemma corres_retype_region_createNewCaps: apply (rule corres_return[where P =\ and P'=\,THEN iffD2]) apply simp apply wp+ - apply (simp add: liftM_def[symmetric] o_def list_all2_map1 - list_all2_map2 list_all2_same - arch_default_cap_def mapM_x_mapM) - apply (simp add: dc_def[symmetric]) - apply (rule corres_machine_op) - apply (rule corres_Id) - apply (simp add: shiftl_t2n shiftL_nat - vspace_bits_defs) - apply simp - apply (simp add: mapM_discarded[where g = "return ()",simplified,symmetric]) - apply (rule no_fail_pre) - apply (wp no_fail_mapM|clarsimp)+ + apply (rule corres_split, rule corres_mapM_x', rule corres_machine_op) + apply (clarsimp simp: vs_apiobj_size_def) + apply (rule corres_underlying_trivial_dc, wp) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: list_all2_map1 list_all2_map2 list_all2_same arch_default_cap_def) + apply wp+ apply (rule hoare_vcg_conj_lift) apply (rule hoare_post_imp) prefer 2 @@ -5848,25 +5906,26 @@ lemma corres_retype_region_createNewCaps: APIType_map2_def default_arch_object_def default_object_def archObjSize_def vspace_bits_defs fromIntegral_def toInteger_nat fromInteger_nat)[2] \ \VCPUObject\ - apply (subst retype_region2_extra_ext_trivial) - apply (simp add: APIType_map2_def) - apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype[where 'a = vcpu], - simp_all add: obj_bits_api_def objBits_simps pageBits_def default_arch_object_def - APIType_map2_def makeObjectKO_def archObjSize_def vcpu_bits_def - other_objs_default_relation)[1] - apply (fastforce simp: range_cover_def) - apply (simp add: no_gs_types_def) - apply (auto simp add: obj_relation_retype_def range_cover_def objBitsKO_def arch_kobj_size_def default_object_def - archObjSize_def vcpu_bits_def pageBits_def obj_bits_def cte_level_bits_def default_arch_object_def - other_obj_relation_def vcpu_relation_def default_vcpu_def makeObject_vcpu - makeVCPUObject_def default_gic_vcpu_interface_def vgic_map_def)[1] - apply simp+ - apply (clarsimp simp: list_all2_same list_all2_map1 list_all2_map2 - objBits_simps APIType_map2_def arch_default_cap_def) + apply (subst retype_region2_extra_ext_trivial) + apply (simp add: APIType_map2_def) + apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) + apply (rule corres_rel_imp) + apply (simp add: init_arch_objects_APIType_map2_VCPU_noop split del: if_split) + apply (rule corres_guard_imp) + apply (rule corres_retype[where 'a = vcpu], + simp_all add: obj_bits_api_def objBits_simps pageBits_def default_arch_object_def + APIType_map2_def makeObjectKO_def archObjSize_def vcpu_bits_def + other_objs_default_relation)[1] + apply (fastforce simp: range_cover_def) + apply (simp add: no_gs_types_def) + apply (auto simp: obj_relation_retype_def range_cover_def objBitsKO_def arch_kobj_size_def + default_object_def default_arch_object_def + archObjSize_def vcpu_bits_def pageBits_def obj_bits_def cte_level_bits_def + other_obj_relation_def vcpu_relation_def default_vcpu_def makeObject_vcpu + makeVCPUObject_def default_gic_vcpu_interface_def vgic_map_def)[1] + apply simp+ + apply (clarsimp simp: list_all2_same list_all2_map1 list_all2_map2 + objBits_simps APIType_map2_def arch_default_cap_def) done end diff --git a/proof/refine/ARM_HYP/Schedule_R.thy b/proof/refine/ARM_HYP/Schedule_R.thy index ee340f2f7e..76a843cac0 100644 --- a/proof/refine/ARM_HYP/Schedule_R.thy +++ b/proof/refine/ARM_HYP/Schedule_R.thy @@ -8,7 +8,7 @@ theory Schedule_R imports VSpace_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare hoare_weak_lift_imp[wp_split del] diff --git a/proof/refine/ARM_HYP/StateRelation.thy b/proof/refine/ARM_HYP/StateRelation.thy index 458995c779..2bf686614c 100644 --- a/proof/refine/ARM_HYP/StateRelation.thy +++ b/proof/refine/ARM_HYP/StateRelation.thy @@ -12,7 +12,7 @@ theory StateRelation imports InvariantUpdates_H begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition cte_map :: "cslot_ptr \ word32" where @@ -34,12 +34,12 @@ where | ExceptionTypes_A.GuardMismatch n g \ Fault_H.GuardMismatch n (of_bl g) (length g)" primrec - arch_fault_map :: "Machine_A.ARM_A.arch_fault \ ArchFault_H.ARM_HYP_H.arch_fault" + arch_fault_map :: "Machine_A.ARM_HYP_A.arch_fault \ ArchFault_H.ARM_HYP_H.arch_fault" where - "arch_fault_map (Machine_A.ARM_A.VMFault ptr msg) = ArchFault_H.ARM_HYP_H.VMFault ptr msg" -| "arch_fault_map (Machine_A.ARM_A.VGICMaintenance datalist) = VGICMaintenance datalist " -| "arch_fault_map (Machine_A.ARM_A.VPPIEvent irq) = VPPIEvent irq" -| "arch_fault_map (Machine_A.ARM_A.VCPUFault data) = VCPUFault data" + "arch_fault_map (Machine_A.ARM_HYP_A.VMFault ptr msg) = ArchFault_H.ARM_HYP_H.VMFault ptr msg" +| "arch_fault_map (Machine_A.ARM_HYP_A.VGICMaintenance datalist) = VGICMaintenance datalist " +| "arch_fault_map (Machine_A.ARM_HYP_A.VPPIEvent irq) = VPPIEvent irq" +| "arch_fault_map (Machine_A.ARM_HYP_A.VCPUFault data) = VCPUFault data" primrec fault_map :: "ExceptionTypes_A.fault \ Fault_H.fault" @@ -141,7 +141,7 @@ where (vgic_lr v)" definition - vcpu_relation :: "ARM_A.vcpu \ vcpu \ bool" + vcpu_relation :: "ARM_HYP_A.vcpu \ vcpu \ bool" where "vcpu_relation \ \v v'. vcpu_tcb v = vcpuTCBPtr v' \ vgic_map (vcpu_vgic v) = vcpuVGIC v' \ @@ -231,34 +231,34 @@ where (case (obj, obj') of (Endpoint ep, KOEndpoint ep') \ ep_relation ep ep' | (Notification ntfn, KONotification ntfn') \ ntfn_relation ntfn ntfn' - | (ArchObj (ARM_A.ASIDPool pool), KOArch (KOASIDPool pool')) + | (ArchObj (ARM_HYP_A.ASIDPool pool), KOArch (KOASIDPool pool')) \ asid_pool_relation pool pool' - | (ArchObj (ARM_A.VCPU vcpu), KOArch (KOVCPU vcpu')) + | (ArchObj (ARM_HYP_A.VCPU vcpu), KOArch (KOVCPU vcpu')) \ vcpu_relation vcpu vcpu' | _ \ False)" primrec - pde_relation' :: "ARM_A.pde \ ARM_HYP_H.pde \ bool" + pde_relation' :: "ARM_HYP_A.pde \ ARM_HYP_H.pde \ bool" where - "pde_relation' ARM_A.InvalidPDE x = (x = ARM_HYP_H.InvalidPDE)" -| "pde_relation' (ARM_A.PageTablePDE ptr) x + "pde_relation' ARM_HYP_A.InvalidPDE x = (x = ARM_HYP_H.InvalidPDE)" +| "pde_relation' (ARM_HYP_A.PageTablePDE ptr) x = (x = ARM_HYP_H.PageTablePDE ptr)" -| "pde_relation' (ARM_A.SectionPDE ptr atts rghts) x +| "pde_relation' (ARM_HYP_A.SectionPDE ptr atts rghts) x = (x = ARM_HYP_H.SectionPDE ptr (PageCacheable \ atts) (XNever \ atts) (vmrights_map rghts))" -| "pde_relation' (ARM_A.SuperSectionPDE ptr atts rghts) x +| "pde_relation' (ARM_HYP_A.SuperSectionPDE ptr atts rghts) x = (x = ARM_HYP_H.SuperSectionPDE ptr (PageCacheable \ atts) (XNever \ atts) (vmrights_map rghts))" primrec - pte_relation' :: "ARM_A.pte \ ARM_HYP_H.pte \ bool" + pte_relation' :: "ARM_HYP_A.pte \ ARM_HYP_H.pte \ bool" where - "pte_relation' ARM_A.InvalidPTE x = (x = ARM_HYP_H.InvalidPTE)" -| "pte_relation' (ARM_A.LargePagePTE ptr atts rghts) x + "pte_relation' ARM_HYP_A.InvalidPTE x = (x = ARM_HYP_H.InvalidPTE)" +| "pte_relation' (ARM_HYP_A.LargePagePTE ptr atts rghts) x = (x = ARM_HYP_H.LargePagePTE ptr (PageCacheable \ atts) (XNever \ atts) (vmrights_map rghts))" -| "pte_relation' (ARM_A.SmallPagePTE ptr atts rghts) x +| "pte_relation' (ARM_HYP_A.SmallPagePTE ptr atts rghts) x = (x = ARM_HYP_H.SmallPagePTE ptr (PageCacheable \ atts) (XNever \ atts) (vmrights_map rghts))" @@ -270,7 +270,7 @@ where case pde of ARM_HYP_H.pde.SuperSectionPDE _ _ _ _ \ 4 | _ \ 0" lemmas pde_align_simps[simp] = - pde_align'_def[split_simps ARM_A.pde.split] + pde_align'_def[split_simps ARM_HYP_A.pde.split] definition pte_align' :: "ARM_HYP_H.pte \ nat" @@ -278,17 +278,17 @@ where "pte_align' pte \ case pte of ARM_HYP_H.pte.LargePagePTE _ _ _ _ \ 4 | _ \ 0" lemmas pte_align_simps[simp] = - pte_align'_def[split_simps ARM_A.pte.split] + pte_align'_def[split_simps ARM_HYP_A.pte.split] definition "pde_relation_aligned y pde pde' \ if is_aligned y (pde_align' pde') then pde_relation' pde pde' - else pde = ARM_A.InvalidPDE" + else pde = ARM_HYP_A.InvalidPDE" definition "pte_relation_aligned y pte pte' \ if is_aligned y (pte_align' pte') then pte_relation' pte pte' - else pte = ARM_A.InvalidPTE" + else pte = ARM_HYP_A.InvalidPTE" definition "pte_relation y \ \ko ko'. \pt pte. ko = ArchObj (PageTable pt) \ ko' = KOArch (KOPTE pte) @@ -299,17 +299,17 @@ definition \ pde_relation_aligned y (pd y) pde" primrec - aobj_relation_cuts :: "ARM_A.arch_kernel_obj \ word32 \ obj_relation_cuts" + aobj_relation_cuts :: "ARM_HYP_A.arch_kernel_obj \ word32 \ obj_relation_cuts" where "aobj_relation_cuts (DataPage dev sz) x = {(x + n * 2 ^ pageBits, \_ obj. obj = (if dev then KOUserDataDevice else KOUserData) ) | n . n < 2 ^ (pageBitsForSize sz - pageBits) }" -| "aobj_relation_cuts (ARM_A.ASIDPool pool) x = +| "aobj_relation_cuts (ARM_HYP_A.ASIDPool pool) x = {(x, other_obj_relation)}" | "aobj_relation_cuts (PageTable pt) x = (\y. (x + (ucast y << pte_bits), pte_relation y)) ` UNIV" | "aobj_relation_cuts (PageDirectory pd) x = (\y. (x + (ucast y << pde_bits), pde_relation y)) ` UNIV" -| "aobj_relation_cuts (ARM_A.VCPU v) x = +| "aobj_relation_cuts (ARM_HYP_A.VCPU v) x = {(x, other_obj_relation)}" definition tcb_relation_cut :: "Structures_A.kernel_object \ kernel_object \ bool" where @@ -345,7 +345,7 @@ lemma obj_relation_cuts_def2: {(x + n * 2 ^ pageBits, \_ obj. obj =(if dev then KOUserDataDevice else KOUserData)) | n . n < 2 ^ (pageBitsForSize sz - pageBits) } | _ \ {(x, other_obj_relation)})" by (simp split: Structures_A.kernel_object.split - ARM_A.arch_kernel_obj.split) + ARM_HYP_A.arch_kernel_obj.split) lemma obj_relation_cuts_def3: "obj_relation_cuts ko x = @@ -362,7 +362,7 @@ lemma obj_relation_cuts_def3: | _ \ {(x, other_obj_relation)})" apply (simp add: obj_relation_cuts_def2 a_type_def split: Structures_A.kernel_object.split - ARM_A.arch_kernel_obj.split) + ARM_HYP_A.arch_kernel_obj.split) apply (clarsimp simp: well_formed_cnode_n_def length_set_helper) done @@ -571,7 +571,7 @@ lemma obj_relation_cutsE: by (force simp: obj_relation_cuts_def2 is_other_obj_relation_type_def a_type_def cte_relation_def pte_relation_def pde_relation_def tcb_relation_cut_def split: Structures_A.kernel_object.splits kernel_object.splits if_splits - ARM_A.arch_kernel_obj.splits) + ARM_HYP_A.arch_kernel_obj.splits) lemma eq_trans_helper: "\ x = y; P y = Q \ \ P x = Q" @@ -638,7 +638,7 @@ where | SuperSectionObj \ SuperSectionObject | PageTableObj \ PageTableObject | PageDirectoryObj \ PageDirectoryObject - | ARM_A.VCPUObj \ VCPUObject)" + | ARM_HYP_A.VCPUObj \ VCPUObject)" definition state_relation :: "(det_state \ kernel_state) set" diff --git a/proof/refine/ARM_HYP/SubMonad_R.thy b/proof/refine/ARM_HYP/SubMonad_R.thy index dffd4ded32..b256cf9132 100644 --- a/proof/refine/ARM_HYP/SubMonad_R.thy +++ b/proof/refine/ARM_HYP/SubMonad_R.thy @@ -47,7 +47,7 @@ lemma doMachineOp_mapM_x: done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "asUser_fetch \ \t s. case (ksPSpace s t) of Some (KOTCB tcb) \ (atcbContextGet o tcbArch) tcb diff --git a/proof/refine/ARM_HYP/Syscall_R.thy b/proof/refine/ARM_HYP/Syscall_R.thy index 4e22f87935..80a53138fd 100644 --- a/proof/refine/ARM_HYP/Syscall_R.thy +++ b/proof/refine/ARM_HYP/Syscall_R.thy @@ -12,7 +12,7 @@ theory Syscall_R imports Tcb_R Arch_R Interrupt_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* syscall has 5 sections: m_fault h_fault m_error h_error m_finalise @@ -536,7 +536,7 @@ crunch InterruptDecls_H.invokeIRQHandler for typ_at'[wp]: "\s. P (typ_at' T p s)" lemmas invokeIRQHandler_typ_ats[wp] = - typ_at_lifts [OF InterruptDecls_H_invokeIRQHandler_typ_at'] + typ_at_lifts [OF invokeIRQHandler_typ_at'] crunch setDomain for tcb_at'[wp]: "tcb_at' tptr" diff --git a/proof/refine/ARM_HYP/TcbAcc_R.thy b/proof/refine/ARM_HYP/TcbAcc_R.thy index af0a477202..94985e6a86 100644 --- a/proof/refine/ARM_HYP/TcbAcc_R.thy +++ b/proof/refine/ARM_HYP/TcbAcc_R.thy @@ -8,7 +8,7 @@ theory TcbAcc_R imports CSpace_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare if_weak_cong [cong] declare hoare_in_monad_post[wp] @@ -94,7 +94,7 @@ lemma st_tcb_at_coerce_abstract: apply (fastforce simp: st_tcb_at_def obj_at_def other_obj_relation_def tcb_relation_def split: Structures_A.kernel_object.split_asm if_split_asm - ARM_A.arch_kernel_obj.split_asm)+ + ARM_HYP_A.arch_kernel_obj.split_asm)+ done lemma st_tcb_at_runnable_coerce_concrete: @@ -524,7 +524,7 @@ lemma pspace_relation_tcb_at: apply (erule(1) obj_relation_cutsE) apply (clarsimp simp: other_obj_relation_def is_tcb obj_at_def split: Structures_A.kernel_object.split_asm if_split_asm - ARM_A.arch_kernel_obj.split_asm)+ + ARM_HYP_A.arch_kernel_obj.split_asm)+ done lemma threadSet_corres_noopT: @@ -6070,7 +6070,7 @@ lemma set_eobject_corres': apply (clarsimp simp: obj_at'_def other_obj_relation_def tcb_relation_cut_def cte_relation_def tcb_relation_def projectKOs split: if_split_asm)+ - apply (clarsimp simp: aobj_relation_cuts_def split: ARM_A.arch_kernel_obj.splits) + apply (clarsimp simp: aobj_relation_cuts_def split: ARM_HYP_A.arch_kernel_obj.splits) apply (rename_tac arch_kernel_obj obj d p ts) apply (case_tac arch_kernel_obj; simp) apply (clarsimp simp: pte_relation_def pde_relation_def is_tcb_def diff --git a/proof/refine/ARM_HYP/Tcb_R.thy b/proof/refine/ARM_HYP/Tcb_R.thy index 7e6e012cda..59dfd5cde1 100644 --- a/proof/refine/ARM_HYP/Tcb_R.thy +++ b/proof/refine/ARM_HYP/Tcb_R.thy @@ -8,7 +8,7 @@ theory Tcb_R imports CNodeInv_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma asUser_setNextPC_corres: "corres dc (tcb_at t and invs) (tcb_at' t and invs') @@ -1630,7 +1630,7 @@ end consts copyregsets_map :: "arch_copy_register_sets \ Arch.copy_register_sets" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec tcbinv_relation :: "tcb_invocation \ tcbinvocation \ bool" diff --git a/proof/refine/ARM_HYP/Untyped_R.thy b/proof/refine/ARM_HYP/Untyped_R.thy index f43a553319..30bb90e5c5 100644 --- a/proof/refine/ARM_HYP/Untyped_R.thy +++ b/proof/refine/ARM_HYP/Untyped_R.thy @@ -9,7 +9,7 @@ theory Untyped_R imports Detype_R Invocations_R InterruptAcc_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec untypinv_relation :: "Invocations_A.untyped_invocation \ @@ -1004,7 +1004,7 @@ locale mdb_insert_again = context mdb_insert_again begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemmas parent = mdb_ptr_parent.m_p lemmas site = mdb_ptr_site.m_p @@ -1395,7 +1395,7 @@ crunch create_cap_ext and work_units_completed[wp]: "\s. P (work_units_completed s)" (ignore_del: create_cap_ext) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma updateNewFreeIndex_noop_psp_corres: "corres_underlying {(s, s'). pspace_relations (ekheap s) (kheap s) (ksPSpace s')} False True @@ -1750,7 +1750,7 @@ locale mdb_insert_again_all = mdb_insert_again_child + fixes n' defines "n' \ modify_map n (mdbNext parent_node) (cteMDBNode_update (mdbPrev_update (\a. site)))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma no_0_n' [simp]: "no_0 n'" using no_0_n by (simp add: n'_def) @@ -2724,7 +2724,7 @@ lemma caps_overlap_reserved'_D: apply (erule(2) impE) apply fastforce done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma insertNewCap_valid_mdb: "\valid_mdb' and valid_objs' and K (slot \ p) and caps_overlap_reserved' (untypedRange cap) and @@ -3922,7 +3922,7 @@ lemma cte_wp_at': "cte_wp_at' (\cte. cteCap cte = capability.UntypedCap "\x\set slots. ex_cte_cap_wp_to' (\_. True) x s" using vui by (auto simp: cte_wp_at_ctes_of) -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma idx_cases: "((\ reset \ idx \ unat (ptr - (ptr && ~~ mask sz))) \ reset \ ptr = ptr && ~~ mask sz)" @@ -4066,7 +4066,7 @@ lemma idx_le_new_offs: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma valid_sched_etcbs[elim!]: "valid_sched_2 queues ekh sa cdom kh ct it \ valid_etcbs_2 ekh kh" by (simp add: valid_sched_def) @@ -4224,7 +4224,7 @@ lemma ex_tupI: "P (fst x) (snd x) \ \a b. P a b" by blast -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* mostly stuff about PPtr/fromPPtr, which seems pretty soft *) lemma resetUntypedCap_corres: @@ -4439,7 +4439,7 @@ lemma ex_cte_cap_wp_to_irq_state_independent_H[simp]: "irq_state_independent_H (ex_cte_cap_wp_to' P slot)" by (simp add: ex_cte_cap_wp_to'_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma updateFreeIndex_ctes_of: "\\s. P (modify_map (ctes_of s) ptr (cteCap_update (capFreeIndex_update (\_. idx))))\ @@ -4661,7 +4661,7 @@ lemma (in range_cover) funky_aligned: apply simp done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) defs archOverlap_def: "archOverlap \ \_ _. False" diff --git a/proof/refine/ARM_HYP/VSpace_R.thy b/proof/refine/ARM_HYP/VSpace_R.thy index 23c51a7cc8..912406cb66 100644 --- a/proof/refine/ARM_HYP/VSpace_R.thy +++ b/proof/refine/ARM_HYP/VSpace_R.thy @@ -12,14 +12,14 @@ theory VSpace_R imports TcbAcc_R begin -context Arch begin global_naming ARM (*FIXME: arch_split*) +context Arch begin global_naming ARM (*FIXME: arch-split*) lemmas store_pte_typ_ats[wp] = store_pte_typ_ats abs_atyp_at_lifts[OF store_pte_typ_at] lemmas store_pde_typ_ats[wp] = store_pde_typ_ats abs_atyp_at_lifts[OF store_pde_typ_at] end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma option_case_all_conv: "(case x of None \ True | Some v \ P v) = (\v. x = Some v \ P v)" @@ -2127,7 +2127,7 @@ lemma checkMappingPPtr_corres: auto simp add: is_aligned_mask[symmetric] is_aligned_shiftr pg_entry_align_def pte_bits_def unlessE_def returnOk_def pte_relation_aligned_def - split: ARM_A.pte.split if_splits ARM_HYP_H.pte.split ) + split: ARM_HYP_A.pte.split if_splits ARM_HYP_H.pte.split ) apply wp+ apply simp apply (simp add:is_aligned_mask[symmetric] is_aligned_shiftr pg_entry_align_def) @@ -2138,7 +2138,7 @@ lemma checkMappingPPtr_corres: auto simp add: is_aligned_mask[symmetric] is_aligned_shiftr pg_entry_align_def pde_bits_def unlessE_def returnOk_def pde_relation_aligned_def - split: ARM_A.pde.split if_splits ARM_HYP_H.pde.split ) + split: ARM_HYP_A.pde.split if_splits ARM_HYP_H.pde.split ) apply wp+ apply simp+ done @@ -2315,10 +2315,10 @@ lemma unmapPage_corres: definition "flush_type_map type \ case type of - ARM_A.flush_type.Clean \ ARM_HYP_H.flush_type.Clean - | ARM_A.flush_type.Invalidate \ ARM_HYP_H.flush_type.Invalidate - | ARM_A.flush_type.CleanInvalidate \ ARM_HYP_H.flush_type.CleanInvalidate - | ARM_A.flush_type.Unify \ ARM_HYP_H.flush_type.Unify" + ARM_HYP_A.flush_type.Clean \ ARM_HYP_H.flush_type.Clean + | ARM_HYP_A.flush_type.Invalidate \ ARM_HYP_H.flush_type.Invalidate + | ARM_HYP_A.flush_type.CleanInvalidate \ ARM_HYP_H.flush_type.CleanInvalidate + | ARM_HYP_A.flush_type.Unify \ ARM_HYP_H.flush_type.Unify" lemma doFlush_corres: "corres_underlying Id nf nf' dc \ \ @@ -2339,8 +2339,8 @@ lemma doFlush_corres: definition "page_directory_invocation_map pdi pdi' \ case pdi of - ARM_A.PageDirectoryNothing \ pdi' = PageDirectoryNothing - | ARM_A.PageDirectoryFlush typ start end pstart pd asid \ + ARM_HYP_A.PageDirectoryNothing \ pdi' = PageDirectoryNothing + | ARM_HYP_A.PageDirectoryFlush typ start end pstart pd asid \ pdi' = PageDirectoryFlush (flush_type_map typ) start end pstart pd asid" lemma performPageDirectoryInvocation_corres: @@ -2373,16 +2373,16 @@ lemma performPageDirectoryInvocation_corres: definition "page_invocation_map pgi pgi' \ case pgi of - ARM_A.PageMap a c ptr m \ + ARM_HYP_A.PageMap a c ptr m \ \c' m'. pgi' = PageMap a c' (cte_map ptr) m' \ cap_relation c c' \ mapping_map m m' - | ARM_A.PageUnmap c ptr \ + | ARM_HYP_A.PageUnmap c ptr \ \c'. pgi' = PageUnmap c' (cte_map ptr) \ acap_relation c c' - | ARM_A.PageFlush typ start end pstart pd asid \ + | ARM_HYP_A.PageFlush typ start end pstart pd asid \ pgi' = PageFlush (flush_type_map typ) start end pstart pd asid - | ARM_A.PageGetAddr ptr \ + | ARM_HYP_A.PageGetAddr ptr \ pgi' = PageGetAddr ptr" definition @@ -2587,7 +2587,7 @@ lemma corres_store_pde_with_invalid_tail: "\ \slot \set ys. \ is_aligned (slot >> pde_bits) (pde_align' ab); length ys < 2^word_bits \ \corres dc ((\s. \y\ set ys. pde_at y s) and pspace_aligned and valid_etcbs) (pspace_aligned' and pspace_distinct') - (mapM (swp store_pde ARM_A.pde.InvalidPDE) ys) + (mapM (swp store_pde ARM_HYP_A.pde.InvalidPDE) ys) (mapM (\(slot, i). storePDE slot (addPDEOffset ab i)) (zip ys [1.e.of_nat (length ys)]))" apply (rule_tac S ="{(x,y). x = fst y \ x \ set ys}" in corres_mapM[where r = dc and r' = dc]) apply simp @@ -2611,7 +2611,7 @@ lemma corres_store_pte_with_invalid_tail: "\ \slot\ set ys. \ is_aligned (slot >> pte_bits) (pte_align' aa); length ys < 2^word_bits\ \ corres dc ((\s. \y\set ys. pte_at y s) and pspace_aligned and valid_etcbs) (pspace_aligned' and pspace_distinct') - (mapM (swp store_pte ARM_A.pte.InvalidPTE) ys) + (mapM (swp store_pte ARM_HYP_A.pte.InvalidPTE) ys) (mapM (\(slot, i). storePTE slot (addPTEOffset aa i)) (zip ys [1.e.of_nat (length ys)]))" apply (rule_tac S ="{(x,y). x = fst y \ x \ set ys}" in corres_mapM[where r = dc and r' = dc]) apply simp @@ -2694,7 +2694,7 @@ definition (\s. \pd. vspace_at_asid asid pd s)" lemma set_cap_valid_page_map_inv: - "\valid_page_inv (ARM_A.page_invocation.PageMap asid cap slot m)\ set_cap cap slot \\rv. valid_page_map_inv asid cap slot m\" + "\valid_page_inv (ARM_HYP_A.page_invocation.PageMap asid cap slot m)\ set_cap cap slot \\rv. valid_page_map_inv asid cap slot m\" apply (simp add: valid_page_inv_def valid_page_map_inv_def) apply (wp set_cap_cte_wp_at_cases hoare_vcg_ex_lift| simp)+ apply clarsimp @@ -2873,7 +2873,7 @@ proof - and (\s. \pd. vspace_at_asid word pd s)" in hoare_strengthen_post) prefer 2 apply auto[1] - apply (wp mapM_swp_store_pte_invs[where pte="ARM_A.pte.InvalidPTE", simplified] + apply (wp mapM_swp_store_pte_invs[where pte="ARM_HYP_A.pte.InvalidPTE", simplified] hoare_vcg_ex_lift) apply (wp mapM_UNIV_wp | clarsimp simp add: swp_def split: prod.split simp del: fun_upd_apply)+ @@ -2933,7 +2933,7 @@ proof - and (\s. \pd. vspace_at_asid word pd s)" in hoare_strengthen_post) prefer 2 apply auto[1] - apply (wp mapM_swp_store_pde_invs_unmap[where pde="ARM_A.pde.InvalidPDE", simplified] + apply (wp mapM_swp_store_pde_invs_unmap[where pde="ARM_HYP_A.pde.InvalidPDE", simplified] hoare_vcg_ex_lift) apply (wp mapM_UNIV_wp store_pde_pd_at_asid | clarsimp simp add: swp_def)+ apply (clarsimp simp add: cte_wp_at_caps_of_state simp del: fun_upd_apply) @@ -2961,7 +2961,7 @@ proof - apply (rule conjI) apply (clarsimp simp: pde_at_def obj_at_def a_type_def) apply (clarsimp split: Structures_A.kernel_object.split_asm if_split_asm - ARM_A.arch_kernel_obj.splits) + ARM_HYP_A.arch_kernel_obj.splits) apply (rule conjI[rotated], fastforce) apply (erule ballEI) apply (clarsimp simp: pde_at_def obj_at_def @@ -3054,11 +3054,11 @@ qed definition "page_table_invocation_map pti pti' \ case pti of - ARM_A.PageTableMap cap ptr pde p \ + ARM_HYP_A.PageTableMap cap ptr pde p \ \cap' pde'. pti' = PageTableMap cap' (cte_map ptr) pde' p \ cap_relation cap cap' \ pde_relation' pde pde' \ is_aligned (p >> pde_bits) (pde_align' pde') - | ARM_A.PageTableUnmap cap ptr \ + | ARM_HYP_A.PageTableUnmap cap ptr \ \cap'. pti' = PageTableUnmap cap' (cte_map ptr) \ cap_relation cap (ArchObjectCap cap')" @@ -3077,7 +3077,7 @@ definition lemma clear_page_table_corres: "corres dc (pspace_aligned and page_table_at p and valid_etcbs) (pspace_aligned' and pspace_distinct') - (mapM_x (swp store_pte ARM_A.InvalidPTE) + (mapM_x (swp store_pte ARM_HYP_A.InvalidPTE) [p , p + 8 .e. p + 2 ^ ptBits - 1]) (mapM_x (swp storePTE ARM_HYP_H.InvalidPTE) [p , p + 8 .e. p + 2 ^ ptBits - 1])" @@ -3211,7 +3211,7 @@ lemma performASIDPoolInvocation_corres: apply (rule corres_guard_imp) apply (rule corres_split[OF getSlotCap_corres]) apply simp - apply (rule_tac F="\p asid. rv = Structures_A.ArchObjectCap (ARM_A.PageDirectoryCap p asid)" in corres_gen_asm) + apply (rule_tac F="\p asid. rv = Structures_A.ArchObjectCap (ARM_HYP_A.PageDirectoryCap p asid)" in corres_gen_asm) apply clarsimp apply (rule_tac Q="valid_objs and pspace_aligned and pspace_distinct and asid_pool_at word2 and valid_etcbs and cte_wp_at (\c. cap_master_cap c = diff --git a/proof/refine/RISCV64/ADT_H.thy b/proof/refine/RISCV64/ADT_H.thy index 6f953fe3e9..cfb631f4e5 100644 --- a/proof/refine/RISCV64/ADT_H.thy +++ b/proof/refine/RISCV64/ADT_H.thy @@ -33,7 +33,7 @@ consts initBootFrames :: "machine_word list" initDataStart :: machine_word -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \ The construction of the abstract data type @@ -1185,7 +1185,7 @@ locale partial_sort_cdt = "pspace_distinct' s'" "valid_objs s" "valid_mdb s" "valid_list s" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma valid_list_2 : "valid_list_2 t m" apply (insert assms') @@ -1370,7 +1370,7 @@ lemma sort_cdt_list_correct: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition absCDTList where "absCDTList cnp h \ sort_cdt_list (absCDT cnp h) h" diff --git a/proof/refine/RISCV64/ArchAcc_R.thy b/proof/refine/RISCV64/ArchAcc_R.thy index c1ec1f2162..563c8f6d30 100644 --- a/proof/refine/RISCV64/ArchAcc_R.thy +++ b/proof/refine/RISCV64/ArchAcc_R.thy @@ -29,7 +29,7 @@ method simp_to_elim = (drule fun_all, elim allE impE) end -context Arch begin global_naming RISCV64_A (*FIXME: arch_split*) +context Arch begin global_naming RISCV64_A (*FIXME: arch-split*) lemma asid_pool_at_ko: "asid_pool_at p s \ \pool. ko_at (ArchObj (RISCV64_A.ASIDPool pool)) p s" @@ -63,7 +63,7 @@ lemmas storePTE_valid_pspace'[wp] = end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) method readObject_arch_obj_at'_method = clarsimp simp: readObject_def obind_def omonad_defs split_def loadObject_default_def obj_at'_def diff --git a/proof/refine/RISCV64/Arch_R.thy b/proof/refine/RISCV64/Arch_R.thy index f1759a5230..cbeb486449 100644 --- a/proof/refine/RISCV64/Arch_R.thy +++ b/proof/refine/RISCV64/Arch_R.thy @@ -17,7 +17,7 @@ unbundle l4v_word_context lemmas [datatype_schematic] = cap.sel list.sel(1) list.sel(3) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare arch_cap.sel [datatype_schematic] declare is_aligned_shiftl [intro!] diff --git a/proof/refine/RISCV64/Bits_R.thy b/proof/refine/RISCV64/Bits_R.thy index bd9054cff3..78e957ccd1 100644 --- a/proof/refine/RISCV64/Bits_R.thy +++ b/proof/refine/RISCV64/Bits_R.thy @@ -32,7 +32,7 @@ crunch_ignore (add: lookupPTSlotFromLevel lookupPTFromLevel) end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma throwE_R: "\\\ throw f \P\,-" by (simp add: validE_R_def) wp diff --git a/proof/refine/RISCV64/CNodeInv_R.thy b/proof/refine/RISCV64/CNodeInv_R.thy index 5897e6c460..1448b61c00 100644 --- a/proof/refine/RISCV64/CNodeInv_R.thy +++ b/proof/refine/RISCV64/CNodeInv_R.thy @@ -15,7 +15,7 @@ begin unbundle l4v_word_context -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec valid_cnode_inv' :: "Invocations_H.cnode_invocation \ kernel_state \ bool" @@ -4913,7 +4913,7 @@ lemma cteSwap_valid_pspace'[wp]: apply clarsimp+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch cteSwap for tcb_at [wp]: "tcb_at' t" @@ -6487,7 +6487,7 @@ lemma cteDelete_cte_wp_at_invs: apply simp done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch "Arch.finaliseCap", unbindMaybeNotification, prepareThreadDelete, schedContextMaybeUnbindNtfn, cleanReply @@ -6850,7 +6850,7 @@ lemmas rec_del_concrete_unfold = rec_del_concrete.simps red_zombie_will_fail.simps if_True if_False ball_simps simp_thms -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cap_relation_removables: "\ cap_relation cap cap'; isNullCap cap' \ isZombie cap'; @@ -6915,7 +6915,7 @@ lemmas finaliseSlot_typ_ats[wp] = typ_at_lifts[OF finaliseSlot_typ_at'] lemmas rec_del_valid_list_irq_state_independent[wp] = rec_del_preservation[OF cap_swap_for_delete_valid_list set_cap_valid_list empty_slot_valid_list finalise_cap_valid_list preemption_point_valid_list] -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma rec_del_corres: "\C \ rec_del_concrete args. @@ -7859,7 +7859,7 @@ lemma (in mdb_move) m'_cap: context mdb_move begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma m_to_src: "m \ p \ src = (p \ 0 \ p = mdbPrev src_node)" @@ -8378,7 +8378,7 @@ qed end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteMove_iflive'[wp]: "\\s. if_live_then_nonz_cap' s @@ -8625,7 +8625,7 @@ lemma corres_disj_abs: \ corres rv (\s. P s \ Q s) R f g" by (auto simp: corres_underlying_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cap_relation_same: "\ cap_relation cap cap'; cap_relation cap cap'' \ diff --git a/proof/refine/RISCV64/CSpace1_R.thy b/proof/refine/RISCV64/CSpace1_R.thy index c1083ffcf6..b5cb02e60c 100644 --- a/proof/refine/RISCV64/CSpace1_R.thy +++ b/proof/refine/RISCV64/CSpace1_R.thy @@ -13,7 +13,7 @@ imports CSpace_I begin -context Arch begin global_naming RISCV64_A (*FIXME: arch_split*) +context Arch begin global_naming RISCV64_A (*FIXME: arch-split*) lemmas final_matters_def = final_matters_def[simplified final_matters_arch_def] @@ -24,7 +24,7 @@ lemmas final_matters_simps[simp] end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma isMDBParentOf_CTE1: "isMDBParentOf (CTE cap node) cte = @@ -951,7 +951,7 @@ lemma updateMDB_no_0 [wp]: \\rv s. no_0 (ctes_of s)\" by wp simp -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma isMDBParentOf_next_update [simp]: "isMDBParentOf (cteMDBNode_update (mdbNext_update f) cte) cte' = @@ -2927,7 +2927,7 @@ locale masterCap = fixes cap cap' assumes master: "capMasterCap cap = capMasterCap cap'" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma isZombie [simp]: "isZombie cap' = isZombie cap" using master @@ -3516,7 +3516,7 @@ locale mdb_insert_sib = mdb_insert_der + (mdbRevocable_update (\a. isCapRevocable c' src_cap) (mdbPrev_update (\a. src) src_node))))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) (* If dest is inserted as sibling, src can not have had children. If it had had children, then dest_node which is just a derived copy @@ -3663,7 +3663,7 @@ lemma descendants: by (rule set_eqI) (simp add: descendants_of'_def parent_n_eq) end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma mdb_None: assumes F: "\p'. cte_map p \ descendants_of' p' m' \ False" assumes R: "cdt_relation (swp cte_at s) (cdt s) m'" @@ -4519,7 +4519,7 @@ locale mdb_inv_preserve = \ (\x. sameRegionAs x (cteCap cte)) = (\x. sameRegionAs x (cteCap cte'))" assumes mdb_next:"\p. mdb_next m p = mdb_next m' p" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma preserve_stuff: "valid_dlist m = valid_dlist m' \ ut_revocable' m = ut_revocable' m' @@ -5137,7 +5137,7 @@ lemma cte_map_inj_eq': \ p = p'" by (rule cte_map_inj_eq; fastforce) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_corres: notes split_paired_All[simp del] split_paired_Ex[simp del] trans_state_update'[symmetric,simp] @@ -7075,7 +7075,7 @@ lemma subtree_no_parent: shows "False" using assms by induct (auto simp: parentOf_def mdb_next_unfold) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ensureNoChildren_corres: "p' = cte_map p \ diff --git a/proof/refine/RISCV64/CSpace_I.thy b/proof/refine/RISCV64/CSpace_I.thy index 2076b96bda..f9699373b3 100644 --- a/proof/refine/RISCV64/CSpace_I.thy +++ b/proof/refine/RISCV64/CSpace_I.thy @@ -12,7 +12,7 @@ theory CSpace_I imports ArchAcc_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas capUntypedPtr_simps[simp] = capUntypedPtr_def[split_simps capability.split, simplified PPtr_def id_def] lemmas arch_capUntypedPtr_simps[simp] @@ -1516,7 +1516,7 @@ lemma no_mdb_not_target: apply (simp add: no_mdb_def) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma valid_dlist_init: "\ valid_dlist m; m p = Some cte; no_mdb cte \ \ valid_dlist (m (p \ CTE cap initMDBNode))" @@ -1714,7 +1714,7 @@ lemma untyped_inc_init: apply (rule untypedRange_in_capRange)+ apply (simp add:Int_ac) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma valid_nullcaps_init: "\ valid_nullcaps m; cap \ NullCap \ \ valid_nullcaps (m(p \ CTE cap initMDBNode))" by (simp add: valid_nullcaps_def initMDBNode_def nullPointer_def) @@ -1774,7 +1774,7 @@ lemma distinct_zombies_copyE: lemmas distinct_zombies_sameE = distinct_zombies_copyE [where y=x and x=x for x, simplified, OF _ _ _ _ _] -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma capBits_Master: "capBits (capMasterCap cap) = capBits cap" by (clarsimp simp: capMasterCap_def split: capability.split arch_capability.split) diff --git a/proof/refine/RISCV64/CSpace_R.thy b/proof/refine/RISCV64/CSpace_R.thy index 886395012f..2cf4115e5d 100644 --- a/proof/refine/RISCV64/CSpace_R.thy +++ b/proof/refine/RISCV64/CSpace_R.thy @@ -51,7 +51,7 @@ locale mdb_move = modify_map n (mdbNext src_node) (cteMDBNode_update (mdbPrev_update (\_. dest)))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemmas src = m_p @@ -739,7 +739,7 @@ lemma set_cap_not_quite_corres': using cr by (rule set_cap_not_quite_corres; fastforce simp: c p) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteMove_corres: assumes cr: "cap_relation cap cap'" notes trans_state_update'[symmetric,simp] @@ -1135,7 +1135,7 @@ crunch cteInsert context mdb_insert begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma n_src_dest: "n \ src \ dest" by (simp add: n_direct_eq) @@ -1661,7 +1661,7 @@ lemma is_derived_badge_derived': "is_derived' m src cap cap' \ badge_derived' cap cap'" by (simp add: is_derived'_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_mdb_chain_0: "\valid_mdb' and pspace_aligned' and pspace_distinct' and (\s. src \ dest) and @@ -4155,7 +4155,7 @@ locale mdb_insert_simple = mdb_insert + assumes simple: "is_simple_cap' c'" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma dest_no_parent_n: "n \ dest \ p = False" @@ -4349,7 +4349,7 @@ lemma maskedAsFull_revokable_safe_parent: apply (clarsimp simp:isCap_simps is_simple_cap'_def)+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_simple_corres: assumes "cap_relation c c'" "src' = cte_map src" "dest' = cte_map dest" @@ -4725,7 +4725,7 @@ locale mdb_insert_simple' = mdb_insert_simple + fixes n' defines "n' \ modify_map n (mdbNext src_node) (cteMDBNode_update (mdbPrev_update (\_. dest)))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma no_0_n' [intro!]: "no_0 n'" by (auto simp: n'_def) lemmas n_0_simps' [iff] = no_0_simps [OF no_0_n'] @@ -5407,7 +5407,7 @@ lemma updateCapFreeIndex_no_0: apply (clarsimp simp:cte_wp_at_ctes_of)+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_simple_mdb': "\valid_mdb' and pspace_aligned' and pspace_distinct' and (\s. src \ dest) and K (capAligned cap) and diff --git a/proof/refine/RISCV64/Detype_R.thy b/proof/refine/RISCV64/Detype_R.thy index a59de5e3a4..701e90409e 100644 --- a/proof/refine/RISCV64/Detype_R.thy +++ b/proof/refine/RISCV64/Detype_R.thy @@ -9,7 +9,7 @@ theory Detype_R imports Retype_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \Establishing that the invariants are maintained when a region of memory is detyped, that is, @@ -87,7 +87,7 @@ lemma descendants_range_inD': done end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma descendants_range'_def2: "descendants_range' cap p = descendants_range_in' (capRange cap) p" @@ -427,7 +427,7 @@ end locale detype_locale' = detype_locale + constrains s::"det_state" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \Invariant preservation across concrete deletion\ @@ -479,7 +479,7 @@ locale delete_locale = and sa_simp: "sch_act_simple s'" and al: "is_aligned base bits" -context delete_locale begin interpretation Arch . (*FIXME: arch_split*) +context delete_locale begin interpretation Arch . (*FIXME: arch-split*) lemma valid_objs: "valid_objs' s'" and vreplies: "valid_replies' s'" @@ -672,7 +672,7 @@ lemma deletionIsSafe_holds: and vu: "valid_untyped (cap.UntypedCap d base bits idx) s" shows "deletionIsSafe base bits s'" proof - - interpret Arch . (* FIXME: arch_split *) + interpret Arch . (* FIXME: arch-split *) note [simp del] = atLeastAtMost_simps have arch: @@ -734,7 +734,7 @@ proof - qed end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* FIXME: generalizes lemma SubMonadLib.corres_submonad *) (* FIXME: generalizes lemma SubMonad_R.corres_machine_op *) @@ -1013,7 +1013,7 @@ lemma deleteObjects_corres: done end -context delete_locale begin interpretation Arch . (*FIXME: arch_split*) +context delete_locale begin interpretation Arch . (*FIXME: arch-split*) lemma live_idle_untyped_range': "ko_wp_at' live' p s' \ p = idle_thread_ptr \ p = idle_sc_ptr \ p \ base_bits" @@ -1456,7 +1456,7 @@ using vds proof (simp add: invs'_def valid_pspace'_def valid_mdb'_def valid_mdb_ctes_def, safe) - interpret Arch . (*FIXME: arch_split*) + interpret Arch . (*FIXME: arch-split*) let ?s = state' let ?ran = base_bits @@ -1722,7 +1722,7 @@ lemma (in delete_locale) delete_sym_refs': state'))" (is "sym_refs (state_refs_of' (?state''))") proof - - interpret Arch . (*FIXME: arch_split*) + interpret Arch . (*FIXME: arch-split*) let ?s = state' let ?ran = base_bits @@ -1809,7 +1809,7 @@ lemma doMachineOp_modify: apply (simp add: simpler_gets_def simpler_modify_def bind_def) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma deleteObjects_invs': "\cte_wp_at' (\c. cteCap c = UntypedCap d ptr bits idx) p and invs' and ct_active' and sch_act_simple diff --git a/proof/refine/RISCV64/EmptyFail.thy b/proof/refine/RISCV64/EmptyFail.thy index 74efc9a552..a0bcfa7b91 100644 --- a/proof/refine/RISCV64/EmptyFail.thy +++ b/proof/refine/RISCV64/EmptyFail.thy @@ -55,7 +55,7 @@ lemma empty_fail_getSlotCap [intro!, wp, simp]: "empty_fail (getSlotCap a)" unfolding getSlotCap_def by fastforce -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma empty_fail_getObject: "empty_fail (getObject x :: 'a :: pspace_storable kernel)" diff --git a/proof/refine/RISCV64/EmptyFail_H.thy b/proof/refine/RISCV64/EmptyFail_H.thy index 30d9db8bed..1189568113 100644 --- a/proof/refine/RISCV64/EmptyFail_H.thy +++ b/proof/refine/RISCV64/EmptyFail_H.thy @@ -13,7 +13,7 @@ crunch_ignore (empty_fail) CSpaceDecls_H.resolveAddressBits doMachineOp suspend restart schedule) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas forM_empty_fail[intro!, wp, simp] = empty_fail_mapM[simplified forM_def[symmetric]] lemmas forM_x_empty_fail[intro!, wp, simp] = empty_fail_mapM_x[simplified forM_x_def[symmetric]] diff --git a/proof/refine/RISCV64/Finalise_R.thy b/proof/refine/RISCV64/Finalise_R.thy index a341e510da..a5756daa59 100644 --- a/proof/refine/RISCV64/Finalise_R.thy +++ b/proof/refine/RISCV64/Finalise_R.thy @@ -11,7 +11,7 @@ imports Retype_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare doUnbindNotification_def[simp] @@ -88,7 +88,7 @@ crunch clearUntypedFreeIndex global_interpretation clearUntypedFreeIndex: typ_at_all_props' "clearUntypedFreeIndex slot" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch postCapDeletion for tcb_at'[wp]: "tcb_at' t" @@ -202,7 +202,7 @@ locale mdb_empty = slot (cteCap_update (%_. capability.NullCap))) slot (cteMDBNode_update (const nullMDBNode))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemmas m_slot_prev = m_p_prev lemmas m_slot_next = m_p_next @@ -1405,7 +1405,7 @@ lemma deletedIRQHandler_irqs_masked'[wp]: apply (simp add: irqs_masked'_def) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setObject_cte_irq_masked'[wp]: "setObject p (v::cte) \irqs_masked'\" @@ -2023,7 +2023,7 @@ lemma (in vmdb) isFinal_untypedParent: sameObjectAs_sym) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma no_fail_isFinalCapability [wp]: "no_fail (valid_mdb' and cte_wp_at' ((=) cte) p) (isFinalCapability cte)" @@ -2248,7 +2248,7 @@ lemma finaliseCap_cases[wp]: apply (auto simp add: isCap_simps cap_has_cleanup'_def) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch finaliseCap for aligned'[wp]: pspace_aligned' @@ -2402,7 +2402,7 @@ crunch replyRemove and pspace_in_kernel_mappings'[wp]: pspace_in_kernel_mappings' (simp: crunch_simps wp: crunch_wps) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch replyRemove, handleFaultReply for ex_nonz_cap_to'[wp]: "ex_nonz_cap_to' ptr" @@ -2682,7 +2682,7 @@ lemma finaliseCap_True_invs'[wp]: apply (wp irqs_masked_lift| simp | wpc)+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma invs_asid_update_strg': "invs' s \ tab = riscvKSASIDTable (ksArchState s) \ @@ -3604,7 +3604,7 @@ lemma suspend_cte_wp_at': apply (wpsimp wp: hoare_vcg_imp_lift hoare_disjI2[where Q'="\_. cte_wp_at' a b" for a b]) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch deleteASIDPool for cte_wp_at'[wp]: "cte_wp_at' P p" @@ -3914,7 +3914,7 @@ lemma finaliseCap_cte_cap_wp_to[wp]: global_interpretation unbindNotification: typ_at_all_props' "unbindNotification tcb" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma finaliseCap_valid_cap[wp]: "\valid_cap' cap\ finaliseCap cap final flag \\rv. valid_cap' (fst rv)\" @@ -3980,7 +3980,7 @@ lemma (in delete_one) deletingIRQHandler_corres: apply (clarsimp simp: cte_wp_at_ctes_of) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma arch_finaliseCap_corres: "\ final_matters' (ArchObjectCap cap') \ final = final'; acap_relation cap cap' \ @@ -4559,7 +4559,7 @@ lemma can_fast_finalise_finaliseCap: = do finaliseCap cap final True; return (NullCap, NullCap) od" by (cases cap; simp add: finaliseCap_def isCap_simps) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma finaliseCap_corres: "\ final_matters' cap' \ final = final'; cap_relation cap cap'; @@ -4662,7 +4662,7 @@ lemma threadSet_ct_idle_or_in_cur_domain': apply (auto simp: obj_at'_def) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas final_matters'_simps = final_matters'_def [split_simps capability.split arch_capability.split] diff --git a/proof/refine/RISCV64/Init_R.thy b/proof/refine/RISCV64/Init_R.thy index 9c8c4b1348..0b2d29da07 100644 --- a/proof/refine/RISCV64/Init_R.thy +++ b/proof/refine/RISCV64/Init_R.thy @@ -10,7 +10,7 @@ imports begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* This provides a very simple witness that the state relation used in the first refinement proof is diff --git a/proof/refine/RISCV64/InterruptAcc_R.thy b/proof/refine/RISCV64/InterruptAcc_R.thy index ca8196b449..6ba0750bbb 100644 --- a/proof/refine/RISCV64/InterruptAcc_R.thy +++ b/proof/refine/RISCV64/InterruptAcc_R.thy @@ -22,7 +22,7 @@ crunch modifyWorkUnits for typ_at'[wp]: "\s. P (typ_at' T p s)" and sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) global_interpretation modifyWorkUnits: typ_at_all_props' "modifyWorkUnits f" by typ_at_props' diff --git a/proof/refine/RISCV64/Interrupt_R.thy b/proof/refine/RISCV64/Interrupt_R.thy index 1a33e84fbe..1dfd9caf02 100644 --- a/proof/refine/RISCV64/Interrupt_R.thy +++ b/proof/refine/RISCV64/Interrupt_R.thy @@ -14,7 +14,7 @@ begin context Arch begin -(*FIXME: arch_split: move up *) +(*FIXME: arch-split: move up *) requalify_types irqcontrol_invocation @@ -22,11 +22,11 @@ lemmas [crunch_def] = decodeIRQControlInvocation_def performIRQControl_def context begin global_naming global -(*FIXME: arch_split: move up *) +(*FIXME: arch-split: move up *) requalify_types Invocations_H.irqcontrol_invocation -(*FIXME: arch_split*) +(*FIXME: arch-split*) requalify_facts Interrupt_H.decodeIRQControlInvocation_def Interrupt_H.performIRQControl_def @@ -95,7 +95,7 @@ where ex_cte_cap_to' ptr and real_cte_at' ptr and (Not o irq_issued' irq) and K (irq \ maxIRQ \ irq \ irqInvalid))" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma decodeIRQHandlerInvocation_corres: "\ list_all2 cap_relation (map fst caps) (map fst caps'); diff --git a/proof/refine/RISCV64/Invariants_H.thy b/proof/refine/RISCV64/Invariants_H.thy index 26e11faccc..a8798c69aa 100644 --- a/proof/refine/RISCV64/Invariants_H.thy +++ b/proof/refine/RISCV64/Invariants_H.thy @@ -1415,7 +1415,7 @@ locale mdb_order = mdb_next + \ \---------------------------------------------------------------------------\ section "Alternate split rules for preserving subgoal order" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ntfn_splits[split]: " P (case ntfn of Structures_H.ntfn.IdleNtfn \ f1 | Structures_H.ntfn.ActiveNtfn x \ f2 x @@ -3288,7 +3288,7 @@ lemma ex_cte_cap_to'_pres: section "Relationship of Executable Spec to Kernel Configuration" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma page_table_pte_atI': "page_table_at' p s \ pte_at' (p + (ucast (x::pt_index) << pte_bits)) s" @@ -3453,7 +3453,7 @@ lemma vms_sch_act_update'[iff]: valid_machine_state' s" by (simp add: valid_machine_state'_def ) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas bit_simps' = pteBits_def asidHighBits_def asidPoolBits_def asid_low_bits_def asid_high_bits_def minSchedContextBits_def diff --git a/proof/refine/RISCV64/Invocations_R.thy b/proof/refine/RISCV64/Invocations_R.thy index e8b65fe583..bb1a133618 100644 --- a/proof/refine/RISCV64/Invocations_R.thy +++ b/proof/refine/RISCV64/Invocations_R.thy @@ -8,7 +8,7 @@ theory Invocations_R imports Invariants_H begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma invocationType_eq[simp]: "invocationType = invocation_type" diff --git a/proof/refine/RISCV64/IpcCancel_R.thy b/proof/refine/RISCV64/IpcCancel_R.thy index f0ac9a59df..bad293b5d7 100644 --- a/proof/refine/RISCV64/IpcCancel_R.thy +++ b/proof/refine/RISCV64/IpcCancel_R.thy @@ -11,7 +11,7 @@ imports "Lib.SimpStrategy" begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* FIXME RT: remove *) declare if_weak_cong [cong] @@ -428,7 +428,7 @@ lemma cte_map_tcb_2: "cte_map (t, tcb_cnode_index 2) = t + 2*2^cte_level_bits" by (simp add: cte_map_def tcb_cnode_index_def to_bl_1 shiftl_t2n) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma reply_mdbNext_is_descendantD: assumes sr: "(s, s') \ state_relation" @@ -1760,7 +1760,7 @@ declare cart_singleton_empty2[simp] lemma sch_act_simple_not_t[simp]: "sch_act_simple s \ sch_act_not t s" by (clarsimp simp: sch_act_simple_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch setNotification for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers @@ -3239,7 +3239,7 @@ lemma setThreadState_unlive_other: apply (fastforce simp: ko_wp_at'_def obj_at'_def) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma possibleSwitchTo_unlive_other: "\ko_wp_at' (Not \ live') p and K (p \ t) and valid_tcbs'\ diff --git a/proof/refine/RISCV64/Ipc_R.thy b/proof/refine/RISCV64/Ipc_R.thy index 049f0e4c57..477208f37b 100644 --- a/proof/refine/RISCV64/Ipc_R.thy +++ b/proof/refine/RISCV64/Ipc_R.thy @@ -8,7 +8,7 @@ theory Ipc_R imports Finalise_R Reply_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas lookup_slot_wrapper_defs'[simp] = lookupSourceSlot_def lookupTargetSlot_def lookupPivotSlot_def @@ -377,7 +377,7 @@ lemma maskedAsFull_null_cap[simp]: "(capability.NullCap = maskedAsFull x y) = (x = capability.NullCap)" by (case_tac x, auto simp:maskedAsFull_def isCap_simps ) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma maskCapRights_eq_null: "(RetypeDecls_H.maskCapRights r xa = capability.NullCap) = @@ -1079,7 +1079,7 @@ crunch transferCaps global_interpretation transferCaps: typ_at_all_props' "transferCaps info caps endpoint receiver receiveBuffer" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma isIRQControlCap_mask [simp]: "isIRQControlCap (maskCapRights R c) = isIRQControlCap c" @@ -1181,7 +1181,7 @@ crunch copyMRs global_interpretation copyMRs: typ_at_all_props' "copyMRs s sb r rb n" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma copy_mrs_invs'[wp]: "\ invs' and tcb_at' s and tcb_at' r \ copyMRs s sb r rb n \\rv. invs' \" @@ -1524,7 +1524,7 @@ lemma msgFromLookupFailure_map[simp]: = msg_from_lookup_failure lf" by (cases lf, simp_all add: lookup_failure_map_def msgFromLookupFailure_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma asUser_getRestartPC_corres: "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ @@ -1608,7 +1608,7 @@ lemmas threadget_fault_corres = and f = tcb_fault and f' = tcbFault, simplified tcb_relation_def, simplified] -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch make_fault_msg for in_user_Frame[wp]: "in_user_frame buffer" @@ -1738,7 +1738,7 @@ end global_interpretation doIPCTransfer: typ_at_all_props' "doIPCTransfer s e b g r" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas dit_irq_node'[wp] = valid_irq_node_lift [OF doIPCTransfer_irq_node' doIPCTransfer_typ_at'] @@ -1905,7 +1905,7 @@ crunch replyRemove, replyRemoveTCB, cancelSignal, cancelIPC, replyClear, cteDele for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" (simp: crunch_simps wp: crunch_wps) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch handleFaultReply for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" @@ -2768,7 +2768,7 @@ global_interpretation maybeReturnSc: typ_at_all_props' "maybeReturnSc ntfnPtr tc global_interpretation setMessageInfo: typ_at_all_props' "setMessageInfo t info" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch cancel_ipc for cur[wp]: "cur_tcb" @@ -5905,7 +5905,7 @@ lemma cteInsert_cap_to': apply (clarsimp simp: cte_wp_at_ctes_of)+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch setExtraBadge, doIPCTransfer for cap_to'[wp]: "ex_nonz_cap_to' p" diff --git a/proof/refine/RISCV64/KHeap_R.thy b/proof/refine/RISCV64/KHeap_R.thy index 08b9475127..a5f1ba40cb 100644 --- a/proof/refine/RISCV64/KHeap_R.thy +++ b/proof/refine/RISCV64/KHeap_R.thy @@ -77,7 +77,7 @@ lemma koTypeOf_injectKO: apply (simp add: project_koType[symmetric]) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setObject_modify_variable_size: fixes v :: "'a :: pspace_storable" shows @@ -564,7 +564,7 @@ local @{typ reply}, @{typ endpoint}, - (*FIXME: arch_split*) + (*FIXME: arch-split*) @{typ asidpool}, @{typ pte} ]; @@ -653,7 +653,7 @@ lemma setObject_typ_at'[wp]: global_interpretation setObject: typ_at_all_props' "setObject p v" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setObject_cte_wp_at2': assumes x: "\x n tcb s t. \ t \ fst (updateObject v (KOTCB tcb) ptr x n s); Q s; @@ -2865,7 +2865,7 @@ interpretation setBoundNotification: pspace_only' "setBoundNotification ntfnPtr by (simp add: setBoundNotification_def threadSet_pspace_only') -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas setNotification_cap_to'[wp] = ex_cte_cap_to'_pres [OF set_ntfn'.cte_wp_at' set_ntfn'.ksInterruptState] @@ -3219,7 +3219,7 @@ crunch doMachineOp and idle'[wp]: "valid_idle'" and ko_wp_at'[wp]: "\s. P (ko_wp_at' T p s)" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas is_aligned_add_step_le' = is_aligned_add_step_le[simplified mask_2pm1 add_diff_eq] @@ -3434,7 +3434,7 @@ lemma ep_queued_st_tcb_at': (* cross lemmas *) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma pspace_aligned_cross: "\ pspace_aligned s; pspace_relation (kheap s) (ksPSpace s') \ \ pspace_aligned' s'" @@ -4362,7 +4362,7 @@ lemma set_refills_is_active_sc2[wp]: (* updateSchedContext *) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* update wp rules without ko_at' *) lemma updateSchedContext_wp: diff --git a/proof/refine/RISCV64/LevityCatch.thy b/proof/refine/RISCV64/LevityCatch.thy index 9ed1c7eda7..d693347f6a 100644 --- a/proof/refine/RISCV64/LevityCatch.thy +++ b/proof/refine/RISCV64/LevityCatch.thy @@ -22,7 +22,7 @@ lemma magnitudeCheck_assert: "magnitudeCheck x y n = assert (case y of None \ True | Some z \ 1 << n \ z - x)" by (simp add: magnitudeCheck_def read_magnitudeCheck_assert) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas makeObject_simps = makeObject_endpoint makeObject_notification makeObject_cte makeObject_tcb makeObject_user_data makeObject_pte @@ -60,7 +60,7 @@ lemma updateObject_default_inv: unfolding updateObject_default_def by (simp, wp magnitudeCheck_inv alignCheck_inv projectKO_inv, simp) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma to_from_apiType [simp]: "toAPIType (fromAPIType x) = Some x" by (cases x) (auto simp add: fromAPIType_def RISCV64_H.fromAPIType_def diff --git a/proof/refine/RISCV64/Machine_R.thy b/proof/refine/RISCV64/Machine_R.thy index b5f98981c8..92c5644e5b 100644 --- a/proof/refine/RISCV64/Machine_R.thy +++ b/proof/refine/RISCV64/Machine_R.thy @@ -48,7 +48,7 @@ lemma time_state_independent_HI[intro!, simp]: \ time_state_independent_H P" by (simp add: time_state_independent_H_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma dmo_getirq_inv[wp]: "irq_state_independent_H P \ \P\ doMachineOp (getActiveIRQ in_kernel) \\rv. P\" diff --git a/proof/refine/RISCV64/PageTableDuplicates.thy b/proof/refine/RISCV64/PageTableDuplicates.thy index 99c9da9e22..2dcf517844 100644 --- a/proof/refine/RISCV64/PageTableDuplicates.thy +++ b/proof/refine/RISCV64/PageTableDuplicates.thy @@ -8,7 +8,7 @@ theory PageTableDuplicates imports Syscall_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma doMachineOp_ksPSpace_inv[wp]: "\\s. P (ksPSpace s)\ doMachineOp f \\ya s. P (ksPSpace s)\" diff --git a/proof/refine/RISCV64/Refine.thy b/proof/refine/RISCV64/Refine.thy index e72029e949..2cc119e8d2 100644 --- a/proof/refine/RISCV64/Refine.thy +++ b/proof/refine/RISCV64/Refine.thy @@ -16,7 +16,7 @@ imports PageTableDuplicates begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \User memory content is the same on both levels\ lemma typ_at_AUserDataI: diff --git a/proof/refine/RISCV64/Retype_R.thy b/proof/refine/RISCV64/Retype_R.thy index ab2ad3dffd..01f11b0390 100644 --- a/proof/refine/RISCV64/Retype_R.thy +++ b/proof/refine/RISCV64/Retype_R.thy @@ -12,7 +12,7 @@ theory Retype_R imports VSpace_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition APIType_map2 :: "kernel_object + RISCV64_H.object_type \ Structures_A.apiobject_type" @@ -1163,7 +1163,7 @@ end global_interpretation update_gs: PSpace_update_eq "update_gs ty us ptrs" by (simp add: PSpace_update_eq_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ksMachineState_update_gs[simp]: "ksMachineState (update_gs tp us addrs s) = ksMachineState s" @@ -2699,9 +2699,9 @@ lemma corres_retype: by auto lemma init_arch_objects_APIType_map2: - "init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs = + "init_arch_objects (APIType_map2 (Inr ty)) dev ptr bits sz refs = (case ty of APIObjectType _ \ return () - | _ \ init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs)" + | _ \ init_arch_objects (APIType_map2 (Inr ty)) dev ptr bits sz refs)" apply (clarsimp split: RISCV64_H.object_type.split) apply (simp add: init_arch_objects_def APIType_map2_def split: apiobject_type.split) @@ -2784,7 +2784,7 @@ locale retype_mdb = vmdb + defines "n \ \p. if P p then Some makeObject else m p" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma no_0_n: "no_0 n" using no_0 by (simp add: no_0_def n_def 0) @@ -3109,7 +3109,7 @@ lemma caps_no_overlapD'': apply blast done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma valid_untyped'_helper: assumes valid : "valid_cap' c s" @@ -5505,7 +5505,7 @@ lemma createObjects_tcb_at': done lemma init_arch_objects_APIType_map2_noop: - "init_arch_objects (APIType_map2 tp) ptr n m addrs = return ()" + "init_arch_objects (APIType_map2 tp) dev ptr n m addrs = return ()" apply (simp add: init_arch_objects_def APIType_map2_def) done @@ -5530,7 +5530,7 @@ lemma corres_retype_region_createNewCaps: \ valid_pspace' s \ valid_arch_state' s \ range_cover y sz (obj_bits_api (APIType_map2 (Inr ty)) us) n \ n\ 0) (do x \ retype_region y n us (APIType_map2 (Inr ty)) dev :: obj_ref list det_ext_monad; - init_arch_objects (APIType_map2 (Inr ty)) y n us x; + init_arch_objects (APIType_map2 (Inr ty)) dev y n us x; return x od) (createNewCaps ty y n us dev)" apply (rule_tac F="range_cover y sz diff --git a/proof/refine/RISCV64/SchedContextInv_R.thy b/proof/refine/RISCV64/SchedContextInv_R.thy index 78865be38a..8e3da19b1b 100644 --- a/proof/refine/RISCV64/SchedContextInv_R.thy +++ b/proof/refine/RISCV64/SchedContextInv_R.thy @@ -11,7 +11,7 @@ begin global_interpretation schedContextCompleteYieldTo: typ_at_all_props' "schedContextCompleteYieldTo scp" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec valid_sc_inv' :: "sched_context_invocation \ kernel_state \ bool" where "valid_sc_inv' (InvokeSchedContextConsumed scptr args) = diff --git a/proof/refine/RISCV64/SchedContext_R.thy b/proof/refine/RISCV64/SchedContext_R.thy index df9fc1b4eb..a15b65e367 100644 --- a/proof/refine/RISCV64/SchedContext_R.thy +++ b/proof/refine/RISCV64/SchedContext_R.thy @@ -172,7 +172,7 @@ lemma updateSchedContext_invs'_indep: apply (frule (1) invs'_ko_at_valid_sched_context', simp) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma schedContextUpdateConsumed_corres: "corres (=) (sc_at scp) (sc_at' scp) @@ -784,7 +784,7 @@ lemma readRefillReady_no_ofail[wp]: apply (wpsimp wp: no_ofail_readCurTime) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma refillReady_corres: "sc_ptr = scPtr \ diff --git a/proof/refine/RISCV64/Schedule_R.thy b/proof/refine/RISCV64/Schedule_R.thy index 81d9ad5583..d118ee1a79 100644 --- a/proof/refine/RISCV64/Schedule_R.thy +++ b/proof/refine/RISCV64/Schedule_R.thy @@ -12,7 +12,7 @@ crunch scReleased, getReprogramTimer, getCurTime, getRefills, getReleaseQueue, g refillReady, isRoundRobin for inv[wp]: P -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare hoare_weak_lift_imp[wp_split del] @@ -106,7 +106,7 @@ global_interpretation refillNew: typ_at_all_props' "refillNew scPtr maxRefills b global_interpretation refillUpdate: typ_at_all_props' "refillUpdate scPtr newPeriod newBudget newMaxRefills" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma findM_awesome': assumes x: "\x xs. suffix (x # xs) xs' \ diff --git a/proof/refine/RISCV64/SubMonad_R.thy b/proof/refine/RISCV64/SubMonad_R.thy index 4c45fcf1fd..3d618cd57b 100644 --- a/proof/refine/RISCV64/SubMonad_R.thy +++ b/proof/refine/RISCV64/SubMonad_R.thy @@ -48,7 +48,7 @@ lemma doMachineOp_mapM_x: done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "asUser_fetch \ \t s. case (ksPSpace s t) of Some (KOTCB tcb) \ (atcbContextGet o tcbArch) tcb diff --git a/proof/refine/RISCV64/Syscall_R.thy b/proof/refine/RISCV64/Syscall_R.thy index 4e125b6dc2..831eb78040 100644 --- a/proof/refine/RISCV64/Syscall_R.thy +++ b/proof/refine/RISCV64/Syscall_R.thy @@ -12,7 +12,7 @@ theory Syscall_R imports Tcb_R Arch_R Interrupt_R SchedContextInv_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* syscall has 5 sections: m_fault h_fault m_error h_error m_finalise @@ -581,7 +581,7 @@ lemma sts_mcpriority_tcb_at'[wp]: crunch setThreadState for valid_ipc_buffer_ptr'[wp]: "valid_ipc_buffer_ptr' buf" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma sts_valid_inv'[wp]: "setThreadState st t \valid_invocation' i\" @@ -1928,7 +1928,7 @@ end global_interpretation refillResetRR: typ_at_all_props' "refillResetRR scPtr" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma refillResetRR_invs'[wp]: "refillResetRR scp \invs'\" diff --git a/proof/refine/RISCV64/TcbAcc_R.thy b/proof/refine/RISCV64/TcbAcc_R.thy index 9bd166d61d..807829012c 100644 --- a/proof/refine/RISCV64/TcbAcc_R.thy +++ b/proof/refine/RISCV64/TcbAcc_R.thy @@ -9,7 +9,7 @@ theory TcbAcc_R imports CSpace_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare if_weak_cong [cong] declare hoare_in_monad_post[wp] @@ -1630,7 +1630,7 @@ lemma no_fail_asUser[wp]: apply (wpsimp wp: hoare_drop_imps no_fail_threadGet)+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma asUser_setRegister_corres: "corres dc (tcb_at t and pspace_aligned and pspace_distinct) \ @@ -3758,7 +3758,7 @@ lemma threadGet_const: apply (clarsimp simp: obj_at'_def) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) schematic_goal l2BitmapSize_def': (* arch specific consequence *) "l2BitmapSize = numeral ?X" diff --git a/proof/refine/RISCV64/Tcb_R.thy b/proof/refine/RISCV64/Tcb_R.thy index 9e9f282f04..e22d145f03 100644 --- a/proof/refine/RISCV64/Tcb_R.thy +++ b/proof/refine/RISCV64/Tcb_R.thy @@ -8,7 +8,7 @@ theory Tcb_R imports CNodeInv_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma asUser_setNextPC_corres: "corres dc (tcb_at t and invs) (tcb_at' t and invs') @@ -1126,7 +1126,7 @@ termination recursive apply simp done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cte_map_tcb_0: "cte_map (t, tcb_cnode_index 0) = t" @@ -1431,7 +1431,7 @@ end consts copyregsets_map :: "arch_copy_register_sets \ Arch.copy_register_sets" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec tcbinv_relation :: "tcb_invocation \ tcbinvocation \ bool" diff --git a/proof/refine/RISCV64/Untyped_R.thy b/proof/refine/RISCV64/Untyped_R.thy index ce85a2f30a..322c16af35 100644 --- a/proof/refine/RISCV64/Untyped_R.thy +++ b/proof/refine/RISCV64/Untyped_R.thy @@ -12,7 +12,7 @@ begin unbundle l4v_word_context -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec untypinv_relation :: "Invocations_A.untyped_invocation \ @@ -978,7 +978,7 @@ locale mdb_insert_again = context mdb_insert_again begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemmas parent = mdb_ptr_parent.m_p lemmas site = mdb_ptr_site.m_p @@ -1372,7 +1372,7 @@ crunch create_cap_ext crunch create_cap_ext for work_units_completed[wp]: "\s. P (work_units_completed s)" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma updateNewFreeIndex_noop_psp_corres: "corres_underlying {(s, s'). pspace_relations (ekheap s) (kheap s) (ksPSpace s')} False True @@ -1745,7 +1745,7 @@ locale mdb_insert_again_all = mdb_insert_again_child + fixes n' defines "n' \ modify_map n (mdbNext parent_node) (cteMDBNode_update (mdbPrev_update (\a. site)))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma no_0_n' [simp]: "no_0 n'" using no_0_n by (simp add: n'_def) @@ -2708,7 +2708,7 @@ lemma caps_overlap_reserved'_D: apply fastforce done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma insertNewCap_valid_mdb: "\valid_mdb' and valid_objs' and K (slot \ p) and caps_overlap_reserved' (untypedRange cap) and @@ -2754,7 +2754,7 @@ end global_interpretation updateNewFreeIndex: typ_at_all_props' "updateNewFreeIndex slot" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma updateNewFreeIndex_valid_objs[wp]: "\valid_objs'\ updateNewFreeIndex slot \\_. valid_objs'\" @@ -3941,7 +3941,7 @@ lemma cte_wp_at': "cte_wp_at' (\cte. cteCap cte = capability.UntypedCap using vui by (auto simp: cte_wp_at_ctes_of) -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma idx_cases: "((\ reset \ idx \ unat (ptr - (ptr && ~~ mask sz))) \ reset \ ptr = ptr && ~~ mask sz)" @@ -4108,7 +4108,7 @@ lemma idx_le_new_offs: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch deleteObjects for ksIdleThread[wp]: "\s. P (ksIdleThread s)" @@ -4255,7 +4255,7 @@ lemma ex_tupI: "P (fst x) (snd x) \ \a b. P a b" by blast -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma resetUntypedCap_corres: "untypinv_relation ui ui' @@ -4483,7 +4483,7 @@ lemma ex_cte_cap_wp_to_irq_state_independent_H[simp]: "irq_state_independent_H (ex_cte_cap_wp_to' P slot)" by (simp add: ex_cte_cap_wp_to'_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma updateFreeIndex_ctes_of: "\\s. P (modify_map (ctes_of s) ptr (cteCap_update (capFreeIndex_update (\_. idx))))\ @@ -4715,7 +4715,7 @@ lemma (in range_cover) funky_aligned: defs canonicalAddressAssert_def: "canonicalAddressAssert p \ RISCV64.canonical_address p" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) defs archOverlap_def: "archOverlap \ \_ _. False" diff --git a/proof/refine/RISCV64/VSpace_R.thy b/proof/refine/RISCV64/VSpace_R.thy index 99acae5baf..94eaea373a 100644 --- a/proof/refine/RISCV64/VSpace_R.thy +++ b/proof/refine/RISCV64/VSpace_R.thy @@ -13,14 +13,14 @@ theory VSpace_R imports TcbAcc_R begin -context Arch begin global_naming RISCV64 (*FIXME: arch_split*) +context Arch begin global_naming RISCV64 (*FIXME: arch-split*) (*FIXME: move to ainvs*) lemmas store_pte_typ_ats[wp] = store_pte_typ_ats abs_atyp_at_lifts[OF store_pte_typ_at] end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "vspace_at_asid' vs asid \ \s. \ap pool. @@ -300,7 +300,7 @@ sublocale Arch < performASIDPoolInvocation: typ_at_all_props' "performASIDPoolIn sublocale Arch < performPageInvocation: typ_at_all_props' "performPageInvocation iv" by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma getObject_PTE_corres'': assumes "p' = p" diff --git a/proof/refine/RISCV64/orphanage/Orphanage.thy b/proof/refine/RISCV64/orphanage/Orphanage.thy index b1bc552e9e..9ef514c4dd 100644 --- a/proof/refine/RISCV64/orphanage/Orphanage.thy +++ b/proof/refine/RISCV64/orphanage/Orphanage.thy @@ -14,7 +14,7 @@ text \ or about to be switched to, or be in a scheduling queue. \ -(*FIXME: arch_split: move up? *) +(*FIXME: arch-split: move up? *) context Arch begin requalify_facts @@ -30,7 +30,7 @@ requalify_facts end end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition is_active_thread_state :: "thread_state \ bool" diff --git a/proof/refine/X64/ADT_H.thy b/proof/refine/X64/ADT_H.thy index d736b254d3..692e074674 100644 --- a/proof/refine/X64/ADT_H.thy +++ b/proof/refine/X64/ADT_H.thy @@ -28,7 +28,7 @@ consts initBootFrames :: "machine_word list" initDataStart :: machine_word -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \ The construction of the abstract data type @@ -1639,7 +1639,7 @@ locale partial_sort_cdt = partial_sort "\ x y. m' \ cte_map begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma valid_list_2 : "valid_list_2 t m" apply (insert assms') @@ -1836,7 +1836,7 @@ lemma sort_cdt_list_correct: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition absCDTList where "absCDTList cnp h \ sort_cdt_list (absCDT cnp h) h" diff --git a/proof/refine/X64/ArchAcc_R.thy b/proof/refine/X64/ArchAcc_R.thy index a33e4b6ebc..70febd9bc3 100644 --- a/proof/refine/X64/ArchAcc_R.thy +++ b/proof/refine/X64/ArchAcc_R.thy @@ -12,7 +12,7 @@ theory ArchAcc_R imports SubMonad_R ArchMove_R begin -context Arch begin global_naming X64_A (*FIXME: arch_split*) +context Arch begin global_naming X64_A (*FIXME: arch-split*) lemma asid_pool_at_ko: "asid_pool_at p s \ \pool. ko_at (ArchObj (X64_A.ASIDPool pool)) p s" @@ -25,7 +25,7 @@ lemma asid_pool_at_ko: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare if_cong[cong] diff --git a/proof/refine/X64/Arch_R.thy b/proof/refine/X64/Arch_R.thy index 7065b5d8a8..9f298cff5b 100644 --- a/proof/refine/X64/Arch_R.thy +++ b/proof/refine/X64/Arch_R.thy @@ -15,7 +15,7 @@ begin unbundle l4v_word_context -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare is_aligned_shiftl [intro!] declare is_aligned_shiftr [intro!] diff --git a/proof/refine/X64/Bits_R.thy b/proof/refine/X64/Bits_R.thy index b211aeaedd..c997541ad9 100644 --- a/proof/refine/X64/Bits_R.thy +++ b/proof/refine/X64/Bits_R.thy @@ -26,7 +26,7 @@ crunch_ignore (add: emptyOnFailure clearMemoryVM null_cap_on_failure setNextPC getRestartPC assertDerived throw_on_false setObject getObject updateObject loadObject) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma throwE_R: "\\\ throw f \P\,-" by (simp add: validE_R_def) wp diff --git a/proof/refine/X64/CNodeInv_R.thy b/proof/refine/X64/CNodeInv_R.thy index 308d4e2dd3..ce6a0ebdb5 100644 --- a/proof/refine/X64/CNodeInv_R.thy +++ b/proof/refine/X64/CNodeInv_R.thy @@ -15,7 +15,7 @@ begin unbundle l4v_word_context -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec valid_cnode_inv' :: "Invocations_H.cnode_invocation \ kernel_state \ bool" @@ -4980,7 +4980,7 @@ lemma cteSwap_valid_pspace'[wp]: apply clarsimp+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch cteSwap for tcb_at[wp]: "tcb_at' t" @@ -6779,7 +6779,7 @@ lemmas storePDE_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF storePDE_ctes] lemmas storePDPTE_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF storePDPTE_ctes] lemmas storePML4E_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF storePML4E_ctes] -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) context notes option.case_cong_weak[cong] @@ -8017,7 +8017,7 @@ lemma (in mdb_move) m'_cap: context mdb_move begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma m_to_src: "m \ p \ src = (p \ 0 \ p = mdbPrev src_node)" @@ -8570,7 +8570,7 @@ qed end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteMove_iflive'[wp]: "\\s. if_live_then_nonz_cap' s @@ -8775,7 +8775,7 @@ crunch updateMDB for valid_bitmaps[wp]: valid_bitmaps (rule: valid_bitmaps_lift) -(* FIXME: arch_split *) +(* FIXME: arch-split *) lemma haskell_assert_inv: "haskell_assert Q L \P\" by wpsimp diff --git a/proof/refine/X64/CSpace1_R.thy b/proof/refine/X64/CSpace1_R.thy index eca14c9c75..717408df1e 100644 --- a/proof/refine/X64/CSpace1_R.thy +++ b/proof/refine/X64/CSpace1_R.thy @@ -14,7 +14,7 @@ imports "AInvs.ArchDetSchedSchedule_AI" begin -context Arch begin global_naming X64_A (*FIXME: arch_split*) +context Arch begin global_naming X64_A (*FIXME: arch-split*) lemmas final_matters_def = final_matters_def[simplified final_matters_arch_def] @@ -25,7 +25,7 @@ lemmas final_matters_simps[simp] end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma isMDBParentOf_CTE1: "isMDBParentOf (CTE cap node) cte = @@ -2973,7 +2973,7 @@ locale masterCap = fixes cap cap' assumes master: "capMasterCap cap = capMasterCap cap'" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma isZombie [simp]: "isZombie cap' = isZombie cap" using master @@ -3572,7 +3572,7 @@ locale mdb_insert_sib = mdb_insert_der + (mdbRevocable_update (\a. isCapRevocable c' src_cap) (mdbPrev_update (\a. src) src_node))))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) (* If dest is inserted as sibling, src can not have had children. If it had had children, then dest_node which is just a derived copy @@ -3719,7 +3719,7 @@ lemma descendants: by (rule set_eqI) (simp add: descendants_of'_def parent_n_eq) end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma mdb_None: assumes F: "\p'. cte_map p \ descendants_of' p' m' \ False" assumes R: "cdt_relation (swp cte_at s) (cdt s) m'" @@ -4612,7 +4612,7 @@ locale mdb_inv_preserve = \ (\x. sameRegionAs x (cteCap cte)) = (\x. sameRegionAs x (cteCap cte'))" assumes mdb_next:"\p. mdb_next m p = mdb_next m' p" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma preserve_stuff: "valid_dlist m = valid_dlist m' \ ut_revocable' m = ut_revocable' m' @@ -5303,7 +5303,7 @@ lemma cte_map_inj_eq': apply (rule cte_map_inj_eq; fastforce) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_corres: notes split_paired_All[simp del] split_paired_Ex[simp del] trans_state_update'[symmetric,simp] @@ -7288,7 +7288,7 @@ lemma subtree_no_parent: shows "False" using assms by induct (auto simp: parentOf_def mdb_next_unfold) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ensureNoChildren_corres: "p' = cte_map p \ diff --git a/proof/refine/X64/CSpace_I.thy b/proof/refine/X64/CSpace_I.thy index 0883f69d7e..511a6e758d 100644 --- a/proof/refine/X64/CSpace_I.thy +++ b/proof/refine/X64/CSpace_I.thy @@ -12,7 +12,7 @@ theory CSpace_I imports ArchAcc_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma capUntypedPtr_simps [simp]: "capUntypedPtr (ThreadCap r) = r" @@ -1574,7 +1574,7 @@ lemma no_mdb_not_target: apply (simp add: no_mdb_def) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma valid_dlist_init: "\ valid_dlist m; m p = Some cte; no_mdb cte \ \ valid_dlist (m (p \ CTE cap initMDBNode))" @@ -1772,7 +1772,7 @@ lemma untyped_inc_init: apply (rule untypedRange_in_capRange)+ apply (simp add:Int_ac) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma valid_nullcaps_init: "\ valid_nullcaps m; cap \ NullCap \ \ valid_nullcaps (m(p \ CTE cap initMDBNode))" by (simp add: valid_nullcaps_def initMDBNode_def nullPointer_def) @@ -1832,7 +1832,7 @@ lemma distinct_zombies_copyE: lemmas distinct_zombies_sameE = distinct_zombies_copyE [where y=x and x=x for x, simplified, OF _ _ _ _ _] -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma capBits_Master: "capBits (capMasterCap cap) = capBits cap" by (clarsimp simp: capMasterCap_def split: capability.split arch_capability.split) diff --git a/proof/refine/X64/CSpace_R.thy b/proof/refine/X64/CSpace_R.thy index 95b31abac5..101b3d92b3 100644 --- a/proof/refine/X64/CSpace_R.thy +++ b/proof/refine/X64/CSpace_R.thy @@ -53,7 +53,7 @@ locale mdb_move = modify_map n (mdbNext src_node) (cteMDBNode_update (mdbPrev_update (\_. dest)))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemmas src = m_p @@ -734,7 +734,7 @@ lemma set_cap_not_quite_corres': apply (fastforce simp: c p pspace_relations_def)+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteMove_corres: assumes cr: "cap_relation cap cap'" notes trans_state_update'[symmetric,simp] @@ -1130,7 +1130,7 @@ crunch cteInsert end context mdb_insert begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma n_src_dest: "n \ src \ dest" by (simp add: n_direct_eq) @@ -1673,7 +1673,7 @@ lemma is_derived_badge_derived': "is_derived' m src cap cap' \ badge_derived' cap cap'" by (simp add: is_derived'_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_mdb_chain_0: "\valid_mdb' and pspace_aligned' and pspace_distinct' and (\s. src \ dest) and @@ -4757,7 +4757,7 @@ locale mdb_insert_simple = mdb_insert + assumes safe_parent: "safe_parent_for' m src c'" assumes simple: "is_simple_cap' c'" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma dest_no_parent_n: "n \ dest \ p = False" using src simple safe_parent @@ -4957,7 +4957,7 @@ lemma maskedAsFull_revokable_safe_parent: apply (rule conjI; clarsimp) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_simple_corres: assumes "cap_relation c c'" "src' = cte_map src" "dest' = cte_map dest" @@ -5338,7 +5338,7 @@ locale mdb_insert_simple' = mdb_insert_simple + fixes n' defines "n' \ modify_map n (mdbNext src_node) (cteMDBNode_update (mdbPrev_update (\_. dest)))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma no_0_n' [intro!]: "no_0 n'" by (auto simp: n'_def) lemmas n_0_simps' [iff] = no_0_simps [OF no_0_n'] @@ -6093,7 +6093,7 @@ lemma updateCapFreeIndex_no_0: apply (clarsimp simp:cte_wp_at_ctes_of)+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_simple_mdb': "\valid_mdb' and pspace_aligned' and pspace_distinct' and (\s. src \ dest) and K (capAligned cap) and diff --git a/proof/refine/X64/Detype_R.thy b/proof/refine/X64/Detype_R.thy index 84f3c2be02..77a7f92807 100644 --- a/proof/refine/X64/Detype_R.thy +++ b/proof/refine/X64/Detype_R.thy @@ -8,7 +8,7 @@ theory Detype_R imports Retype_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \Establishing that the invariants are maintained when a region of memory is detyped, that is, @@ -86,7 +86,7 @@ lemma descendants_range_inD': done end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma descendants_range'_def2: "descendants_range' cap p = descendants_range_in' (capRange cap) p" @@ -471,7 +471,7 @@ lemma (in detype_locale') deletionIsSafe: and vu: "valid_untyped (cap.UntypedCap d base magnitude idx) s" shows "deletionIsSafe base magnitude s'" proof - - interpret Arch . (* FIXME: arch_split *) + interpret Arch . (* FIXME: arch-split *) note blah[simp del] = atLeastatMost_subset_iff atLeastLessThan_iff Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex atLeastAtMost_iff @@ -552,7 +552,7 @@ proof - thus ?thesis using cte by (auto simp: deletionIsSafe_def) qed -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \Invariant preservation across concrete deletion\ @@ -603,7 +603,7 @@ locale delete_locale = and al: "is_aligned base bits" and safe: "deletionIsSafe base bits s'" -context delete_locale begin interpretation Arch . (*FIXME: arch_split*) +context delete_locale begin interpretation Arch . (*FIXME: arch-split*) lemma valid_objs: "valid_objs' s'" and pa: "pspace_aligned' s'" @@ -840,7 +840,7 @@ lemma refs_notRange: done end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* FIXME: generalizes lemma SubMonadLib.corres_submonad *) (* FIXME: generalizes lemma SubMonad_R.corres_machine_op *) @@ -1072,7 +1072,7 @@ lemma deleteObjects_corres: done end -context delete_locale begin interpretation Arch . (*FIXME: arch_split*) +context delete_locale begin interpretation Arch . (*FIXME: arch-split*) lemma live_idle_untyped_range': "ko_wp_at' live' p s' \ p = idle_thread_ptr \ p \ base_bits" @@ -1390,7 +1390,7 @@ using vds proof (simp add: invs'_def valid_state'_def valid_pspace'_def valid_mdb'_def valid_mdb_ctes_def, safe) - interpret Arch . (*FIXME: arch_split*) + interpret Arch . (*FIXME: arch-split*) let ?s = state' let ?ran = base_bits @@ -1790,7 +1790,7 @@ lemma doMachineOp_modify: apply (rule ext) apply (simp add: simpler_gets_def simpler_modify_def bind_def) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma deleteObjects_invs': "\cte_wp_at' (\c. cteCap c = UntypedCap d ptr bits idx) p and invs' and ct_active' and sch_act_simple diff --git a/proof/refine/X64/EmptyFail.thy b/proof/refine/X64/EmptyFail.thy index 7c62a3f9ce..a9e8a9df02 100644 --- a/proof/refine/X64/EmptyFail.thy +++ b/proof/refine/X64/EmptyFail.thy @@ -66,7 +66,7 @@ lemma empty_fail_getSlotCap [intro!, wp, simp]: "empty_fail (getSlotCap a)" unfolding getSlotCap_def by fastforce -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma empty_fail_getObject: assumes "\b c d. empty_fail (loadObject x b c d::'a :: pspace_storable kernel)" diff --git a/proof/refine/X64/EmptyFail_H.thy b/proof/refine/X64/EmptyFail_H.thy index abd008ae8e..dd6659e2fe 100644 --- a/proof/refine/X64/EmptyFail_H.thy +++ b/proof/refine/X64/EmptyFail_H.thy @@ -13,7 +13,7 @@ crunch_ignore (empty_fail) CSpaceDecls_H.resolveAddressBits doMachineOp suspend restart schedule) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas forM_empty_fail[intro!, wp, simp] = empty_fail_mapM[simplified forM_def[symmetric]] lemmas forM_x_empty_fail[intro!, wp, simp] = empty_fail_mapM_x[simplified forM_x_def[symmetric]] diff --git a/proof/refine/X64/Finalise_R.thy b/proof/refine/X64/Finalise_R.thy index 546ebcc0a1..9e91269b5a 100644 --- a/proof/refine/X64/Finalise_R.thy +++ b/proof/refine/X64/Finalise_R.thy @@ -10,7 +10,7 @@ imports InterruptAcc_R Retype_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare doUnbindNotification_def[simp] @@ -183,7 +183,7 @@ locale mdb_empty = slot (cteCap_update (%_. capability.NullCap))) slot (cteMDBNode_update (const nullMDBNode))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemmas m_slot_prev = m_p_prev lemmas m_slot_next = m_p_next @@ -1509,7 +1509,7 @@ lemma deletedIRQHandler_irqs_masked'[wp]: apply (simp add: irqs_masked'_def) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch emptySlot for irqs_masked'[wp]: "irqs_masked'" @@ -2189,7 +2189,7 @@ lemma (in vmdb) isFinal_untypedParent: sameObjectAs_sym) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma no_fail_isFinalCapability [wp]: "no_fail (valid_mdb' and cte_wp_at' ((=) cte) p) (isFinalCapability cte)" @@ -3107,7 +3107,7 @@ lemma suspend_cte_wp_at': | simp add: x)+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch deleteASIDPool for cte_wp_at'[wp]: "cte_wp_at' P p" @@ -3437,7 +3437,7 @@ lemma finaliseCap_valid_cap[wp]: done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch "Arch.finaliseCap" for nosch[wp]: "\s. P (ksSchedulerAction s)" @@ -3499,7 +3499,7 @@ lemma (in delete_one) deletingIRQHandler_corres: apply (clarsimp simp: cte_wp_at_ctes_of) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma arch_finaliseCap_corres: "\ final_matters' (ArchObjectCap cap') \ final = final'; acap_relation cap cap' \ @@ -3725,7 +3725,7 @@ lemma finaliseCap_corres: apply (rule corres_guard_imp [OF arch_finaliseCap_corres], (fastforce simp: valid_sched_def)+) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch copyGlobalMappings for ifunsafe'[wp]: "if_unsafe_then_cap'" diff --git a/proof/refine/X64/Init_R.thy b/proof/refine/X64/Init_R.thy index 844799594f..37861d7dd0 100644 --- a/proof/refine/X64/Init_R.thy +++ b/proof/refine/X64/Init_R.thy @@ -10,7 +10,7 @@ imports begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* This provides a very simple witness that the state relation used in the first refinement proof is diff --git a/proof/refine/X64/InterruptAcc_R.thy b/proof/refine/X64/InterruptAcc_R.thy index 5cf160806a..e2f7c27817 100644 --- a/proof/refine/X64/InterruptAcc_R.thy +++ b/proof/refine/X64/InterruptAcc_R.thy @@ -18,7 +18,7 @@ lemma getIRQSlot_corres: ucast_nat_def shiftl_t2n) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setIRQState_corres: "irq_state_relation state state' \ diff --git a/proof/refine/X64/Interrupt_R.thy b/proof/refine/X64/Interrupt_R.thy index fc38160e56..af90929ad9 100644 --- a/proof/refine/X64/Interrupt_R.thy +++ b/proof/refine/X64/Interrupt_R.thy @@ -14,7 +14,7 @@ begin context Arch begin -(*FIXME: arch_split: move up *) +(*FIXME: arch-split: move up *) requalify_types irqcontrol_invocation @@ -22,11 +22,11 @@ lemmas [crunch_def] = decodeIRQControlInvocation_def performIRQControl_def context begin global_naming global -(*FIXME: arch_split: move up *) +(*FIXME: arch-split: move up *) requalify_types Invocations_H.irqcontrol_invocation -(*FIXME: arch_split*) +(*FIXME: arch-split*) requalify_facts Interrupt_H.decodeIRQControlInvocation_def Interrupt_H.performIRQControl_def @@ -94,7 +94,7 @@ where ex_cte_cap_to' ptr and real_cte_at' ptr and (Not o irq_issued' irq) and K (irq \ maxIRQ))" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma decodeIRQHandlerInvocation_corres: "\ list_all2 cap_relation (map fst caps) (map fst caps'); diff --git a/proof/refine/X64/InvariantUpdates_H.thy b/proof/refine/X64/InvariantUpdates_H.thy index 1406c2ebba..c2daa7de54 100644 --- a/proof/refine/X64/InvariantUpdates_H.thy +++ b/proof/refine/X64/InvariantUpdates_H.thy @@ -270,7 +270,7 @@ lemma valid_arch_state'_interrupt[simp]: "valid_arch_state' (ksInterruptState_update f s) = valid_arch_state' s" by (simp add: valid_arch_state'_def cong: option.case_cong) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma valid_ioports_cr3_update[simp]: "valid_ioports' (s\ksArchState := x64KSCurrentUserCR3_update (\_. c) (ksArchState s)\) = valid_ioports' s" diff --git a/proof/refine/X64/Invariants_H.thy b/proof/refine/X64/Invariants_H.thy index b237e71d45..64124182bc 100644 --- a/proof/refine/X64/Invariants_H.thy +++ b/proof/refine/X64/Invariants_H.thy @@ -47,7 +47,7 @@ lemma le_maxDomain_eq_less_numDomains: by (auto simp: Kernel_Config.numDomains_def maxDomain_def word_le_nat_alt) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) \ \---------------------------------------------------------------------------\ section "Invariants on Executable Spec" @@ -338,7 +338,7 @@ where section "Valid caps and objects (Haskell)" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec acapBits :: "arch_capability \ nat" where @@ -397,7 +397,7 @@ definition -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition page_table_at' :: "machine_word \ kernel_state \ bool" @@ -1458,7 +1458,7 @@ locale mdb_order = mdb_next + \ \---------------------------------------------------------------------------\ section "Alternate split rules for preserving subgoal order" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ntfn_splits[split]: " P (case ntfn of Structures_H.ntfn.IdleNtfn \ f1 | Structures_H.ntfn.ActiveNtfn x \ f2 x @@ -3123,7 +3123,7 @@ lemma ex_cte_cap_to'_pres: apply assumption apply simp done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma page_directory_pde_atI': "\ page_directory_at' p s; x < 2 ^ ptTranslationBits \ \ pde_at' (p + (x << word_size_bits)) s" by (simp add: page_directory_at'_def pageBits_def) @@ -3299,7 +3299,7 @@ lemma vms_sch_act_update'[iff]: "valid_machine_state' (ksSchedulerAction_update f s) = valid_machine_state' s" by (simp add: valid_machine_state'_def ) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma objBitsT_simps: "objBitsT EndpointT = epSizeBits" "objBitsT NotificationT = ntfnSizeBits" diff --git a/proof/refine/X64/Invocations_R.thy b/proof/refine/X64/Invocations_R.thy index 60ffad1ed0..5f49d06d96 100644 --- a/proof/refine/X64/Invocations_R.thy +++ b/proof/refine/X64/Invocations_R.thy @@ -8,7 +8,7 @@ theory Invocations_R imports Invariants_H begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma invocationType_eq[simp]: "invocationType = invocation_type" diff --git a/proof/refine/X64/IpcCancel_R.thy b/proof/refine/X64/IpcCancel_R.thy index 45bf872c51..f599dd7f35 100644 --- a/proof/refine/X64/IpcCancel_R.thy +++ b/proof/refine/X64/IpcCancel_R.thy @@ -9,7 +9,7 @@ imports Schedule_R "Lib.SimpStrategy" begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch cancelAllIPC for aligned'[wp]: pspace_aligned' @@ -350,7 +350,7 @@ lemma cte_map_tcb_2: "cte_map (t, tcb_cnode_index 2) = t + 2*2^cte_level_bits" by (simp add: cte_map_def tcb_cnode_index_def to_bl_1) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cte_wp_at_master_reply_cap_to_ex_rights: "cte_wp_at (is_master_reply_cap_to t) ptr @@ -524,7 +524,7 @@ lemma (in delete_one) cancelIPC_ReplyCap_corres: od) od)" proof - - interpret Arch . (*FIXME: arch_split*) + interpret Arch . (*FIXME: arch-split*) show ?thesis apply (simp add: reply_cancel_ipc_def getThreadReplySlot_def locateSlot_conv liftM_def tcbReplySlot_def @@ -653,7 +653,7 @@ declare cart_singleton_empty2[simp] lemma sch_act_simple_not_t[simp]: "sch_act_simple s \ sch_act_not t s" by (clarsimp simp: sch_act_simple_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch setNotification for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers @@ -1217,7 +1217,7 @@ lemma do_extended_op_pspace_distinct[wp]: "do_extended_op f \pspace_distinct\" by (wpsimp simp: do_extended_op_def) -context begin interpretation Arch . (* FIXME: arch_split *) +context begin interpretation Arch . (* FIXME: arch-split *) crunch arch_post_cap_deletion for pspace_aligned[wp]: pspace_aligned @@ -1269,13 +1269,13 @@ lemma (in delete_one) suspend_corres: lemma no_fail_switchFpuOwner[wp]: "no_fail \ (X64.switchFpuOwner thread cpu)" - by (simp add: X64.switchFpuOwner_def Arch.no_fail_machine_op_lift) + by (simp add: X64.switchFpuOwner_def X64.no_fail_machine_op_lift) lemma no_fail_nativeThreadUsingFPU[wp]: "no_fail (\ and \) (X64.nativeThreadUsingFPU thread)" supply Collect_const[simp del] apply (simp only: X64.nativeThreadUsingFPU_def) - apply (wpsimp wp: Arch.no_fail_machine_op_lift) + apply (wpsimp wp: X64.no_fail_machine_op_lift) done lemma (in delete_one) prepareThreadDelete_corres: @@ -1988,7 +1988,7 @@ lemma cancelAll_unlive_helper: apply (clarsimp elim!: ko_wp_at'_weakenE) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setObject_ko_wp_at': fixes v :: "'a :: pspace_storable" assumes x: "\v :: 'a. updateObject v = updateObject_default v" diff --git a/proof/refine/X64/Ipc_R.thy b/proof/refine/X64/Ipc_R.thy index 665b14d5b3..0f295b273f 100644 --- a/proof/refine/X64/Ipc_R.thy +++ b/proof/refine/X64/Ipc_R.thy @@ -8,7 +8,7 @@ theory Ipc_R imports Finalise_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas lookup_slot_wrapper_defs'[simp] = lookupSourceSlot_def lookupTargetSlot_def lookupPivotSlot_def diff --git a/proof/refine/X64/KHeap_R.thy b/proof/refine/X64/KHeap_R.thy index 5f05460050..81e3f8de71 100644 --- a/proof/refine/X64/KHeap_R.thy +++ b/proof/refine/X64/KHeap_R.thy @@ -21,7 +21,7 @@ lemma koTypeOf_injectKO: apply (simp add: project_koType[symmetric]) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setObject_modify_variable_size: fixes v :: "'a :: pspace_storable" shows @@ -88,7 +88,7 @@ end translations (type) "'a kernel" <=(type) "kernel_state \ ('a \ kernel_state) set \ bool" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma no_fail_loadObject_default [wp]: "no_fail (\s. \obj. projectKO_opt ko = Some (obj::'a) \ diff --git a/proof/refine/X64/LevityCatch.thy b/proof/refine/X64/LevityCatch.thy index 9ba1e50687..10d81455d0 100644 --- a/proof/refine/X64/LevityCatch.thy +++ b/proof/refine/X64/LevityCatch.thy @@ -20,7 +20,7 @@ lemma magnitudeCheck_assert: split: option.split) apply fastforce done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas makeObject_simps = makeObject_endpoint makeObject_notification makeObject_cte makeObject_tcb makeObject_user_data makeObject_pde makeObject_pte @@ -55,7 +55,7 @@ lemma updateObject_default_inv: "\P\ updateObject_default obj ko x y n \\rv. P\" unfolding updateObject_default_def by (simp, wp magnitudeCheck_inv alignCheck_inv projectKO_inv, simp) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma to_from_apiType [simp]: "toAPIType (fromAPIType x) = Some x" by (cases x) (auto simp add: fromAPIType_def X64_H.fromAPIType_def toAPIType_def X64_H.toAPIType_def) diff --git a/proof/refine/X64/Machine_R.thy b/proof/refine/X64/Machine_R.thy index fb94126946..d5a9d9eb7a 100644 --- a/proof/refine/X64/Machine_R.thy +++ b/proof/refine/X64/Machine_R.thy @@ -22,7 +22,7 @@ lemma irq_state_independent_HI[intro!, simp]: \ irq_state_independent_H P" by (simp add: irq_state_independent_H_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma dmo_getirq_inv[wp]: "irq_state_independent_H P \ \P\ doMachineOp (getActiveIRQ in_kernel) \\rv. P\" diff --git a/proof/refine/X64/PageTableDuplicates.thy b/proof/refine/X64/PageTableDuplicates.thy index f91be3ed3e..786b17c3dd 100644 --- a/proof/refine/X64/PageTableDuplicates.thy +++ b/proof/refine/X64/PageTableDuplicates.thy @@ -8,7 +8,7 @@ theory PageTableDuplicates imports Syscall_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma doMachineOp_ksPSpace_inv[wp]: "\\s. P (ksPSpace s)\ doMachineOp f \\ya s. P (ksPSpace s)\" diff --git a/proof/refine/X64/Refine.thy b/proof/refine/X64/Refine.thy index c263007517..e092230ae0 100644 --- a/proof/refine/X64/Refine.thy +++ b/proof/refine/X64/Refine.thy @@ -16,7 +16,7 @@ imports PageTableDuplicates begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \User memory content is the same on both levels\ lemma typ_at_AUserDataI: diff --git a/proof/refine/X64/Retype_R.thy b/proof/refine/X64/Retype_R.thy index bde0b2c232..e8126f5bc2 100644 --- a/proof/refine/X64/Retype_R.thy +++ b/proof/refine/X64/Retype_R.thy @@ -12,7 +12,7 @@ theory Retype_R imports TcbAcc_R VSpace_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition APIType_map2 :: "kernel_object + X64_H.object_type \ Structures_A.apiobject_type" @@ -1175,7 +1175,7 @@ end global_interpretation update_gs: PSpace_update_eq "update_gs ty us ptrs" by (simp add: PSpace_update_eq_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma update_gs_id: "tp \ no_gs_types \ update_gs tp us addrs = id" @@ -1622,7 +1622,7 @@ end interpretation retype_region2_ext_extended: is_extended "retype_region2_ext ptrs type" by (unfold_locales; wp) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "retype_region2_extra_ext ptrs type \ @@ -1641,7 +1641,7 @@ end interpretation retype_region2_extra_ext_extended: is_extended "retype_region2_extra_ext ptrs type" by (unfold_locales; wp) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition retype_region2 :: "obj_ref \ nat \ nat \ Structures_A.apiobject_type \ bool \ (obj_ref list,'z::state_ext) s_monad" @@ -2721,9 +2721,9 @@ lemma corres_retype: done lemma init_arch_objects_APIType_map2: - "init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs = + "init_arch_objects (APIType_map2 (Inr ty)) dev ptr bits sz refs = (case ty of APIObjectType _ \ return () - | _ \ init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs)" + | _ \ init_arch_objects (APIType_map2 (Inr ty)) dev ptr bits sz refs)" apply (clarsimp split: X64_H.object_type.split) apply (simp add: init_arch_objects_def APIType_map2_def split: apiobject_type.split) @@ -2817,7 +2817,7 @@ locale retype_mdb = vmdb + defines "n \ \p. if P p then Some makeObject else m p" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma no_0_n: "no_0 n" using no_0 by (simp add: no_0_def n_def 0) @@ -3157,7 +3157,7 @@ lemma caps_no_overlapD'': apply blast done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma valid_untyped'_helper: assumes valid : "valid_cap' c s" and cte_at : "cte_wp_at' (\cap. cteCap cap = c) q s" @@ -5579,7 +5579,7 @@ lemma createObjects_Not_tcbQueued: lemma init_arch_objects_APIType_map2_noop: "tp \ Inr PML4Object - \ init_arch_objects (APIType_map2 tp) ptr n m addrs + \ init_arch_objects (APIType_map2 tp) dev ptr n m addrs = return ()" apply (simp add: init_arch_objects_def APIType_map2_def) apply (cases tp, simp_all split: kernel_object.split arch_kernel_object.split @@ -5645,7 +5645,7 @@ lemma corres_retype_region_createNewCaps: \ valid_pspace' s \ valid_arch_state' s \ range_cover y sz (obj_bits_api (APIType_map2 (Inr ty)) us) n \ n\ 0) (do x \ retype_region y n us (APIType_map2 (Inr ty)) dev :: obj_ref list det_ext_monad; - init_arch_objects (APIType_map2 (Inr ty)) y n us x; + init_arch_objects (APIType_map2 (Inr ty)) dev y n us x; return x od) (createNewCaps ty y n us dev)" apply (rule_tac F="range_cover y sz (obj_bits_api (APIType_map2 (Inr ty)) us) n diff --git a/proof/refine/X64/Schedule_R.thy b/proof/refine/X64/Schedule_R.thy index fb37c1c16b..2fa59346eb 100644 --- a/proof/refine/X64/Schedule_R.thy +++ b/proof/refine/X64/Schedule_R.thy @@ -8,7 +8,7 @@ theory Schedule_R imports VSpace_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare hoare_weak_lift_imp[wp_split del] diff --git a/proof/refine/X64/StateRelation.thy b/proof/refine/X64/StateRelation.thy index f8b3c00bd3..2bddf7bc16 100644 --- a/proof/refine/X64/StateRelation.thy +++ b/proof/refine/X64/StateRelation.thy @@ -12,7 +12,7 @@ theory StateRelation imports InvariantUpdates_H begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition cte_map :: "cslot_ptr \ machine_word" diff --git a/proof/refine/X64/SubMonad_R.thy b/proof/refine/X64/SubMonad_R.thy index a591ba5320..8cd3624905 100644 --- a/proof/refine/X64/SubMonad_R.thy +++ b/proof/refine/X64/SubMonad_R.thy @@ -44,7 +44,7 @@ lemma doMachineOp_mapM_x: done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "asUser_fetch \ \t s. case (ksPSpace s t) of Some (KOTCB tcb) \ (atcbContextGet o tcbArch) tcb diff --git a/proof/refine/X64/Syscall_R.thy b/proof/refine/X64/Syscall_R.thy index bc54db1691..4db9157811 100644 --- a/proof/refine/X64/Syscall_R.thy +++ b/proof/refine/X64/Syscall_R.thy @@ -12,7 +12,7 @@ theory Syscall_R imports Tcb_R Arch_R Interrupt_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* syscall has 5 sections: m_fault h_fault m_error h_error m_finalise @@ -535,7 +535,7 @@ crunch InterruptDecls_H.invokeIRQHandler for typ_at'[wp]: "\s. P (typ_at' T p s)" lemmas invokeIRQHandler_typ_ats[wp] = - typ_at_lifts [OF InterruptDecls_H_invokeIRQHandler_typ_at'] + typ_at_lifts [OF invokeIRQHandler_typ_at'] crunch setDomain for tcb_at'[wp]: "tcb_at' tptr" diff --git a/proof/refine/X64/TcbAcc_R.thy b/proof/refine/X64/TcbAcc_R.thy index 1a1f1475e5..ef658ae695 100644 --- a/proof/refine/X64/TcbAcc_R.thy +++ b/proof/refine/X64/TcbAcc_R.thy @@ -8,7 +8,7 @@ theory TcbAcc_R imports CSpace_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare if_weak_cong [cong] declare hoare_in_monad_post[wp] diff --git a/proof/refine/X64/Tcb_R.thy b/proof/refine/X64/Tcb_R.thy index 71ed81bbf1..2251376335 100644 --- a/proof/refine/X64/Tcb_R.thy +++ b/proof/refine/X64/Tcb_R.thy @@ -8,7 +8,7 @@ theory Tcb_R imports CNodeInv_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma asUser_setNextPC_corres: "corres dc (tcb_at t and invs) invs' @@ -1671,7 +1671,7 @@ end consts copyregsets_map :: "arch_copy_register_sets \ Arch.copy_register_sets" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec tcbinv_relation :: "tcb_invocation \ tcbinvocation \ bool" diff --git a/proof/refine/X64/Untyped_R.thy b/proof/refine/X64/Untyped_R.thy index 0102c32122..37391c6c25 100644 --- a/proof/refine/X64/Untyped_R.thy +++ b/proof/refine/X64/Untyped_R.thy @@ -9,7 +9,7 @@ theory Untyped_R imports Detype_R Invocations_R InterruptAcc_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec untypinv_relation :: "Invocations_A.untyped_invocation \ @@ -1032,7 +1032,7 @@ locale mdb_insert_again = context mdb_insert_again begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemmas parent = mdb_ptr_parent.m_p lemmas site = mdb_ptr_site.m_p @@ -1418,7 +1418,7 @@ crunch create_cap_ext and work_units_completed[wp]: "\s. P (work_units_completed s)" (ignore_del: create_cap_ext) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma updateNewFreeIndex_noop_psp_corres: "corres_underlying {(s, s'). pspace_relations (ekheap s) (kheap s) (ksPSpace s')} False True @@ -1775,7 +1775,7 @@ locale mdb_insert_again_all = mdb_insert_again_child + fixes n' defines "n' \ modify_map n (mdbNext parent_node) (cteMDBNode_update (mdbPrev_update (\a. site)))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma no_0_n' [simp]: "no_0 n'" using no_0_n by (simp add: n'_def) @@ -2758,7 +2758,7 @@ lemma caps_overlap_reserved'_D: apply (erule(2) impE) apply fastforce done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma insertNewCap_valid_mdb: "\valid_mdb' and valid_objs' and K (slot \ p) and caps_overlap_reserved' (untypedRange cap) and @@ -3979,7 +3979,7 @@ lemma cte_wp_at': "cte_wp_at' (\cte. cteCap cte = capability.UntypedCap "\x\set slots. ex_cte_cap_wp_to' (\_. True) x s" using vui by (auto simp: cte_wp_at_ctes_of) -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma idx_cases: "((\ reset \ idx \ unat (ptr - (ptr && ~~ mask sz))) \ reset \ ptr = ptr && ~~ mask sz)" @@ -4144,7 +4144,7 @@ lemma idx_le_new_offs: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma valid_sched_etcbs[elim!]: "valid_sched_2 queues ekh sa cdom kh ct it \ valid_etcbs_2 ekh kh" by (simp add: valid_sched_def) @@ -4302,7 +4302,7 @@ lemma ex_tupI: "P (fst x) (snd x) \ \a b. P a b" by blast -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* mostly stuff about PPtr/fromPPtr, which seems pretty soft *) lemma resetUntypedCap_corres: @@ -4515,7 +4515,7 @@ lemma ex_cte_cap_wp_to_irq_state_independent_H[simp]: "irq_state_independent_H (ex_cte_cap_wp_to' P slot)" by (simp add: ex_cte_cap_wp_to'_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma updateFreeIndex_ctes_of: "\\s. P (modify_map (ctes_of s) ptr (cteCap_update (capFreeIndex_update (\_. idx))))\ @@ -4737,7 +4737,7 @@ lemma (in range_cover) funky_aligned: apply simp done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) defs archOverlap_def: "archOverlap \ \_ _. False" diff --git a/proof/refine/X64/VSpace_R.thy b/proof/refine/X64/VSpace_R.thy index 59345acaa6..1af6e3907c 100644 --- a/proof/refine/X64/VSpace_R.thy +++ b/proof/refine/X64/VSpace_R.thy @@ -12,11 +12,11 @@ theory VSpace_R imports TcbAcc_R begin -context Arch begin global_naming X64 (*FIXME: arch_split*) +context Arch begin global_naming X64 (*FIXME: arch-split*) end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "vspace_at_asid' vs asid \ \s. \ap pool. diff --git a/spec/abstract/AARCH64/ArchCSpace_A.thy b/spec/abstract/AARCH64/ArchCSpace_A.thy index d3b32c7056..bc56bf92c0 100644 --- a/spec/abstract/AARCH64/ArchCSpace_A.thy +++ b/spec/abstract/AARCH64/ArchCSpace_A.thy @@ -12,7 +12,7 @@ imports ArchVSpace_A begin -context Arch begin global_naming AARCH64_A +context Arch begin arch_global_naming (A) definition cnode_guard_size_bits :: "nat" where "cnode_guard_size_bits \ 6" diff --git a/spec/abstract/AARCH64/ArchDecode_A.thy b/spec/abstract/AARCH64/ArchDecode_A.thy index 760949487e..61a09c5703 100644 --- a/spec/abstract/AARCH64/ArchDecode_A.thy +++ b/spec/abstract/AARCH64/ArchDecode_A.thy @@ -14,7 +14,7 @@ imports "ExecSpec.InvocationLabels_H" begin -context Arch begin global_naming AARCH64_A +context Arch begin arch_global_naming (A) section "Helper definitions" diff --git a/spec/abstract/AARCH64/ArchFault_A.thy b/spec/abstract/AARCH64/ArchFault_A.thy index d77bc9558b..3d8d6d6bc5 100644 --- a/spec/abstract/AARCH64/ArchFault_A.thy +++ b/spec/abstract/AARCH64/ArchFault_A.thy @@ -10,7 +10,7 @@ theory ArchFault_A imports Structures_A Tcb_A begin -context Arch begin global_naming AARCH64_A +context Arch begin arch_global_naming (A) fun make_arch_fault_msg :: "arch_fault \ obj_ref \ (data \ data list,'z::state_ext) s_monad" where "make_arch_fault_msg (VMFault vptr archData) thread = do diff --git a/spec/abstract/AARCH64/ArchInterrupt_A.thy b/spec/abstract/AARCH64/ArchInterrupt_A.thy index 77b9eb9786..79945af74e 100644 --- a/spec/abstract/AARCH64/ArchInterrupt_A.thy +++ b/spec/abstract/AARCH64/ArchInterrupt_A.thy @@ -11,7 +11,7 @@ theory ArchInterrupt_A imports Ipc_A begin -context Arch begin global_naming AARCH64_A +context Arch begin arch_global_naming (A) definition virqSetEOIIRQEN :: "virq \ machine_word \ virq" where "virqSetEOIIRQEN virq v \ diff --git a/spec/abstract/AARCH64/ArchInvocation_A.thy b/spec/abstract/AARCH64/ArchInvocation_A.thy index a7a83569a6..e7b63dcd8d 100644 --- a/spec/abstract/AARCH64/ArchInvocation_A.thy +++ b/spec/abstract/AARCH64/ArchInvocation_A.thy @@ -11,7 +11,7 @@ theory ArchInvocation_A imports Structures_A begin -context Arch begin global_naming AARCH64_A +context Arch begin arch_global_naming (A) text \ These datatypes encode the arguments to the various possible AARCH64-specific system calls. diff --git a/spec/abstract/AARCH64/ArchIpcCancel_A.thy b/spec/abstract/AARCH64/ArchIpcCancel_A.thy index 3b6a944668..db0cc85201 100644 --- a/spec/abstract/AARCH64/ArchIpcCancel_A.thy +++ b/spec/abstract/AARCH64/ArchIpcCancel_A.thy @@ -11,7 +11,7 @@ theory ArchIpcCancel_A imports CSpaceAcc_A begin -context Arch begin global_naming AARCH64_A +context Arch begin arch_global_naming (A) text \Actions to be taken after a cap is deleted\ definition arch_post_cap_deletion :: "arch_cap \ (unit, 'z::state_ext) s_monad" where diff --git a/spec/abstract/AARCH64/ArchRetype_A.thy b/spec/abstract/AARCH64/ArchRetype_A.thy index 0b6655da13..f3872ef2ae 100644 --- a/spec/abstract/AARCH64/ArchRetype_A.thy +++ b/spec/abstract/AARCH64/ArchRetype_A.thy @@ -13,7 +13,7 @@ imports ArchInvocation_A begin -context Arch begin global_naming AARCH64_A +context Arch begin arch_global_naming (A) text \ This is a placeholder function. We may wish to extend the specification @@ -24,9 +24,34 @@ definition reserve_region :: "obj_ref \ nat \ bool \Initialise architecture-specific objects.\ +definition vs_apiobj_size where + "vs_apiobj_size ty \ + case ty of + ArchObject SmallPageObj \ pageBitsForSize ARMSmallPage + | ArchObject LargePageObj \ pageBitsForSize ARMLargePage + | ArchObject HugePageObj \ pageBitsForSize ARMHugePage + | ArchObject PageTableObj \ table_size NormalPT_T + | ArchObject VSpaceObj \ table_size VSRootPT_T" + definition init_arch_objects :: - "apiobject_type \ obj_ref \ nat \ nat \ obj_ref list \ (unit,'z::state_ext) s_monad" where - "init_arch_objects new_type ptr num_objects obj_sz refs \ return ()" + "apiobject_type \ bool \ obj_ref \ nat \ nat \ obj_ref list \ (unit,'z::state_ext) s_monad" + where + "init_arch_objects new_type is_device ptr num_objects obj_sz refs \ + if \is_device \ + new_type \ {ArchObject SmallPageObj, ArchObject LargePageObj, ArchObject HugePageObj} + then + mapM_x (\ref. do_machine_op $ + cleanCacheRange_RAM ref (ref + mask (vs_apiobj_size new_type)) + (addrFromPPtr ref)) + refs + else if new_type \ {ArchObject PageTableObj, ArchObject VSpaceObj} + then + mapM_x (\ref. do_machine_op $ + cleanCacheRange_PoU ref (ref + mask (vs_apiobj_size new_type)) + (addrFromPPtr ref)) + refs + else + return ()" definition empty_context :: user_context where "empty_context \ UserContext (FPUState (\_. 0) 0 0) (\_. 0)" diff --git a/spec/abstract/AARCH64/ArchTcb_A.thy b/spec/abstract/AARCH64/ArchTcb_A.thy index d96effca5a..ad486ad50f 100644 --- a/spec/abstract/AARCH64/ArchTcb_A.thy +++ b/spec/abstract/AARCH64/ArchTcb_A.thy @@ -10,7 +10,7 @@ theory ArchTcb_A imports KHeap_A begin -context Arch begin global_naming AARCH64_A +context Arch begin arch_global_naming (A) definition sanitise_register :: "bool \ register \ machine_word \ machine_word" where "sanitise_register b r v \ case r of diff --git a/spec/abstract/AARCH64/ArchVSpaceAcc_A.thy b/spec/abstract/AARCH64/ArchVSpaceAcc_A.thy index 6334ccdacf..073c040f12 100644 --- a/spec/abstract/AARCH64/ArchVSpaceAcc_A.thy +++ b/spec/abstract/AARCH64/ArchVSpaceAcc_A.thy @@ -11,7 +11,7 @@ theory ArchVSpaceAcc_A imports KHeap_A begin -context Arch begin global_naming AARCH64_A +context Arch begin arch_global_naming (A) text \ This part of the specification is fairly concrete as the machine architecture is visible to diff --git a/spec/abstract/AARCH64/ArchVSpace_A.thy b/spec/abstract/AARCH64/ArchVSpace_A.thy index 40164aef35..962540c8ec 100644 --- a/spec/abstract/AARCH64/ArchVSpace_A.thy +++ b/spec/abstract/AARCH64/ArchVSpace_A.thy @@ -13,7 +13,7 @@ imports VCPUAcc_A begin -context Arch begin global_naming AARCH64_A +context Arch begin arch_global_naming (A) text \ Look up a thread's IPC buffer and check that the thread has the authority to read or (in the diff --git a/spec/abstract/AARCH64/Arch_A.thy b/spec/abstract/AARCH64/Arch_A.thy index 2b01bf2cc3..462642c0a4 100644 --- a/spec/abstract/AARCH64/Arch_A.thy +++ b/spec/abstract/AARCH64/Arch_A.thy @@ -11,7 +11,7 @@ theory Arch_A imports TcbAcc_A VCPU_A begin -context Arch begin global_naming AARCH64_A +context Arch begin arch_global_naming (A) fun arch_invoke_irq_control :: "arch_irq_control_invocation \ (unit,'z::state_ext) p_monad" where "arch_invoke_irq_control (ARMIRQControlInvocation irq handler_slot control_slot trigger) = diff --git a/spec/abstract/AARCH64/Arch_Structs_A.thy b/spec/abstract/AARCH64/Arch_Structs_A.thy index 23df8699bb..753e95142e 100644 --- a/spec/abstract/AARCH64/Arch_Structs_A.thy +++ b/spec/abstract/AARCH64/Arch_Structs_A.thy @@ -15,11 +15,11 @@ imports ExecSpec.Arch_Kernel_Config_Lemmas begin -context begin interpretation Arch . +context begin interpretation Arch . (* code equations must be added via interpretation *) lemmas [code] = pageBits_def ipa_size_def end -context Arch begin global_naming AARCH64_A +context Arch begin arch_global_naming (A) text \ This theory provides architecture-specific definitions and datatypes including @@ -157,7 +157,7 @@ record vcpu = end_qualify -context Arch begin global_naming AARCH64_A +context Arch begin arch_global_naming (A) definition "vcpu_sctlr vcpu \ vcpu_regs vcpu VCPURegSCTLR" @@ -337,7 +337,7 @@ record arch_state = end_qualify -context Arch begin global_naming AARCH64_A +context Arch begin arch_global_naming (A) section "Type declarations for invariant definitions" @@ -371,7 +371,7 @@ record arch_tcb = end_qualify -context Arch begin global_naming AARCH64_A +context Arch begin arch_global_naming (A) definition default_arch_tcb :: arch_tcb where "default_arch_tcb \ \tcb_context = new_context, tcb_vcpu = None\" diff --git a/spec/abstract/AARCH64/Hypervisor_A.thy b/spec/abstract/AARCH64/Hypervisor_A.thy index 502c97635e..b396cf8d64 100644 --- a/spec/abstract/AARCH64/Hypervisor_A.thy +++ b/spec/abstract/AARCH64/Hypervisor_A.thy @@ -10,7 +10,7 @@ theory Hypervisor_A imports Ipc_A begin -context Arch begin global_naming AARCH64_A +context Arch begin arch_global_naming (A) fun handle_hypervisor_fault :: "machine_word \ hyp_fault_type \ (unit, 'z::state_ext) s_monad" where diff --git a/spec/abstract/AARCH64/Init_A.thy b/spec/abstract/AARCH64/Init_A.thy index 3b08aa35ad..9182f606e2 100644 --- a/spec/abstract/AARCH64/Init_A.thy +++ b/spec/abstract/AARCH64/Init_A.thy @@ -13,7 +13,7 @@ imports "Lib.SplitRule" begin -context Arch begin global_naming AARCH64_A +context Arch begin arch_global_naming (A) text \ This is not a specification of true kernel initialisation. This theory describes a dummy diff --git a/spec/abstract/AARCH64/Machine_A.thy b/spec/abstract/AARCH64/Machine_A.thy index 7932435383..1bcaeae612 100644 --- a/spec/abstract/AARCH64/Machine_A.thy +++ b/spec/abstract/AARCH64/Machine_A.thy @@ -12,7 +12,7 @@ imports "ExecSpec.MachineOps" begin -context Arch begin global_naming AARCH64_A +context Arch begin arch_global_naming (A) text \ The specification is written with abstract type names for object references, user pointers, @@ -165,8 +165,6 @@ datatype arch_fault end -context begin interpretation Arch . - requalify_consts idle_thread_ptr -end +arch_requalify_consts (A) idle_thread_ptr end diff --git a/spec/abstract/AARCH64/VCPUAcc_A.thy b/spec/abstract/AARCH64/VCPUAcc_A.thy index b0c8bdfffa..26b69800fa 100644 --- a/spec/abstract/AARCH64/VCPUAcc_A.thy +++ b/spec/abstract/AARCH64/VCPUAcc_A.thy @@ -13,7 +13,7 @@ imports ArchTcb_A begin -context Arch begin global_naming AARCH64_A +context Arch begin arch_global_naming (A) section \Accessors\ @@ -39,7 +39,7 @@ definition vgic_update :: "obj_ref \ (gic_vcpu_interface \ gic_vcpu_interface) \ (unit,'z::state_ext) s_monad" where "vgic_update vr f \ vcpu_update vr (\vcpu. vcpu \ vcpu_vgic := f (vcpu_vgic vcpu) \ )" -definition vgic_update_lr :: "obj_ref \ nat \ AARCH64_A.virq \ (unit,'z::state_ext) s_monad" where +definition vgic_update_lr :: "obj_ref \ nat \ virq \ (unit,'z::state_ext) s_monad" where "vgic_update_lr vr irq_idx virq \ vgic_update vr (\vgic. vgic \ vgic_lr := (vgic_lr vgic)(irq_idx := virq) \)" diff --git a/spec/abstract/AARCH64/VCPU_A.thy b/spec/abstract/AARCH64/VCPU_A.thy index e4ed0ad630..497cce331f 100644 --- a/spec/abstract/AARCH64/VCPU_A.thy +++ b/spec/abstract/AARCH64/VCPU_A.thy @@ -13,15 +13,16 @@ imports InvocationLabels_A begin +context Arch begin arch_global_naming (A) + +section "VCPU" + text \This is used by some decode functions. VCPU decode functions are the first that need to bounds check IRQs from the user.\ definition arch_check_irq :: "data \ (unit,'z::state_ext) se_monad" where "arch_check_irq irq \ whenE (irq > maxIRQ \ irq < ucast minIRQ) $ throwError (RangeError (ucast minIRQ) maxIRQ)" -context Arch begin global_naming AARCH64_A - -section "VCPU" subsection "VCPU: Set TCB" diff --git a/spec/abstract/ARM/ArchCSpace_A.thy b/spec/abstract/ARM/ArchCSpace_A.thy index 4889b95634..8f42dd4607 100644 --- a/spec/abstract/ARM/ArchCSpace_A.thy +++ b/spec/abstract/ARM/ArchCSpace_A.thy @@ -15,7 +15,7 @@ imports ArchVSpace_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) definition cnode_guard_size_bits :: "nat" where diff --git a/spec/abstract/ARM/ArchDecode_A.thy b/spec/abstract/ARM/ArchDecode_A.thy index eff2b44e38..40a7f90f11 100644 --- a/spec/abstract/ARM/ArchDecode_A.thy +++ b/spec/abstract/ARM/ArchDecode_A.thy @@ -15,7 +15,7 @@ imports Interrupt_A InvocationLabels_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) section "Helper definitions" diff --git a/spec/abstract/ARM/ArchFault_A.thy b/spec/abstract/ARM/ArchFault_A.thy index a78b23c8b2..4283230f2b 100644 --- a/spec/abstract/ARM/ArchFault_A.thy +++ b/spec/abstract/ARM/ArchFault_A.thy @@ -14,7 +14,7 @@ theory ArchFault_A imports Structures_A Tcb_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) fun make_arch_fault_msg :: "arch_fault \ obj_ref \ (data \ data list,'z::state_ext) s_monad" where diff --git a/spec/abstract/ARM/ArchInterrupt_A.thy b/spec/abstract/ARM/ArchInterrupt_A.thy index 932acd0314..be22727826 100644 --- a/spec/abstract/ARM/ArchInterrupt_A.thy +++ b/spec/abstract/ARM/ArchInterrupt_A.thy @@ -14,7 +14,7 @@ theory ArchInterrupt_A imports Ipc_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) definition handle_reserved_irq :: "irq \ (unit,'z::state_ext) s_monad" where "handle_reserved_irq irq = return ()" diff --git a/spec/abstract/ARM/ArchInvocation_A.thy b/spec/abstract/ARM/ArchInvocation_A.thy index 61d3374e04..a721c86af3 100644 --- a/spec/abstract/ARM/ArchInvocation_A.thy +++ b/spec/abstract/ARM/ArchInvocation_A.thy @@ -14,7 +14,7 @@ theory ArchInvocation_A imports Structures_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) text \These datatypes encode the arguments to the various possible ARM-specific system calls. Selectors are defined for various fields diff --git a/spec/abstract/ARM/ArchIpcCancel_A.thy b/spec/abstract/ARM/ArchIpcCancel_A.thy index bbcc91ae82..b16dbd3140 100644 --- a/spec/abstract/ARM/ArchIpcCancel_A.thy +++ b/spec/abstract/ARM/ArchIpcCancel_A.thy @@ -14,7 +14,7 @@ theory ArchIpcCancel_A imports Sporadic_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) text \Actions to be taken after a cap is deleted\ definition diff --git a/spec/abstract/ARM/ArchRetype_A.thy b/spec/abstract/ARM/ArchRetype_A.thy index e54b651510..81f12f0a24 100644 --- a/spec/abstract/ARM/ArchRetype_A.thy +++ b/spec/abstract/ARM/ArchRetype_A.thy @@ -16,7 +16,7 @@ imports ArchInvocation_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) text \This is a placeholder function. We may wish to extend the specification with explicitly tagging kernel data regions in memory.\ @@ -26,15 +26,38 @@ definition text \Initialise architecture-specific objects.\ -definition - init_arch_objects :: "apiobject_type \ obj_ref \ nat \ nat \ obj_ref list \ (unit,'z::state_ext) s_monad" -where - "init_arch_objects new_type ptr num_objects obj_sz refs - \ if new_type = ArchObject PageDirectoryObj then (do - mapM_x copy_global_mappings refs; - do_machine_op $ mapM_x (\x. cleanCacheRange_PoU x (x + ((1::word32) << pd_bits) - 1) - (addrFromPPtr x)) refs - od) else return ()" +definition vs_apiobj_size where + "vs_apiobj_size ty \ + case ty of + ArchObject SmallPageObj \ pageBitsForSize ARMSmallPage + | ArchObject LargePageObj \ pageBitsForSize ARMLargePage + | ArchObject SectionObj \ pageBitsForSize ARMSection + | ArchObject SuperSectionObj \ pageBitsForSize ARMSuperSection + | ArchObject PageTableObj \ pt_bits + | ArchObject PageDirectoryObj \ pd_bits" + +definition init_arch_objects :: + "apiobject_type \ bool \ obj_ref \ nat \ nat \ obj_ref list \ (unit,'z::state_ext) s_monad" + where + "init_arch_objects new_type is_device ptr num_objects obj_sz refs \ do + when (new_type = ArchObject PageDirectoryObj) $ mapM_x copy_global_mappings refs; + if \is_device \ + new_type \ {ArchObject SmallPageObj, ArchObject LargePageObj, + ArchObject SectionObj, ArchObject SuperSectionObj} + then + mapM_x (\ref. do_machine_op $ + cleanCacheRange_RAM ref (ref + mask (vs_apiobj_size new_type)) + (addrFromPPtr ref)) + refs + else if new_type \ {ArchObject PageTableObj, ArchObject PageDirectoryObj} + then + mapM_x (\ref. do_machine_op $ + cleanCacheRange_PoU ref (ref + mask (vs_apiobj_size new_type)) + (addrFromPPtr ref)) + refs + else + return () + od" definition empty_context :: user_context where diff --git a/spec/abstract/ARM/ArchTcb_A.thy b/spec/abstract/ARM/ArchTcb_A.thy index fa412bbe20..27c9bc67a1 100644 --- a/spec/abstract/ARM/ArchTcb_A.thy +++ b/spec/abstract/ARM/ArchTcb_A.thy @@ -14,7 +14,7 @@ theory ArchTcb_A imports KHeap_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) definition sanitise_register :: "bool \ register \ machine_word \ machine_word" diff --git a/spec/abstract/ARM/ArchVSpaceAcc_A.thy b/spec/abstract/ARM/ArchVSpaceAcc_A.thy index 22845bf339..f7112d5ca0 100644 --- a/spec/abstract/ARM/ArchVSpaceAcc_A.thy +++ b/spec/abstract/ARM/ArchVSpaceAcc_A.thy @@ -14,7 +14,7 @@ theory ArchVSpaceAcc_A imports KHeap_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) text \ This part of the specification is fairly concrete as the machine architecture diff --git a/spec/abstract/ARM/ArchVSpace_A.thy b/spec/abstract/ARM/ArchVSpace_A.thy index 5482b17b46..fd7d4cb67f 100644 --- a/spec/abstract/ARM/ArchVSpace_A.thy +++ b/spec/abstract/ARM/ArchVSpace_A.thy @@ -14,7 +14,7 @@ theory ArchVSpace_A imports Retype_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) text \Save the set of entries that would be inserted into a page table or page directory to map various different sizes of frame at a given virtual diff --git a/spec/abstract/ARM/Arch_A.thy b/spec/abstract/ARM/Arch_A.thy index 70e53a007e..f6ff7a7033 100644 --- a/spec/abstract/ARM/Arch_A.thy +++ b/spec/abstract/ARM/Arch_A.thy @@ -15,7 +15,7 @@ theory Arch_A imports CSpace_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) definition "page_bits \ pageBits" diff --git a/spec/abstract/ARM/Arch_Structs_A.thy b/spec/abstract/ARM/Arch_Structs_A.thy index 3f21eb6de7..ee3dbd3983 100644 --- a/spec/abstract/ARM/Arch_Structs_A.thy +++ b/spec/abstract/ARM/Arch_Structs_A.thy @@ -18,7 +18,7 @@ imports ExecSpec.Arch_Kernel_Config_Lemmas begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) text \ This theory provides architecture-specific definitions and datatypes @@ -56,15 +56,6 @@ definition is_page_cap :: "arch_cap \ bool" where "is_page_cap c \ \x0 x1 x2 x3 x4. c = PageCap x0 x1 x2 x3 x4" -definition - asid_high_bits :: nat where - "asid_high_bits \ 7" -definition - asid_low_bits :: nat where - "asid_low_bits \ 10 :: nat" -definition - asid_bits :: nat where - "asid_bits \ 17 :: nat" section \Architecture-specific objects\ @@ -250,7 +241,7 @@ record arch_state = end_qualify -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) definition pd_bits :: "nat" where @@ -296,7 +287,7 @@ record arch_tcb = end_qualify -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) definition default_arch_tcb :: arch_tcb where diff --git a/spec/abstract/ARM/Hypervisor_A.thy b/spec/abstract/ARM/Hypervisor_A.thy index d94a120e36..2509823d9f 100644 --- a/spec/abstract/ARM/Hypervisor_A.thy +++ b/spec/abstract/ARM/Hypervisor_A.thy @@ -10,7 +10,7 @@ theory Hypervisor_A imports Exceptions_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) fun handle_hypervisor_fault :: "word32 \ hyp_fault_type \ (unit, 'z::state_ext) s_monad" where diff --git a/spec/abstract/ARM/Init_A.thy b/spec/abstract/ARM/Init_A.thy index 4312c9ad69..d8ab5b3686 100644 --- a/spec/abstract/ARM/Init_A.thy +++ b/spec/abstract/ARM/Init_A.thy @@ -14,7 +14,7 @@ theory Init_A imports Retype_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) text \ This is not a specification of true kernel diff --git a/spec/abstract/ARM/Machine_A.thy b/spec/abstract/ARM/Machine_A.thy index b31ff6429f..da5d59c059 100644 --- a/spec/abstract/ARM/Machine_A.thy +++ b/spec/abstract/ARM/Machine_A.thy @@ -16,7 +16,7 @@ imports "ExecSpec.MachineOps" begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) text \ The specification is written with abstract type names for object @@ -127,11 +127,9 @@ definition end -context begin interpretation Arch . - requalify_consts kernel_base idle_thread_ptr idle_sc_ptr -end +arch_requalify_consts (A) kernel_base idle_thread_ptr idle_sc_ptr -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) text \Miscellaneous definitions of constants used in modelling machine operations.\ diff --git a/spec/abstract/ARM_HYP/ArchCSpace_A.thy b/spec/abstract/ARM_HYP/ArchCSpace_A.thy index f0ee3c00d8..2ddcc5c21b 100644 --- a/spec/abstract/ARM_HYP/ArchCSpace_A.thy +++ b/spec/abstract/ARM_HYP/ArchCSpace_A.thy @@ -14,7 +14,7 @@ theory ArchCSpace_A imports ArchVSpace_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) definition cnode_guard_size_bits :: "nat" where diff --git a/spec/abstract/ARM_HYP/ArchDecode_A.thy b/spec/abstract/ARM_HYP/ArchDecode_A.thy index f06266fe0f..377fd336ab 100644 --- a/spec/abstract/ARM_HYP/ArchDecode_A.thy +++ b/spec/abstract/ARM_HYP/ArchDecode_A.thy @@ -14,7 +14,7 @@ theory ArchDecode_A imports Interrupt_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) section "Helper definitions" diff --git a/spec/abstract/ARM_HYP/ArchFault_A.thy b/spec/abstract/ARM_HYP/ArchFault_A.thy index cac2344730..63d8fcb2f3 100644 --- a/spec/abstract/ARM_HYP/ArchFault_A.thy +++ b/spec/abstract/ARM_HYP/ArchFault_A.thy @@ -14,7 +14,7 @@ theory ArchFault_A imports Structures_A Tcb_A begin -context Arch begin global_naming ARM_HYP_A +context Arch begin arch_global_naming (A) fun make_arch_fault_msg :: "arch_fault \ obj_ref \ (data \ data list,'z::state_ext) s_monad" where diff --git a/spec/abstract/ARM_HYP/ArchInterrupt_A.thy b/spec/abstract/ARM_HYP/ArchInterrupt_A.thy index 49227c8181..d74686e157 100644 --- a/spec/abstract/ARM_HYP/ArchInterrupt_A.thy +++ b/spec/abstract/ARM_HYP/ArchInterrupt_A.thy @@ -14,7 +14,7 @@ theory ArchInterrupt_A imports Ipc_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) text \VGIC Maintenance\ diff --git a/spec/abstract/ARM_HYP/ArchInvocation_A.thy b/spec/abstract/ARM_HYP/ArchInvocation_A.thy index 459df77fbb..bbed73b076 100644 --- a/spec/abstract/ARM_HYP/ArchInvocation_A.thy +++ b/spec/abstract/ARM_HYP/ArchInvocation_A.thy @@ -14,7 +14,7 @@ theory ArchInvocation_A imports Structures_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) text \These datatypes encode the arguments to the various possible ARM-specific system calls. Selectors are defined for various fields diff --git a/spec/abstract/ARM_HYP/ArchIpcCancel_A.thy b/spec/abstract/ARM_HYP/ArchIpcCancel_A.thy index 0e7742b6ce..fa745f95a0 100644 --- a/spec/abstract/ARM_HYP/ArchIpcCancel_A.thy +++ b/spec/abstract/ARM_HYP/ArchIpcCancel_A.thy @@ -14,7 +14,7 @@ theory ArchIpcCancel_A imports CSpaceAcc_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) text \Actions to be taken after a cap is deleted\ definition diff --git a/spec/abstract/ARM_HYP/ArchRetype_A.thy b/spec/abstract/ARM_HYP/ArchRetype_A.thy index 45346e5530..b076a6097b 100644 --- a/spec/abstract/ARM_HYP/ArchRetype_A.thy +++ b/spec/abstract/ARM_HYP/ArchRetype_A.thy @@ -16,7 +16,7 @@ imports ArchInvocation_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) text \This is a placeholder function. We may wish to extend the specification with explicitly tagging kernel data regions in memory.\ @@ -26,15 +26,38 @@ definition text \Initialise architecture-specific objects.\ -definition - init_arch_objects :: "apiobject_type \ obj_ref \ nat \ nat \ obj_ref list \ (unit,'z::state_ext) s_monad" -where - "init_arch_objects new_type ptr num_objects obj_sz refs - \ if new_type = ArchObject PageDirectoryObj then (do - mapM_x copy_global_mappings refs; - do_machine_op $ mapM_x (\x. cleanCacheRange_PoU x (x + ((1::word32) << pd_bits) - 1) - (addrFromPPtr x)) refs - od) else return ()" +definition vs_apiobj_size where + "vs_apiobj_size ty \ + case ty of + ArchObject SmallPageObj \ pageBitsForSize ARMSmallPage + | ArchObject LargePageObj \ pageBitsForSize ARMLargePage + | ArchObject SectionObj \ pageBitsForSize ARMSection + | ArchObject SuperSectionObj \ pageBitsForSize ARMSuperSection + | ArchObject PageTableObj \ pt_bits + | ArchObject PageDirectoryObj \ pd_bits" + +definition init_arch_objects :: + "apiobject_type \ bool \ obj_ref \ nat \ nat \ obj_ref list \ (unit,'z::state_ext) s_monad" + where + "init_arch_objects new_type is_device ptr num_objects obj_sz refs \ do + when (new_type = ArchObject PageDirectoryObj) $ mapM_x copy_global_mappings refs; + if \is_device \ + new_type \ {ArchObject SmallPageObj, ArchObject LargePageObj, + ArchObject SectionObj, ArchObject SuperSectionObj} + then + mapM_x (\ref. do_machine_op $ + cleanCacheRange_RAM ref (ref + mask (vs_apiobj_size new_type)) + (addrFromPPtr ref)) + refs + else if new_type \ {ArchObject PageTableObj, ArchObject PageDirectoryObj} + then + mapM_x (\ref. do_machine_op $ + cleanCacheRange_PoU ref (ref + mask (vs_apiobj_size new_type)) + (addrFromPPtr ref)) + refs + else + return () + od" definition empty_context :: user_context where diff --git a/spec/abstract/ARM_HYP/ArchTcb_A.thy b/spec/abstract/ARM_HYP/ArchTcb_A.thy index db887ae4cb..e5da56d323 100644 --- a/spec/abstract/ARM_HYP/ArchTcb_A.thy +++ b/spec/abstract/ARM_HYP/ArchTcb_A.thy @@ -14,7 +14,7 @@ theory ArchTcb_A imports KHeap_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) definition sanitise_register :: "bool \ register \ machine_word \ machine_word" diff --git a/spec/abstract/ARM_HYP/ArchVSpaceAcc_A.thy b/spec/abstract/ARM_HYP/ArchVSpaceAcc_A.thy index a54192042e..bf60e89c46 100644 --- a/spec/abstract/ARM_HYP/ArchVSpaceAcc_A.thy +++ b/spec/abstract/ARM_HYP/ArchVSpaceAcc_A.thy @@ -14,7 +14,7 @@ theory ArchVSpaceAcc_A imports KHeap_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) text \ This part of the specification is fairly concrete as the machine architecture diff --git a/spec/abstract/ARM_HYP/ArchVSpace_A.thy b/spec/abstract/ARM_HYP/ArchVSpace_A.thy index 93efae9649..2e70fab195 100644 --- a/spec/abstract/ARM_HYP/ArchVSpace_A.thy +++ b/spec/abstract/ARM_HYP/ArchVSpace_A.thy @@ -17,7 +17,7 @@ imports ArchTcb_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) text \Save the set of entries that would be inserted into a page table or page directory to map various different sizes of frame at a given virtual @@ -329,7 +329,7 @@ where "vgic_update vr f \ vcpu_update vr (\vcpu. vcpu \ vcpu_vgic := f (vcpu_vgic vcpu) \ )" definition - vgic_update_lr :: "obj_ref \ nat \ ARM_A.virq \ (unit,'z::state_ext) s_monad" + vgic_update_lr :: "obj_ref \ nat \ virq \ (unit,'z::state_ext) s_monad" where "vgic_update_lr vr irq_idx virq \ vgic_update vr (\vgic. vgic \ vgic_lr := (vgic_lr vgic)(irq_idx := virq) \)" diff --git a/spec/abstract/ARM_HYP/Arch_A.thy b/spec/abstract/ARM_HYP/Arch_A.thy index 884ec48871..161b0c067d 100644 --- a/spec/abstract/ARM_HYP/Arch_A.thy +++ b/spec/abstract/ARM_HYP/Arch_A.thy @@ -15,7 +15,7 @@ theory Arch_A imports TcbAcc_A VCPU_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) definition "page_bits \ pageBits" diff --git a/spec/abstract/ARM_HYP/Arch_Structs_A.thy b/spec/abstract/ARM_HYP/Arch_Structs_A.thy index b3b60122ac..ba98106cc1 100644 --- a/spec/abstract/ARM_HYP/Arch_Structs_A.thy +++ b/spec/abstract/ARM_HYP/Arch_Structs_A.thy @@ -18,7 +18,7 @@ imports ExecSpec.Arch_Kernel_Config_Lemmas begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) text \ This theory provides architecture-specific definitions and datatypes @@ -57,15 +57,6 @@ definition is_page_cap :: "arch_cap \ bool" where "is_page_cap c \ \x0 x1 x2 x3 x4. c = PageCap x0 x1 x2 x3 x4" -definition - asid_high_bits :: nat where - "asid_high_bits \ 7" -definition - asid_low_bits :: nat where - "asid_low_bits \ 10 :: nat" -definition - asid_bits :: nat where - "asid_bits \ 17 :: nat" section \Architecture-specific objects\ @@ -131,13 +122,13 @@ type_synonym virq = machine_word end -qualify ARM_A (in Arch) +qualify ARM_HYP_A (in Arch) record gic_vcpu_interface = vgic_hcr :: machine_word vgic_vmcr :: machine_word vgic_apr :: machine_word - vgic_lr :: "nat \ ARM_A.virq" + vgic_lr :: "nat \ ARM_HYP_A.virq" record vcpu = vcpu_tcb :: "obj_ref option" @@ -149,7 +140,7 @@ record vcpu = end_qualify -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) definition "vcpu_sctlr vcpu \ vcpu_regs vcpu VCPURegSCTLR" @@ -333,23 +324,23 @@ currently active page directory. The second component of end -qualify ARM_A (in Arch) +qualify ARM_HYP_A (in Arch) text \arch\_state\ record arch_state = arm_asid_table :: "7 word \ obj_ref" - arm_hwasid_table :: "ARM_A.hw_asid \ ARM_A.asid" - arm_next_asid :: ARM_A.hw_asid - arm_asid_map :: "ARM_A.asid \ (ARM_A.hw_asid \ obj_ref)" + arm_hwasid_table :: "ARM_HYP_A.hw_asid \ ARM_HYP_A.asid" + arm_next_asid :: ARM_HYP_A.hw_asid + arm_asid_map :: "ARM_HYP_A.asid \ (ARM_HYP_A.hw_asid \ obj_ref)" arm_current_vcpu :: "(obj_ref \ bool) option" arm_gicvcpu_numlistregs :: nat - arm_kernel_vspace :: ARM_A.arm_vspace_region_uses + arm_kernel_vspace :: ARM_HYP_A.arm_vspace_region_uses arm_us_global_pd :: obj_ref end_qualify -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) section "Type declarations for invariant definitions" @@ -380,7 +371,7 @@ end section "Arch-specific tcb" -qualify ARM_A (in Arch) +qualify ARM_HYP_A (in Arch) (* arch specific part of tcb: this must have a field for user context *) record arch_tcb = @@ -390,7 +381,7 @@ record arch_tcb = end_qualify -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) definition default_arch_tcb :: arch_tcb where diff --git a/spec/abstract/ARM_HYP/Hypervisor_A.thy b/spec/abstract/ARM_HYP/Hypervisor_A.thy index 6b811910ae..3d54a27f81 100644 --- a/spec/abstract/ARM_HYP/Hypervisor_A.thy +++ b/spec/abstract/ARM_HYP/Hypervisor_A.thy @@ -10,7 +10,7 @@ theory Hypervisor_A imports Ipc_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) fun handle_hypervisor_fault :: "word32 \ hyp_fault_type \ (unit, 'z::state_ext) s_monad" where diff --git a/spec/abstract/ARM_HYP/Init_A.thy b/spec/abstract/ARM_HYP/Init_A.thy index 0d25ded079..e87c2dd6cd 100644 --- a/spec/abstract/ARM_HYP/Init_A.thy +++ b/spec/abstract/ARM_HYP/Init_A.thy @@ -14,7 +14,7 @@ theory Init_A imports Retype_A begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) text \ This is not a specification of true kernel diff --git a/spec/abstract/ARM_HYP/Machine_A.thy b/spec/abstract/ARM_HYP/Machine_A.thy index 6787a6c4cb..068e7e9886 100644 --- a/spec/abstract/ARM_HYP/Machine_A.thy +++ b/spec/abstract/ARM_HYP/Machine_A.thy @@ -16,7 +16,7 @@ imports "ExecSpec.MachineOps" begin -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) text \ The specification is written with abstract type names for object @@ -123,11 +123,9 @@ definition end -context begin interpretation Arch . - requalify_consts kernel_base idle_thread_ptr -end +arch_requalify_consts (A) kernel_base idle_thread_ptr -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) text \Miscellaneous definitions of constants used in modelling machine operations.\ diff --git a/spec/abstract/ARM_HYP/VCPU_A.thy b/spec/abstract/ARM_HYP/VCPU_A.thy index 04fb104018..94a1f0d3ea 100644 --- a/spec/abstract/ARM_HYP/VCPU_A.thy +++ b/spec/abstract/ARM_HYP/VCPU_A.thy @@ -17,16 +17,6 @@ imports InvocationLabels_A begin -text \ - This is used by some decode functions. VCPU decode functions are the first that need to bounds - check IRQs from the user. - \ - -definition - arch_check_irq :: "data \ (unit,'z::state_ext) se_monad" -where - "arch_check_irq irq \ whenE (irq > maxIRQ) $ throwError (RangeError 0 maxIRQ)" - text \ Some parts of some registers cannot be written by the user. Bits set in the mask will be preserved (used in vcpu\_write\_register). @@ -35,10 +25,21 @@ consts register_mask :: "machine_word option" (* no need for option? *) -context Arch begin global_naming ARM_A +context Arch begin arch_global_naming (A) section "VCPU" +text \ + This is used by some decode functions. VCPU decode functions are the first that need to bounds + check IRQs from the user. + \ + +definition + arch_check_irq :: "data \ (unit,'z::state_ext) se_monad" +where + "arch_check_irq irq \ whenE (irq > maxIRQ) $ throwError (RangeError 0 maxIRQ)" + + subsection "VCPU: Set TCB" definition decode_vcpu_set_tcb :: "arch_cap \ (cap \ cslot_ptr) list \ (arch_invocation,'z::state_ext) se_monad" diff --git a/spec/abstract/CSpace_A.thy b/spec/abstract/CSpace_A.thy index 4d150368bb..dc264c87db 100644 --- a/spec/abstract/CSpace_A.thy +++ b/spec/abstract/CSpace_A.thy @@ -19,9 +19,7 @@ imports "HOL-Library.Prefix_Order" begin -context begin interpretation Arch . - -requalify_consts +arch_requalify_consts (A) aobjs_of arch_update_cap_data arch_derive_cap @@ -35,8 +33,6 @@ requalify_consts cnode_guard_size_bits arch_is_cap_revocable -end - text \This theory develops an abstract model of \emph{capability spaces}, or CSpace, in seL4. The CSpace of a thread can be thought of diff --git a/spec/abstract/Decode_A.thy b/spec/abstract/Decode_A.thy index 7e4b4c7ef8..c7b01078e3 100644 --- a/spec/abstract/Decode_A.thy +++ b/spec/abstract/Decode_A.thy @@ -17,9 +17,7 @@ imports "ExecSpec.InvocationLabels_H" begin -context begin interpretation Arch . - -requalify_consts +arch_requalify_consts (A) ArchDefaultExtraRegisters check_valid_ipc_buffer is_valid_vtable_root @@ -28,9 +26,6 @@ requalify_consts arch_decode_invocation arch_check_irq -end - - text \ This theory includes definitions describing how user arguments are decoded into invocation structures; these structures are then used diff --git a/spec/abstract/ExceptionTypes_A.thy b/spec/abstract/ExceptionTypes_A.thy index 90f43b9b2e..215b5cf796 100644 --- a/spec/abstract/ExceptionTypes_A.thy +++ b/spec/abstract/ExceptionTypes_A.thy @@ -14,9 +14,7 @@ theory ExceptionTypes_A imports MiscMachine_A begin -context begin interpretation Arch . -requalify_types arch_fault -end +arch_requalify_types (A) arch_fault text \ There are two types of exceptions that can occur in the kernel: diff --git a/spec/abstract/Interrupt_A.thy b/spec/abstract/Interrupt_A.thy index 75a449bc47..d24de734c7 100644 --- a/spec/abstract/Interrupt_A.thy +++ b/spec/abstract/Interrupt_A.thy @@ -14,15 +14,11 @@ theory Interrupt_A imports ArchInterrupt_A begin -context begin interpretation Arch . - -requalify_consts +arch_requalify_consts (A) arch_invoke_irq_control arch_invoke_irq_handler handle_reserved_irq arch_mask_irq_signal -end - text \The IRQControl capability can be used to create a new IRQHandler capability as well as to perform whatever architecture specific interrupt diff --git a/spec/abstract/Invocations_A.thy b/spec/abstract/Invocations_A.thy index 5f837e5a40..52e66a170d 100644 --- a/spec/abstract/Invocations_A.thy +++ b/spec/abstract/Invocations_A.thy @@ -14,15 +14,11 @@ theory Invocations_A imports ArchInvocation_A begin -context begin interpretation Arch . - -requalify_types +arch_requalify_types (A) arch_copy_register_sets arch_irq_control_invocation arch_invocation -end - text \These datatypes encode the arguments to the available system calls.\ datatype cnode_invocation = diff --git a/spec/abstract/IpcCancel_A.thy b/spec/abstract/IpcCancel_A.thy index 8bf254efa6..b1ca28430e 100644 --- a/spec/abstract/IpcCancel_A.thy +++ b/spec/abstract/IpcCancel_A.thy @@ -14,20 +14,18 @@ theory IpcCancel_A imports ArchIpcCancel_A begin -context begin interpretation Arch . - -requalify_consts +arch_requalify_consts (A) arch_post_cap_deletion arch_gen_obj_refs arch_cap_cleanup_opt + +arch_requalify_consts faultRegister nextInstructionRegister -requalify_types +arch_requalify_types (A) arch_gen_obj_ref -end - text \Scheduling context accessors.\ definition sched_context_bind_ntfn :: "obj_ref \ obj_ref \ (unit, 'z::state_ext) s_monad" diff --git a/spec/abstract/Ipc_A.thy b/spec/abstract/Ipc_A.thy index 333157230e..1048ab8d00 100644 --- a/spec/abstract/Ipc_A.thy +++ b/spec/abstract/Ipc_A.thy @@ -14,12 +14,9 @@ theory Ipc_A imports Tcb_A ArchFault_A begin -context begin interpretation Arch . - -requalify_consts +arch_requalify_consts (A) make_arch_fault_msg handle_arch_fault_reply -end section \Getting and setting the message info register.\ diff --git a/spec/abstract/MiscMachine_A.thy b/spec/abstract/MiscMachine_A.thy index ca3008b647..2ceb445c89 100644 --- a/spec/abstract/MiscMachine_A.thy +++ b/spec/abstract/MiscMachine_A.thy @@ -14,12 +14,11 @@ theory MiscMachine_A imports Machine_A "ExecSpec.MachineExports" begin -context begin interpretation Arch . - -requalify_types +arch_requalify_types user_context user_monad - register + +arch_requalify_types (A) data obj_ref asid_high_len @@ -33,7 +32,7 @@ requalify_types length_type vspace_ref -requalify_consts +arch_requalify_consts (A) nat_to_cref msg_info_register msg_registers @@ -55,8 +54,6 @@ requalify_consts data_to_cptr combine_ntfn_badges -end - (* Needs to be done here after plain type names are exported *) translations (type) "'a user_monad" <= (type) "user_context \ ('a \ user_context) set \ bool" diff --git a/spec/abstract/RISCV64/ArchCSpace_A.thy b/spec/abstract/RISCV64/ArchCSpace_A.thy index 7d2515e17d..df1d5cb38d 100644 --- a/spec/abstract/RISCV64/ArchCSpace_A.thy +++ b/spec/abstract/RISCV64/ArchCSpace_A.thy @@ -11,7 +11,7 @@ imports ArchVSpace_A begin -context Arch begin global_naming RISCV64_A +context Arch begin arch_global_naming (A) definition cnode_guard_size_bits :: "nat" where diff --git a/spec/abstract/RISCV64/ArchDecode_A.thy b/spec/abstract/RISCV64/ArchDecode_A.thy index 777c508307..096c8e2d3f 100644 --- a/spec/abstract/RISCV64/ArchDecode_A.thy +++ b/spec/abstract/RISCV64/ArchDecode_A.thy @@ -13,7 +13,7 @@ imports "ExecSpec.InvocationLabels_H" begin -context Arch begin global_naming RISCV64_A +context Arch begin arch_global_naming (A) section "Helper definitions" diff --git a/spec/abstract/RISCV64/ArchFault_A.thy b/spec/abstract/RISCV64/ArchFault_A.thy index 65442f3efd..3dcb81ec05 100644 --- a/spec/abstract/RISCV64/ArchFault_A.thy +++ b/spec/abstract/RISCV64/ArchFault_A.thy @@ -10,7 +10,7 @@ theory ArchFault_A imports Structures_A Tcb_A begin -context Arch begin global_naming RISCV64_A +context Arch begin arch_global_naming (A) fun make_arch_fault_msg :: "arch_fault \ obj_ref \ (data \ data list,'z::state_ext) s_monad" where diff --git a/spec/abstract/RISCV64/ArchInterrupt_A.thy b/spec/abstract/RISCV64/ArchInterrupt_A.thy index 1efc623321..5f4445d885 100644 --- a/spec/abstract/RISCV64/ArchInterrupt_A.thy +++ b/spec/abstract/RISCV64/ArchInterrupt_A.thy @@ -10,7 +10,7 @@ theory ArchInterrupt_A imports Ipc_A begin -context Arch begin global_naming RISCV64_A +context Arch begin arch_global_naming (A) definition handle_reserved_irq :: "irq \ (unit,'z::state_ext) s_monad" where @@ -27,12 +27,8 @@ definition arch_mask_irq_signal :: "irq \ (unit,'z::state_ext) s_mon end -context begin interpretation Arch . - (* On Arm architectures, maxIRQ is defined in Kernel_Config. On RISCV64 it is defined manually. *) -requalify_consts +arch_requalify_consts maxIRQ end - -end diff --git a/spec/abstract/RISCV64/ArchInvocation_A.thy b/spec/abstract/RISCV64/ArchInvocation_A.thy index d89712d685..5523178bad 100644 --- a/spec/abstract/RISCV64/ArchInvocation_A.thy +++ b/spec/abstract/RISCV64/ArchInvocation_A.thy @@ -10,7 +10,7 @@ theory ArchInvocation_A imports Structures_A begin -context Arch begin global_naming RISCV64_A +context Arch begin arch_global_naming (A) text \These datatypes encode the arguments to the various possible RISCV64-specific system calls. Selectors are defined for various fields for convenience elsewhere.\ diff --git a/spec/abstract/RISCV64/ArchIpcCancel_A.thy b/spec/abstract/RISCV64/ArchIpcCancel_A.thy index 4b5fa71f61..7a11ed870a 100644 --- a/spec/abstract/RISCV64/ArchIpcCancel_A.thy +++ b/spec/abstract/RISCV64/ArchIpcCancel_A.thy @@ -10,7 +10,7 @@ theory ArchIpcCancel_A imports Sporadic_A begin -context Arch begin global_naming RISCV64_A +context Arch begin arch_global_naming (A) text \Actions to be taken after a cap is deleted\ definition arch_post_cap_deletion :: "arch_cap \ (unit, 'z::state_ext) s_monad" diff --git a/spec/abstract/RISCV64/ArchRetype_A.thy b/spec/abstract/RISCV64/ArchRetype_A.thy index ccd49a8f35..9b16a3efa5 100644 --- a/spec/abstract/RISCV64/ArchRetype_A.thy +++ b/spec/abstract/RISCV64/ArchRetype_A.thy @@ -12,7 +12,7 @@ imports ArchInvocation_A begin -context Arch begin global_naming RISCV64_A +context Arch begin arch_global_naming (A) text \ This is a placeholder function. We may wish to extend the specification @@ -25,9 +25,9 @@ definition reserve_region :: "obj_ref \ nat \ bool \Initialise architecture-specific objects.\ definition init_arch_objects :: - "apiobject_type \ obj_ref \ nat \ nat \ obj_ref list \ (unit,'z::state_ext) s_monad" + "apiobject_type \ bool \ obj_ref \ nat \ nat \ obj_ref list \ (unit,'z::state_ext) s_monad" where - "init_arch_objects new_type ptr num_objects obj_sz refs \ return ()" + "init_arch_objects new_type is_device ptr num_objects obj_sz refs \ return ()" definition empty_context :: user_context where diff --git a/spec/abstract/RISCV64/ArchTcb_A.thy b/spec/abstract/RISCV64/ArchTcb_A.thy index b96b5e753f..4e071341a9 100644 --- a/spec/abstract/RISCV64/ArchTcb_A.thy +++ b/spec/abstract/RISCV64/ArchTcb_A.thy @@ -10,7 +10,7 @@ theory ArchTcb_A imports KHeap_A begin -context Arch begin global_naming RISCV64_A +context Arch begin arch_global_naming (A) definition sanitise_register :: "bool \ register \ machine_word \ machine_word" where diff --git a/spec/abstract/RISCV64/ArchVSpaceAcc_A.thy b/spec/abstract/RISCV64/ArchVSpaceAcc_A.thy index 5e60447760..2f36ecea27 100644 --- a/spec/abstract/RISCV64/ArchVSpaceAcc_A.thy +++ b/spec/abstract/RISCV64/ArchVSpaceAcc_A.thy @@ -10,7 +10,7 @@ theory ArchVSpaceAcc_A imports KHeap_A begin -context Arch begin global_naming RISCV64_A +context Arch begin arch_global_naming (A) text \ This part of the specification is fairly concrete as the machine architecture is visible to diff --git a/spec/abstract/RISCV64/ArchVSpace_A.thy b/spec/abstract/RISCV64/ArchVSpace_A.thy index b427200f50..4d5dc2dc79 100644 --- a/spec/abstract/RISCV64/ArchVSpace_A.thy +++ b/spec/abstract/RISCV64/ArchVSpace_A.thy @@ -10,7 +10,7 @@ theory ArchVSpace_A imports Retype_A begin -context Arch begin global_naming RISCV64_A +context Arch begin arch_global_naming (A) text \ Look up a thread's IPC buffer and check that the thread has the authority to read or (in the diff --git a/spec/abstract/RISCV64/Arch_A.thy b/spec/abstract/RISCV64/Arch_A.thy index 6e10e0b304..3bba17f4ad 100644 --- a/spec/abstract/RISCV64/Arch_A.thy +++ b/spec/abstract/RISCV64/Arch_A.thy @@ -11,7 +11,7 @@ theory Arch_A imports CSpace_A begin -context Arch begin global_naming RISCV64_A +context Arch begin arch_global_naming (A) definition page_bits :: nat where diff --git a/spec/abstract/RISCV64/Arch_Structs_A.thy b/spec/abstract/RISCV64/Arch_Structs_A.thy index 65f04ca032..d1adeab279 100644 --- a/spec/abstract/RISCV64/Arch_Structs_A.thy +++ b/spec/abstract/RISCV64/Arch_Structs_A.thy @@ -14,7 +14,7 @@ imports ExecSpec.Arch_Kernel_Config_Lemmas begin -context Arch begin global_naming RISCV64_A +context Arch begin arch_global_naming (A) text \ This theory provides architecture-specific definitions and datatypes including @@ -247,7 +247,7 @@ text \ end_qualify -context Arch begin global_naming RISCV64_A +context Arch begin arch_global_naming (A) section "Type declarations for invariant definitions" @@ -280,7 +280,7 @@ record arch_tcb = end_qualify -context Arch begin global_naming RISCV64_A +context Arch begin arch_global_naming (A) definition default_arch_tcb :: arch_tcb where diff --git a/spec/abstract/RISCV64/Hypervisor_A.thy b/spec/abstract/RISCV64/Hypervisor_A.thy index 6d14378b20..289966ac24 100644 --- a/spec/abstract/RISCV64/Hypervisor_A.thy +++ b/spec/abstract/RISCV64/Hypervisor_A.thy @@ -10,7 +10,7 @@ theory Hypervisor_A imports Exceptions_A begin -context Arch begin global_naming RISCV64_A +context Arch begin arch_global_naming (A) fun handle_hypervisor_fault :: "machine_word \ hyp_fault_type \ (unit, 'z::state_ext) s_monad" where diff --git a/spec/abstract/RISCV64/Init_A.thy b/spec/abstract/RISCV64/Init_A.thy index 17ff7dedad..dcf83326f1 100644 --- a/spec/abstract/RISCV64/Init_A.thy +++ b/spec/abstract/RISCV64/Init_A.thy @@ -13,7 +13,7 @@ imports "Lib.SplitRule" begin -context Arch begin global_naming RISCV64_A +context Arch begin arch_global_naming (A) text \ This is not a specification of true kernel initialisation. This theory describes a dummy diff --git a/spec/abstract/RISCV64/Machine_A.thy b/spec/abstract/RISCV64/Machine_A.thy index b33ee4bfff..289492d288 100644 --- a/spec/abstract/RISCV64/Machine_A.thy +++ b/spec/abstract/RISCV64/Machine_A.thy @@ -11,7 +11,7 @@ imports "ExecSpec.MachineOps" begin -context Arch begin global_naming RISCV64_A +context Arch begin arch_global_naming (A) text \ The specification is written with abstract type names for object references, user pointers, @@ -192,8 +192,6 @@ datatype arch_fault end -context begin interpretation Arch . - requalify_consts idle_thread_ptr idle_sc_ptr -end +arch_requalify_consts (A) idle_thread_ptr idle_sc_ptr end diff --git a/spec/abstract/Retype_A.thy b/spec/abstract/Retype_A.thy index 9402f9bd24..fefc82bb03 100644 --- a/spec/abstract/Retype_A.thy +++ b/spec/abstract/Retype_A.thy @@ -18,16 +18,11 @@ imports ArchRetype_A begin -context begin interpretation Arch . - -requalify_consts +arch_requalify_consts (A) arch_default_cap default_arch_object init_arch_objects -end - - section "Creating Caps" text \The original capability created when an object of a given type is @@ -197,7 +192,7 @@ doE \ \Create new objects.\ orefs \ retype_region retype_base (length slots) obj_sz new_type is_device; - init_arch_objects new_type retype_base (length slots) obj_sz orefs; + init_arch_objects new_type is_device retype_base (length slots) obj_sz orefs; mapM_x (create_cap new_type obj_sz src_slot is_device) (zip slots orefs) od odE" diff --git a/spec/abstract/Schedule_A.thy b/spec/abstract/Schedule_A.thy index 6e1c3d50a6..bf7e47772d 100644 --- a/spec/abstract/Schedule_A.thy +++ b/spec/abstract/Schedule_A.thy @@ -10,14 +10,10 @@ theory Schedule_A imports Arch_A begin -context begin interpretation Arch . - -requalify_consts +arch_requalify_consts (A) arch_switch_to_thread arch_switch_to_idle_thread -end - abbreviation "idle st \ st = Structures_A.IdleThreadState" diff --git a/spec/abstract/Structures_A.thy b/spec/abstract/Structures_A.thy index 874342814d..49a4b87ffa 100644 --- a/spec/abstract/Structures_A.thy +++ b/spec/abstract/Structures_A.thy @@ -18,25 +18,20 @@ imports "ExecSpec.MachineExports" begin -context begin interpretation Arch . - -requalify_types +arch_requalify_types (A) aobject_type arch_cap - vm_rights arch_kernel_obj arch_state arch_tcb aa_type -requalify_consts +arch_requalify_consts (A) acap_rights acap_rights_update arch_kobj_size arch_obj_size aobj_ref - asid_high_bits - asid_low_bits arch_is_frame_type badge_bits default_arch_tcb @@ -54,11 +49,9 @@ requalify_consts untyped_max_bits msg_label_bits -requalify_facts +arch_requalify_facts kernelWCET_ticks_pos2 -end - text \ User mode can request these objects to be created by retype: \ diff --git a/spec/abstract/Syscall_A.thy b/spec/abstract/Syscall_A.thy index d500b5d3e3..c503089aa0 100644 --- a/spec/abstract/Syscall_A.thy +++ b/spec/abstract/Syscall_A.thy @@ -18,13 +18,10 @@ imports Hypervisor_A begin -context begin interpretation Arch . - -requalify_consts +arch_requalify_consts (A) arch_perform_invocation handle_vm_fault handle_hypervisor_fault -end text\ diff --git a/spec/abstract/TcbAcc_A.thy b/spec/abstract/TcbAcc_A.thy index eeeffc903e..e0de8e4a38 100644 --- a/spec/abstract/TcbAcc_A.thy +++ b/spec/abstract/TcbAcc_A.thy @@ -14,16 +14,10 @@ theory TcbAcc_A imports "./$L4V_ARCH/ArchCSpace_A" begin -context begin interpretation Arch . - -requalify_consts +arch_requalify_consts (A) in_user_frame - as_user - msg_max_length lookup_ipc_buffer -end - text \Store or load a word at an offset from an IPC buffer.\ definition store_word_offs :: "obj_ref \ nat \ machine_word \ (unit,'z::state_ext) s_monad" where diff --git a/spec/abstract/Tcb_A.thy b/spec/abstract/Tcb_A.thy index 8842788f8e..1dcd308541 100644 --- a/spec/abstract/Tcb_A.thy +++ b/spec/abstract/Tcb_A.thy @@ -14,16 +14,12 @@ theory Tcb_A imports Schedule_A ArchTcb_A begin -context begin interpretation Arch . - -requalify_consts +arch_requalify_consts (A) arch_activate_idle_thread sanitise_register arch_get_sanitise_register_info arch_post_modify_registers -end - section "Activating Threads" text \Reactivate a thread if it is not already running.\ diff --git a/spec/abstract/X64/ArchCSpace_A.thy b/spec/abstract/X64/ArchCSpace_A.thy index cd186e6638..639f488967 100644 --- a/spec/abstract/X64/ArchCSpace_A.thy +++ b/spec/abstract/X64/ArchCSpace_A.thy @@ -15,7 +15,7 @@ imports ArchVSpace_A begin -context Arch begin global_naming X64_A +context Arch begin arch_global_naming (A) definition cnode_guard_size_bits :: "nat" where diff --git a/spec/abstract/X64/ArchDecode_A.thy b/spec/abstract/X64/ArchDecode_A.thy index 24a8aa9b3b..7a7b45e82d 100644 --- a/spec/abstract/X64/ArchDecode_A.thy +++ b/spec/abstract/X64/ArchDecode_A.thy @@ -17,7 +17,7 @@ imports "ExecSpec.InvocationLabels_H" begin -context Arch begin global_naming X64_A +context Arch begin arch_global_naming (A) section "Helper definitions" diff --git a/spec/abstract/X64/ArchFault_A.thy b/spec/abstract/X64/ArchFault_A.thy index e42acf5520..b4ec269eea 100644 --- a/spec/abstract/X64/ArchFault_A.thy +++ b/spec/abstract/X64/ArchFault_A.thy @@ -14,7 +14,7 @@ theory ArchFault_A imports Structures_A Tcb_A begin -context Arch begin global_naming X64_A +context Arch begin arch_global_naming (A) fun make_arch_fault_msg :: "arch_fault \ obj_ref \ (data \ data list,'z::state_ext) s_monad" where diff --git a/spec/abstract/X64/ArchInterrupt_A.thy b/spec/abstract/X64/ArchInterrupt_A.thy index a8bb69b689..7a022200e3 100644 --- a/spec/abstract/X64/ArchInterrupt_A.thy +++ b/spec/abstract/X64/ArchInterrupt_A.thy @@ -14,7 +14,7 @@ theory ArchInterrupt_A imports Ipc_A begin -context Arch begin global_naming X64_A +context Arch begin arch_global_naming (A) definition handle_reserved_irq :: "irq \ (unit,'z::state_ext) s_monad" where "handle_reserved_irq irq = return ()" @@ -30,12 +30,8 @@ definition arch_mask_irq_signal :: "irq \ (unit,'z::state_ext) s_mon end -context begin interpretation Arch . - (* On Arm architectures, maxIRQ is defined in Kernel_Config. On X64 it is defined manually. *) -requalify_consts +arch_requalify_consts maxIRQ end - -end diff --git a/spec/abstract/X64/ArchInvocation_A.thy b/spec/abstract/X64/ArchInvocation_A.thy index 567cf9c6a2..8aab7a2237 100644 --- a/spec/abstract/X64/ArchInvocation_A.thy +++ b/spec/abstract/X64/ArchInvocation_A.thy @@ -14,7 +14,7 @@ theory ArchInvocation_A imports Structures_A begin -context Arch begin global_naming X64_A +context Arch begin arch_global_naming (A) text \These datatypes encode the arguments to the various possible x64-specific system calls. Selectors are defined for various fields diff --git a/spec/abstract/X64/ArchIpcCancel_A.thy b/spec/abstract/X64/ArchIpcCancel_A.thy index 914fe612e0..2a514a7956 100644 --- a/spec/abstract/X64/ArchIpcCancel_A.thy +++ b/spec/abstract/X64/ArchIpcCancel_A.thy @@ -14,7 +14,7 @@ theory ArchIpcCancel_A imports CSpaceAcc_A begin -context Arch begin global_naming X64_A +context Arch begin arch_global_naming (A) definition set_ioport_mask :: "io_port \ io_port \ bool \ (unit, 'z::state_ext) s_monad" diff --git a/spec/abstract/X64/ArchRetype_A.thy b/spec/abstract/X64/ArchRetype_A.thy index d311228b73..3d9ab1ad68 100644 --- a/spec/abstract/X64/ArchRetype_A.thy +++ b/spec/abstract/X64/ArchRetype_A.thy @@ -16,7 +16,7 @@ imports ArchInvocation_A begin -context Arch begin global_naming X64_A +context Arch begin arch_global_naming (A) text \This is a placeholder function. We may wish to extend the specification with explicitly tagging kernel data regions in memory.\ @@ -27,10 +27,10 @@ definition text \Initialise architecture-specific objects.\ definition - init_arch_objects :: "apiobject_type \ obj_ref \ nat \ nat \ obj_ref list + init_arch_objects :: "apiobject_type \ bool \ obj_ref \ nat \ nat \ obj_ref list \ (unit,'z::state_ext) s_monad" where - "init_arch_objects new_type ptr num_objects obj_sz refs + "init_arch_objects new_type is_device ptr num_objects obj_sz refs \ when (new_type = ArchObject PML4Obj) (mapM_x copy_global_mappings refs)" definition diff --git a/spec/abstract/X64/ArchTcb_A.thy b/spec/abstract/X64/ArchTcb_A.thy index b6c44d2cda..56d8c16a8b 100644 --- a/spec/abstract/X64/ArchTcb_A.thy +++ b/spec/abstract/X64/ArchTcb_A.thy @@ -14,7 +14,7 @@ theory ArchTcb_A imports KHeap_A begin -context Arch begin global_naming X64_A +context Arch begin arch_global_naming (A) definition sanitise_or_flags :: machine_word diff --git a/spec/abstract/X64/ArchVSpaceAcc_A.thy b/spec/abstract/X64/ArchVSpaceAcc_A.thy index ed78d47cc5..b10d61db67 100644 --- a/spec/abstract/X64/ArchVSpaceAcc_A.thy +++ b/spec/abstract/X64/ArchVSpaceAcc_A.thy @@ -14,7 +14,7 @@ theory ArchVSpaceAcc_A imports KHeap_A begin -context Arch begin global_naming X64_A +context Arch begin arch_global_naming (A) text \ This part of the specification is fairly concrete as the machine architecture diff --git a/spec/abstract/X64/ArchVSpace_A.thy b/spec/abstract/X64/ArchVSpace_A.thy index 277e94487e..78c3df1fd0 100644 --- a/spec/abstract/X64/ArchVSpace_A.thy +++ b/spec/abstract/X64/ArchVSpace_A.thy @@ -14,7 +14,7 @@ theory ArchVSpace_A imports Retype_A begin -context Arch begin global_naming X64_A +context Arch begin arch_global_naming (A) text \ These attributes are always set to @{const False} when pages are mapped. \ diff --git a/spec/abstract/X64/Arch_A.thy b/spec/abstract/X64/Arch_A.thy index 845c037801..a3e370d7d7 100644 --- a/spec/abstract/X64/Arch_A.thy +++ b/spec/abstract/X64/Arch_A.thy @@ -15,7 +15,7 @@ theory Arch_A imports TcbAcc_A begin -context Arch begin global_naming X64_A +context Arch begin arch_global_naming (A) definition "page_bits \ pageBits" diff --git a/spec/abstract/X64/Arch_Structs_A.thy b/spec/abstract/X64/Arch_Structs_A.thy index 8d35283924..2cb066cbf0 100644 --- a/spec/abstract/X64/Arch_Structs_A.thy +++ b/spec/abstract/X64/Arch_Structs_A.thy @@ -14,7 +14,7 @@ imports ExecSpec.Arch_Kernel_Config_Lemmas begin -context Arch begin global_naming X64_A +context Arch begin arch_global_naming (A) text \ This theory provides architecture-specific definitions and datatypes @@ -321,7 +321,7 @@ record arch_state = end_qualify -context Arch begin global_naming X64_A +context Arch begin arch_global_naming (A) definition pd_shift_bits :: "nat" where @@ -411,7 +411,7 @@ record arch_tcb = end_qualify -context Arch begin global_naming X64_A +context Arch begin arch_global_naming (A) definition default_arch_tcb :: arch_tcb where diff --git a/spec/abstract/X64/Hypervisor_A.thy b/spec/abstract/X64/Hypervisor_A.thy index 330679f8ba..f12efa188e 100644 --- a/spec/abstract/X64/Hypervisor_A.thy +++ b/spec/abstract/X64/Hypervisor_A.thy @@ -10,7 +10,7 @@ theory Hypervisor_A imports Exceptions_A begin -context Arch begin global_naming X64_A +context Arch begin arch_global_naming (A) fun handle_hypervisor_fault :: "machine_word \ hyp_fault_type \ (unit, 'z::state_ext) s_monad" where diff --git a/spec/abstract/X64/Init_A.thy b/spec/abstract/X64/Init_A.thy index 45e1f95c65..c0dd40f3a4 100644 --- a/spec/abstract/X64/Init_A.thy +++ b/spec/abstract/X64/Init_A.thy @@ -14,7 +14,7 @@ theory Init_A imports Retype_A begin -context Arch begin global_naming X64_A +context Arch begin arch_global_naming (A) text \ This is not a specification of true kernel diff --git a/spec/abstract/X64/Machine_A.thy b/spec/abstract/X64/Machine_A.thy index 67cccb9218..b8d9aeb0dd 100644 --- a/spec/abstract/X64/Machine_A.thy +++ b/spec/abstract/X64/Machine_A.thy @@ -18,7 +18,7 @@ imports "ExecSpec.MachineOps" begin -context Arch begin global_naming X64_A +context Arch begin arch_global_naming (A) text \ The specification is written with abstract type names for object @@ -134,11 +134,9 @@ definition end -context begin interpretation Arch . - requalify_consts idle_thread_ptr -end +arch_requalify_consts (A) idle_thread_ptr -context Arch begin global_naming X64_A +context Arch begin arch_global_naming (A) (* is nat_to_cref arch specific ? *) definition diff --git a/spec/cspec/AARCH64/Kernel_C.thy b/spec/cspec/AARCH64/Kernel_C.thy index dcac934181..a280b5fdaf 100644 --- a/spec/cspec/AARCH64/Kernel_C.thy +++ b/spec/cspec/AARCH64/Kernel_C.thy @@ -25,7 +25,7 @@ end declare [[populate_globals=true]] -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* Sanity checks for array sizes. ptTranslationBits not yet available at definition site. *) lemma ptTranslationBits_vs_index_bits: diff --git a/spec/cspec/ARM/Kernel_C.thy b/spec/cspec/ARM/Kernel_C.thy index d463f2b6ec..66d48e9646 100644 --- a/spec/cspec/ARM/Kernel_C.thy +++ b/spec/cspec/ARM/Kernel_C.thy @@ -24,7 +24,7 @@ end declare [[populate_globals=true]] -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) type_synonym cghost_state = "(machine_word \ vmpage_size) * (machine_word \ nat) * ghost_assertions * diff --git a/spec/cspec/ARM_HYP/Kernel_C.thy b/spec/cspec/ARM_HYP/Kernel_C.thy index cd19383b65..60c5c0bb40 100644 --- a/spec/cspec/ARM_HYP/Kernel_C.thy +++ b/spec/cspec/ARM_HYP/Kernel_C.thy @@ -23,7 +23,7 @@ end declare [[populate_globals=true]] -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) type_synonym cghost_state = "(machine_word \ vmpage_size) * (machine_word \ nat) * ghost_assertions" diff --git a/spec/cspec/RISCV64/Kernel_C.thy b/spec/cspec/RISCV64/Kernel_C.thy index af1b9849ce..def1bb61c7 100644 --- a/spec/cspec/RISCV64/Kernel_C.thy +++ b/spec/cspec/RISCV64/Kernel_C.thy @@ -24,7 +24,7 @@ end declare [[populate_globals=true]] -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) type_synonym cghost_state = "(machine_word \ vmpage_size) * (machine_word \ nat) * ghost_assertions * diff --git a/spec/cspec/X64/Kernel_C.thy b/spec/cspec/X64/Kernel_C.thy index 5de120a414..5b77943ff7 100644 --- a/spec/cspec/X64/Kernel_C.thy +++ b/spec/cspec/X64/Kernel_C.thy @@ -23,7 +23,7 @@ end declare [[populate_globals=true]] -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) type_synonym cghost_state = "(machine_word \ vmpage_size) * (machine_word \ nat) * ghost_assertions" diff --git a/spec/cspec/c/gen-config-thy.py b/spec/cspec/c/gen-config-thy.py index 0065a6e597..4b0c0d598d 100755 --- a/spec/cspec/c/gen-config-thy.py +++ b/spec/cspec/c/gen-config-thy.py @@ -116,7 +116,7 @@ 'CONFIG_TK1_SMMU': (bool, None), 'CONFIG_ENABLE_A9_PREFETCHER': (bool, None), 'CONFIG_EXPORT_PMU_USER': (bool, None), - 'CONFIG_DISABLE_WFI_WFE_TRAPS': (bool, None), + 'CONFIG_DISABLE_WFI_WFE_TRAPS': (bool, 'config_DISABLE_WFI_WFE_TRAPS'), 'CONFIG_SMMU_INTERRUPT_ENABLE': (bool, None), 'CONFIG_AARCH32_FPU_ENABLE_CONTEXT_SWITCH': (bool, None), 'CONFIG_L1_CACHE_LINE_SIZE_BITS': (nat, None), diff --git a/spec/design/m-skel/AARCH64/MachineTypes.thy b/spec/design/m-skel/AARCH64/MachineTypes.thy index e23dadc466..01858f1636 100644 --- a/spec/design/m-skel/AARCH64/MachineTypes.thy +++ b/spec/design/m-skel/AARCH64/MachineTypes.thy @@ -14,7 +14,7 @@ imports Platform begin -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming #INCLUDE_SETTINGS keep_constructor=hyp_fault_type #INCLUDE_SETTINGS keep_constructor=virt_timer @@ -33,11 +33,9 @@ section "Types" end -context begin interpretation Arch . -requalify_types register vcpureg vppievent_irq virt_timer -end +arch_requalify_types register vcpureg vppievent_irq virt_timer -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming #INCLUDE_HASKELL SEL4/Machine/RegisterSet/AARCH64.hs CONTEXT AARCH64 instanceproofs #INCLUDE_HASKELL SEL4/Object/Structures/AARCH64.hs CONTEXT AARCH64 instanceproofs ONLY VPPIEventIRQ VirtTimer @@ -73,7 +71,7 @@ where end_qualify -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming text \ The machine monad is used for operations on the state defined above. @@ -85,7 +83,7 @@ end translations (type) "'c AARCH64.machine_monad" <= (type) "(AARCH64.machine_state, 'c) nondet_monad" -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming text \ After kernel initialisation all IRQs are masked. @@ -117,16 +115,15 @@ definition PT_Type \ VMFaultType HypFaultType vmFaultTypeFSR VMPageSize pageBits ptTranslationBits \ pageBitsForSize \ + hcrCommon hcrTWE hcrTWI \ hcrVCPU hcrNative vgicHCREN sctlrDefault sctlrEL1VM actlrDefault gicVCPUMaxNumLR \ vcpuBits end -context begin interpretation Arch . -requalify_types vmpage_size -end +arch_requalify_types vmpage_size -context Arch begin global_naming AARCH64 +context Arch begin arch_global_naming #INCLUDE_HASKELL SEL4/Machine/Hardware/AARCH64.hs CONTEXT AARCH64 instanceproofs ONLY VMFaultType HypFaultType VMPageSize diff --git a/spec/design/m-skel/ARM/MachineTypes.thy b/spec/design/m-skel/ARM/MachineTypes.thy index 307eca3594..b6af23fa1b 100644 --- a/spec/design/m-skel/ARM/MachineTypes.thy +++ b/spec/design/m-skel/ARM/MachineTypes.thy @@ -15,7 +15,7 @@ imports Platform begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming text \ An implementation of the machine's types, defining register set @@ -29,11 +29,9 @@ section "Types" end -context begin interpretation Arch . -requalify_types register -end +arch_requalify_types register -context Arch begin global_naming ARM +context Arch begin arch_global_naming #INCLUDE_HASKELL SEL4/Machine/RegisterSet/ARM.lhs CONTEXT ARM instanceproofs (*>*) @@ -89,7 +87,7 @@ axiomatization end_qualify -context Arch begin global_naming ARM +context Arch begin arch_global_naming text \ The machine monad is used for operations on the state defined above. @@ -101,7 +99,7 @@ end translations (type) "'c ARM.machine_monad" <= (type) "(ARM.machine_state, 'c) nondet_monad" -context Arch begin global_naming ARM +context Arch begin arch_global_naming text \ After kernel initialisation all IRQs are masked. @@ -145,11 +143,9 @@ definition end -context begin interpretation Arch . -requalify_types vmpage_size -end +arch_requalify_types vmpage_size -context Arch begin global_naming ARM +context Arch begin arch_global_naming #INCLUDE_HASKELL SEL4/Machine/Hardware/ARM.lhs CONTEXT ARM instanceproofs ONLY HardwareASID VMFaultType VMPageSize HypFaultType diff --git a/spec/design/m-skel/ARM_HYP/MachineTypes.thy b/spec/design/m-skel/ARM_HYP/MachineTypes.thy index a1b97a4f8f..abcfd83029 100644 --- a/spec/design/m-skel/ARM_HYP/MachineTypes.thy +++ b/spec/design/m-skel/ARM_HYP/MachineTypes.thy @@ -11,10 +11,10 @@ imports Word_Lib.WordSetup Monads.Nondet_Empty_Fail Monads.Nondet_Reader_Option - Setup_Locale + Lib.HaskellLib_H Platform begin -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming #INCLUDE_SETTINGS keep_constructor=hyp_fault_type #INCLUDE_SETTINGS keep_constructor=virt_timer @@ -33,12 +33,9 @@ section "Types" end -context begin interpretation Arch . -requalify_types register vcpureg vppievent_irq virt_timer +arch_requalify_types register vcpureg vppievent_irq virt_timer -end - -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming #INCLUDE_HASKELL SEL4/Machine/RegisterSet/ARM.lhs CONTEXT ARM_HYP instanceproofs #INCLUDE_HASKELL SEL4/Object/Structures/ARM.lhs CONTEXT ARM_HYP instanceproofs ONLY VPPIEventIRQ VirtTimer @@ -89,7 +86,7 @@ where end_qualify -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming text \ The machine monad is used for operations on the state defined above. @@ -101,7 +98,7 @@ end translations (type) "'c ARM_HYP.machine_monad" <= (type) "(ARM_HYP.machine_state, 'c) nondet_monad" -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming text \ After kernel initialisation all IRQs are masked. @@ -139,15 +136,13 @@ definition (* Machine/Hardware/ARM.lhs - hardware_asid, vmfault_type and vmpage_size *) -#INCLUDE_HASKELL SEL4/Machine/Hardware/ARM.lhs CONTEXT ARM_HYP ONLY HardwareASID VMFaultType HypFaultType VMPageSize pageBits pageBitsForSize hcrVCPU hcrNative vgicHCREN sctlrDefault actlrDefault gicVCPUMaxNumLR +#INCLUDE_HASKELL SEL4/Machine/Hardware/ARM.lhs CONTEXT ARM_HYP ONLY HardwareASID VMFaultType HypFaultType VMPageSize pageBits pageBitsForSize hcrCommon hcrTWE hcrTWI hcrVCPU hcrNative vgicHCREN sctlrDefault actlrDefault gicVCPUMaxNumLR end -context begin interpretation Arch . -requalify_types vmpage_size -end +arch_requalify_types vmpage_size -context Arch begin global_naming ARM_HYP +context Arch begin arch_global_naming #INCLUDE_HASKELL SEL4/Machine/Hardware/ARM.lhs CONTEXT ARM_HYP instanceproofs ONLY HardwareASID VMFaultType HypFaultType VMPageSize diff --git a/spec/design/m-skel/RISCV64/MachineTypes.thy b/spec/design/m-skel/RISCV64/MachineTypes.thy index 702cec1108..6ca477869c 100644 --- a/spec/design/m-skel/RISCV64/MachineTypes.thy +++ b/spec/design/m-skel/RISCV64/MachineTypes.thy @@ -15,7 +15,7 @@ imports Platform begin -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming text \ An implementation of the machine's types, defining register set @@ -29,11 +29,9 @@ section "Types" end -context begin interpretation Arch . -requalify_types register -end +arch_requalify_types register -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming #INCLUDE_HASKELL SEL4/Machine/RegisterSet/RISCV64.hs CONTEXT RISCV64 instanceproofs (*>*) @@ -74,7 +72,7 @@ axiomatization end_qualify -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming text \ The machine monad is used for operations on the state defined above. @@ -86,7 +84,7 @@ end translations (type) "'c RISCV64.machine_monad" <= (type) "(RISCV64.machine_state, 'c) nondet_monad" -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming text \ After kernel initialisation all IRQs are masked. @@ -120,11 +118,9 @@ definition end -context begin interpretation Arch . -requalify_types vmpage_size -end +arch_requalify_types vmpage_size -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming #INCLUDE_HASKELL SEL4/Machine/Hardware/RISCV64.hs CONTEXT RISCV64 instanceproofs ONLY VMFaultType HypFaultType VMPageSize diff --git a/spec/design/m-skel/X64/MachineTypes.thy b/spec/design/m-skel/X64/MachineTypes.thy index 54bb5a930b..229318ad57 100644 --- a/spec/design/m-skel/X64/MachineTypes.thy +++ b/spec/design/m-skel/X64/MachineTypes.thy @@ -15,7 +15,7 @@ imports Platform begin -context Arch begin global_naming X64 +context Arch begin arch_global_naming text \ An implementation of the machine's types, defining register set @@ -29,11 +29,9 @@ section "Types" end -context begin interpretation Arch . -requalify_types register gdtslot -end +arch_requalify_types register gdtslot -context Arch begin global_naming X64 +context Arch begin arch_global_naming #INCLUDE_HASKELL SEL4/Machine/RegisterSet/X64.lhs CONTEXT X64 instanceproofs (*>*) @@ -65,7 +63,7 @@ consts irq_oracle :: "nat \ word8" end_qualify -context Arch begin global_naming X64 +context Arch begin arch_global_naming text \ The machine monad is used for operations on the state defined above. @@ -77,7 +75,7 @@ end translations (type) "'c X64.machine_monad" <= (type) "(X64.machine_state, 'c) nondet_monad" -context Arch begin global_naming X64 +context Arch begin arch_global_naming text \ After kernel initialisation all IRQs are masked. @@ -109,11 +107,9 @@ definition end -context begin interpretation Arch . -requalify_types vmpage_size vmmap_type -end +arch_requalify_types vmpage_size vmmap_type -context Arch begin global_naming X64 +context Arch begin arch_global_naming #INCLUDE_HASKELL SEL4/Machine/Hardware/X64.lhs CONTEXT X64 instanceproofs ONLY VMFaultType HypFaultType VMPageSize VMMapType diff --git a/spec/design/skel/AARCH64/ArchFaultHandler_H.thy b/spec/design/skel/AARCH64/ArchFaultHandler_H.thy index 1e68fbd75b..5c2c0e71e7 100644 --- a/spec/design/skel/AARCH64/ArchFaultHandler_H.thy +++ b/spec/design/skel/AARCH64/ArchFaultHandler_H.thy @@ -10,7 +10,7 @@ theory ArchFaultHandler_H imports TCB_H Structures_H begin -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL_PREPARSE SEL4/API/Failures/AARCH64.hs diff --git a/spec/design/skel/AARCH64/ArchFault_H.thy b/spec/design/skel/AARCH64/ArchFault_H.thy index 093f896f12..6628c39845 100644 --- a/spec/design/skel/AARCH64/ArchFault_H.thy +++ b/spec/design/skel/AARCH64/ArchFault_H.thy @@ -12,7 +12,7 @@ theory ArchFault_H imports Types_H begin -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/API/Failures/AARCH64.hs CONTEXT AARCH64_H decls_only #INCLUDE_HASKELL SEL4/API/Failures/AARCH64.hs CONTEXT AARCH64_H bodies_only diff --git a/spec/design/skel/AARCH64/ArchHypervisor_H.thy b/spec/design/skel/AARCH64/ArchHypervisor_H.thy index 9da1e70b57..740f6677d8 100644 --- a/spec/design/skel/AARCH64/ArchHypervisor_H.thy +++ b/spec/design/skel/AARCH64/ArchHypervisor_H.thy @@ -15,7 +15,7 @@ imports FaultHandlerDecls_H InterruptDecls_H begin -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Object/VCPU/AARCH64.hs CONTEXT AARCH64_H decls_only \ ONLY countTrailingZeros irqVPPIEventIndex diff --git a/spec/design/skel/AARCH64/ArchIntermediate_H.thy b/spec/design/skel/AARCH64/ArchIntermediate_H.thy index 016a51f40c..0f297533b8 100644 --- a/spec/design/skel/AARCH64/ArchIntermediate_H.thy +++ b/spec/design/skel/AARCH64/ArchIntermediate_H.thy @@ -21,6 +21,11 @@ private abbreviation (input) modify (\ks. ks \ gsUserPages := (\ addr. if addr `~elem~` map fromPPtr addrs then Just pSize else gsUserPages ks addr)\); + when (\dev) $ + mapM_x (\addr. doMachineOp $ + cleanCacheRange_RAM addr + (addr + mask (pageBitsForSize pSize)) + (addrFromPPtr addr)) addrs; return $ map (\n. FrameCap (PPtr (fromPPtr n)) VMReadWrite pSize dev Nothing) addrs od)" @@ -35,6 +40,8 @@ private abbreviation (input) if addr `~elem~` map fromPPtr addrs then Just ptType else gsPTTypes (ksArchState ks) addr)\\); initialiseMappings pts; + mapM_x (\addr. doMachineOp $ + cleanCacheRange_PoU addr (addr + mask tableBits) (addrFromPPtr addr)) addrs; return $ map (\pt. cap pt Nothing) pts od)" @@ -59,7 +66,7 @@ defs Arch_createNewCaps_def: (\pts. return ()) | VCPUObject \ (do addrs \ createObjects regionBase numObjects (injectKO (makeObject :: vcpu)) 0; - return $ map (\ addr. VCPUCap addr) addrs + return $ map (\addr. VCPUCap addr) addrs od) )" diff --git a/spec/design/skel/AARCH64/ArchInterruptDecls_H.thy b/spec/design/skel/AARCH64/ArchInterruptDecls_H.thy index f8294f4725..d1ae420f31 100644 --- a/spec/design/skel/AARCH64/ArchInterruptDecls_H.thy +++ b/spec/design/skel/AARCH64/ArchInterruptDecls_H.thy @@ -8,7 +8,7 @@ theory ArchInterruptDecls_H imports RetypeDecls_H CNode_H begin -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Object/Interrupt/AARCH64.hs CONTEXT AARCH64_H decls_only ArchInv= Arch=MachineOps NOT plic_complete_claim diff --git a/spec/design/skel/AARCH64/ArchInterrupt_H.thy b/spec/design/skel/AARCH64/ArchInterrupt_H.thy index e3adf88154..9d89d84f75 100644 --- a/spec/design/skel/AARCH64/ArchInterrupt_H.thy +++ b/spec/design/skel/AARCH64/ArchInterrupt_H.thy @@ -13,7 +13,7 @@ imports ArchHypervisor_H begin -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Object/Interrupt/AARCH64.hs CONTEXT AARCH64_H bodies_only ArchInv= Arch= NOT plic_complete_claim diff --git a/spec/design/skel/AARCH64/ArchInvocationLabels_H.thy b/spec/design/skel/AARCH64/ArchInvocationLabels_H.thy index 4b7e93575f..468186bd8f 100644 --- a/spec/design/skel/AARCH64/ArchInvocationLabels_H.thy +++ b/spec/design/skel/AARCH64/ArchInvocationLabels_H.thy @@ -11,7 +11,7 @@ imports "Word_Lib.Enumeration" Setup_Locale begin -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) text \ An enumeration of arch-specific system call labels. @@ -21,11 +21,12 @@ text \ end -context begin interpretation Arch . -requalify_types arch_invocation_label -end +(* not possible to move this requalification to generic, since enum instance proofs must + be done outside of Arch locale *) +arch_requalify_types (H) + arch_invocation_label -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/API/InvocationLabels/AARCH64.hs CONTEXT AARCH64_H instanceproofs ONLY ArchInvocationLabel diff --git a/spec/design/skel/AARCH64/ArchLabelFuns_H.thy b/spec/design/skel/AARCH64/ArchLabelFuns_H.thy index e70ddb11e6..d03de5f77b 100644 --- a/spec/design/skel/AARCH64/ArchLabelFuns_H.thy +++ b/spec/design/skel/AARCH64/ArchLabelFuns_H.thy @@ -10,7 +10,7 @@ chapter "Architecture-specific Invocation Label Functions" theory ArchLabelFuns_H imports InvocationLabels_H begin -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) text \ Arch-specific functions on invocation labels diff --git a/spec/design/skel/AARCH64/ArchPSpace_H.thy b/spec/design/skel/AARCH64/ArchPSpace_H.thy index b766a985b5..e567d9296e 100644 --- a/spec/design/skel/AARCH64/ArchPSpace_H.thy +++ b/spec/design/skel/AARCH64/ArchPSpace_H.thy @@ -11,7 +11,7 @@ imports ObjectInstances_H begin -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Model/PSpace/AARCH64.hs decls_only ONLY pTablePartialOverlap #INCLUDE_HASKELL SEL4/Model/PSpace/AARCH64.hs NOT pTablePartialOverlap diff --git a/spec/design/skel/AARCH64/ArchRetypeDecls_H.thy b/spec/design/skel/AARCH64/ArchRetypeDecls_H.thy index 2e0d9d9e68..6dca174950 100644 --- a/spec/design/skel/AARCH64/ArchRetypeDecls_H.thy +++ b/spec/design/skel/AARCH64/ArchRetypeDecls_H.thy @@ -16,7 +16,7 @@ imports ArchObjInsts_H begin -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL_PREPARSE SEL4/Object/Structures/AARCH64.hs diff --git a/spec/design/skel/AARCH64/ArchRetype_H.thy b/spec/design/skel/AARCH64/ArchRetype_H.thy index 95a6dd9182..58e94bb770 100644 --- a/spec/design/skel/AARCH64/ArchRetype_H.thy +++ b/spec/design/skel/AARCH64/ArchRetype_H.thy @@ -16,7 +16,7 @@ imports VCPU_H begin -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Object/ObjectType/AARCH64.hs CONTEXT AARCH64_H Arch.Types=ArchTypes_H ArchInv=ArchRetypeDecls_H NOT bodies_only #INCLUDE_HASKELL SEL4/API/Invocation/AARCH64.hs CONTEXT AARCH64_H bodies_only \ diff --git a/spec/design/skel/AARCH64/ArchStateData_H.thy b/spec/design/skel/AARCH64/ArchStateData_H.thy index a39087880f..d61ebf7659 100644 --- a/spec/design/skel/AARCH64/ArchStateData_H.thy +++ b/spec/design/skel/AARCH64/ArchStateData_H.thy @@ -18,7 +18,7 @@ imports ArchStructures_H begin -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Model/StateData/AARCH64.hs CONTEXT AARCH64_H NOT ArmVSpaceRegionUse diff --git a/spec/design/skel/AARCH64/ArchStructures_H.thy b/spec/design/skel/AARCH64/ArchStructures_H.thy index 67e0d81a69..4e81bd0ad0 100644 --- a/spec/design/skel/AARCH64/ArchStructures_H.thy +++ b/spec/design/skel/AARCH64/ArchStructures_H.thy @@ -12,7 +12,7 @@ imports Hardware_H begin -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) #INCLUDE_SETTINGS keep_constructor=asidpool #INCLUDE_SETTINGS keep_constructor=arch_tcb @@ -54,10 +54,8 @@ where end -context begin interpretation Arch . - -requalify_types +(* not possible to move this requalification to generic, as some arches don't have vcpu *) +arch_requalify_types (H) vcpu end -end diff --git a/spec/design/skel/AARCH64/ArchTCB_H.thy b/spec/design/skel/AARCH64/ArchTCB_H.thy index d897f7724a..39085e3663 100644 --- a/spec/design/skel/AARCH64/ArchTCB_H.thy +++ b/spec/design/skel/AARCH64/ArchTCB_H.thy @@ -8,7 +8,7 @@ theory ArchTCB_H imports TCBDecls_H begin -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Object/TCB/AARCH64.hs RegisterSet= CONTEXT AARCH64_H diff --git a/spec/design/skel/AARCH64/ArchThreadDecls_H.thy b/spec/design/skel/AARCH64/ArchThreadDecls_H.thy index 632e3a6c7c..78849071ae 100644 --- a/spec/design/skel/AARCH64/ArchThreadDecls_H.thy +++ b/spec/design/skel/AARCH64/ArchThreadDecls_H.thy @@ -17,7 +17,7 @@ imports KernelInitMonad_H begin -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Kernel/Thread/AARCH64.hs CONTEXT AARCH64_H decls_only diff --git a/spec/design/skel/AARCH64/ArchThread_H.thy b/spec/design/skel/AARCH64/ArchThread_H.thy index 8aa5b9bac7..3cb95f63f9 100644 --- a/spec/design/skel/AARCH64/ArchThread_H.thy +++ b/spec/design/skel/AARCH64/ArchThread_H.thy @@ -15,7 +15,7 @@ imports ArchHypervisor_H begin -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Kernel/Thread/AARCH64.hs CONTEXT AARCH64_H Arch=MachineOps ArchReg=MachineTypes bodies_only diff --git a/spec/design/skel/AARCH64/ArchTypes_H.thy b/spec/design/skel/AARCH64/ArchTypes_H.thy index 0529a18bb3..67c856f348 100644 --- a/spec/design/skel/AARCH64/ArchTypes_H.thy +++ b/spec/design/skel/AARCH64/ArchTypes_H.thy @@ -20,7 +20,7 @@ begin #INCLUDE_HASKELL SEL4/API/Types/Universal.lhs all_bits -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/API/Types/AARCH64.hs CONTEXT AARCH64_H @@ -75,8 +75,4 @@ interpretation Arch . instance by (intro_classes, simp add: enum_alt_object_type) end -context begin interpretation Arch . -requalify_types object_type -end - end diff --git a/spec/design/skel/AARCH64/ArchVSpaceDecls_H.thy b/spec/design/skel/AARCH64/ArchVSpaceDecls_H.thy index 301ad1c62c..75ee023a32 100644 --- a/spec/design/skel/AARCH64/ArchVSpaceDecls_H.thy +++ b/spec/design/skel/AARCH64/ArchVSpaceDecls_H.thy @@ -11,7 +11,7 @@ theory ArchVSpaceDecls_H imports ArchRetypeDecls_H InvocationLabels_H begin -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL_PREPARSE SEL4/Object/Structures.lhs CONTEXT AARCH64_H #INCLUDE_HASKELL_PREPARSE SEL4/API/InvocationLabels/AARCH64.hs CONTEXT AARCH64 diff --git a/spec/design/skel/AARCH64/ArchVSpace_H.thy b/spec/design/skel/AARCH64/ArchVSpace_H.thy index 3da0ae4f31..25a4a1716f 100644 --- a/spec/design/skel/AARCH64/ArchVSpace_H.thy +++ b/spec/design/skel/AARCH64/ArchVSpace_H.thy @@ -17,7 +17,7 @@ imports ArchHypervisor_H begin -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Kernel/VSpace/AARCH64.hs CONTEXT AARCH64_H bodies_only ArchInv=ArchRetypeDecls_H ONLY pteAtIndex getPPtrFromHWPTE isPageTablePTE ptBitsLeft diff --git a/spec/design/skel/AARCH64/Arch_Structs_B.thy b/spec/design/skel/AARCH64/Arch_Structs_B.thy index caa471f08a..e495da1473 100644 --- a/spec/design/skel/AARCH64/Arch_Structs_B.thy +++ b/spec/design/skel/AARCH64/Arch_Structs_B.thy @@ -13,7 +13,7 @@ theory Arch_Structs_B imports Setup_Locale begin -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Model/StateData/AARCH64.hs CONTEXT AARCH64_H ONLY ArmVSpaceRegionUse diff --git a/spec/design/skel/AARCH64/Hardware_H.thy b/spec/design/skel/AARCH64/Hardware_H.thy index dfd8138c4b..9c1e2074f1 100644 --- a/spec/design/skel/AARCH64/Hardware_H.thy +++ b/spec/design/skel/AARCH64/Hardware_H.thy @@ -11,7 +11,7 @@ imports State_H begin -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Machine/Hardware/AARCH64.hs Platform=Platform.AARCH64 CONTEXT AARCH64_H \ NOT PT_Type plic_complete_claim getMemoryRegions getDeviceRegions getKernelDevices \ @@ -41,11 +41,10 @@ context Arch begin global_naming AARCH64_H end -context begin interpretation Arch . -requalify_types vmrights -end +arch_requalify_types (H) + vmrights -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Machine/Hardware/AARCH64.hs CONTEXT AARCH64_H instanceproofs NOT plic_complete_claim HardwareASID VMFaultType VMPageSize VMPageEntry HypFaultType @@ -53,7 +52,7 @@ context Arch begin global_naming AARCH64_H (* Kernel_Config provides a generic numeral, Haskell expects type irq *) abbreviation (input) maxIRQ :: irq where - "maxIRQ == Kernel_Config.maxIRQ" + "maxIRQ \ Kernel_Config.maxIRQ" end (* context AARCH64 *) diff --git a/spec/design/skel/AARCH64/RegisterSet_H.thy b/spec/design/skel/AARCH64/RegisterSet_H.thy index ccee8e5dab..68bca7fb98 100644 --- a/spec/design/skel/AARCH64/RegisterSet_H.thy +++ b/spec/design/skel/AARCH64/RegisterSet_H.thy @@ -12,7 +12,7 @@ imports "Lib.HaskellLib_H" MachineOps begin -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) definition newFPUState :: "fpu_state" where "newFPUState \ FPUState (K 0) 0 0 " diff --git a/spec/design/skel/AARCH64/State_H.thy b/spec/design/skel/AARCH64/State_H.thy index 54e12f7926..8ab656f844 100644 --- a/spec/design/skel/AARCH64/State_H.thy +++ b/spec/design/skel/AARCH64/State_H.thy @@ -14,7 +14,7 @@ theory State_H imports RegisterSet_H begin -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) definition Word :: "machine_word \ machine_word" @@ -26,16 +26,14 @@ where end -context begin interpretation Arch . - -requalify_consts +(* Note: while this requalify and arch-generic Haskell import of WordLib.lhs could be moved to + a generic theory, no good candidate theory exists at the moment. *) +arch_requalify_consts (H) wordBits -end - #INCLUDE_HASKELL Data/WordLib.lhs all_bits NOT wordBits -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Machine/RegisterSet.lhs Arch=AARCH64 CONTEXT AARCH64_H all_bits NOT UserContext UserMonad getRegister setRegister newContext mask Word PPtr diff --git a/spec/design/skel/AARCH64/VCPU_H.thy b/spec/design/skel/AARCH64/VCPU_H.thy index 481fab4492..97dfc4c813 100644 --- a/spec/design/skel/AARCH64/VCPU_H.thy +++ b/spec/design/skel/AARCH64/VCPU_H.thy @@ -14,7 +14,7 @@ imports Invocations_H TCB_H begin -context Arch begin global_naming AARCH64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL_PREPARSE SEL4/Object/Structures.lhs CONTEXT AARCH64_H #INCLUDE_HASKELL SEL4/Object/VCPU/AARCH64.hs CONTEXT AARCH64_H ArchInv=Arch \ diff --git a/spec/design/skel/ARM/ArchFaultHandler_H.thy b/spec/design/skel/ARM/ArchFaultHandler_H.thy index e0729561d0..9a4492d6fa 100644 --- a/spec/design/skel/ARM/ArchFaultHandler_H.thy +++ b/spec/design/skel/ARM/ArchFaultHandler_H.thy @@ -10,7 +10,7 @@ theory ArchFaultHandler_H imports TCB_H Structures_H begin -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL_PREPARSE SEL4/API/Failures/ARM.lhs diff --git a/spec/design/skel/ARM/ArchFault_H.thy b/spec/design/skel/ARM/ArchFault_H.thy index 0348207fa9..ad30f75c37 100644 --- a/spec/design/skel/ARM/ArchFault_H.thy +++ b/spec/design/skel/ARM/ArchFault_H.thy @@ -11,7 +11,7 @@ theory ArchFault_H imports Types_H begin -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/API/Failures/ARM.lhs CONTEXT ARM_H decls_only diff --git a/spec/design/skel/ARM/ArchHypervisor_H.thy b/spec/design/skel/ARM/ArchHypervisor_H.thy index a0e218c7cc..9b8f129d34 100644 --- a/spec/design/skel/ARM/ArchHypervisor_H.thy +++ b/spec/design/skel/ARM/ArchHypervisor_H.thy @@ -14,7 +14,7 @@ imports KI_Decls_H InterruptDecls_H begin -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Kernel/Hypervisor/ARM.lhs Arch= CONTEXT ARM_H decls_only ArchInv= ArchLabels= diff --git a/spec/design/skel/ARM/ArchIntermediate_H.thy b/spec/design/skel/ARM/ArchIntermediate_H.thy index 2cbf1f9ccd..a6200aca3d 100644 --- a/spec/design/skel/ARM/ArchIntermediate_H.thy +++ b/spec/design/skel/ARM/ArchIntermediate_H.thy @@ -20,6 +20,11 @@ private abbreviation (input) modify (\ks. ks \ gsUserPages := (\ addr. if addr `~elem~` map fromPPtr addrs then Just pSize else gsUserPages ks addr)\); + when (\dev) $ + mapM_x (\addr. doMachineOp $ + cleanCacheRange_RAM addr + (addr + mask (pageBitsForSize pSize)) + (addrFromPPtr addr)) addrs; return $ map (\n. PageCap dev (PPtr (fromPPtr n)) VMReadWrite pSize Nothing) addrs od)" @@ -29,6 +34,8 @@ private abbreviation (input) addrs \ createObjects regionBase numObjects (injectKO objectProto) tableSize; pts \ return (map (PPtr \ fromPPtr) addrs); initialiseMappings pts; + mapM_x (\addr. doMachineOp $ + cleanCacheRange_PoU addr (addr + mask tableBits) (addrFromPPtr addr)) addrs; return $ map (\pt. cap pt Nothing) pts od)" @@ -51,10 +58,7 @@ defs Arch_createNewCaps_def: | PageDirectoryObject \ createNewTableCaps regionBase numObjects pdBits (makeObject::pde) PageDirectoryCap (\pds. do objSize \ return (((1::nat) `~shiftL~` pdBits)); - mapM_x copyGlobalMappings pds; - doMachineOp $ mapM_x (\x. cleanCacheRange_PoU x - (x + (fromIntegral objSize) - 1) - (addrFromPPtr x)) pds + mapM_x copyGlobalMappings pds od) )" diff --git a/spec/design/skel/ARM/ArchInterruptDecls_H.thy b/spec/design/skel/ARM/ArchInterruptDecls_H.thy index e620da7216..eea27acf73 100644 --- a/spec/design/skel/ARM/ArchInterruptDecls_H.thy +++ b/spec/design/skel/ARM/ArchInterruptDecls_H.thy @@ -8,7 +8,7 @@ theory ArchInterruptDecls_H imports RetypeDecls_H CNode_H begin -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Object/Interrupt/ARM.lhs CONTEXT ARM_H decls_only ArchInv= diff --git a/spec/design/skel/ARM/ArchInterrupt_H.thy b/spec/design/skel/ARM/ArchInterrupt_H.thy index 0c1a5ee861..484443ba02 100644 --- a/spec/design/skel/ARM/ArchInterrupt_H.thy +++ b/spec/design/skel/ARM/ArchInterrupt_H.thy @@ -13,7 +13,7 @@ imports ArchHypervisor_H begin -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Object/Interrupt/ARM.lhs Arch= CONTEXT ARM_H bodies_only ArchInv= diff --git a/spec/design/skel/ARM/ArchInvocationLabels_H.thy b/spec/design/skel/ARM/ArchInvocationLabels_H.thy index f09d72dc54..af48844b85 100644 --- a/spec/design/skel/ARM/ArchInvocationLabels_H.thy +++ b/spec/design/skel/ARM/ArchInvocationLabels_H.thy @@ -11,7 +11,7 @@ imports "Word_Lib.Enumeration" Setup_Locale begin -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) text \ An enumeration of arch-specific system call labels. @@ -21,11 +21,12 @@ text \ end -context begin interpretation Arch . -requalify_types arch_invocation_label -end +(* not possible to move this requalification to generic, since enum instance proofs must + be done outside of Arch locale *) +arch_requalify_types (H) + arch_invocation_label -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/API/InvocationLabels/ARM.lhs CONTEXT ARM_H instanceproofs ONLY ArchInvocationLabel diff --git a/spec/design/skel/ARM/ArchLabelFuns_H.thy b/spec/design/skel/ARM/ArchLabelFuns_H.thy index 2011bda04a..17e3c789d3 100644 --- a/spec/design/skel/ARM/ArchLabelFuns_H.thy +++ b/spec/design/skel/ARM/ArchLabelFuns_H.thy @@ -9,7 +9,7 @@ chapter "Architecture-specific Invocation Label Functions" theory ArchLabelFuns_H imports InvocationLabels_H begin -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) text \ Arch-specific functions on invocation labels \ diff --git a/spec/design/skel/ARM/ArchPSpace_H.thy b/spec/design/skel/ARM/ArchPSpace_H.thy index af3737ffb7..18fb9fbd18 100644 --- a/spec/design/skel/ARM/ArchPSpace_H.thy +++ b/spec/design/skel/ARM/ArchPSpace_H.thy @@ -11,7 +11,7 @@ imports ObjectInstances_H begin -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Model/PSpace/ARM.hs diff --git a/spec/design/skel/ARM/ArchRetypeDecls_H.thy b/spec/design/skel/ARM/ArchRetypeDecls_H.thy index ceef162022..87eecd669d 100644 --- a/spec/design/skel/ARM/ArchRetypeDecls_H.thy +++ b/spec/design/skel/ARM/ArchRetypeDecls_H.thy @@ -15,7 +15,7 @@ imports PSpaceFuns_H ArchObjInsts_H begin -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/API/Invocation/ARM.lhs CONTEXT ARM_H decls_only NOT isPageFlushLabel isPDFlushLabel Invocation IRQControlInvocation CopyRegisterSets diff --git a/spec/design/skel/ARM/ArchRetype_H.thy b/spec/design/skel/ARM/ArchRetype_H.thy index c5516ab04e..61e4a0ef78 100644 --- a/spec/design/skel/ARM/ArchRetype_H.thy +++ b/spec/design/skel/ARM/ArchRetype_H.thy @@ -13,7 +13,7 @@ imports Hardware_H KI_Decls_H begin -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Object/ObjectType/ARM.lhs CONTEXT ARM_H Arch.Types= ArchInv= bodies_only #INCLUDE_HASKELL SEL4/API/Invocation/ARM.lhs bodies_only CONTEXT ARM_H NOT isPDFlushLabel isPageFlushLabel diff --git a/spec/design/skel/ARM/ArchStateData_H.thy b/spec/design/skel/ARM/ArchStateData_H.thy index 1a9acf6f72..e5bc7527b2 100644 --- a/spec/design/skel/ARM/ArchStateData_H.thy +++ b/spec/design/skel/ARM/ArchStateData_H.thy @@ -16,7 +16,7 @@ imports ArchTypes_H ArchStructures_H begin -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Model/StateData/ARM.lhs CONTEXT ARM_H NOT ArmVSpaceRegionUse diff --git a/spec/design/skel/ARM/ArchStructures_H.thy b/spec/design/skel/ARM/ArchStructures_H.thy index ced98a9354..306ff88e7f 100644 --- a/spec/design/skel/ARM/ArchStructures_H.thy +++ b/spec/design/skel/ARM/ArchStructures_H.thy @@ -10,7 +10,7 @@ imports Types_H Hardware_H begin -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) #INCLUDE_SETTINGS keep_constructor=asidpool #INCLUDE_SETTINGS keep_constructor=arch_tcb diff --git a/spec/design/skel/ARM/ArchTCB_H.thy b/spec/design/skel/ARM/ArchTCB_H.thy index a3fd51156e..ef1f9925db 100644 --- a/spec/design/skel/ARM/ArchTCB_H.thy +++ b/spec/design/skel/ARM/ArchTCB_H.thy @@ -7,7 +7,7 @@ theory ArchTCB_H imports TCBDecls_H begin -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Object/TCB/ARM.lhs RegisterSet= CONTEXT ARM_H diff --git a/spec/design/skel/ARM/ArchThreadDecls_H.thy b/spec/design/skel/ARM/ArchThreadDecls_H.thy index 3536521e59..146404bb09 100644 --- a/spec/design/skel/ARM/ArchThreadDecls_H.thy +++ b/spec/design/skel/ARM/ArchThreadDecls_H.thy @@ -17,7 +17,7 @@ imports KernelInitMonad_H begin -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Kernel/Thread/ARM.lhs CONTEXT Arch decls_only diff --git a/spec/design/skel/ARM/ArchThread_H.thy b/spec/design/skel/ARM/ArchThread_H.thy index 4661bd058d..32ff4247d7 100644 --- a/spec/design/skel/ARM/ArchThread_H.thy +++ b/spec/design/skel/ARM/ArchThread_H.thy @@ -12,7 +12,7 @@ imports TCBDecls_H ArchVSpaceDecls_H begin -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Kernel/Thread/ARM.lhs CONTEXT ARM_H ARMHardware=ARM bodies_only diff --git a/spec/design/skel/ARM/ArchTypes_H.thy b/spec/design/skel/ARM/ArchTypes_H.thy index e82300474d..5eb35a9a40 100644 --- a/spec/design/skel/ARM/ArchTypes_H.thy +++ b/spec/design/skel/ARM/ArchTypes_H.thy @@ -19,7 +19,7 @@ begin #INCLUDE_HASKELL SEL4/API/Types/Universal.lhs all_bits -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/API/Types/ARM.lhs CONTEXT ARM_H @@ -74,8 +74,4 @@ interpretation Arch . instance by (intro_classes, simp add: enum_alt_object_type) end -context begin interpretation Arch . -requalify_types object_type -end - end diff --git a/spec/design/skel/ARM/ArchVSpaceDecls_H.thy b/spec/design/skel/ARM/ArchVSpaceDecls_H.thy index cae8b84d60..344c1b7edb 100644 --- a/spec/design/skel/ARM/ArchVSpaceDecls_H.thy +++ b/spec/design/skel/ARM/ArchVSpaceDecls_H.thy @@ -9,7 +9,7 @@ chapter "Retyping Objects" theory ArchVSpaceDecls_H imports ArchRetypeDecls_H InvocationLabels_H begin -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL_PREPARSE SEL4/Object/Structures.lhs CONTEXT ARM_H #INCLUDE_HASKELL SEL4/Kernel/VSpace/ARM.lhs CONTEXT ARM_H decls_only ArchInv= diff --git a/spec/design/skel/ARM/ArchVSpace_H.thy b/spec/design/skel/ARM/ArchVSpace_H.thy index 8ef22eb02d..0317d66b3d 100644 --- a/spec/design/skel/ARM/ArchVSpace_H.thy +++ b/spec/design/skel/ARM/ArchVSpace_H.thy @@ -16,7 +16,7 @@ imports ArchVSpaceDecls_H ArchHypervisor_H begin -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Kernel/VSpace/ARM.lhs CONTEXT ARM_H bodies_only ArchInv=ArchRetypeDecls_H.ARM ArchLabels=ArchInvocationLabels_H.ARM NOT checkPDAt checkPTAt checkPDASIDMapMembership checkValidMappingSize vptrFromPPtr diff --git a/spec/design/skel/ARM/Arch_Structs_B.thy b/spec/design/skel/ARM/Arch_Structs_B.thy index 188feeedf0..0817aa7d62 100644 --- a/spec/design/skel/ARM/Arch_Structs_B.thy +++ b/spec/design/skel/ARM/Arch_Structs_B.thy @@ -11,7 +11,7 @@ chapter "Common, Architecture-Specific Data Types" theory Arch_Structs_B imports Main Setup_Locale begin -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Model/StateData/ARM.lhs CONTEXT ARM_H ONLY ArmVSpaceRegionUse diff --git a/spec/design/skel/ARM/Hardware_H.thy b/spec/design/skel/ARM/Hardware_H.thy index 863449e587..f74ebd35fb 100644 --- a/spec/design/skel/ARM/Hardware_H.thy +++ b/spec/design/skel/ARM/Hardware_H.thy @@ -10,7 +10,7 @@ imports State_H begin -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) definition usToTicks :: "word64 \ word64" where "usToTicks \ us_to_ticks" @@ -37,11 +37,10 @@ definition maxPeriodUs :: "word64" where end -context begin interpretation Arch . -requalify_types vmrights -end +arch_requalify_types (H) + vmrights -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Machine/Hardware/ARM.lhs CONTEXT ARM_H instanceproofs NOT HardwareASID VMFaultType VMPageSize HypFaultType @@ -51,5 +50,9 @@ context Arch begin global_naming ARM_H abbreviation (input) maxIRQ :: irq where "maxIRQ == Kernel_Config.maxIRQ" +(* provide ARM/ARM_HYP machine op in _H global_prefix for arch-split *) +abbreviation (input) initIRQController where + "initIRQController \ ARM.initIRQController" + end end diff --git a/spec/design/skel/ARM/RegisterSet_H.thy b/spec/design/skel/ARM/RegisterSet_H.thy index 28821559dc..5e767490f2 100644 --- a/spec/design/skel/ARM/RegisterSet_H.thy +++ b/spec/design/skel/ARM/RegisterSet_H.thy @@ -11,7 +11,7 @@ imports "Lib.HaskellLib_H" MachineOps begin -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) definition newContext :: "user_context" diff --git a/spec/design/skel/ARM/State_H.thy b/spec/design/skel/ARM/State_H.thy index ca3dd1891d..8c52f1470c 100644 --- a/spec/design/skel/ARM/State_H.thy +++ b/spec/design/skel/ARM/State_H.thy @@ -16,7 +16,7 @@ imports RegisterSet_H MachineOps begin -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) definition Word :: "machine_word \ machine_word" @@ -28,16 +28,14 @@ where end -context begin interpretation Arch . - -requalify_consts +(* Note: while this requalify and arch-generic Haskell import of WordLib.lhs could be moved to + a generic theory, no good candidate theory exists at the moment. *) +arch_requalify_consts (H) wordBits -end - #INCLUDE_HASKELL Data/WordLib.lhs all_bits NOT wordBits -context Arch begin global_naming ARM_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Machine/RegisterSet.lhs Arch=ARM CONTEXT ARM_H all_bits NOT UserContext UserMonad getRegister setRegister newContext mask Word PPtr diff --git a/spec/design/skel/ARM_HYP/ArchFaultHandler_H.thy b/spec/design/skel/ARM_HYP/ArchFaultHandler_H.thy index f7a0255de4..9a4492d6fa 100644 --- a/spec/design/skel/ARM_HYP/ArchFaultHandler_H.thy +++ b/spec/design/skel/ARM_HYP/ArchFaultHandler_H.thy @@ -10,7 +10,7 @@ theory ArchFaultHandler_H imports TCB_H Structures_H begin -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL_PREPARSE SEL4/API/Failures/ARM.lhs diff --git a/spec/design/skel/ARM_HYP/ArchFault_H.thy b/spec/design/skel/ARM_HYP/ArchFault_H.thy index 818492b1d8..c58ad8d134 100644 --- a/spec/design/skel/ARM_HYP/ArchFault_H.thy +++ b/spec/design/skel/ARM_HYP/ArchFault_H.thy @@ -11,7 +11,7 @@ theory ArchFault_H imports Types_H begin -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/API/Failures/ARM.lhs CONTEXT ARM_HYP_H decls_only diff --git a/spec/design/skel/ARM_HYP/ArchHypervisor_H.thy b/spec/design/skel/ARM_HYP/ArchHypervisor_H.thy index 4043575bf5..689dfaf6b6 100644 --- a/spec/design/skel/ARM_HYP/ArchHypervisor_H.thy +++ b/spec/design/skel/ARM_HYP/ArchHypervisor_H.thy @@ -14,7 +14,7 @@ imports FaultHandlerDecls_H InterruptDecls_H begin -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Object/VCPU/ARM.lhs CONTEXT ARM_HYP_H decls_only ONLY countTrailingZeros irqVPPIEventIndex #INCLUDE_HASKELL SEL4/Object/VCPU/ARM.lhs CONTEXT ARM_HYP_H bodies_only ONLY countTrailingZeros irqVPPIEventIndex diff --git a/spec/design/skel/ARM_HYP/ArchIntermediate_H.thy b/spec/design/skel/ARM_HYP/ArchIntermediate_H.thy index 9b1261671a..03c61307d6 100644 --- a/spec/design/skel/ARM_HYP/ArchIntermediate_H.thy +++ b/spec/design/skel/ARM_HYP/ArchIntermediate_H.thy @@ -20,6 +20,11 @@ private abbreviation (input) modify (\ks. ks \ gsUserPages := (\ addr. if addr `~elem~` map fromPPtr addrs then Just pSize else gsUserPages ks addr)\); + when (\dev) $ + mapM_x (\addr. doMachineOp $ + cleanCacheRange_RAM addr + (addr + mask (pageBitsForSize pSize)) + (addrFromPPtr addr)) addrs; return $ map (\n. PageCap dev (PPtr (fromPPtr n)) VMReadWrite pSize Nothing) addrs od)" @@ -29,6 +34,8 @@ private abbreviation (input) addrs \ createObjects regionBase numObjects (injectKO objectProto) tableSize; pts \ return (map (PPtr \ fromPPtr) addrs); initialiseMappings pts; + mapM_x (\addr. doMachineOp $ + cleanCacheRange_PoU addr (addr + mask tableBits) (addrFromPPtr addr)) addrs; return $ map (\pt. cap pt Nothing) pts od)" @@ -51,14 +58,11 @@ defs Arch_createNewCaps_def: | PageDirectoryObject \ createNewTableCaps regionBase numObjects pdBits (makeObject::pde) PageDirectoryCap (\pds. do objSize \ return (((1::nat) `~shiftL~` pdBits)); - mapM_x copyGlobalMappings pds; - doMachineOp $ mapM_x (\x. cleanCacheRange_PoU x - (x + (fromIntegral objSize) - 1) - (addrFromPPtr x)) pds + mapM_x copyGlobalMappings pds od) | VCPUObject \ (do addrs \ createObjects regionBase numObjects (injectKO (makeObject :: vcpu)) 0; - return $ map (\ addr. VCPUCap addr) addrs + return $ map (\addr. VCPUCap addr) addrs od) )" diff --git a/spec/design/skel/ARM_HYP/ArchInterruptDecls_H.thy b/spec/design/skel/ARM_HYP/ArchInterruptDecls_H.thy index 8aa686f3e0..64915f3e99 100644 --- a/spec/design/skel/ARM_HYP/ArchInterruptDecls_H.thy +++ b/spec/design/skel/ARM_HYP/ArchInterruptDecls_H.thy @@ -8,7 +8,7 @@ theory ArchInterruptDecls_H imports RetypeDecls_H CNode_H begin -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Object/Interrupt/ARM.lhs CONTEXT Arch decls_only ArchInv= diff --git a/spec/design/skel/ARM_HYP/ArchInterrupt_H.thy b/spec/design/skel/ARM_HYP/ArchInterrupt_H.thy index 919733bdb6..62b663c6af 100644 --- a/spec/design/skel/ARM_HYP/ArchInterrupt_H.thy +++ b/spec/design/skel/ARM_HYP/ArchInterrupt_H.thy @@ -13,7 +13,7 @@ imports ArchHypervisor_H begin -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Object/Interrupt/ARM.lhs Arch= CONTEXT ARM_HYP_H bodies_only ArchInv= NOT initInterruptController diff --git a/spec/design/skel/ARM_HYP/ArchInvocationLabels_H.thy b/spec/design/skel/ARM_HYP/ArchInvocationLabels_H.thy index bbfce96925..bb512efe2b 100644 --- a/spec/design/skel/ARM_HYP/ArchInvocationLabels_H.thy +++ b/spec/design/skel/ARM_HYP/ArchInvocationLabels_H.thy @@ -11,7 +11,7 @@ imports "Word_Lib.Enumeration" Setup_Locale begin -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) text \ An enumeration of arch-specific system call labels. @@ -21,11 +21,12 @@ text \ end -context begin interpretation Arch . -requalify_types arch_invocation_label -end +(* not possible to move this requalification to generic, since enum instance proofs must + be done outside of Arch locale *) +arch_requalify_types (H) + arch_invocation_label -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/API/InvocationLabels/ARM.lhs CONTEXT ARM_HYP_H instanceproofs ONLY ArchInvocationLabel diff --git a/spec/design/skel/ARM_HYP/ArchLabelFuns_H.thy b/spec/design/skel/ARM_HYP/ArchLabelFuns_H.thy index 7698938352..8c368abada 100644 --- a/spec/design/skel/ARM_HYP/ArchLabelFuns_H.thy +++ b/spec/design/skel/ARM_HYP/ArchLabelFuns_H.thy @@ -9,7 +9,7 @@ chapter "Architecture-specific Invocation Label Functions" theory ArchLabelFuns_H imports InvocationLabels_H begin -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) text \ Arch-specific functions on invocation labels \ diff --git a/spec/design/skel/ARM_HYP/ArchPSpace_H.thy b/spec/design/skel/ARM_HYP/ArchPSpace_H.thy index 38644c9b44..18fb9fbd18 100644 --- a/spec/design/skel/ARM_HYP/ArchPSpace_H.thy +++ b/spec/design/skel/ARM_HYP/ArchPSpace_H.thy @@ -11,7 +11,7 @@ imports ObjectInstances_H begin -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Model/PSpace/ARM.hs diff --git a/spec/design/skel/ARM_HYP/ArchRetypeDecls_H.thy b/spec/design/skel/ARM_HYP/ArchRetypeDecls_H.thy index 004b3395b9..8f8dd25701 100644 --- a/spec/design/skel/ARM_HYP/ArchRetypeDecls_H.thy +++ b/spec/design/skel/ARM_HYP/ArchRetypeDecls_H.thy @@ -15,7 +15,7 @@ imports PSpaceFuns_H ArchObjInsts_H begin -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/API/Invocation/ARM.lhs CONTEXT ARM_HYP_H decls_only NOT isPageFlushLabel isPDFlushLabel Invocation IRQControlInvocation CopyRegisterSets diff --git a/spec/design/skel/ARM_HYP/ArchRetype_H.thy b/spec/design/skel/ARM_HYP/ArchRetype_H.thy index ea516d86c0..51e44a07cf 100644 --- a/spec/design/skel/ARM_HYP/ArchRetype_H.thy +++ b/spec/design/skel/ARM_HYP/ArchRetype_H.thy @@ -14,7 +14,7 @@ imports VCPU_H KI_Decls_H begin -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Object/ObjectType/ARM.lhs CONTEXT ARM_HYP_H Arch.Types= ArchInv= bodies_only #INCLUDE_HASKELL SEL4/API/Invocation/ARM.lhs bodies_only CONTEXT ARM_HYP_H NOT isPDFlushLabel isPageFlushLabel diff --git a/spec/design/skel/ARM_HYP/ArchStateData_H.thy b/spec/design/skel/ARM_HYP/ArchStateData_H.thy index 44c9f51a56..b094f04a85 100644 --- a/spec/design/skel/ARM_HYP/ArchStateData_H.thy +++ b/spec/design/skel/ARM_HYP/ArchStateData_H.thy @@ -16,7 +16,7 @@ imports ArchTypes_H ArchStructures_H begin -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Model/StateData/ARM.lhs CONTEXT ARM_HYP_H NOT ArmVSpaceRegionUse diff --git a/spec/design/skel/ARM_HYP/ArchStructures_H.thy b/spec/design/skel/ARM_HYP/ArchStructures_H.thy index 47bf8628ed..a10a1163a5 100644 --- a/spec/design/skel/ARM_HYP/ArchStructures_H.thy +++ b/spec/design/skel/ARM_HYP/ArchStructures_H.thy @@ -10,7 +10,7 @@ imports Types_H Hardware_H begin -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) #INCLUDE_SETTINGS keep_constructor=asidpool #INCLUDE_SETTINGS keep_constructor=arch_tcb @@ -52,10 +52,8 @@ where end -context begin interpretation Arch . - -requalify_types +(* not possible to move this requalification to generic, as some arches don't have vcpu *) +arch_requalify_types (H) vcpu end -end diff --git a/spec/design/skel/ARM_HYP/ArchTCB_H.thy b/spec/design/skel/ARM_HYP/ArchTCB_H.thy index d01651eb25..d7deff832b 100644 --- a/spec/design/skel/ARM_HYP/ArchTCB_H.thy +++ b/spec/design/skel/ARM_HYP/ArchTCB_H.thy @@ -7,7 +7,7 @@ theory ArchTCB_H imports TCBDecls_H begin -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Object/TCB/ARM.lhs RegisterSet= CONTEXT ARM_HYP_H diff --git a/spec/design/skel/ARM_HYP/ArchThreadDecls_H.thy b/spec/design/skel/ARM_HYP/ArchThreadDecls_H.thy index fcfa48857d..146404bb09 100644 --- a/spec/design/skel/ARM_HYP/ArchThreadDecls_H.thy +++ b/spec/design/skel/ARM_HYP/ArchThreadDecls_H.thy @@ -17,7 +17,7 @@ imports KernelInitMonad_H begin -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Kernel/Thread/ARM.lhs CONTEXT Arch decls_only diff --git a/spec/design/skel/ARM_HYP/ArchThread_H.thy b/spec/design/skel/ARM_HYP/ArchThread_H.thy index 514d097eeb..d476d36309 100644 --- a/spec/design/skel/ARM_HYP/ArchThread_H.thy +++ b/spec/design/skel/ARM_HYP/ArchThread_H.thy @@ -13,7 +13,7 @@ imports ArchVSpaceDecls_H ArchHypervisor_H begin -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Kernel/Thread/ARM.lhs CONTEXT ARM_HYP_H ARMHardware=ARM_HYP bodies_only diff --git a/spec/design/skel/ARM_HYP/ArchTypes_H.thy b/spec/design/skel/ARM_HYP/ArchTypes_H.thy index b80c0e045e..88d26d65e8 100644 --- a/spec/design/skel/ARM_HYP/ArchTypes_H.thy +++ b/spec/design/skel/ARM_HYP/ArchTypes_H.thy @@ -19,7 +19,7 @@ begin #INCLUDE_HASKELL SEL4/API/Types/Universal.lhs all_bits -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/API/Types/ARM.lhs CONTEXT ARM_HYP_H @@ -75,8 +75,4 @@ interpretation Arch . instance by (intro_classes, simp add: enum_alt_object_type) end -context begin interpretation Arch . -requalify_types object_type -end - end diff --git a/spec/design/skel/ARM_HYP/ArchVSpaceDecls_H.thy b/spec/design/skel/ARM_HYP/ArchVSpaceDecls_H.thy index da0372748b..27369149a6 100644 --- a/spec/design/skel/ARM_HYP/ArchVSpaceDecls_H.thy +++ b/spec/design/skel/ARM_HYP/ArchVSpaceDecls_H.thy @@ -9,7 +9,7 @@ chapter "Retyping Objects" theory ArchVSpaceDecls_H imports ArchRetypeDecls_H InvocationLabels_H begin -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL_PREPARSE SEL4/Object/Structures.lhs CONTEXT ARM_HYP_H #INCLUDE_HASKELL SEL4/Kernel/VSpace/ARM.lhs CONTEXT ARM_HYP_H decls_only NOT pageBase ArchInv= diff --git a/spec/design/skel/ARM_HYP/ArchVSpace_H.thy b/spec/design/skel/ARM_HYP/ArchVSpace_H.thy index 6828c59406..97681550fb 100644 --- a/spec/design/skel/ARM_HYP/ArchVSpace_H.thy +++ b/spec/design/skel/ARM_HYP/ArchVSpace_H.thy @@ -15,7 +15,7 @@ imports ArchVSpaceDecls_H ArchHypervisor_H begin -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Kernel/VSpace/ARM.lhs CONTEXT ARM_HYP_H bodies_only ArchInv=ArchRetypeDecls_H.ARM_HYP ArchLabels=ArchInvocationLabels_H.ARM_HYP NOT checkPDAt checkPTAt checkPDASIDMapMembership checkValidMappingSize vptrFromPPtr diff --git a/spec/design/skel/ARM_HYP/Arch_Structs_B.thy b/spec/design/skel/ARM_HYP/Arch_Structs_B.thy index 4b5ae6373c..75b5f0b951 100644 --- a/spec/design/skel/ARM_HYP/Arch_Structs_B.thy +++ b/spec/design/skel/ARM_HYP/Arch_Structs_B.thy @@ -11,7 +11,7 @@ chapter "Common, Architecture-Specific Data Types" theory Arch_Structs_B imports Main Setup_Locale begin -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Model/StateData/ARM.lhs CONTEXT ARM_HYP_H ONLY ArmVSpaceRegionUse diff --git a/spec/design/skel/ARM_HYP/Hardware_H.thy b/spec/design/skel/ARM_HYP/Hardware_H.thy index 41a1e90664..baeeb65637 100644 --- a/spec/design/skel/ARM_HYP/Hardware_H.thy +++ b/spec/design/skel/ARM_HYP/Hardware_H.thy @@ -9,17 +9,16 @@ imports MachineOps State_H begin -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Machine/Hardware/ARM.lhs Platform=Platform.ARM_HYP CONTEXT ARM_HYP_H NOT getMemoryRegions getDeviceRegions getKernelDevices loadWord storeWord storeWordVM getActiveIRQ ackInterrupt maskInterrupt configureTimer resetTimer debugPrint getRestartPC setNextPC clearMemory clearMemoryVM initMemory freeMemory writeTTBR0 setGlobalPD setTTBCR setHardwareASID invalidateLocalTLB invalidateLocalTLB_ASID invalidateLocalTLB_VAASID cleanByVA cleanByVA_PoU invalidateByVA invalidateByVA_I invalidate_I_PoU cleanInvalByVA branchFlush clean_D_PoU cleanInvalidate_D_PoC cleanInvalidate_D_PoU cleanInvalidateL2Range invalidateL2Range cleanL2Range isb dsb dmb getIFSR getDFSR getFAR HardwareASID wordFromPDE wordFromPTE VMFaultType HypFaultType VMPageSize pageBits pageBitsForSize toPAddr paddrBase pptrBase pptrTop paddrTop kernelELFPAddrBase kernelELFBase kernelELFBaseOffset pptrBaseOffset cacheLineBits cacheLine lineStart cacheRangeOp cleanCacheRange_PoC cleanInvalidateCacheRange_RAM cleanCacheRange_RAM cleanCacheRange_PoU invalidateCacheRange_RAM invalidateCacheRange_I branchFlushRange cleanCaches_PoU cleanInvalidateL1Caches addrFromPPtr ptrFromPAddr addrFromKPPtr initIRQController MachineData hapFromVMRights wordsFromPDE wordsFromPTE writeContextIDAndPD hcrVCPU hcrNative vgicHCREN sctlrDefault actlrDefault gicVCPUMaxNumLR getHSR setHCR getHDFAR addressTranslateS1 getSCTLR setSCTLR getACTLR setACTLR get_gic_vcpu_ctrl_hcr set_gic_vcpu_ctrl_hcr get_gic_vcpu_ctrl_vmcr set_gic_vcpu_ctrl_vmcr get_gic_vcpu_ctrl_apr set_gic_vcpu_ctrl_apr get_gic_vcpu_ctrl_vtr get_gic_vcpu_ctrl_eisr0 get_gic_vcpu_ctrl_eisr1 get_gic_vcpu_ctrl_misr get_gic_vcpu_ctrl_lr set_gic_vcpu_ctrl_lr setCurrentPDPL2 readVCPUHardwareReg setIRQTrigger writeVCPUHardwareReg getTPIDRURO setTPIDRURO get_cntv_cval_64 set_cntv_cval_64 set_cntv_off_64 get_cntv_off_64 read_cntpct end -context begin interpretation Arch . -requalify_types vmrights -end +arch_requalify_types (H) + vmrights -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Machine/Hardware/ARM.lhs CONTEXT ARM_HYP_H instanceproofs NOT HardwareASID VMFaultType HypFaultType VMPageSize @@ -27,7 +26,11 @@ context Arch begin global_naming ARM_HYP_H (* Kernel_Config provides a generic numeral, Haskell expects type irq *) abbreviation (input) maxIRQ :: irq where - "maxIRQ == Kernel_Config.maxIRQ" + "maxIRQ \ Kernel_Config.maxIRQ" + +(* provide ARM/ARM_HYP machine op in _H global_prefix for arch-split *) +abbreviation (input) initIRQController where + "initIRQController \ ARM_HYP.initIRQController" end end diff --git a/spec/design/skel/ARM_HYP/RegisterSet_H.thy b/spec/design/skel/ARM_HYP/RegisterSet_H.thy index 81ec35c669..5e767490f2 100644 --- a/spec/design/skel/ARM_HYP/RegisterSet_H.thy +++ b/spec/design/skel/ARM_HYP/RegisterSet_H.thy @@ -11,7 +11,7 @@ imports "Lib.HaskellLib_H" MachineOps begin -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) definition newContext :: "user_context" diff --git a/spec/design/skel/ARM_HYP/State_H.thy b/spec/design/skel/ARM_HYP/State_H.thy index f968b26748..e3bcb45a66 100644 --- a/spec/design/skel/ARM_HYP/State_H.thy +++ b/spec/design/skel/ARM_HYP/State_H.thy @@ -16,7 +16,7 @@ imports RegisterSet_H MachineOps begin -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) definition Word :: "machine_word \ machine_word" @@ -28,16 +28,14 @@ where end -context begin interpretation Arch . - -requalify_consts +(* Note: while this requalify and arch-generic Haskell import of WordLib.lhs could be moved to + a generic theory, no good candidate theory exists at the moment. *) +arch_requalify_consts (H) wordBits -end - #INCLUDE_HASKELL Data/WordLib.lhs all_bits NOT wordBits -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Machine/RegisterSet.lhs Arch=ARM_HYP CONTEXT ARM_HYP_H all_bits NOT UserContext UserMonad getRegister setRegister newContext mask Word PPtr diff --git a/spec/design/skel/ARM_HYP/VCPU_H.thy b/spec/design/skel/ARM_HYP/VCPU_H.thy index 05376c7f6c..5ef01a104e 100644 --- a/spec/design/skel/ARM_HYP/VCPU_H.thy +++ b/spec/design/skel/ARM_HYP/VCPU_H.thy @@ -13,7 +13,7 @@ imports Invocations_H TCB_H begin -context Arch begin global_naming ARM_HYP_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL_PREPARSE SEL4/Object/Structures.lhs CONTEXT ARM_HYP_H #INCLUDE_HASKELL SEL4/Object/VCPU/ARM.lhs CONTEXT ARM_HYP_H ArchInv=Arch NOT vcpuUpdate vgicUpdate vgicUpdateLR vcpuSaveReg vcpuRestoreReg vcpuSaveRegRange vcpuRestoreRegRange vcpuWriteReg vcpuReadReg saveVirtTimer restoreVirtTimer vcpuDisable vcpuEnable vcpuRestore vcpuSave vcpuSwitch vcpuInvalidateActive vcpuCleanInvalidateActive countTrailingZeros virqSetEOIIRQEN vgicMaintenance vppiEvent irqVPPIEventIndex armvVCPUSave diff --git a/spec/design/skel/FaultHandler_H.thy b/spec/design/skel/FaultHandler_H.thy index f1e584b794..702a23e1a2 100644 --- a/spec/design/skel/FaultHandler_H.thy +++ b/spec/design/skel/FaultHandler_H.thy @@ -13,15 +13,14 @@ imports ArchFaultHandler_H begin -context begin interpretation Arch . -requalify_consts - syscallMessage - fromVPtr - exceptionMessage - debugPrint +arch_requalify_consts (H) makeArchFaultMessage handleArchFaultReply -end + +(* clobbers previously requalified abstract spec constants with design spec versions *) +arch_requalify_consts (aliasing, H) + syscallMessage + exceptionMessage #INCLUDE_HASKELL_PREPARSE SEL4/API/Failures.lhs diff --git a/spec/design/skel/FaultMonad_H.thy b/spec/design/skel/FaultMonad_H.thy index 1d0a3a716d..dff217eb0f 100644 --- a/spec/design/skel/FaultMonad_H.thy +++ b/spec/design/skel/FaultMonad_H.thy @@ -7,14 +7,11 @@ chapter "The Fault Monad" theory FaultMonad_H -imports KernelStateData_H Fault_H +imports + KernelStateData_H + Fault_H begin -context begin interpretation Arch . -requalify_consts - getActiveIRQ -end - type_synonym ('f, 'a) kernel_f = "('f + 'a) kernel" translations diff --git a/spec/design/skel/Fault_H.thy b/spec/design/skel/Fault_H.thy index 96848f7ffb..654f86d94b 100644 --- a/spec/design/skel/Fault_H.thy +++ b/spec/design/skel/Fault_H.thy @@ -14,11 +14,8 @@ theory Fault_H imports ArchFault_H begin -context begin interpretation Arch . - -requalify_types +arch_requalify_types (H) arch_fault -end #INCLUDE_HASKELL_PREPARSE SEL4/API/Types.lhs #INCLUDE_HASKELL SEL4/API/Failures.lhs decls_only diff --git a/spec/design/skel/Hypervisor_H.thy b/spec/design/skel/Hypervisor_H.thy index ee49f7da94..e5ae0bdede 100644 --- a/spec/design/skel/Hypervisor_H.thy +++ b/spec/design/skel/Hypervisor_H.thy @@ -15,9 +15,7 @@ imports KernelInitMonad_H begin -context begin interpretation Arch . -requalify_consts +arch_requalify_consts (H) handleHypervisorFault -end end diff --git a/spec/design/skel/Intermediate_H.thy b/spec/design/skel/Intermediate_H.thy index eef031bf95..4a3376bda2 100644 --- a/spec/design/skel/Intermediate_H.thy +++ b/spec/design/skel/Intermediate_H.thy @@ -10,11 +10,6 @@ theory Intermediate_H imports "API_H" begin -context begin interpretation Arch . -requalify_consts - clearMemory -end - (* * Intermediate function bodies that were once in the Haskell spec, but are * now no longer. diff --git a/spec/design/skel/Interrupt_H.thy b/spec/design/skel/Interrupt_H.thy index 2e92d6ce31..654cedefdf 100644 --- a/spec/design/skel/Interrupt_H.thy +++ b/spec/design/skel/Interrupt_H.thy @@ -16,35 +16,35 @@ begin context Arch begin +(* match Haskell, expects these under Arch. *) requalify_consts checkIRQ + handleReservedIRQ + maskIrqSignal + +(* disambiguate name clash between Arch and non-arch consts with same names *) +requalify_consts (aliasing) decodeIRQControlInvocation - performIRQControl invokeIRQHandler + performIRQControl initInterruptController - handleReservedIRQ - maskIrqSignal context begin global_naming global -requalify_consts +requalify_consts (aliasing) InterruptDecls_H.decodeIRQControlInvocation + InterruptDecls_H.invokeIRQHandler InterruptDecls_H.performIRQControl -end + InterruptDecls_H.initInterruptController end +end -context begin interpretation Arch . - -requalify_consts - maxIRQ - minIRQ - maskInterrupt - ackInterrupt - resetTimer - debugPrint +arch_requalify_consts deadlineIRQ -end +(* override Kernel_Config const with constrained abbreviation from Hardware_H *) +arch_requalify_consts (aliasing, H) + maxIRQ #INCLUDE_HASKELL_PREPARSE SEL4/Object/Structures.lhs #INCLUDE_HASKELL SEL4/Object/Interrupt.lhs bodies_only diff --git a/spec/design/skel/InvocationLabels_H.thy b/spec/design/skel/InvocationLabels_H.thy index faa65f8248..9fa2794ca9 100644 --- a/spec/design/skel/InvocationLabels_H.thy +++ b/spec/design/skel/InvocationLabels_H.thy @@ -10,11 +10,6 @@ theory InvocationLabels_H imports ArchInvocationLabels_H begin -context begin interpretation Arch . -requalify_types - arch_invocation_label -end - text \ An enumeration of all system call labels. \ diff --git a/spec/design/skel/Invocations_H.thy b/spec/design/skel/Invocations_H.thy index 3227324cbe..8ef06a4248 100644 --- a/spec/design/skel/Invocations_H.thy +++ b/spec/design/skel/Invocations_H.thy @@ -10,6 +10,8 @@ imports ArchRetypeDecls_H ArchLabelFuns_H begin + +(* Haskell expects these with Arch prefix *) requalify_types (in Arch) copy_register_sets irqcontrol_invocation invocation @@ -17,9 +19,10 @@ requalify_types (in Arch) #INCLUDE_HASKELL SEL4/API/Invocation.lhs Arch=Arch NOT GenInvocationLabels InvocationLabel #INCLUDE_HASKELL SEL4/API/InvocationLabels.lhs ONLY invocationType genInvocationType +(* disambiguate name clash between Arch and non-arch consts with same names *) context Arch begin context begin global_naming global -requalify_types +requalify_types (aliasing) Invocations_H.invocation end end diff --git a/spec/design/skel/KernelInit_H.thy b/spec/design/skel/KernelInit_H.thy index f13ea853ea..7bd7ea9622 100644 --- a/spec/design/skel/KernelInit_H.thy +++ b/spec/design/skel/KernelInit_H.thy @@ -15,15 +15,11 @@ imports Thread_H begin -context begin interpretation Arch . - -requalify_consts +arch_requalify_consts getMemoryRegions addrFromPPtr init_machine_state -end - requalify_consts (in Arch) newKernelState @@ -83,11 +79,19 @@ newKernelState_def: ksMachineState = init_machine_state \" +(* disambiguate name clash between Arch and non-arch consts with same names *) context Arch begin -requalify_facts +requalify_facts (aliasing) + newKernelState_def +requalify_consts (aliasing) + newKernelState + +context begin global_naming global +requalify_facts (aliasing) KernelInit_H.newKernelState_def -requalify_consts +requalify_consts (aliasing) KernelInit_H.newKernelState end +end end diff --git a/spec/design/skel/KernelStateData_H.thy b/spec/design/skel/KernelStateData_H.thy index 40179a2dce..7a7b8f656d 100644 --- a/spec/design/skel/KernelStateData_H.thy +++ b/spec/design/skel/KernelStateData_H.thy @@ -19,16 +19,9 @@ imports ArchStateData_H begin -context begin interpretation Arch . - -requalify_types - vmpage_size - -requalify_consts +arch_requalify_consts (H) usToTicks -end - requalify_types (in Arch) kernel_state diff --git a/spec/design/skel/Notification_H.thy b/spec/design/skel/Notification_H.thy index fd700c6706..be5a7f23be 100644 --- a/spec/design/skel/Notification_H.thy +++ b/spec/design/skel/Notification_H.thy @@ -14,11 +14,6 @@ theory Notification_H imports "NotificationDecls_H" ObjectInstances_H begin -context begin interpretation Arch . -requalify_consts - badgeRegister -end - #INCLUDE_HASKELL SEL4/Object/Notification.lhs bodies_only end diff --git a/spec/design/skel/ObjectInstances_H.thy b/spec/design/skel/ObjectInstances_H.thy index 2a6da83924..2083719f09 100644 --- a/spec/design/skel/ObjectInstances_H.thy +++ b/spec/design/skel/ObjectInstances_H.thy @@ -18,11 +18,9 @@ imports Config_H begin -context begin interpretation Arch . -requalify_consts +arch_requalify_consts (H) VPtr newContext -end lemma projectKO_eq: "(projectKO ko s = Some obj) = (projectKO_opt ko = Some obj)" diff --git a/spec/design/skel/PSpaceFuns_H.thy b/spec/design/skel/PSpaceFuns_H.thy index 76f2ca6078..283a796c54 100644 --- a/spec/design/skel/PSpaceFuns_H.thy +++ b/spec/design/skel/PSpaceFuns_H.thy @@ -15,15 +15,7 @@ imports "Lib.DataMap" begin -context begin interpretation Arch . -requalify_consts - fromPPtr - PPtr - freeMemory - storeWord - loadWord -end - +(* Haskell expects this with Arch prefix *) requalify_consts (in Arch) deleteGhost diff --git a/spec/design/skel/PSpaceStorable_H.thy b/spec/design/skel/PSpaceStorable_H.thy index 04032092e3..9d0be682fa 100644 --- a/spec/design/skel/PSpaceStorable_H.thy +++ b/spec/design/skel/PSpaceStorable_H.thy @@ -11,13 +11,11 @@ imports "Lib.DataMap" begin -context begin interpretation Arch . -requalify_types +arch_requalify_types (H) arch_kernel_object_type -requalify_consts +arch_requalify_consts (H) archTypeOf -end lemma UserData_singleton [simp]: "(v = UserData) = True" "(UserData = v) = True" diff --git a/spec/design/skel/RISCV64/ArchFaultHandler_H.thy b/spec/design/skel/RISCV64/ArchFaultHandler_H.thy index 232190374e..ee65a19777 100644 --- a/spec/design/skel/RISCV64/ArchFaultHandler_H.thy +++ b/spec/design/skel/RISCV64/ArchFaultHandler_H.thy @@ -10,7 +10,7 @@ theory ArchFaultHandler_H imports TCB_H Structures_H begin -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL_PREPARSE SEL4/API/Failures/RISCV64.hs diff --git a/spec/design/skel/RISCV64/ArchFault_H.thy b/spec/design/skel/RISCV64/ArchFault_H.thy index 0ec5f0a68c..d8f0744ec9 100644 --- a/spec/design/skel/RISCV64/ArchFault_H.thy +++ b/spec/design/skel/RISCV64/ArchFault_H.thy @@ -12,7 +12,7 @@ theory ArchFault_H imports Types_H begin -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/API/Failures/RISCV64.hs CONTEXT RISCV64_H decls_only #INCLUDE_HASKELL SEL4/API/Failures/RISCV64.hs CONTEXT RISCV64_H bodies_only diff --git a/spec/design/skel/RISCV64/ArchHypervisor_H.thy b/spec/design/skel/RISCV64/ArchHypervisor_H.thy index ab1c104c90..706c05d99d 100644 --- a/spec/design/skel/RISCV64/ArchHypervisor_H.thy +++ b/spec/design/skel/RISCV64/ArchHypervisor_H.thy @@ -14,7 +14,7 @@ imports KI_Decls_H InterruptDecls_H begin -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Kernel/Hypervisor/RISCV64.hs Arch= CONTEXT RISCV64_H decls_only ArchInv= ArchLabels= diff --git a/spec/design/skel/RISCV64/ArchInterruptDecls_H.thy b/spec/design/skel/RISCV64/ArchInterruptDecls_H.thy index 35a89aaa41..b6c05814a9 100644 --- a/spec/design/skel/RISCV64/ArchInterruptDecls_H.thy +++ b/spec/design/skel/RISCV64/ArchInterruptDecls_H.thy @@ -8,7 +8,7 @@ theory ArchInterruptDecls_H imports RetypeDecls_H CNode_H begin -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Object/Interrupt/RISCV64.hs CONTEXT RISCV64_H decls_only ArchInv= Arch=MachineOps NOT plic_complete_claim diff --git a/spec/design/skel/RISCV64/ArchInterrupt_H.thy b/spec/design/skel/RISCV64/ArchInterrupt_H.thy index 8a4d5e56ce..ff6d6af837 100644 --- a/spec/design/skel/RISCV64/ArchInterrupt_H.thy +++ b/spec/design/skel/RISCV64/ArchInterrupt_H.thy @@ -13,7 +13,7 @@ imports ArchHypervisor_H begin -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Object/Interrupt/RISCV64.hs CONTEXT RISCV64_H bodies_only ArchInv= Arch= NOT plic_complete_claim diff --git a/spec/design/skel/RISCV64/ArchInvocationLabels_H.thy b/spec/design/skel/RISCV64/ArchInvocationLabels_H.thy index bae9fc2b09..f3a4ea8988 100644 --- a/spec/design/skel/RISCV64/ArchInvocationLabels_H.thy +++ b/spec/design/skel/RISCV64/ArchInvocationLabels_H.thy @@ -11,7 +11,7 @@ imports "Word_Lib.Enumeration" Setup_Locale begin -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) text \ An enumeration of arch-specific system call labels. @@ -21,11 +21,12 @@ text \ end -context begin interpretation Arch . -requalify_types arch_invocation_label -end +(* not possible to move this requalification to generic, since enum instance proofs must + be done outside of Arch locale *) +arch_requalify_types (H) + arch_invocation_label -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/API/InvocationLabels/RISCV64.hs CONTEXT RISCV64_H instanceproofs ONLY ArchInvocationLabel diff --git a/spec/design/skel/RISCV64/ArchPSpace_H.thy b/spec/design/skel/RISCV64/ArchPSpace_H.thy index d692e99c12..9c09086726 100644 --- a/spec/design/skel/RISCV64/ArchPSpace_H.thy +++ b/spec/design/skel/RISCV64/ArchPSpace_H.thy @@ -11,7 +11,7 @@ imports ObjectInstances_H begin -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Model/PSpace/RISCV64.hs diff --git a/spec/design/skel/RISCV64/ArchRetypeDecls_H.thy b/spec/design/skel/RISCV64/ArchRetypeDecls_H.thy index d6231de32c..bf3b66bd85 100644 --- a/spec/design/skel/RISCV64/ArchRetypeDecls_H.thy +++ b/spec/design/skel/RISCV64/ArchRetypeDecls_H.thy @@ -15,7 +15,7 @@ imports ArchObjInsts_H begin -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL_PREPARSE SEL4/Object/Structures/RISCV64.hs diff --git a/spec/design/skel/RISCV64/ArchRetype_H.thy b/spec/design/skel/RISCV64/ArchRetype_H.thy index ff26de9ce2..0cdc635027 100644 --- a/spec/design/skel/RISCV64/ArchRetype_H.thy +++ b/spec/design/skel/RISCV64/ArchRetype_H.thy @@ -14,7 +14,7 @@ imports KI_Decls_H begin -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Object/ObjectType/RISCV64.hs CONTEXT RISCV64_H Arch.Types=ArchTypes_H ArchInv=ArchRetypeDecls_H NOT bodies_only #INCLUDE_HASKELL SEL4/API/Invocation/RISCV64.hs CONTEXT RISCV64_H bodies_only diff --git a/spec/design/skel/RISCV64/ArchStateData_H.thy b/spec/design/skel/RISCV64/ArchStateData_H.thy index f6dd515b1b..0f33fe9b2f 100644 --- a/spec/design/skel/RISCV64/ArchStateData_H.thy +++ b/spec/design/skel/RISCV64/ArchStateData_H.thy @@ -17,7 +17,7 @@ imports ArchStructures_H begin -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Model/StateData/RISCV64.hs CONTEXT RISCV64_H NOT RISCVVSpaceRegionUse diff --git a/spec/design/skel/RISCV64/ArchStructures_H.thy b/spec/design/skel/RISCV64/ArchStructures_H.thy index 002c9174e2..b3ba3b4cde 100644 --- a/spec/design/skel/RISCV64/ArchStructures_H.thy +++ b/spec/design/skel/RISCV64/ArchStructures_H.thy @@ -11,7 +11,7 @@ imports Hardware_H begin -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) #INCLUDE_SETTINGS keep_constructor=asidpool #INCLUDE_SETTINGS keep_constructor=arch_tcb diff --git a/spec/design/skel/RISCV64/ArchTCB_H.thy b/spec/design/skel/RISCV64/ArchTCB_H.thy index a32c257809..ae5edaa16d 100644 --- a/spec/design/skel/RISCV64/ArchTCB_H.thy +++ b/spec/design/skel/RISCV64/ArchTCB_H.thy @@ -8,7 +8,7 @@ theory ArchTCB_H imports TCBDecls_H begin -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Object/TCB/RISCV64.hs RegisterSet= CONTEXT RISCV64_H diff --git a/spec/design/skel/RISCV64/ArchThreadDecls_H.thy b/spec/design/skel/RISCV64/ArchThreadDecls_H.thy index dfc27dde01..ce0037d709 100644 --- a/spec/design/skel/RISCV64/ArchThreadDecls_H.thy +++ b/spec/design/skel/RISCV64/ArchThreadDecls_H.thy @@ -17,7 +17,7 @@ imports KernelInitMonad_H begin -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Kernel/Thread/RISCV64.hs CONTEXT RISCV64_H decls_only diff --git a/spec/design/skel/RISCV64/ArchThread_H.thy b/spec/design/skel/RISCV64/ArchThread_H.thy index 073b2ddd5f..f861bb4504 100644 --- a/spec/design/skel/RISCV64/ArchThread_H.thy +++ b/spec/design/skel/RISCV64/ArchThread_H.thy @@ -13,7 +13,7 @@ imports ArchVSpaceDecls_H begin -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Kernel/Thread/RISCV64.hs CONTEXT RISCV64_H Arch=MachineOps ArchReg=MachineTypes bodies_only diff --git a/spec/design/skel/RISCV64/ArchTypes_H.thy b/spec/design/skel/RISCV64/ArchTypes_H.thy index 62054f07a0..1618981af0 100644 --- a/spec/design/skel/RISCV64/ArchTypes_H.thy +++ b/spec/design/skel/RISCV64/ArchTypes_H.thy @@ -19,7 +19,7 @@ begin #INCLUDE_HASKELL SEL4/API/Types/Universal.lhs all_bits -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/API/Types/RISCV64.hs CONTEXT RISCV64_H @@ -72,8 +72,4 @@ interpretation Arch . instance by (intro_classes, simp add: enum_alt_object_type) end -context begin interpretation Arch . -requalify_types object_type -end - end diff --git a/spec/design/skel/RISCV64/ArchVSpaceDecls_H.thy b/spec/design/skel/RISCV64/ArchVSpaceDecls_H.thy index b75eb06b18..62c650a4a4 100644 --- a/spec/design/skel/RISCV64/ArchVSpaceDecls_H.thy +++ b/spec/design/skel/RISCV64/ArchVSpaceDecls_H.thy @@ -10,7 +10,7 @@ theory ArchVSpaceDecls_H imports ArchRetypeDecls_H InvocationLabels_H begin -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL_PREPARSE SEL4/Object/Structures.lhs CONTEXT RISCV64_H #INCLUDE_HASKELL_PREPARSE SEL4/API/InvocationLabels/RISCV64.hs CONTEXT RISCV64 diff --git a/spec/design/skel/RISCV64/ArchVSpace_H.thy b/spec/design/skel/RISCV64/ArchVSpace_H.thy index 5baf29d517..a2b24b39ac 100644 --- a/spec/design/skel/RISCV64/ArchVSpace_H.thy +++ b/spec/design/skel/RISCV64/ArchVSpace_H.thy @@ -16,7 +16,7 @@ imports ArchVSpaceDecls_H begin -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Kernel/VSpace/RISCV64.hs CONTEXT RISCV64_H bodies_only ArchInv=ArchRetypeDecls_H ONLY pteAtIndex getPPtrFromHWPTE isPageTablePTE ptBitsLeft diff --git a/spec/design/skel/RISCV64/Arch_Structs_B.thy b/spec/design/skel/RISCV64/Arch_Structs_B.thy index d1ea2108ba..5ced589393 100644 --- a/spec/design/skel/RISCV64/Arch_Structs_B.thy +++ b/spec/design/skel/RISCV64/Arch_Structs_B.thy @@ -12,7 +12,7 @@ theory Arch_Structs_B imports Setup_Locale begin -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Model/StateData/RISCV64.hs CONTEXT RISCV64_H ONLY RISCVVSpaceRegionUse diff --git a/spec/design/skel/RISCV64/Hardware_H.thy b/spec/design/skel/RISCV64/Hardware_H.thy index c4af3e77d1..6023691c4d 100644 --- a/spec/design/skel/RISCV64/Hardware_H.thy +++ b/spec/design/skel/RISCV64/Hardware_H.thy @@ -10,7 +10,7 @@ imports State_H begin -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) definition usToTicks :: "word64 \ word64" where "usToTicks \ us_to_ticks" @@ -37,16 +37,20 @@ definition maxPeriodUs :: "word64" where end -context begin interpretation Arch . -requalify_types vmrights -end +arch_requalify_types (H) + vmrights -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Machine/Hardware/RISCV64.hs CONTEXT RISCV64_H instanceproofs NOT plic_complete_claim HardwareASID VMFaultType VMPageSize VMPageEntry HypFaultType #INCLUDE_HASKELL SEL4/Machine/Hardware/RISCV64.hs CONTEXT RISCV64_H ONLY wordFromPTE +(* Unlike on Arm architectures, maxIRQ comes from Platform definitions. + We provide this abbreviation to match arch-split expectations. *) +abbreviation (input) maxIRQ :: irq where + "maxIRQ \ Platform.RISCV64.maxIRQ" + end (* context RISCV64 *) end diff --git a/spec/design/skel/RISCV64/RegisterSet_H.thy b/spec/design/skel/RISCV64/RegisterSet_H.thy index 5d3a530422..5e767490f2 100644 --- a/spec/design/skel/RISCV64/RegisterSet_H.thy +++ b/spec/design/skel/RISCV64/RegisterSet_H.thy @@ -11,7 +11,7 @@ imports "Lib.HaskellLib_H" MachineOps begin -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) definition newContext :: "user_context" diff --git a/spec/design/skel/RISCV64/State_H.thy b/spec/design/skel/RISCV64/State_H.thy index 76c01dd88e..1537716f91 100644 --- a/spec/design/skel/RISCV64/State_H.thy +++ b/spec/design/skel/RISCV64/State_H.thy @@ -14,7 +14,7 @@ theory State_H imports RegisterSet_H begin -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) definition Word :: "machine_word \ machine_word" @@ -26,16 +26,14 @@ where end -context begin interpretation Arch . - -requalify_consts +(* Note: while this requalify and arch-generic Haskell import of WordLib.lhs could be moved to + a generic theory, no good candidate theory exists at the moment. *) +arch_requalify_consts (H) wordBits -end - #INCLUDE_HASKELL Data/WordLib.lhs all_bits NOT wordBits -context Arch begin global_naming RISCV64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Machine/RegisterSet.lhs Arch=RISCV64 CONTEXT RISCV64_H all_bits NOT UserContext UserMonad getRegister setRegister newContext mask Word PPtr diff --git a/spec/design/skel/Retype_H.thy b/spec/design/skel/Retype_H.thy index c7dd3df95a..6d325434e8 100644 --- a/spec/design/skel/Retype_H.thy +++ b/spec/design/skel/Retype_H.thy @@ -15,22 +15,28 @@ imports begin context Arch begin + +(* match Haskell, expects these under Arch. *) requalify_consts + cteRightsBits cteGuardBits + +(* disambiguate name clash between Arch and non-arch consts with same names *) +requalify_consts (aliasing) deriveCap finaliseCap postCapDeletion isCapRevocable hasCancelSendRights sameRegionAs isPhysicalCap sameObjectAs updateCapData maskCapRights createObject capUntypedPtr capUntypedSize performInvocation decodeInvocation prepareThreadDelete - cteRightsBits cteGuardBits context begin global_naming global -requalify_consts +requalify_consts (aliasing) RetypeDecls_H.deriveCap RetypeDecls_H.finaliseCap RetypeDecls_H.postCapDeletion + RetypeDecls_H.isCapRevocable RetypeDecls_H.hasCancelSendRights RetypeDecls_H.sameRegionAs RetypeDecls_H.isPhysicalCap RetypeDecls_H.sameObjectAs RetypeDecls_H.updateCapData RetypeDecls_H.maskCapRights RetypeDecls_H.createObject RetypeDecls_H.capUntypedPtr RetypeDecls_H.capUntypedSize - RetypeDecls_H.performInvocation RetypeDecls_H.decodeInvocation RetypeDecls_H.isCapRevocable + RetypeDecls_H.performInvocation RetypeDecls_H.decodeInvocation end end diff --git a/spec/design/skel/SchedContext_H.thy b/spec/design/skel/SchedContext_H.thy index 359b360d60..c1ece838a6 100644 --- a/spec/design/skel/SchedContext_H.thy +++ b/spec/design/skel/SchedContext_H.thy @@ -24,7 +24,6 @@ requalify_consts kernelWCETUs ticksToUs maxTicksToUs - getCurrentTime maxPeriodUs end diff --git a/spec/design/skel/Structures_H.thy b/spec/design/skel/Structures_H.thy index a30fbd50f1..a4fa49e645 100644 --- a/spec/design/skel/Structures_H.thy +++ b/spec/design/skel/Structures_H.thy @@ -19,19 +19,14 @@ imports ArchStructures_H begin -context begin interpretation Arch . - -requalify_types - irq +arch_requalify_types (H) arch_capability - user_context arch_kernel_object asid arch_tcb -requalify_consts +arch_requalify_consts (H) archObjSize - pageBits nullPointer newArchTCB fromPPtr @@ -39,13 +34,10 @@ requalify_consts atcbContextGet atcbContextSet -end - #INCLUDE_HASKELL SEL4/Object/Structures.lhs decls_only NOT isNullCap isUntypedCap isIRQControlCap isReplyCap isDomainCap isNotificationCap isThreadCap isSchedContextCap objBitsKO #INCLUDE_HASKELL SEL4/Object/Structures.lhs bodies_only NOT kernelObjectTypeName isNullCap isUntypedCap isIRQControlCap isReplyCap isDomainCap isNotificationCap isThreadCap isSchedContextCap objBitsKO #INCLUDE_HASKELL SEL4/Object/Structures.lhs decls_only ONLY objBitsKO #INCLUDE_HASKELL SEL4/Object/Structures.lhs bodies_only ONLY objBitsKO - end diff --git a/spec/design/skel/TCBDecls_H.thy b/spec/design/skel/TCBDecls_H.thy index a0caf29aca..71d19cf5ee 100644 --- a/spec/design/skel/TCBDecls_H.thy +++ b/spec/design/skel/TCBDecls_H.thy @@ -10,11 +10,7 @@ theory TCBDecls_H imports FaultMonad_H Invocations_H begin -context begin interpretation Arch . -requalify_types - user_monad -end - -#INCLUDE_HASKELL SEL4/Object/TCB.lhs decls_only NOT archThreadGet archThreadSet takeWhileM sort_key tcbEPFindIndex +#INCLUDE_HASKELL SEL4/Object/TCB.lhs decls_only \ + NOT archThreadGet archThreadSet sanitiseRegister getSanitiseRegisterInfo takeWhileM sort_key tcbEPFindIndex end diff --git a/spec/design/skel/TCB_H.thy b/spec/design/skel/TCB_H.thy index 6cf39e4de6..f72713f3de 100644 --- a/spec/design/skel/TCB_H.thy +++ b/spec/design/skel/TCB_H.thy @@ -17,27 +17,24 @@ imports ArchTCB_H begin -context begin interpretation Arch . -requalify_consts +arch_requalify_consts (H) decodeTransfer - gpRegisters - frameRegisters - badgeRegister - getRegister - setNextPC - getRestartPC - sanitiseRegister - getSanitiseRegisterInfo - setRegister performTransfer msgInfoRegister msgRegisters fromVPtr postModifyRegisters + sanitiseRegister + getSanitiseRegisterInfo + +(* clobbers previously requalified abstract spec constants with design spec versions *) +arch_requalify_consts (aliasing, H) + gpRegisters + frameRegisters + badgeRegister tlsBaseRegister maxUsToTicks timerIRQ -end abbreviation "mapMaybe \ option_map" diff --git a/spec/design/skel/Thread_H.thy b/spec/design/skel/Thread_H.thy index 73cf00da40..7464c3c6aa 100644 --- a/spec/design/skel/Thread_H.thy +++ b/spec/design/skel/Thread_H.thy @@ -15,32 +15,31 @@ imports Config_H begin +arch_requalify_consts (H) + capRegister + faultRegister + nextInstructionRegister + context Arch begin +(* match Haskell, expects these under Arch. *) requalify_consts activateIdleThread + +(* disambiguate name clash between Arch and non-arch consts with same names *) +requalify_consts (aliasing) configureIdleThread switchToIdleThread switchToThread context begin global_naming global -requalify_consts +requalify_consts (aliasing) ThreadDecls_H.configureIdleThread ThreadDecls_H.switchToIdleThread ThreadDecls_H.switchToThread end - -end - -context begin interpretation Arch . - -requalify_consts - capRegister - faultRegister - nextInstructionRegister - end #INCLUDE_HASKELL SEL4/Kernel/Thread.lhs Arch=Arch bodies_only NOT doNormalTransfer doIPCTransfer doReplyTransfer doNormalTransfer transferCaps transferCapsToSlots diff --git a/spec/design/skel/Types_H.thy b/spec/design/skel/Types_H.thy index c94e93efc6..4b6e895fd3 100644 --- a/spec/design/skel/Types_H.thy +++ b/spec/design/skel/Types_H.thy @@ -12,28 +12,25 @@ chapter "Types visible in the API" theory Types_H imports + MachineExports ArchTypes_H begin -context begin interpretation Arch . -requalify_types +arch_requalify_types (H) object_type - machine_word paddr vptr -requalify_consts +arch_requalify_consts (H) getObjectSize fromAPIType toAPIType isFrameType pageType - ptrFromPAddr tcbBlockSizeBits -requalify_facts +arch_requalify_facts (H) tcbBlockSizeBits_def -end #INCLUDE_HASKELL SEL4/API/Types.lhs all_bits NOT wordsFromBootInfo messageInfoFromWord wordFromMessageInfo ObjectType getObjectSize fromAPIType toAPIType isFrameType pageType #INCLUDE_HASKELL SEL4/API/Types.lhs all_bits ONLY wordsFromBootInfo messageInfoFromWord wordFromMessageInfo diff --git a/spec/design/skel/Untyped_H.thy b/spec/design/skel/Untyped_H.thy index ee629301bd..9077d857f9 100644 --- a/spec/design/skel/Untyped_H.thy +++ b/spec/design/skel/Untyped_H.thy @@ -14,17 +14,12 @@ imports Invocations_H InvocationLabels_H Config_H - MachineExports begin -context begin interpretation Arch . - -requalify_consts +arch_requalify_consts (H) minUntypedSizeBits maxUntypedSizeBits -end - consts cNodeOverlap :: "(machine_word \ nat option) \ (machine_word \ bool) \ bool" diff --git a/spec/design/skel/VSpace_H.thy b/spec/design/skel/VSpace_H.thy index 9228b087da..59fed6bb01 100644 --- a/spec/design/skel/VSpace_H.thy +++ b/spec/design/skel/VSpace_H.thy @@ -15,14 +15,10 @@ imports KernelInitMonad_H begin -context begin interpretation Arch . -requalify_consts +arch_requalify_consts (H) mapKernelWindow activateGlobalVSpace - initL2Cache initIRQController - configureTimer - createIPCBufferFrame createBIFrame createFramesOfRegion @@ -36,7 +32,6 @@ requalify_consts checkValidIPCBuffer lookupIPCBuffer vptrFromPPtr -end #INCLUDE_HASKELL SEL4/Kernel/VSpace.lhs Arch= ONLY initKernelVM initPlatform initCPU diff --git a/spec/design/skel/X64/ArchFaultHandler_H.thy b/spec/design/skel/X64/ArchFaultHandler_H.thy index f14a1ae5e8..32113213dd 100644 --- a/spec/design/skel/X64/ArchFaultHandler_H.thy +++ b/spec/design/skel/X64/ArchFaultHandler_H.thy @@ -10,7 +10,7 @@ theory ArchFaultHandler_H imports TCB_H Structures_H begin -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL_PREPARSE SEL4/API/Failures/X64.lhs diff --git a/spec/design/skel/X64/ArchFault_H.thy b/spec/design/skel/X64/ArchFault_H.thy index b5337200f2..f8e6dab5e6 100644 --- a/spec/design/skel/X64/ArchFault_H.thy +++ b/spec/design/skel/X64/ArchFault_H.thy @@ -12,7 +12,7 @@ theory ArchFault_H imports Types_H begin -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/API/Failures/X64.lhs CONTEXT X64_H decls_only #INCLUDE_HASKELL SEL4/API/Failures/X64.lhs CONTEXT X64_H bodies_only diff --git a/spec/design/skel/X64/ArchHook_H.thy b/spec/design/skel/X64/ArchHook_H.thy index 0f41142fc0..ba24d6a53f 100644 --- a/spec/design/skel/X64/ArchHook_H.thy +++ b/spec/design/skel/X64/ArchHook_H.thy @@ -10,7 +10,7 @@ theory ArchHook_H imports KernelStateData_H begin -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) definition cEntryHook :: "unit kernel" diff --git a/spec/design/skel/X64/ArchHypervisor_H.thy b/spec/design/skel/X64/ArchHypervisor_H.thy index 380ea00881..16190aacd0 100644 --- a/spec/design/skel/X64/ArchHypervisor_H.thy +++ b/spec/design/skel/X64/ArchHypervisor_H.thy @@ -15,7 +15,7 @@ imports InterruptDecls_H begin -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Kernel/Hypervisor/X64.lhs Arch= CONTEXT X64_H decls_only ArchInv= ArchLabels= #INCLUDE_HASKELL SEL4/Kernel/Hypervisor/X64.lhs Arch= CONTEXT X64_H bodies_only ArchInv= ArchLabels= diff --git a/spec/design/skel/X64/ArchInterruptDecls_H.thy b/spec/design/skel/X64/ArchInterruptDecls_H.thy index c34fbd11af..5a9f01f7b6 100644 --- a/spec/design/skel/X64/ArchInterruptDecls_H.thy +++ b/spec/design/skel/X64/ArchInterruptDecls_H.thy @@ -8,7 +8,7 @@ theory ArchInterruptDecls_H imports RetypeDecls_H CNode_H begin -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Object/Interrupt/X64.lhs CONTEXT X64_H decls_only ArchInv= Arch=MachineOps diff --git a/spec/design/skel/X64/ArchInterrupt_H.thy b/spec/design/skel/X64/ArchInterrupt_H.thy index 06d44aa8c0..dd3a2b3095 100644 --- a/spec/design/skel/X64/ArchInterrupt_H.thy +++ b/spec/design/skel/X64/ArchInterrupt_H.thy @@ -13,7 +13,7 @@ imports ArchHypervisor_H begin -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Object/Interrupt/X64.lhs CONTEXT X64_H bodies_only ArchInv= Arch= diff --git a/spec/design/skel/X64/ArchInvocationLabels_H.thy b/spec/design/skel/X64/ArchInvocationLabels_H.thy index c967f7f16e..b0194706d6 100644 --- a/spec/design/skel/X64/ArchInvocationLabels_H.thy +++ b/spec/design/skel/X64/ArchInvocationLabels_H.thy @@ -11,7 +11,7 @@ imports "Word_Lib.Enumeration" Setup_Locale begin -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) text \ An enumeration of arch-specific system call labels. @@ -21,11 +21,12 @@ text \ end -context begin interpretation Arch . -requalify_types arch_invocation_label -end +(* not possible to move this requalification to generic, since enum instance proofs must + be done outside of Arch locale *) +arch_requalify_types (H) + arch_invocation_label -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/API/InvocationLabels/X64.lhs CONTEXT X64_H instanceproofs ONLY ArchInvocationLabel diff --git a/spec/design/skel/X64/ArchPSpace_H.thy b/spec/design/skel/X64/ArchPSpace_H.thy index 0c9b7e8c3e..054ce2e73b 100644 --- a/spec/design/skel/X64/ArchPSpace_H.thy +++ b/spec/design/skel/X64/ArchPSpace_H.thy @@ -11,7 +11,7 @@ imports ObjectInstances_H begin -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Model/PSpace/X64.hs diff --git a/spec/design/skel/X64/ArchRetypeDecls_H.thy b/spec/design/skel/X64/ArchRetypeDecls_H.thy index c7c2f0b36a..9ba6c12f5a 100644 --- a/spec/design/skel/X64/ArchRetypeDecls_H.thy +++ b/spec/design/skel/X64/ArchRetypeDecls_H.thy @@ -15,7 +15,7 @@ imports ArchObjInsts_H begin -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/API/Invocation/X64.lhs CONTEXT X64_H decls_only NOT Invocation IRQControlInvocation diff --git a/spec/design/skel/X64/ArchRetype_H.thy b/spec/design/skel/X64/ArchRetype_H.thy index 57e6933c35..87a0bbeca9 100644 --- a/spec/design/skel/X64/ArchRetype_H.thy +++ b/spec/design/skel/X64/ArchRetype_H.thy @@ -14,7 +14,7 @@ imports KI_Decls_H begin -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Object/ObjectType/X64.lhs CONTEXT X64_H Arch.Types=ArchTypes_H ArchInv=ArchRetypeDecls_H NOT bodies_only #INCLUDE_HASKELL SEL4/API/Invocation/X64.lhs CONTEXT X64_H bodies_only diff --git a/spec/design/skel/X64/ArchStateData_H.thy b/spec/design/skel/X64/ArchStateData_H.thy index ebd986b24a..b849797ad9 100644 --- a/spec/design/skel/X64/ArchStateData_H.thy +++ b/spec/design/skel/X64/ArchStateData_H.thy @@ -17,7 +17,7 @@ imports ArchStructures_H begin -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Model/StateData/X64.lhs CONTEXT X64_H NOT X64VSpaceRegionUse diff --git a/spec/design/skel/X64/ArchStructures_H.thy b/spec/design/skel/X64/ArchStructures_H.thy index 3d754c9233..903429c1eb 100644 --- a/spec/design/skel/X64/ArchStructures_H.thy +++ b/spec/design/skel/X64/ArchStructures_H.thy @@ -11,7 +11,7 @@ imports Hardware_H begin -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) #INCLUDE_SETTINGS keep_constructor=asidpool #INCLUDE_SETTINGS keep_constructor=arch_tcb diff --git a/spec/design/skel/X64/ArchTCB_H.thy b/spec/design/skel/X64/ArchTCB_H.thy index 9027eec60f..c67b323a3e 100644 --- a/spec/design/skel/X64/ArchTCB_H.thy +++ b/spec/design/skel/X64/ArchTCB_H.thy @@ -8,7 +8,7 @@ theory ArchTCB_H imports TCBDecls_H begin -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Object/TCB/X64.lhs RegisterSet= CONTEXT X64_H diff --git a/spec/design/skel/X64/ArchThreadDecls_H.thy b/spec/design/skel/X64/ArchThreadDecls_H.thy index 9d9bdccfa2..74d343c0c9 100644 --- a/spec/design/skel/X64/ArchThreadDecls_H.thy +++ b/spec/design/skel/X64/ArchThreadDecls_H.thy @@ -17,7 +17,7 @@ imports KernelInitMonad_H begin -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Kernel/Thread/X64.lhs CONTEXT X64_H decls_only diff --git a/spec/design/skel/X64/ArchThread_H.thy b/spec/design/skel/X64/ArchThread_H.thy index 02719eca25..abb68b88e8 100644 --- a/spec/design/skel/X64/ArchThread_H.thy +++ b/spec/design/skel/X64/ArchThread_H.thy @@ -14,7 +14,7 @@ imports begin -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Kernel/Thread/X64.lhs CONTEXT X64_H Arch=MachineOps ArchReg=MachineTypes bodies_only diff --git a/spec/design/skel/X64/ArchTypes_H.thy b/spec/design/skel/X64/ArchTypes_H.thy index 93940fa8a7..593dde7f98 100644 --- a/spec/design/skel/X64/ArchTypes_H.thy +++ b/spec/design/skel/X64/ArchTypes_H.thy @@ -19,7 +19,7 @@ begin #INCLUDE_HASKELL SEL4/API/Types/Universal.lhs all_bits -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/API/Types/X64.lhs CONTEXT X64_H @@ -75,8 +75,4 @@ interpretation Arch . instance by (intro_classes, simp add: enum_alt_object_type) end -context begin interpretation Arch . -requalify_types object_type -end - end diff --git a/spec/design/skel/X64/ArchVSpaceDecls_H.thy b/spec/design/skel/X64/ArchVSpaceDecls_H.thy index a7ce162adf..583b4b69bc 100644 --- a/spec/design/skel/X64/ArchVSpaceDecls_H.thy +++ b/spec/design/skel/X64/ArchVSpaceDecls_H.thy @@ -10,7 +10,7 @@ theory ArchVSpaceDecls_H imports ArchRetypeDecls_H InvocationLabels_H begin -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL_PREPARSE SEL4/Object/Structures.lhs CONTEXT X64_H #INCLUDE_HASKELL_PREPARSE SEL4/API/InvocationLabels/X64.lhs CONTEXT X64 diff --git a/spec/design/skel/X64/ArchVSpace_H.thy b/spec/design/skel/X64/ArchVSpace_H.thy index b754ef75ed..88bf5f015f 100644 --- a/spec/design/skel/X64/ArchVSpace_H.thy +++ b/spec/design/skel/X64/ArchVSpace_H.thy @@ -16,7 +16,7 @@ imports ArchVSpaceDecls_H begin -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Kernel/VSpace/X64.lhs CONTEXT X64_H bodies_only ArchInv=ArchRetypeDecls_H NOT checkPML4At checkPDPTAt checkPDAt checkPTAt checkValidMappingSize #INCLUDE_HASKELL SEL4/Object/IOPort/X64.lhs CONTEXT X64_H bodies_only ArchInv=ArchRetypeDecls_H diff --git a/spec/design/skel/X64/Arch_Structs_B.thy b/spec/design/skel/X64/Arch_Structs_B.thy index 8c368218b8..3a3aafffa6 100644 --- a/spec/design/skel/X64/Arch_Structs_B.thy +++ b/spec/design/skel/X64/Arch_Structs_B.thy @@ -12,7 +12,7 @@ theory Arch_Structs_B imports Main Setup_Locale begin -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Model/StateData/X64.lhs CONTEXT X64_H ONLY X64VSpaceRegionUse diff --git a/spec/design/skel/X64/Hardware_H.thy b/spec/design/skel/X64/Hardware_H.thy index 213cb40783..085eabdc3e 100644 --- a/spec/design/skel/X64/Hardware_H.thy +++ b/spec/design/skel/X64/Hardware_H.thy @@ -10,22 +10,26 @@ imports State_H begin -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Machine/Hardware/X64.lhs Platform=Platform.X64 CONTEXT X64_H NOT getMemoryRegions getDeviceRegions getKernelDevices loadWord storeWord storeWordVM getActiveIRQ ackInterrupt maskInterrupt configureTimer resetTimer debugPrint getRestartPC setNextPC clearMemory clearMemoryVM initMemory freeMemory wordFromPDE wordFromPTE VMFaultType HypFaultType VMMapType VMPageSize pageBits pageBitsForSize paddrBase pptrBase pptrTop pptrBaseOffset kernelELFBaseOffset kernelELFPAddrBase kernelELFBase toPAddr addrFromPPtr ptrFromPAddr addrFromKPPtr setCurrentUserCR3 getCurrentUserCR3 invalidateTLB invalidateTLBEntry mfence wordFromPML4E wordFromPDPTE firstValidIODomain numIODomainIDBits hwASIDInvalidate getFaultAddress irqIntOffset maxPCIBus maxPCIDev maxPCIFunc ioapicIRQLines ioapicMapPinToVector irqStateIRQIOAPICNew irqStateIRQMSINew updateIRQState in8 out8 in16 out16 in32 out32 invalidatePageStructureCache writeCR3 invalidateASID invalidateTranslationSingleASID invalidateLocalPageStructureCacheASID ptTranslationBits nativeThreadUsingFPU switchFpuOwner end -context begin interpretation Arch . -requalify_types vmrights -end +arch_requalify_types (H) + vmrights -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Machine/Hardware/X64.lhs CONTEXT X64_H instanceproofs NOT VMFaultType VMPageSize VMPageEntry VMMapType HypFaultType #INCLUDE_HASKELL SEL4/Machine/Hardware/X64.lhs CONTEXT X64_H ONLY wordFromPDE wordFromPTE wordFromPML4E wordFromPDPTE +(* Unlike on Arm architectures, maxIRQ comes from Platform definitions. + We provide this abbreviation to match arch-split expectations. *) +abbreviation (input) maxIRQ :: irq where + "maxIRQ \ Platform.X64.maxIRQ" + end (* context X64 *) end diff --git a/spec/design/skel/X64/RegisterSet_H.thy b/spec/design/skel/X64/RegisterSet_H.thy index eac65549f2..9f6ae70d61 100644 --- a/spec/design/skel/X64/RegisterSet_H.thy +++ b/spec/design/skel/X64/RegisterSet_H.thy @@ -11,7 +11,7 @@ imports "Lib.HaskellLib_H" MachineOps begin -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) definition newContext :: "user_context" diff --git a/spec/design/skel/X64/State_H.thy b/spec/design/skel/X64/State_H.thy index 87502594c5..8a4289e321 100644 --- a/spec/design/skel/X64/State_H.thy +++ b/spec/design/skel/X64/State_H.thy @@ -14,7 +14,7 @@ theory State_H imports RegisterSet_H begin -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) definition Word :: "machine_word \ machine_word" @@ -26,16 +26,14 @@ where end -context begin interpretation Arch . - -requalify_consts +(* Note: while this requalify and arch-generic Haskell import of WordLib.lhs could be moved to + a generic theory, no good candidate theory exists at the moment. *) +arch_requalify_consts (H) wordBits -end - #INCLUDE_HASKELL Data/WordLib.lhs all_bits NOT wordBits -context Arch begin global_naming X64_H +context Arch begin arch_global_naming (H) #INCLUDE_HASKELL SEL4/Machine/RegisterSet.lhs Arch=X64 CONTEXT X64_H all_bits NOT UserContext UserMonad getRegister setRegister newContext mask Word PPtr diff --git a/spec/haskell/src/SEL4/Machine/Hardware/AARCH64.hs b/spec/haskell/src/SEL4/Machine/Hardware/AARCH64.hs index 2e452b472b..887cd90aa7 100644 --- a/spec/haskell/src/SEL4/Machine/Hardware/AARCH64.hs +++ b/spec/haskell/src/SEL4/Machine/Hardware/AARCH64.hs @@ -442,7 +442,21 @@ check_export_arch_timer = error "Unimplemented - machine op" {- Constants -} -hcrVCPU = (0x80086039 :: Word) -- HCR_VCPU +hcrCommon :: Word +-- HCR_VM | HCR_RW | HCR_AMO | HCR_IMO | HCR_FMO | HCR_TSC +hcrCommon = bit 0 .|. bit 31 .|. bit 5 .|. bit 4 .|. bit 3 .|. bit 19 + +hcrTWE :: Word +hcrTWE = bit 14 + +hcrTWI :: Word +hcrTWI = bit 13 + +hcrVCPU :: Word -- HCR_VCPU +hcrVCPU = if config_DISABLE_WFI_WFE_TRAPS + then hcrCommon + else hcrCommon .|. hcrTWE .|. hcrTWI + hcrNative = (0x8E28103B :: Word) -- HCR_NATIVE sctlrEL1VM = (0x34d58820 :: Word) -- SCTLR_EL1_VM sctlrDefault = (0x34d59824 :: Word) -- SCTLR_DEFAULT @@ -455,3 +469,7 @@ gicVCPUMaxNumLR = (64 :: Int) -- The size of the physical address space in hyp mode can be configured on some platforms. config_ARM_PA_SIZE_BITS_40 :: Bool config_ARM_PA_SIZE_BITS_40 = error "generated from CMake config" + +-- Wether to trap WFI/WFE instructions or not in hyp mode +config_DISABLE_WFI_WFE_TRAPS :: Bool +config_DISABLE_WFI_WFE_TRAPS = error "generated from CMake config" diff --git a/spec/haskell/src/SEL4/Machine/Hardware/ARM.lhs b/spec/haskell/src/SEL4/Machine/Hardware/ARM.lhs index b2d73a5285..3b57e3d21f 100644 --- a/spec/haskell/src/SEL4/Machine/Hardware/ARM.lhs +++ b/spec/haskell/src/SEL4/Machine/Hardware/ARM.lhs @@ -888,13 +888,31 @@ FIXME ARMHYP consider moving to platform code? #ifdef CONFIG_ARM_HYPERVISOR_SUPPORT -> hcrVCPU = (0x87039 :: Word) -- HCR_VCPU +> hcrCommon :: Word +> -- HCR_TSC | HCR_AMO | HCR_IO | HCR_FMO | HCR_DC | HCR_VM +> hcrCommon = bit 19 .|. bit 5 .|. bit 4 .|. bit 3 .|. bit 12 .|. bit 0 + +> hcrTWE :: Word +> hcrTWE = bit 14 + +> hcrTWI :: Word +> hcrTWI = bit 13 + +> hcrVCPU :: Word -- HCR_VCPU +> hcrVCPU = if config_DISABLE_WFI_WFE_TRAPS +> then hcrCommon +> else hcrCommon .|. hcrTWE .|. hcrTWI + > hcrNative = (0xFE8103B :: Word) -- HCR_NATIVE > vgicHCREN = (0x1 :: Word) -- VGIC_HCR_EN > sctlrDefault = (0xc5187c :: Word) -- SCTLR_DEFAULT > actlrDefault = (0x40 :: Word) -- ACTLR_DEFAULT > gicVCPUMaxNumLR = (64 :: Int) +> -- Wether to trap WFI/WFE instructions or not in hyp mode +> config_DISABLE_WFI_WFE_TRAPS :: Bool +> config_DISABLE_WFI_WFE_TRAPS = error "generated from CMake config" + #endif > getCurrentTime :: MachineMonad Word64 diff --git a/spec/haskell/src/SEL4/Machine/Hardware/ARM/Exynos4210.hs b/spec/haskell/src/SEL4/Machine/Hardware/ARM/Exynos4210.hs index be41651def..93b6d599fc 100644 --- a/spec/haskell/src/SEL4/Machine/Hardware/ARM/Exynos4210.hs +++ b/spec/haskell/src/SEL4/Machine/Hardware/ARM/Exynos4210.hs @@ -174,9 +174,8 @@ cacheInvalidateL2RangeCallback _ _ _ = return () cacheCleanL2RangeCallback :: Ptr CallbackData -> PAddr -> PAddr -> IO () cacheCleanL2RangeCallback _ _ _ = return () --- For the ARM1136 cacheLine :: Int -cacheLine = 32 +cacheLine = error "see Kernel_Config.thy" cacheLineBits :: Int -cacheLineBits = 5 +cacheLineBits = error "see Kernel_Config.thy" diff --git a/spec/haskell/src/SEL4/Machine/Hardware/ARM/KZM.hs b/spec/haskell/src/SEL4/Machine/Hardware/ARM/KZM.hs index b4aa07ae39..b931f21ac8 100644 --- a/spec/haskell/src/SEL4/Machine/Hardware/ARM/KZM.hs +++ b/spec/haskell/src/SEL4/Machine/Hardware/ARM/KZM.hs @@ -170,9 +170,8 @@ cacheInvalidateL2RangeCallback _ _ _ = return () cacheCleanL2RangeCallback :: Ptr CallbackData -> PAddr -> PAddr -> IO () cacheCleanL2RangeCallback _ _ _ = return () --- For the ARM1136 cacheLine :: Int -cacheLine = 32 +cacheLine = error "see Kernel_Config.thy" cacheLineBits :: Int -cacheLineBits = 5 +cacheLineBits = error "see Kernel_Config.thy" diff --git a/spec/haskell/src/SEL4/Machine/Hardware/ARM/Sabre.hs b/spec/haskell/src/SEL4/Machine/Hardware/ARM/Sabre.hs index 0785d1667c..6fcd0a1232 100644 --- a/spec/haskell/src/SEL4/Machine/Hardware/ARM/Sabre.hs +++ b/spec/haskell/src/SEL4/Machine/Hardware/ARM/Sabre.hs @@ -171,9 +171,8 @@ cacheInvalidateL2RangeCallback _ _ _ = return () cacheCleanL2RangeCallback :: Ptr CallbackData -> PAddr -> PAddr -> IO () cacheCleanL2RangeCallback _ _ _ = return () --- FIXME: This is not correct now, we do not have l2cc interface abstracted. cacheLine :: Int -cacheLine = 32 +cacheLine = error "see Kernel_Config.thy" cacheLineBits :: Int -cacheLineBits = 5 +cacheLineBits = error "see Kernel_Config.thy" diff --git a/spec/haskell/src/SEL4/Machine/Hardware/ARM/TK1.hs b/spec/haskell/src/SEL4/Machine/Hardware/ARM/TK1.hs index 95f433f5b4..91197e9a35 100644 --- a/spec/haskell/src/SEL4/Machine/Hardware/ARM/TK1.hs +++ b/spec/haskell/src/SEL4/Machine/Hardware/ARM/TK1.hs @@ -167,9 +167,8 @@ cacheInvalidateL2RangeCallback _ _ _ = return () cacheCleanL2RangeCallback :: Ptr CallbackData -> PAddr -> PAddr -> IO () cacheCleanL2RangeCallback _ _ _ = return () --- For the ARM1136 cacheLine :: Int -cacheLine = 64 +cacheLine = error "see Kernel_Config.thy" cacheLineBits :: Int -cacheLineBits = 6 +cacheLineBits = error "see Kernel_Config.thy" diff --git a/spec/haskell/src/SEL4/Object/ObjectType/AARCH64.hs b/spec/haskell/src/SEL4/Object/ObjectType/AARCH64.hs index b71e018100..7a30a7f5ef 100644 --- a/spec/haskell/src/SEL4/Object/ObjectType/AARCH64.hs +++ b/spec/haskell/src/SEL4/Object/ObjectType/AARCH64.hs @@ -177,6 +177,10 @@ createObject t regionBase _ isDevice = modify (\ks -> ks { gsUserPages = funupd (gsUserPages ks) (fromPPtr regionBase) (Just ARMSmallPage)}) + when (not isDevice) $ doMachineOp $ + cleanCacheRange_RAM (VPtr $ fromPPtr regionBase) + (VPtr $ fromPPtr regionBase + mask (pageBitsForSize ARMSmallPage)) + (addrFromPPtr regionBase) return $ FrameCap (pointerCast regionBase) VMReadWrite ARMSmallPage isDevice Nothing Arch.Types.LargePageObject -> do @@ -184,6 +188,10 @@ createObject t regionBase _ isDevice = modify (\ks -> ks { gsUserPages = funupd (gsUserPages ks) (fromPPtr regionBase) (Just ARMLargePage)}) + when (not isDevice) $ doMachineOp $ + cleanCacheRange_RAM (VPtr $ fromPPtr regionBase) + (VPtr $ fromPPtr regionBase + mask (pageBitsForSize ARMLargePage)) + (addrFromPPtr regionBase) return $ FrameCap (pointerCast regionBase) VMReadWrite ARMLargePage isDevice Nothing Arch.Types.HugePageObject -> do @@ -191,17 +199,29 @@ createObject t regionBase _ isDevice = modify (\ks -> ks { gsUserPages = funupd (gsUserPages ks) (fromPPtr regionBase) (Just ARMHugePage)}) + when (not isDevice) $ doMachineOp $ + cleanCacheRange_RAM (VPtr $ fromPPtr regionBase) + (VPtr $ fromPPtr regionBase + mask (pageBitsForSize ARMHugePage)) + (addrFromPPtr regionBase) return $ FrameCap (pointerCast regionBase) VMReadWrite ARMHugePage isDevice Nothing Arch.Types.PageTableObject -> do let ptSize = ptBits NormalPT_T - objBits (makeObject :: PTE) placeNewObject regionBase (makeObject :: PTE) ptSize updatePTType regionBase NormalPT_T + doMachineOp $ + cleanCacheRange_PoU (VPtr $ fromPPtr regionBase) + (VPtr $ fromPPtr regionBase + mask (ptBits NormalPT_T)) + (addrFromPPtr regionBase) return $ PageTableCap (pointerCast regionBase) NormalPT_T Nothing Arch.Types.VSpaceObject -> do let ptSize = ptBits VSRootPT_T - objBits (makeObject :: PTE) placeNewObject regionBase (makeObject :: PTE) ptSize updatePTType regionBase VSRootPT_T + doMachineOp $ + cleanCacheRange_PoU (VPtr $ fromPPtr regionBase) + (VPtr $ fromPPtr regionBase + mask (ptBits VSRootPT_T)) + (addrFromPPtr regionBase) return $ PageTableCap (pointerCast regionBase) VSRootPT_T Nothing Arch.Types.VCPUObject -> do placeNewObject regionBase (makeObject :: VCPU) 0 diff --git a/spec/haskell/src/SEL4/Object/ObjectType/ARM.lhs b/spec/haskell/src/SEL4/Object/ObjectType/ARM.lhs index 84d7dde5e0..2c49bad9e4 100644 --- a/spec/haskell/src/SEL4/Object/ObjectType/ARM.lhs +++ b/spec/haskell/src/SEL4/Object/ObjectType/ARM.lhs @@ -218,12 +218,20 @@ Create an architecture-specific object. > modify (\ks -> ks { gsUserPages = > funupd (gsUserPages ks) > (fromPPtr regionBase) (Just ARMSmallPage)}) +> when (not isDevice) $ doMachineOp $ +> cleanCacheRange_RAM (VPtr $ fromPPtr regionBase) +> (VPtr $ fromPPtr regionBase + mask (pageBitsForSize ARMSmallPage)) +> (addrFromPPtr regionBase) > return $ mkPageCap ARMSmallPage > Arch.Types.LargePageObject -> do > placeNewDataObject regionBase 4 isDevice > modify (\ks -> ks { gsUserPages = > funupd (gsUserPages ks) > (fromPPtr regionBase) (Just ARMLargePage)}) +> when (not isDevice) $ doMachineOp $ +> cleanCacheRange_RAM (VPtr $ fromPPtr regionBase) +> (VPtr $ fromPPtr regionBase + mask (pageBitsForSize ARMLargePage)) +> (addrFromPPtr regionBase) > return $ mkPageCap ARMLargePage > Arch.Types.SectionObject -> do #ifdef CONFIG_ARM_HYPERVISOR_SUPPORT @@ -234,6 +242,10 @@ Create an architecture-specific object. > modify (\ks -> ks { gsUserPages = > funupd (gsUserPages ks) > (fromPPtr regionBase) (Just ARMSection)}) +> when (not isDevice) $ doMachineOp $ +> cleanCacheRange_RAM (VPtr $ fromPPtr regionBase) +> (VPtr $ fromPPtr regionBase + mask (pageBitsForSize ARMSection)) +> (addrFromPPtr regionBase) > return $ mkPageCap ARMSection > Arch.Types.SuperSectionObject -> do #ifdef CONFIG_ARM_HYPERVISOR_SUPPORT @@ -244,19 +256,26 @@ Create an architecture-specific object. > modify (\ks -> ks { gsUserPages = > funupd (gsUserPages ks) > (fromPPtr regionBase) (Just ARMSuperSection)}) +> when (not isDevice) $ doMachineOp $ +> cleanCacheRange_RAM (VPtr $ fromPPtr regionBase) +> (VPtr $ fromPPtr regionBase + mask (pageBitsForSize ARMSuperSection)) +> (addrFromPPtr regionBase) > return $ mkPageCap ARMSuperSection > Arch.Types.PageTableObject -> do > let ptSize = ptBits - objBits (makeObject :: PTE) > placeNewObject regionBase (makeObject :: PTE) ptSize +> doMachineOp $ +> cleanCacheRange_PoU (VPtr $ fromPPtr regionBase) +> (VPtr $ fromPPtr regionBase + mask ptBits) +> (addrFromPPtr regionBase) > return $ PageTableCap (pointerCast regionBase) Nothing > Arch.Types.PageDirectoryObject -> do > let pdSize = pdBits - objBits (makeObject :: PDE) -> let regionSize = (1 `shiftL` pdBits) > placeNewObject regionBase (makeObject :: PDE) pdSize > copyGlobalMappings (pointerCast regionBase) > doMachineOp $ > cleanCacheRange_PoU (VPtr $ fromPPtr regionBase) -> (VPtr $ fromPPtr regionBase + regionSize - 1) +> (VPtr $ fromPPtr regionBase + mask pdBits) > (addrFromPPtr regionBase) > return $ PageDirectoryCap (pointerCast regionBase) Nothing #ifdef CONFIG_ARM_HYPERVISOR_SUPPORT diff --git a/spec/machine/AARCH64/Arch_Kernel_Config_Lemmas.thy b/spec/machine/AARCH64/Arch_Kernel_Config_Lemmas.thy index ab6dfd5121..0e5724b680 100644 --- a/spec/machine/AARCH64/Arch_Kernel_Config_Lemmas.thy +++ b/spec/machine/AARCH64/Arch_Kernel_Config_Lemmas.thy @@ -117,5 +117,16 @@ lemma maxIRQ_1_plus_eq_Suc_machine[simp]: "unat (1 + Kernel_Config.maxIRQ :: machine_word) = Suc Kernel_Config.maxIRQ" by (simp add: Kernel_Config.maxIRQ_def) + +(* cacheLineBits conditions *) + +(* Folding cacheLineBits_val in C functions only works reliably if cacheLineBits is not 1 and + not too large to conflict with other values used inside cache ops. + 12 is ptBits, which is only available after ExecSpec. Anything > 1 and smaller than ptBits + works. *) +lemma cacheLineBits_sanity: + "cacheLineBits \ {2..12}" + by (simp add: cacheLineBits_def Kernel_Config.CONFIG_L1_CACHE_LINE_SIZE_BITS_def) + end end diff --git a/spec/machine/AARCH64/MachineOps.thy b/spec/machine/AARCH64/MachineOps.thy index e5a5dde703..af007a9860 100644 --- a/spec/machine/AARCH64/MachineOps.thy +++ b/spec/machine/AARCH64/MachineOps.thy @@ -414,12 +414,10 @@ lemmas cache_machine_op_defs = subsection "Clearing Memory" -text \Clear memory contents to recycle it as user memory\ +text \Clear memory contents to recycle it as user memory. Do not yet flush the cache.\ definition clearMemory :: "machine_word \ nat \ unit machine_monad" where - "clearMemory ptr bytelength \ do - mapM_x (\p. storeWord p 0) [ptr, ptr + word_size .e. ptr + (of_nat bytelength) - 1]; - cleanCacheRange_RAM ptr (ptr + of_nat bytelength - 1) (addrFromPPtr ptr) - od" + "clearMemory ptr bytelength \ + mapM_x (\p. storeWord p 0) [ptr, ptr + word_size .e. ptr + (of_nat bytelength) - 1]" text \Haskell simulator interface stub.\ definition clearMemoryVM :: "machine_word \ nat \ unit machine_monad" where diff --git a/spec/machine/AARCH64/Platform.thy b/spec/machine/AARCH64/Platform.thy index de18040238..095cc41d9d 100644 --- a/spec/machine/AARCH64/Platform.thy +++ b/spec/machine/AARCH64/Platform.thy @@ -52,6 +52,9 @@ abbreviation (input) "fromPAddr \ id" definition canonical_bit :: nat where "canonical_bit = 47" +definition cacheLineBits :: nat where + "cacheLineBits = CONFIG_L1_CACHE_LINE_SIZE_BITS" + definition kdevBase :: machine_word where "kdevBase = 0x000000FFFFE00000" diff --git a/spec/machine/ARM/Arch_Kernel_Config_Lemmas.thy b/spec/machine/ARM/Arch_Kernel_Config_Lemmas.thy index a842e107b3..49eff00372 100644 --- a/spec/machine/ARM/Arch_Kernel_Config_Lemmas.thy +++ b/spec/machine/ARM/Arch_Kernel_Config_Lemmas.thy @@ -119,5 +119,16 @@ lemma maxIRQ_1_plus_eq_Suc_machine[simp]: "unat (1 + maxIRQ :: machine_word) = Suc Kernel_Config.maxIRQ" by (simp add: Kernel_Config.maxIRQ_def) + +(* cacheLineBits conditions *) + +(* Folding cacheLineBits_val in C functions only works reliably if cacheLineBits is not 1 and + not too large to conflict with other values used inside cache ops. + 10 is ptBits, which is only available after ExecSpec. Anything > 1 and smaller than ptBits + works. *) +lemma cacheLineBits_sanity: + "cacheLineBits \ {2..10}" + by (simp add: cacheLineBits_def Kernel_Config.CONFIG_L1_CACHE_LINE_SIZE_BITS_def) + end end diff --git a/spec/machine/ARM/MachineOps.thy b/spec/machine/ARM/MachineOps.thy index a27c654777..955be62d06 100644 --- a/spec/machine/ARM/MachineOps.thy +++ b/spec/machine/ARM/MachineOps.thy @@ -28,7 +28,7 @@ text \ All this is done only to avoid a large number of axioms (2 for each operation). \ -context Arch begin global_naming ARM +context Arch begin arch_global_naming section "The Operations" @@ -118,11 +118,6 @@ consts' timerPrecision :: "64 word" consts' max_ticks_to_us :: "64 word" consts' max_us_to_ticks :: "64 word" -end - - -qualify ARM (in Arch) - type_synonym ticks = "64 word" type_synonym time = "64 word" @@ -136,6 +131,10 @@ text \ This matches @{text "60 * 60 * MS_IN_S * US_IN_MS"} because it shou definition MAX_PERIOD_US :: "64 word" where "MAX_PERIOD_US \ 60 * 60 * 1000 * 1000" +end + +qualify ARM (in Arch) + \ \The following notepad shows that the axioms introduced below, which provide various results about several constants and their conversion via us_to_ticks, are consistent.\ @@ -150,13 +149,13 @@ define us_to_ticks :: "64 word \ 64 word" where have kernelWCET_us_pos2: "0 < 2 * kernelWCET_us" by (simp add: kernelWCET_us_def) -have MIN_BUDGET_le_MAX_PERIOD: "2 * kernelWCET_us \ MAX_PERIOD_US" - by (simp add: kernelWCET_us_def MAX_PERIOD_US_def) +have MIN_BUDGET_le_MAX_PERIOD: "2 * kernelWCET_us \ ARM.MAX_PERIOD_US" + by (simp add: kernelWCET_us_def ARM.MAX_PERIOD_US_def) have ticks_per_timer_unit_non_zero: "ticks_per_timer_unit \ 0" by (simp add: ticks_per_timer_unit_def) -have MIN_BUDGET_bound: "2 * unat kernelWCET_us * unat ticks_per_timer_unit < unat max_time" +have MIN_BUDGET_bound: "2 * unat kernelWCET_us * unat ticks_per_timer_unit < unat ARM.max_time" apply (subst unat_max_word[symmetric]) apply clarsimp apply (prop_tac "unat kernelWCET_us \ 100") @@ -169,8 +168,8 @@ have MIN_BUDGET_bound: "2 * unat kernelWCET_us * unat ticks_per_timer_unit < una done have getCurrentTime_buffer_bound: - "5 * unat MAX_PERIOD_US * unat ticks_per_timer_unit < unat max_time" - apply (fastforce simp: unat_max_word[symmetric] ticks_per_timer_unit_def MAX_PERIOD_US_def) + "5 * unat ARM.MAX_PERIOD_US * unat ticks_per_timer_unit < unat ARM.max_time" + apply (fastforce simp: unat_max_word[symmetric] ticks_per_timer_unit_def ARM.MAX_PERIOD_US_def) done have kernelWCET_pos': "0 < us_to_ticks kernelWCET_us" @@ -185,34 +184,34 @@ have MIN_BUDGET_pos': "0 < 2 * us_to_ticks kernelWCET_us" | fastforce simp: kernelWCET_us_def ticks_per_timer_unit_def timer_unit_def unat_minus_one_word)+ done -have init_domain_time_pos: "0 < us_to_ticks (15 * \s_in_ms)" +have init_domain_time_pos: "0 < us_to_ticks (15 * ARM.\s_in_ms)" apply (clarsimp simp: us_to_ticks_def word_less_nat_alt) apply (subst unat_mult_lem' | subst unat_div - | fastforce simp: \s_in_ms_def ticks_per_timer_unit_def timer_unit_def unat_minus_one_word)+ + | fastforce simp: ARM.\s_in_ms_def ticks_per_timer_unit_def timer_unit_def unat_minus_one_word)+ done -have init_domain_time_bound: "15 * unat \s_in_ms * unat ticks_per_timer_unit < unat max_time" +have init_domain_time_bound: "15 * unat ARM.\s_in_ms * unat ticks_per_timer_unit < unat ARM.max_time" apply (subst unat_mult_lem' - | fastforce simp: \s_in_ms_def ticks_per_timer_unit_def unat_minus_one_word)+ + | fastforce simp: ARM.\s_in_ms_def ticks_per_timer_unit_def unat_minus_one_word)+ done have getCurrentTime_buffer_pos: - "0 < 5 * us_to_ticks MAX_PERIOD_US" - apply (fastforce simp: us_to_ticks_def word_less_nat_alt MAX_PERIOD_US_def + "0 < 5 * us_to_ticks ARM.MAX_PERIOD_US" + apply (fastforce simp: us_to_ticks_def word_less_nat_alt ARM.MAX_PERIOD_US_def ticks_per_timer_unit_def timer_unit_def) done end -consts' kernelWCET_us :: ticks +consts' kernelWCET_us :: ARM.ticks axiomatization where kernelWCET_us_pos2: "0 < 2 * kernelWCET_us" and - MIN_BUDGET_le_MAX_PERIOD: "2 * kernelWCET_us \ MAX_PERIOD_US" + MIN_BUDGET_le_MAX_PERIOD: "2 * kernelWCET_us \ ARM.MAX_PERIOD_US" -consts' ticks_per_timer_unit :: ticks -consts' timer_unit :: ticks +consts' ticks_per_timer_unit :: ARM.ticks +consts' timer_unit :: ARM.ticks definition "us_to_ticks us = (us * ticks_per_timer_unit) div timer_unit" @@ -220,29 +219,29 @@ definition axiomatization where ticks_per_timer_unit_non_zero: "ticks_per_timer_unit \ 0" and - MIN_BUDGET_bound: "2 * unat kernelWCET_us * unat ticks_per_timer_unit < unat max_time" + MIN_BUDGET_bound: "2 * unat kernelWCET_us * unat ticks_per_timer_unit < unat ARM.max_time" and \ \the 5 is from time_buffer_const (defined below)\ getCurrentTime_buffer_bound: - "5 * unat MAX_PERIOD_US * unat ticks_per_timer_unit < unat max_time" + "5 * unat ARM.MAX_PERIOD_US * unat ticks_per_timer_unit < unat ARM.max_time" and kernelWCET_pos': "0 < us_to_ticks kernelWCET_us" and MIN_BUDGET_pos': "0 < 2 * us_to_ticks kernelWCET_us" and \ \the 15 is from the domain time of the initial state\ - init_domain_time_pos: "0 < us_to_ticks (15 * \s_in_ms)" + init_domain_time_pos: "0 < us_to_ticks (15 * ARM.\s_in_ms)" and \ \the 15 is from the domain time of the initial state\ - init_domain_time_bound: "15 * unat \s_in_ms * unat ticks_per_timer_unit < unat max_time" + init_domain_time_bound: "15 * unat ARM.\s_in_ms * unat ticks_per_timer_unit < unat ARM.max_time" and \ \the 5 is from time_buffer_const (defined below)\ - getCurrentTime_buffer_pos: "0 < 5 * us_to_ticks MAX_PERIOD_US" + getCurrentTime_buffer_pos: "0 < 5 * us_to_ticks ARM.MAX_PERIOD_US" -definition "MAX_PERIOD = us_to_ticks MAX_PERIOD_US" +definition "MAX_PERIOD = us_to_ticks ARM.MAX_PERIOD_US" axiomatization - ticks_to_us :: "ticks \ ticks" + ticks_to_us :: "ARM.ticks \ ARM.ticks" end_qualify @@ -731,14 +730,12 @@ where section "Memory Clearance" -text \Clear memory contents to recycle it as user memory\ +text \Clear memory contents to recycle it as user memory. Do not yet flush the cache.\ definition clearMemory :: "machine_word \ nat \ unit machine_monad" where "clearMemory ptr bytelength \ - do mapM_x (\p. storeWord p 0) [ptr, ptr + word_size .e. ptr + (of_nat bytelength) - 1]; - cleanCacheRange_RAM ptr (ptr + of_nat bytelength - 1) (addrFromPPtr ptr) - od" + mapM_x (\p. storeWord p 0) [ptr, ptr + word_size .e. ptr + (of_nat bytelength) - 1]" definition clearMemoryVM :: "machine_word \ nat \ unit machine_monad" diff --git a/spec/machine/ARM/Platform.thy b/spec/machine/ARM/Platform.thy index 000b82ba43..4d676900e1 100644 --- a/spec/machine/ARM/Platform.thy +++ b/spec/machine/ARM/Platform.thy @@ -43,7 +43,7 @@ definition pageColourBits :: nat where "pageColourBits \ 2" definition cacheLineBits :: nat where - "cacheLineBits = 5" + "cacheLineBits = CONFIG_L1_CACHE_LINE_SIZE_BITS" definition cacheLine :: nat where "cacheLine = 2^cacheLineBits" diff --git a/spec/machine/ARM_HYP/Arch_Kernel_Config_Lemmas.thy b/spec/machine/ARM_HYP/Arch_Kernel_Config_Lemmas.thy index a1990c0f6b..4888a72e23 100644 --- a/spec/machine/ARM_HYP/Arch_Kernel_Config_Lemmas.thy +++ b/spec/machine/ARM_HYP/Arch_Kernel_Config_Lemmas.thy @@ -131,5 +131,16 @@ lemma maxIRQ_le_mask_irq_len: using le_maxIRQ_machine_less_irqBits_val by (fastforce simp add: word_le_nat_alt word_less_nat_alt irq_len_val mask_def) + +(* cacheLineBits conditions *) + +(* Folding cacheLineBits_val in C functions only works reliably if cacheLineBits is not 1 and + not too large to conflict with other values used inside cache ops. + 12 is ptBits, which is only available after ExecSpec. Anything > 1 and smaller than ptBits + works. *) +lemma cacheLineBits_sanity: + "cacheLineBits \ {2..12}" + by (simp add: cacheLineBits_def Kernel_Config.CONFIG_L1_CACHE_LINE_SIZE_BITS_def) + end end diff --git a/spec/machine/ARM_HYP/MachineOps.thy b/spec/machine/ARM_HYP/MachineOps.thy index 01bf713619..9f05d7efb8 100644 --- a/spec/machine/ARM_HYP/MachineOps.thy +++ b/spec/machine/ARM_HYP/MachineOps.thy @@ -473,14 +473,12 @@ where section "Memory Clearance" -text \Clear memory contents to recycle it as user memory\ +text \Clear memory contents to recycle it as user memory. Do not yet flush the cache.\ definition clearMemory :: "machine_word \ nat \ unit machine_monad" where "clearMemory ptr bytelength \ - do mapM_x (\p. storeWord p 0) [ptr, ptr + word_size .e. ptr + (of_nat bytelength) - 1]; - cleanCacheRange_RAM ptr (ptr + of_nat bytelength - 1) (addrFromPPtr ptr) - od" + mapM_x (\p. storeWord p 0) [ptr, ptr + word_size .e. ptr + (of_nat bytelength) - 1]" definition clearMemoryVM :: "machine_word \ nat \ unit machine_monad" diff --git a/spec/machine/ARM_HYP/Platform.thy b/spec/machine/ARM_HYP/Platform.thy index 1bf44f827b..666c031b67 100644 --- a/spec/machine/ARM_HYP/Platform.thy +++ b/spec/machine/ARM_HYP/Platform.thy @@ -43,7 +43,7 @@ definition pageColourBits :: nat where "pageColourBits \ 2" definition cacheLineBits :: nat where - "cacheLineBits = 6" + "cacheLineBits = CONFIG_L1_CACHE_LINE_SIZE_BITS" definition cacheLine :: nat where "cacheLine = 2^cacheLineBits" diff --git a/spec/machine/MachineExports.thy b/spec/machine/MachineExports.thy index 87d577bd6b..5ac2632b7a 100644 --- a/spec/machine/MachineExports.thy +++ b/spec/machine/MachineExports.thy @@ -9,21 +9,19 @@ theory MachineExports imports MachineOps begin -context begin interpretation Arch . - (* Check consistency of machine_word and machine_word_len. *) term "id :: machine_word \ machine_word_len word" -requalify_types - machine_word - machine_word_len +arch_requalify_types vmfault_type hyp_fault_type irq + user_monad + user_context ticks time -requalify_consts +arch_requalify_consts getActiveIRQ maskInterrupt freeMemory @@ -48,10 +46,14 @@ requalify_consts getCurrentTime minIRQ timerIRQ - word_size_bits clearMemory non_kernel_IRQs tlsBaseRegister + debugPrint + configureTimer + initL2Cache + ptrFromPAddr + pageBits configureTimer kernelWCET_us kernelWCET_ticks @@ -70,7 +72,7 @@ requalify_consts time_buffer_const \s_in_ms -requalify_facts +arch_requalify_facts MAX_PERIOD_US_def MAX_PERIOD_def kernelWCET_ticks_def @@ -115,5 +117,3 @@ lemma word_size_size_bits_word: by (simp add: word_size_bits_def word_size_def) end - -end diff --git a/spec/machine/MachineMonad.thy b/spec/machine/MachineMonad.thy index d50a1fcdfb..2d966c022a 100644 --- a/spec/machine/MachineMonad.thy +++ b/spec/machine/MachineMonad.thy @@ -9,13 +9,11 @@ theory MachineMonad imports MachineTypes begin -context begin interpretation Arch . - -requalify_types +arch_requalify_types machine_state machine_state_rest -requalify_consts +arch_requalify_consts underlying_memory underlying_memory_update device_state @@ -24,8 +22,6 @@ requalify_consts machine_state_rest machine_state_rest_update -end - text \ The machine monad is used for operations on the state defined above. \ diff --git a/spec/machine/RISCV64/MachineOps.thy b/spec/machine/RISCV64/MachineOps.thy index 8846817d74..99edec082c 100644 --- a/spec/machine/RISCV64/MachineOps.thy +++ b/spec/machine/RISCV64/MachineOps.thy @@ -27,7 +27,7 @@ text \ All this is done only to avoid a large number of axioms (2 for each operation). \ -context Arch begin global_naming RISCV64 +context Arch begin arch_global_naming section "The Operations" @@ -84,10 +84,6 @@ consts' timerPrecision :: "64 word" consts' max_ticks_to_us :: "64 word" consts' max_us_to_ticks :: "64 word" -end - -qualify RISCV64 (in Arch) - type_synonym ticks = "64 word" type_synonym time = "64 word" @@ -101,6 +97,10 @@ text \ This matches @{text "60 * 60 * MS_IN_S * US_IN_MS"} because it shou definition MAX_PERIOD_US :: "64 word" where "MAX_PERIOD_US \ 60 * 60 * 1000 * 1000" +end + +qualify RISCV64 (in Arch) + \ \The following notepad shows that the axioms introduced below, which provide various results about several constants and their conversion via us_to_ticks, are consistent.\ @@ -115,13 +115,13 @@ define us_to_ticks :: "64 word \ 64 word" where have kernelWCET_us_pos2: "0 < 2 * kernelWCET_us" by (simp add: kernelWCET_us_def) -have MIN_BUDGET_le_MAX_PERIOD: "2 * kernelWCET_us \ MAX_PERIOD_US" - by (simp add: kernelWCET_us_def MAX_PERIOD_US_def) +have MIN_BUDGET_le_MAX_PERIOD: "2 * kernelWCET_us \ RISCV64.MAX_PERIOD_US" + by (simp add: kernelWCET_us_def RISCV64.MAX_PERIOD_US_def) have ticks_per_timer_unit_non_zero: "ticks_per_timer_unit \ 0" by (simp add: ticks_per_timer_unit_def) -have MIN_BUDGET_bound: "2 * unat kernelWCET_us * unat ticks_per_timer_unit < unat max_time" +have MIN_BUDGET_bound: "2 * unat kernelWCET_us * unat ticks_per_timer_unit < unat RISCV64.max_time" apply (subst unat_max_word[symmetric]) apply clarsimp apply (prop_tac "unat kernelWCET_us \ 100") @@ -134,8 +134,8 @@ have MIN_BUDGET_bound: "2 * unat kernelWCET_us * unat ticks_per_timer_unit < una done have getCurrentTime_buffer_bound: - "5 * unat MAX_PERIOD_US * unat ticks_per_timer_unit < unat max_time" - apply (fastforce simp: unat_max_word[symmetric] ticks_per_timer_unit_def MAX_PERIOD_US_def) + "5 * unat RISCV64.MAX_PERIOD_US * unat ticks_per_timer_unit < unat RISCV64.max_time" + apply (fastforce simp: unat_max_word[symmetric] ticks_per_timer_unit_def RISCV64.MAX_PERIOD_US_def) done have kernelWCET_pos': "0 < us_to_ticks kernelWCET_us" @@ -150,34 +150,34 @@ have MIN_BUDGET_pos': "0 < 2 * us_to_ticks kernelWCET_us" | fastforce simp: kernelWCET_us_def ticks_per_timer_unit_def timer_unit_def unat_minus_one_word)+ done -have init_domain_time_pos: "0 < us_to_ticks (15 * \s_in_ms)" +have init_domain_time_pos: "0 < us_to_ticks (15 * RISCV64.\s_in_ms)" apply (clarsimp simp: us_to_ticks_def word_less_nat_alt) apply (subst unat_mult_lem' | subst unat_div - | fastforce simp: \s_in_ms_def ticks_per_timer_unit_def timer_unit_def unat_minus_one_word)+ + | fastforce simp: RISCV64.\s_in_ms_def ticks_per_timer_unit_def timer_unit_def unat_minus_one_word)+ done -have init_domain_time_bound: "15 * unat \s_in_ms * unat ticks_per_timer_unit < unat max_time" +have init_domain_time_bound: "15 * unat RISCV64.\s_in_ms * unat ticks_per_timer_unit < unat RISCV64.max_time" apply (subst unat_mult_lem' - | fastforce simp: \s_in_ms_def ticks_per_timer_unit_def unat_minus_one_word)+ + | fastforce simp: RISCV64.\s_in_ms_def ticks_per_timer_unit_def unat_minus_one_word)+ done have getCurrentTime_buffer_pos: - "0 < 5 * us_to_ticks MAX_PERIOD_US" - apply (fastforce simp: us_to_ticks_def word_less_nat_alt MAX_PERIOD_US_def + "0 < 5 * us_to_ticks RISCV64.MAX_PERIOD_US" + apply (fastforce simp: us_to_ticks_def word_less_nat_alt RISCV64.MAX_PERIOD_US_def ticks_per_timer_unit_def timer_unit_def) done end -consts' kernelWCET_us :: ticks +consts' kernelWCET_us :: RISCV64.ticks axiomatization where kernelWCET_us_pos2: "0 < 2 * kernelWCET_us" and - MIN_BUDGET_le_MAX_PERIOD: "2 * kernelWCET_us \ MAX_PERIOD_US" + MIN_BUDGET_le_MAX_PERIOD: "2 * kernelWCET_us \ RISCV64.MAX_PERIOD_US" -consts' ticks_per_timer_unit :: ticks -consts' timer_unit :: ticks +consts' ticks_per_timer_unit :: RISCV64.ticks +consts' timer_unit :: RISCV64.ticks definition "us_to_ticks us = (us * ticks_per_timer_unit) div timer_unit" @@ -185,29 +185,29 @@ definition axiomatization where ticks_per_timer_unit_non_zero: "ticks_per_timer_unit \ 0" and - MIN_BUDGET_bound: "2 * unat kernelWCET_us * unat ticks_per_timer_unit < unat max_time" + MIN_BUDGET_bound: "2 * unat kernelWCET_us * unat ticks_per_timer_unit < unat RISCV64.max_time" and \ \the 5 is from time_buffer_const (defined below)\ getCurrentTime_buffer_bound: - "5 * unat MAX_PERIOD_US * unat ticks_per_timer_unit < unat max_time" + "5 * unat RISCV64.MAX_PERIOD_US * unat ticks_per_timer_unit < unat RISCV64.max_time" and kernelWCET_pos': "0 < us_to_ticks kernelWCET_us" and MIN_BUDGET_pos': "0 < 2 * us_to_ticks kernelWCET_us" and \ \the 15 is from the domain time of the initial state\ - init_domain_time_pos: "0 < us_to_ticks (15 * \s_in_ms)" + init_domain_time_pos: "0 < us_to_ticks (15 * RISCV64.\s_in_ms)" and \ \the 15 is from the domain time of the initial state\ - init_domain_time_bound: "15 * unat \s_in_ms * unat ticks_per_timer_unit < unat max_time" + init_domain_time_bound: "15 * unat RISCV64.\s_in_ms * unat ticks_per_timer_unit < unat RISCV64.max_time" and \ \the 5 is from time_buffer_const (defined below)\ - getCurrentTime_buffer_pos: "0 < 5 * us_to_ticks MAX_PERIOD_US" + getCurrentTime_buffer_pos: "0 < 5 * us_to_ticks RISCV64.MAX_PERIOD_US" -definition "MAX_PERIOD = us_to_ticks MAX_PERIOD_US" +definition "MAX_PERIOD = us_to_ticks RISCV64.MAX_PERIOD_US" axiomatization - ticks_to_us :: "ticks \ ticks" + ticks_to_us :: "RISCV64.ticks \ RISCV64.ticks" end_qualify diff --git a/spec/machine/X64/Platform.thy b/spec/machine/X64/Platform.thy index eef07b6630..6113622eee 100644 --- a/spec/machine/X64/Platform.thy +++ b/spec/machine/X64/Platform.thy @@ -45,14 +45,6 @@ definition pptrUserTop :: word64 where "pptrUserTop = 0x00007fffffffffff" -definition - cacheLineBits :: nat where - "cacheLineBits = 5" - -definition - cacheLine :: nat where - "cacheLine = 2^cacheLineBits" - definition ptrFromPAddr :: "paddr \ word64" where "ptrFromPAddr paddr \ paddr + pptrBase" diff --git a/sys-init/InitVSpace_SI.thy b/sys-init/InitVSpace_SI.thy index 196f0f63dc..1c927d5f3e 100644 --- a/sys-init/InitVSpace_SI.thy +++ b/sys-init/InitVSpace_SI.thy @@ -21,7 +21,7 @@ imports Lib.Guess_ExI begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare object_at_predicate_lift[simp] diff --git a/sys-init/WellFormed_SI.thy b/sys-init/WellFormed_SI.thy index 3f0114b5d3..a81d70088c 100644 --- a/sys-init/WellFormed_SI.thy +++ b/sys-init/WellFormed_SI.thy @@ -23,7 +23,7 @@ imports "AInvs.Rights_AI" begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cap_has_object_NullCap [simp]: "\cap_has_object NullCap" diff --git a/sys-init/examples/ExampleSpecIRQ_SI.thy b/sys-init/examples/ExampleSpecIRQ_SI.thy index 99df757e7c..8a8c133bd9 100644 --- a/sys-init/examples/ExampleSpecIRQ_SI.thy +++ b/sys-init/examples/ExampleSpecIRQ_SI.thy @@ -16,7 +16,7 @@ theory ExampleSpecIRQ_SI imports SysInit.WellFormed_SI begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (**************************************************** * Definitions of all the objects and capabilities. * diff --git a/sys-init/examples/ExampleSpec_SI.thy b/sys-init/examples/ExampleSpec_SI.thy index b0daac1545..66e735795d 100644 --- a/sys-init/examples/ExampleSpec_SI.thy +++ b/sys-init/examples/ExampleSpec_SI.thy @@ -16,7 +16,7 @@ theory ExampleSpec_SI imports SysInit.WellFormed_SI begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma object_slots_empty_object [simp]: "object_slots (Frame \cdl_frame_size_bits = small_frame_size\) slot = Some cap \ cap = NullCap" diff --git a/tools/autocorres/README.md b/tools/autocorres/README.md index e564e53413..42d09b19e9 100644 --- a/tools/autocorres/README.md +++ b/tools/autocorres/README.md @@ -4,7 +4,9 @@ SPDX-License-Identifier: CC-BY-SA-4.0 --> + AutoCorres ========== @@ -15,9 +17,13 @@ in [Isabelle/HOL][1]. In particular, it uses Norrish's abstracts the result to produce a result that is (hopefully) more pleasant to reason about. +Before using this version of AutoCorres, consider using [AutoCorres2] +available from the [Archive of Formal Proofs][AFP]. + [1]: https://isabelle.in.tum.de [2]: https://github.com/seL4/l4v/blob/master/tools/c-parser/README.md - + [AutoCorres2]: https://www.isa-afp.org/entries/AutoCorres2.html + [AFP]: https://www.isa-afp.org Contents of this README @@ -35,7 +41,7 @@ Contents of this README Installation ------------ -AutoCorres is packaged as a theory for Isabelle2022: +AutoCorres is packaged as a theory for Isabelle2024: https://isabelle.in.tum.de diff --git a/tools/autocorres/tools/release_files/ChangeLog b/tools/autocorres/tools/release_files/ChangeLog index e95f216e9b..ab0360bce3 100644 --- a/tools/autocorres/tools/release_files/ChangeLog +++ b/tools/autocorres/tools/release_files/ChangeLog @@ -1,6 +1,14 @@ AutoCorres Change Log ===================== +AutoCorres 1.11 (11 Oct 2024) +---------------------------- + + * Isabelle2024 edition of both AutoCorres and the C parser. + + * Further clean-up and restructure of monad libraries. + + AutoCorres 1.10 (3 Nov 2023) ---------------------------- diff --git a/tools/autocorres/tools/release_files/README b/tools/autocorres/tools/release_files/README index 45a68444ee..0283eb8057 100644 --- a/tools/autocorres/tools/release_files/README +++ b/tools/autocorres/tools/release_files/README @@ -7,9 +7,13 @@ in [Isabelle/HOL][1]. In particular, it uses Norrish's abstracts the result to produce a result that is (hopefully) more pleasant to reason about. +Before using this version of AutoCorres, consider using [AutoCorres2] +available from the [Archive of Formal Proofs][AFP]. + [1]: https://isabelle.in.tum.de/ [2]: https://github.com/seL4/l4v/blob/master/tools/c-parser/README.md - + [AutoCorres2]: https://www.isa-afp.org/entries/AutoCorres2.html + [AFP]: https://www.isa-afp.org Contents of this README @@ -28,7 +32,7 @@ Contents of this README Installation ------------ -AutoCorres is packaged as a theory for Isabelle2023: +AutoCorres is packaged as a theory for Isabelle2024: https://isabelle.in.tum.de diff --git a/tools/c-parser/README.md b/tools/c-parser/README.md index f765baeea4..2e4ded61f5 100644 --- a/tools/c-parser/README.md +++ b/tools/c-parser/README.md @@ -88,10 +88,11 @@ Releases Current release: -- [c-parser-1.20.tar.gz][1.20] (Released 2023-11-03, Isabelle 2023) +- [c-parser-1.21.tar.gz][1.21] (Released 2024-10-11, Isabelle 2024) Older releases: +- [c-parser-1.20.tar.gz][1.20] (Released 2023-11-03, Isabelle 2023) - [c-parser-1.19.tar.gz][1.19] (Released 2022-10-31, Isabelle 2021-1) - [c-parser-1.18.tar.gz][1.18] (Released 2021-10-31, Isabelle 2021) - [c-parser-1.17.tar.gz][1.17] (Released 2020-11-02, Isabelle 2020) @@ -103,6 +104,7 @@ Older releases: - [c-parser-1.12.0.tar.gz][1.12] (Released 2012-12-05, Isabelle 2012) - [c-parser-1.0.tar.gz][1.0] (Released 2012-09-24, Isabelle 2011-1) +[1.21]: https://github.com/seL4/l4v/releases/download/autocorres-1.11/c-parser-1.21.tar.gz [1.20]: https://github.com/seL4/l4v/releases/download/autocorres-1.10/c-parser-1.20.tar.gz [1.19]: https://github.com/seL4/l4v/releases/download/autocorres-1.9/c-parser-1.19.tar.gz [1.18]: https://github.com/seL4/l4v/releases/download/autocorres-1.8/c-parser-1.18.tar.gz diff --git a/tools/c-parser/RELEASES.md b/tools/c-parser/RELEASES.md index 58c9473433..29a47a33cb 100644 --- a/tools/c-parser/RELEASES.md +++ b/tools/c-parser/RELEASES.md @@ -162,3 +162,10 @@ - Builds with Isabelle2023 - Rearranged library session structure and included more libraries for heap reasoning in the release. See e.g. files TypHeapLib.thy and LemmaBucket_C.thy + +## 1.21 + +- Builds with Isabelle2024 +- Updated SIMPL from the AFP +- Ensure that umm_types.txt is saved relative to theory file +- If cpp_path is relative, make it relative to the current theory diff --git a/tools/c-parser/mkrelease b/tools/c-parser/mkrelease index 97afbdddd4..5dc135dae5 100755 --- a/tools/c-parser/mkrelease +++ b/tools/c-parser/mkrelease @@ -12,8 +12,8 @@ set -e case $(uname) in - Darwin* ) TAR=gtar ; SEDIOPT="-i ''" ;; - * ) TAR=tar ; SEDIOPT=-i ;; + Darwin* ) TAR=gtar ;; + * ) TAR=tar ;; esac @@ -145,18 +145,20 @@ echo "Hacking Makefile to remove ROOT generation." if ! grep -q '^testfiles/\$(L4V_ARCH)/ROOT' "$outputdir/src/c-parser/Makefile"; then die "failed to process c-parser/Makefile" fi -sed $SEDIOPT \ +sed -i .bak \ -e '/^testfiles\/\$(L4V_ARCH)\/ROOT/,/CParserTest/d' \ -e '/^all_tests_\$(L4V_ARCH)\.thy/,/CParser/d' \ "$outputdir/src/c-parser/Makefile" +rm -f "$outputdir/src/c-parser/Makefile.bak" echo "Hacking Makefile to change root dir." if ! grep -q '^L4V_ROOT_DIR = ' "$outputdir/src/c-parser/Makefile"; then die "failed to process c-parser/Makefile" fi -sed $SEDIOPT \ +sed -i .bak \ -e 's/^L4V_ROOT_DIR = .*$/L4V_ROOT_DIR = ../' \ "$outputdir/src/c-parser/Makefile" +rm -f "$outputdir/src/c-parser/Makefile.bak" echo "Generating standalone-parser/table.ML" pushd "$TOPLEVEL_DIR/tools/c-parser" > /dev/null @@ -165,10 +167,10 @@ pushd "$TOPLEVEL_DIR/tools/c-parser" > /dev/null cp standalone-parser/table.ML "$outputdir/src/c-parser/standalone-parser" echo "Cleaning up standalone-parser's Makefile" sed ' - 1i\ - SML_COMPILER ?= mlton + /^STP_PFX :=/i\ +SML_COMPILER ?= mlton /^include/d - /General\/table.ML/,/pretty-printing/d + /General\/table.ML/,/unsynchronized_cache/d /ISABELLE_HOME/d /CLEAN_TARGETS/s|\$(STP_PFX)/table.ML|| ' < standalone-parser/Makefile > "$outputdir/src/c-parser/standalone-parser/Makefile" @@ -177,7 +179,7 @@ popd > /dev/null echo "Making PDF of ctranslation file." cd "$outputdir/src/c-parser/doc" make ctranslation.pdf > /dev/null -/bin/rm ctranslation.{log,aux,blg,bbl,toc} +/bin/rm -f ctranslation.{log,aux,blg,bbl,toc} mv ctranslation.pdf "$outputdir/doc" popd > /dev/null