From 8228bf74042121ca8fbe5b1b801622bd854097ac Mon Sep 17 00:00:00 2001
From: Gerwin Klein <gerwin.klein@proofcraft.systems>
Date: Sun, 1 Sep 2024 11:35:00 +0100
Subject: [PATCH 01/31] word_lib: shiftr is always less than max word

Signed-off-by: Gerwin Klein <gerwin.klein@proofcraft.systems>
---
 lib/Word_Lib/Word_Lemmas_Internal.thy | 5 +++++
 1 file changed, 5 insertions(+)

diff --git a/lib/Word_Lib/Word_Lemmas_Internal.thy b/lib/Word_Lib/Word_Lemmas_Internal.thy
index 8e57f22407..a136098823 100644
--- a/lib/Word_Lib/Word_Lemmas_Internal.thy
+++ b/lib/Word_Lib/Word_Lemmas_Internal.thy
@@ -933,6 +933,11 @@ lemma shiftr_not_max_word:
   "0 < n \<Longrightarrow> w >> n \<noteq> 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 \<Longrightarrow> 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"

From 40e0fb49cfaba2aaa403d30c22c988d77ce66256 Mon Sep 17 00:00:00 2001
From: Gerwin Klein <gerwin.klein@proofcraft.systems>
Date: Fri, 30 Aug 2024 16:56:23 +0100
Subject: [PATCH 02/31] haskell: mark cacheLineBits as defined in Isabelle

Signed-off-by: Gerwin Klein <gerwin.klein@proofcraft.systems>
---
 spec/haskell/src/SEL4/Machine/Hardware/ARM/Exynos4210.hs | 5 ++---
 spec/haskell/src/SEL4/Machine/Hardware/ARM/KZM.hs        | 5 ++---
 spec/haskell/src/SEL4/Machine/Hardware/ARM/Sabre.hs      | 5 ++---
 spec/haskell/src/SEL4/Machine/Hardware/ARM/TK1.hs        | 5 ++---
 4 files changed, 8 insertions(+), 12 deletions(-)

diff --git a/spec/haskell/src/SEL4/Machine/Hardware/ARM/Exynos4210.hs b/spec/haskell/src/SEL4/Machine/Hardware/ARM/Exynos4210.hs
index ddb5547a72..3a73f7ce6a 100644
--- a/spec/haskell/src/SEL4/Machine/Hardware/ARM/Exynos4210.hs
+++ b/spec/haskell/src/SEL4/Machine/Hardware/ARM/Exynos4210.hs
@@ -164,9 +164,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 f53bc143fb..b4523ddbf3 100644
--- a/spec/haskell/src/SEL4/Machine/Hardware/ARM/KZM.hs
+++ b/spec/haskell/src/SEL4/Machine/Hardware/ARM/KZM.hs
@@ -161,9 +161,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 9ffd5ee5eb..601c9c5dc4 100644
--- a/spec/haskell/src/SEL4/Machine/Hardware/ARM/Sabre.hs
+++ b/spec/haskell/src/SEL4/Machine/Hardware/ARM/Sabre.hs
@@ -161,9 +161,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"

From 13dbe963a3b0b410c6df470ec74debab5d584ab2 Mon Sep 17 00:00:00 2001
From: Gerwin Klein <gerwin.klein@proofcraft.systems>
Date: Fri, 30 Aug 2024 16:56:55 +0100
Subject: [PATCH 03/31] arm+arm-hyp+aarch64 machine: cacheLineBits from kernel
 config

Use generated CONFIG_L1_CACHE_LINE_SIZE_BITS as source of truth for
the value of cacheLineBits

The requirements for cacheLineBits are numeric: we need more than 1 and
less than or equal to ptBits, which is only available as a constant
after ExecSpec.

1 is excluded, because we want to be able to fold the value of
cacheLineBits inside C cache operations, and 1 is mentioned as index
increment. No other numerals conflict in these functions.

The only observed values for cacheLineBits are 5 and 6 on Arm, but
there is no need to be more restrictive than cacheLineBits_sanity.

Signed-off-by: Gerwin Klein <gerwin.klein@proofcraft.systems>
---
 spec/machine/AARCH64/Arch_Kernel_Config_Lemmas.thy | 11 +++++++++++
 spec/machine/AARCH64/Platform.thy                  |  3 +++
 spec/machine/ARM/Arch_Kernel_Config_Lemmas.thy     | 11 +++++++++++
 spec/machine/ARM/Platform.thy                      |  2 +-
 spec/machine/ARM_HYP/Arch_Kernel_Config_Lemmas.thy | 11 +++++++++++
 spec/machine/ARM_HYP/Platform.thy                  |  2 +-
 6 files changed, 38 insertions(+), 2 deletions(-)

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 \<in> {2..12}"
+  by (simp add: cacheLineBits_def Kernel_Config.CONFIG_L1_CACHE_LINE_SIZE_BITS_def)
+
 end
 end
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 \<equiv> 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 \<in> {2..10}"
+  by (simp add: cacheLineBits_def Kernel_Config.CONFIG_L1_CACHE_LINE_SIZE_BITS_def)
+
 end
 end
diff --git a/spec/machine/ARM/Platform.thy b/spec/machine/ARM/Platform.thy
index 79a6ad7bbe..501e1ed663 100644
--- a/spec/machine/ARM/Platform.thy
+++ b/spec/machine/ARM/Platform.thy
@@ -43,7 +43,7 @@ definition pageColourBits :: nat where
   "pageColourBits \<equiv> 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 \<in> {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/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 \<equiv> 2"
 
 definition cacheLineBits :: nat where
-  "cacheLineBits = 6"
+  "cacheLineBits = CONFIG_L1_CACHE_LINE_SIZE_BITS"
 
 definition cacheLine :: nat where
   "cacheLine = 2^cacheLineBits"

From 4acd9db63cb6f5605d10fbaf7a426af4d9b5db3f Mon Sep 17 00:00:00 2001
From: Gerwin Klein <gerwin.klein@proofcraft.systems>
Date: Fri, 30 Aug 2024 16:59:00 +0100
Subject: [PATCH 04/31] x64 machine: remove unused cacheLineBits

Signed-off-by: Gerwin Klein <gerwin.klein@proofcraft.systems>
---
 spec/machine/X64/Platform.thy | 8 --------
 1 file changed, 8 deletions(-)

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 \<Rightarrow> word64" where
   "ptrFromPAddr paddr \<equiv> paddr + pptrBase"

From 9bcac415227d351141ce84e3e6ffe9c597f8526c Mon Sep 17 00:00:00 2001
From: Gerwin Klein <gerwin.klein@proofcraft.systems>
Date: Fri, 30 Aug 2024 17:11:50 +0100
Subject: [PATCH 05/31] arm+arm-hyp ainvs: remove unfoldings of cacheLineBits

None of the unfoldings of cacheLineBits turn out to be necessary.

Signed-off-by: Gerwin Klein <gerwin.klein@proofcraft.systems>
---
 proof/invariant-abstract/ARM/ArchVSpace_AI.thy | 10 +++-------
 proof/invariant-abstract/ARM/Machine_AI.thy    | 18 +++++-------------
 .../ARM_HYP/ArchVSpace_AI.thy                  | 10 +++-------
 .../invariant-abstract/ARM_HYP/Machine_AI.thy  | 16 +++++-----------
 4 files changed, 16 insertions(+), 38 deletions(-)

diff --git a/proof/invariant-abstract/ARM/ArchVSpace_AI.thy b/proof/invariant-abstract/ARM/ArchVSpace_AI.thy
index 765c51f107..00ae764be0 100644
--- a/proof/invariant-abstract/ARM/ArchVSpace_AI.thy
+++ b/proof/invariant-abstract/ARM/ArchVSpace_AI.thy
@@ -3409,17 +3409,13 @@ lemma unmap_page_table_unmapped2:
 lemma cacheRangeOp_lift[wp]:
   assumes o: "\<And>a b. \<lbrace>P\<rbrace> oper a b \<lbrace>\<lambda>_. P\<rbrace>"
   shows "\<lbrace>P\<rbrace> cacheRangeOp oper x y z \<lbrace>\<lambda>_. P\<rbrace>"
-  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]:
-  "\<lbrace>\<lambda>m'. underlying_memory m' p = um\<rbrace> cleanCacheRange_PoU a b c \<lbrace>\<lambda>_ m'. underlying_memory m' p = um\<rbrace>"
+  "cleanCacheRange_PoU a b c \<lbrace>\<lambda>m'. underlying_memory m' p = um\<rbrace>"
   by (clarsimp simp: cleanCacheRange_PoU_def, wp)
 
-
 lemma unmap_page_table_unmapped3:
   "\<lbrace>pspace_aligned and valid_vspace_objs and page_table_at pt and
       K (ref = [VSRef (vaddr >> 20) (Some APageDirectory),
diff --git a/proof/invariant-abstract/ARM/Machine_AI.thy b/proof/invariant-abstract/ARM/Machine_AI.thy
index 9415eb5759..f058abfa14 100644
--- a/proof/invariant-abstract/ARM/Machine_AI.thy
+++ b/proof/invariant-abstract/ARM/Machine_AI.thy
@@ -270,9 +270,8 @@ lemma no_fail_invalidateCacheRange_I[simp, wp]:
 
 lemma no_fail_invalidateCacheRange_RAM[simp, wp]:
   "no_fail \<top> (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 \<top> (branchFlushRange s e p)"
@@ -586,7 +585,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
 
@@ -701,17 +700,10 @@ lemma empty_fail_flushBTAC: "empty_fail  flushBTAC"
 lemma empty_fail_writeContextID: "empty_fail  writeContextID"
   by (simp add: writeContextID_def)
 
-
-
 lemma empty_fail_cacheRangeOp [simp, intro!]:
   assumes ef: "\<And>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)"
@@ -736,7 +728,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!]:
diff --git a/proof/invariant-abstract/ARM_HYP/ArchVSpace_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchVSpace_AI.thy
index 18cf5c470a..7566151c4d 100644
--- a/proof/invariant-abstract/ARM_HYP/ArchVSpace_AI.thy
+++ b/proof/invariant-abstract/ARM_HYP/ArchVSpace_AI.thy
@@ -4484,17 +4484,13 @@ lemma unmap_page_table_unmapped2:
 lemma cacheRangeOp_lift[wp]:
   assumes o: "\<And>a b. \<lbrace>P\<rbrace> oper a b \<lbrace>\<lambda>_. P\<rbrace>"
   shows "\<lbrace>P\<rbrace> cacheRangeOp oper x y z \<lbrace>\<lambda>_. P\<rbrace>"
-  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]:
-  "\<lbrace>\<lambda>m'. underlying_memory m' p = um\<rbrace> cleanCacheRange_PoU a b c \<lbrace>\<lambda>_ m'. underlying_memory m' p = um\<rbrace>"
+  "cleanCacheRange_PoU a b c \<lbrace>\<lambda>m'. underlying_memory m' p = um\<rbrace>"
   by (clarsimp simp: cleanCacheRange_PoU_def, wp)
 
-
 lemma unmap_page_table_unmapped3:
   "\<lbrace>pspace_aligned and valid_vspace_objs and page_table_at pt and
       K (ref = [VSRef (vaddr >> 21) (Some APageDirectory),
diff --git a/proof/invariant-abstract/ARM_HYP/Machine_AI.thy b/proof/invariant-abstract/ARM_HYP/Machine_AI.thy
index 759dc4c9b9..16c70721cb 100644
--- a/proof/invariant-abstract/ARM_HYP/Machine_AI.thy
+++ b/proof/invariant-abstract/ARM_HYP/Machine_AI.thy
@@ -279,9 +279,8 @@ lemma no_fail_invalidateCacheRange_I[simp, wp]:
 
 lemma no_fail_invalidateCacheRange_RAM[simp, wp]:
   "no_fail \<top> (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 \<top> (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: "\<And>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!]:

From 99286f3cd4f28d49060dd0652f488161ada62af5 Mon Sep 17 00:00:00 2001
From: Gerwin Klein <gerwin.klein@proofcraft.systems>
Date: Sun, 1 Sep 2024 18:07:50 +0100
Subject: [PATCH 06/31] arm-hyp ainvs+crefine: move masking lemmas for
 cacheLineBits

addrFromPPtr_mask and ptrFromPAddr_mask are only needed for masking with
cacheLineBits in CRefine. Move to CRefine where the rest of the
cacheLineBits infrastructure is.

Signed-off-by: Gerwin Klein <gerwin.klein@proofcraft.systems>
---
 proof/crefine/ARM_HYP/Wellformed_C.thy        | 23 +++++++++++++++++++
 .../ARM_HYP/ArchInvariants_AI.thy             | 18 ---------------
 2 files changed, 23 insertions(+), 18 deletions(-)

diff --git a/proof/crefine/ARM_HYP/Wellformed_C.thy b/proof/crefine/ARM_HYP/Wellformed_C.thy
index c5dae8cd44..b65fde118e 100644
--- a/proof/crefine/ARM_HYP/Wellformed_C.thy
+++ b/proof/crefine/ARM_HYP/Wellformed_C.thy
@@ -529,6 +529,29 @@ lemma ucast_irq_array_guard[unfolded irq_array_size_val, simplified]:
   apply simp
   done
 
+
+text \<open>cacheLineBits interface\<close>
+
+lemma addrFromPPtr_mask_SuperSection:
+  "n \<le> pageBitsForSize ARMSuperSection
+   \<Longrightarrow> 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 \<le> pageBitsForSize ARMSuperSection
+   \<Longrightarrow> 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
+
+(* ------------ *)
+
 (* Input abbreviations for API object types *)
 (* disambiguates names *)
 
diff --git a/proof/invariant-abstract/ARM_HYP/ArchInvariants_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchInvariants_AI.thy
index 175dcedbac..e44be22bd9 100644
--- a/proof/invariant-abstract/ARM_HYP/ArchInvariants_AI.thy
+++ b/proof/invariant-abstract/ARM_HYP/ArchInvariants_AI.thy
@@ -2624,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 \<le> pageBitsForSize ARMSuperSection
-   \<Longrightarrow> 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 \<le> pageBitsForSize ARMSuperSection
-   \<Longrightarrow> 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]

From 4d502fe251e520df3dc872eca5f850aaf2c38e77 Mon Sep 17 00:00:00 2001
From: Gerwin Klein <gerwin.klein@proofcraft.systems>
Date: Sun, 1 Sep 2024 10:53:01 +0100
Subject: [PATCH 07/31] arm+arm-hyp crefine: make proof generic in
 cacheLineBits

Signed-off-by: Gerwin Klein <gerwin.klein@proofcraft.systems>
---
 proof/crefine/ARM/ArchMove_C.thy       |   9 +-
 proof/crefine/ARM/Arch_C.thy           |  31 +++---
 proof/crefine/ARM/Invoke_C.thy         |   2 +-
 proof/crefine/ARM/Machine_C.thy        | 144 +++++++++++++------------
 proof/crefine/ARM/Recycle_C.thy        |   3 +-
 proof/crefine/ARM/Retype_C.thy         |   4 +-
 proof/crefine/ARM/VSpace_C.thy         |  23 ++--
 proof/crefine/ARM/Wellformed_C.thy     |  57 ++++++++++
 proof/crefine/ARM_HYP/ArchMove_C.thy   |  11 --
 proof/crefine/ARM_HYP/Arch_C.thy       |  13 +--
 proof/crefine/ARM_HYP/Invoke_C.thy     |   2 +-
 proof/crefine/ARM_HYP/Machine_C.thy    | 136 ++++++++++++-----------
 proof/crefine/ARM_HYP/Retype_C.thy     |   3 +-
 proof/crefine/ARM_HYP/VSpace_C.thy     |  28 +++--
 proof/crefine/ARM_HYP/Wellformed_C.thy |  61 ++++++++++-
 15 files changed, 315 insertions(+), 212 deletions(-)

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 \<le> pageBitsForSize ARMSuperSection
    \<Longrightarrow> 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 \<le> ... 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 31a8f5bb37..167279e00d 100644
--- a/proof/crefine/ARM/Arch_C.thy
+++ b/proof/crefine/ARM/Arch_C.thy
@@ -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 \<le> 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\<close>
             | solves \<open>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\<close>)+)[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 \<le> 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/Invoke_C.thy b/proof/crefine/ARM/Invoke_C.thy
index 524f811aeb..6489c5f838 100644
--- a/proof/crefine/ARM/Invoke_C.thy
+++ b/proof/crefine/ARM/Invoke_C.thy
@@ -1555,7 +1555,7 @@ lemma clearMemory_untyped_ccorres:
                         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 simp
   apply (cases "ptr = 0")
    apply (drule subsetD, rule intvl_self, simp)
    apply (simp split: if_split_asm)
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 \<le> y \<Longrightarrow> lineStart x \<le> 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:
-  "\<lbrakk> x && mask 5 = y && mask 5\<rbrakk> \<Longrightarrow> lineStart (x - y) = lineStart x - lineStart y"
-  apply (clarsimp simp: lineStart_def cacheLineBits_def shiftr_shiftl1)
+  "\<lbrakk> x && mask cacheLineBits = y && mask cacheLineBits\<rbrakk> \<Longrightarrow> 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:
-  "\<lbrakk>w1 \<le> w2; w3 \<le> w3 + (w2 - w1); w1 && mask 5 = w3 && mask 5\<rbrakk>
-   \<Longrightarrow> unat (lineStart w2 - lineStart w1) div 32 =
-           unat (lineStart (w3 + (w2 - w1)) - lineStart w3) div 32"
+  "\<lbrakk>w1 \<le> w2; w3 \<le> w3 + (w2 - w1); w1 && mask cacheLineBits = w3 && mask cacheLineBits\<rbrakk>
+   \<Longrightarrow> 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 \<le> y \<Longrightarrow> lineIndex x \<le> lineIndex y"
-  by (clarsimp simp: lineIndex_def2 cacheLineBits_def le_shiftr)
+  by (clarsimp simp: lineIndex_def2 le_shiftr)
 
 lemma lineIndex_lineStart_diff:
-  "w1 \<le> w2 \<Longrightarrow> (unat (lineStart w2 - lineStart w1) div 32) = unat (lineIndex w2 - lineIndex w1)"
-  apply (subst shiftr_div_2n'[symmetric, where n=5, simplified])
+  "w1 \<le> w2 \<Longrightarrow>
+   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:
   "\<lbrakk>\<And>x y. empty_fail (oper x y);
     \<forall>n. ccorres dc xfdc \<top> (\<lbrace>\<acute>index = lineIndex w1 + of_nat n\<rbrace>) 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;
    \<forall>s. \<Gamma>\<turnstile>\<^bsub>/UNIV\<^esub> {s} f ({t. index_' t = index_' s}) \<rbrakk> \<Longrightarrow>
    ccorres dc xfdc (\<lambda>_. w1 \<le> w2 \<and> w3 \<le> w3 + (w2 - w1)
-                      \<and> w1 && mask 5 = w3 && mask 5)
-                   (\<lbrace>\<acute>index = w1 >> 5\<rbrace>) hs
+                      \<and> w1 && mask cacheLineBits = w3 && mask cacheLineBits)
+                   (\<lbrace>\<acute>index = w1 >> cacheLineBits\<rbrace>) hs
            (doMachineOp (cacheRangeOp oper w1 w2 w3))
-           (While \<lbrace>\<acute>index < (w2 >> 5) + 1\<rbrace>
+           (While \<lbrace>\<acute>index < (w2 >> cacheLineBits) + 1\<rbrace>
              (f;; \<acute>index :== \<acute>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=\<top>, 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 (\<lambda>_. w1 \<le> w2 \<and> w3 \<le> w3 + (w2 - w1)
-                      \<and> w1 && mask 5 = w3 && mask 5)
+                      \<and> w1 && mask cacheLineBits = w3 && mask cacheLineBits)
                    (\<lbrace>\<acute>start = w1\<rbrace> \<inter> \<lbrace>\<acute>end = w2\<rbrace> \<inter> \<lbrace>\<acute>pstart = w3\<rbrace>) []
            (doMachineOp (cleanCacheRange_PoC w1 w2 w3))
            (Call cleanCacheRange_PoC_'proc)"
   apply (rule ccorres_gen_asm[where G=\<top>, 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 ((\<lambda>s. unat (w2 - w1) \<le> gsMaxObjectSize s)
-                      and (\<lambda>_. w1 \<le> w2 \<and> w3 \<le> w3 + (w2 - w1)
-                      \<and> w1 && mask 5 = w3 && mask 5 \<and> unat (w2 - w2) \<le> gsMaxObjectSize s))
-                   (\<lbrace>\<acute>start = w1\<rbrace> \<inter> \<lbrace>\<acute>end = w2\<rbrace> \<inter> \<lbrace>\<acute>pstart = w3\<rbrace>) []
+  "ccorres dc xfdc
+           ((\<lambda>s. unat (w2 - w1) \<le> gsMaxObjectSize s) and
+            (\<lambda>_. w1 \<le> w2 \<and> w3 \<le> w3 + (w2 - w1) \<and>
+            w1 && mask cacheLineBits = w3 && mask cacheLineBits \<and>
+            unat (w2 - w2) \<le> gsMaxObjectSize s))
+           (\<lbrace>\<acute>start = w1\<rbrace> \<inter> \<lbrace>\<acute>end = w2\<rbrace> \<inter> \<lbrace>\<acute>pstart = w3\<rbrace>) []
            (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 (\<lambda>s. w1 \<le> w2 \<and> w3 \<le> w3 + (w2 - w1)
-                      \<and> w1 && mask 5 = w3 && mask 5
+                      \<and> w1 && mask cacheLineBits = w3 && mask cacheLineBits
                       \<and> unat (w2 - w1) \<le> gsMaxObjectSize s)
                    (\<lbrace>\<acute>start = w1\<rbrace> \<inter> \<lbrace>\<acute>end = w2\<rbrace> \<inter> \<lbrace>\<acute>pstart = w3\<rbrace>) []
            (doMachineOp (cleanCacheRange_RAM w1 w2 w3))
@@ -493,12 +500,13 @@ lemma cleanCacheRange_RAM_ccorres:
 lemma cleanCacheRange_PoU_ccorres:
   "ccorres dc xfdc ((\<lambda>s. unat (w2 - w1) \<le> gsMaxObjectSize s)
                     and (\<lambda>_. w1 \<le> w2 \<and> w3 \<le> w3 + (w2 - w1)
-                      \<and> w1 && mask 5 = w3 && mask 5))
+                      \<and> w1 && mask cacheLineBits = w3 && mask cacheLineBits))
                    (\<lbrace>\<acute>start = w1\<rbrace> \<inter> \<lbrace>\<acute>end = w2\<rbrace> \<inter> \<lbrace>\<acute>pstart = w3\<rbrace>) []
            (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 ((\<lambda>s. unat (w2 - w1) \<le> gsMaxObjectSize s)
                     and (\<lambda>_. w1 \<le> w2 \<and> w3 \<le> w3 + (w2 - w1)
-                      \<and> w1 && mask 5 = w3 && mask 5))
+                      \<and> w1 && mask cacheLineBits = w3 && mask cacheLineBits))
                    (\<lbrace>\<acute>start = w1\<rbrace> \<inter> \<lbrace>\<acute>end = w2\<rbrace> \<inter> \<lbrace>\<acute>pstart = w3\<rbrace>) []
            (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=\<top>])
-         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=\<top>])
-           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="\<lambda>s. unat (w2 - w1) \<le> gsMaxObjectSize s"
-          in ccorres_cross_over_guard)
+       apply (rule_tac P="\<lambda>s. unat (w2 - w1) \<le> 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 (\<lambda>_. w1 \<le> w2 \<and> w3 \<le> w3 + (w2 - w1)
-                      \<and> w1 && mask 5 = w3 && mask 5)
+                      \<and> w1 && mask cacheLineBits = w3 && mask cacheLineBits)
                    (\<lbrace>\<acute>start = w1\<rbrace> \<inter> \<lbrace>\<acute>end = w2\<rbrace> \<inter> \<lbrace>\<acute>pstart = w3\<rbrace>) []
            (doMachineOp (invalidateCacheRange_I w1 w2 w3))
            (Call invalidateCacheRange_I_'proc)"
   apply (rule ccorres_gen_asm[where G=\<top>, 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 (\<lambda>_. w1 \<le> w2 \<and> w3 \<le> w3 + (w2 - w1)
-                      \<and> w1 && mask 5 = w3 && mask 5)
+                      \<and> w1 && mask cacheLineBits = w3 && mask cacheLineBits)
                    (\<lbrace>\<acute>start = w1\<rbrace> \<inter> \<lbrace>\<acute>end = w2\<rbrace> \<inter> \<lbrace>\<acute>pstart = w3\<rbrace>) []
            (doMachineOp (branchFlushRange w1 w2 w3))
            (Call branchFlushRange_'proc)"
   apply (rule ccorres_gen_asm[where G=\<top>, 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/Recycle_C.thy b/proof/crefine/ARM/Recycle_C.thy
index 79d6f27ec5..df3ff05be3 100644
--- a/proof/crefine/ARM/Recycle_C.thy
+++ b/proof/crefine/ARM/Recycle_C.thy
@@ -444,7 +444,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/Retype_C.thy b/proof/crefine/ARM/Retype_C.thy
index b0b5fd33ec..45dacb619c 100644
--- a/proof/crefine/ARM/Retype_C.thy
+++ b/proof/crefine/ARM/Retype_C.thy
@@ -4745,7 +4745,9 @@ proof -
        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)+
+                            field_simps is_aligned_mask[symmetric] mask_AND_less_0
+                            cacheLineBits_le_PageDirectoryObject_sz[unfolded APIType_capBits_def,
+                                                                    simplified])+
     done
 qed
 
diff --git a/proof/crefine/ARM/VSpace_C.thy b/proof/crefine/ARM/VSpace_C.thy
index da66e3ee3e..407b485ab9 100644
--- a/proof/crefine/ARM/VSpace_C.thy
+++ b/proof/crefine/ARM/VSpace_C.thy
@@ -1563,8 +1563,10 @@ definition
   | ARM_H.flush_type.Unify \<Rightarrow> (label = Kernel_C.ARMPageUnify_Instruction \<or> label = Kernel_C.ARMPDUnify_Instruction)"
 
 lemma doFlush_ccorres:
-  "ccorres dc xfdc (\<lambda>s. vs \<le> ve \<and> ps \<le> ps + (ve - vs) \<and> vs && mask 5 = ps && mask 5
-        \<and> unat (ve - vs) \<le> gsMaxObjectSize s)
+  "ccorres dc xfdc
+     (\<lambda>s. vs \<le> ve \<and> ps \<le> ps + (ve - vs) \<and>
+          vs && mask cacheLineBits = ps && mask cacheLineBits \<and>
+          unat (ve - vs) \<le> gsMaxObjectSize s)
      (\<lbrace>flushtype_relation t \<acute>invLabel___int\<rbrace> \<inter> \<lbrace>\<acute>start = vs\<rbrace> \<inter> \<lbrace>\<acute>end = ve\<rbrace> \<inter> \<lbrace>\<acute>pstart = ps\<rbrace>) []
      (doMachineOp (doFlush t vs ve ps)) (Call doFlush_'proc)"
   apply (cinit' lift: pstart_')
@@ -1626,7 +1628,7 @@ context kernel_m begin
 lemma performPageFlush_ccorres:
   "ccorres (K (K \<bottom>) \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
        (invs' and K (asid \<le> mask asid_bits)
-              and (\<lambda>s. ps \<le> ps + (ve - vs) \<and> vs && mask 5 = ps && mask 5
+              and (\<lambda>s. ps \<le> ps + (ve - vs) \<and> vs && mask cacheLineBits = ps && mask cacheLineBits
                   \<and> unat (ve - vs) \<le> gsMaxObjectSize s))
        (\<lbrace>\<acute>pd = Ptr pd\<rbrace> \<inter> \<lbrace>\<acute>asid = asid\<rbrace> \<inter>
                \<lbrace>\<acute>start = vs\<rbrace> \<inter> \<lbrace>\<acute>end =  ve\<rbrace> \<inter> \<lbrace>\<acute>pstart = ps\<rbrace> \<inter> \<lbrace>flushtype_relation typ \<acute>invLabel___int \<rbrace>)
@@ -1757,7 +1759,7 @@ lemma setMessageInfo_ccorres:
 lemma performPageDirectoryInvocationFlush_ccorres:
   "ccorres (K (K \<bottom>) \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
        (invs' and K (asid \<le> mask asid_bits)
-              and (\<lambda>s. ps \<le> ps + (ve - vs) \<and> vs && mask 5 = ps && mask 5
+              and (\<lambda>s. ps \<le> ps + (ve - vs) \<and> vs && mask cacheLineBits = ps && mask cacheLineBits
                   \<and> unat (ve - vs) \<le> gsMaxObjectSize s))
        (\<lbrace>\<acute>pd = Ptr pd\<rbrace> \<inter> \<lbrace>\<acute>asid = asid\<rbrace> \<inter>
                \<lbrace>\<acute>start = vs\<rbrace> \<inter> \<lbrace>\<acute>end =  ve\<rbrace> \<inter> \<lbrace>\<acute>pstart = ps\<rbrace> \<inter> \<lbrace>flushtype_relation typ \<acute>invLabel___int \<rbrace>)
@@ -1948,18 +1950,13 @@ lemma ccorres_return_void_C':
   done
 
 lemma is_aligned_cache_preconds:
-  "\<lbrakk>is_aligned rva n; n \<ge> 6\<rbrakk> \<Longrightarrow> rva \<le> rva + 0x3F \<and>
-          addrFromPPtr rva \<le> addrFromPPtr rva + 0x3F \<and> rva && mask 5 = addrFromPPtr rva && mask 5"
+  "\<lbrakk> is_aligned rva n; n \<ge> 6 \<rbrakk> \<Longrightarrow> rva \<le> rva + 0x3F \<and> addrFromPPtr rva \<le> 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 e2c6c7805d..caa878d9bf 100644
--- a/proof/crefine/ARM/Wellformed_C.thy
+++ b/proof/crefine/ARM/Wellformed_C.thy
@@ -495,6 +495,63 @@ lemma ucast_irq_array_guard[unfolded irq_array_size_val, simplified]:
   done
 
 
+text \<open>cacheLineBits interface\<close>
+
+(* 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 \<le> ptBits"
+  using cacheLineBits_sanity
+  by (simp add: ptBits_def pteBits_def)
+
+lemma ptBits_leq_pageBits:
+  "ptBits \<le> pageBits"
+  by (simp add: ptBits_def pageBits_def pteBits_def)
+
+lemma ptBits_leq_pdBits:
+  "ptBits \<le> pdBits"
+  by (simp add: ptBits_def pdBits_def pteBits_def)
+
+lemma cacheLineBits_leq_pageBits:
+  "cacheLineBits \<le> pageBits"
+  using ptBits_leq_pageBits cacheLineBits_le_ptBits
+  by simp
+
+lemma cacheLineBits_leq_pdBits:
+  "cacheLineBits \<le> 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 \<le> APIType_capBits PageDirectoryObject us"
+  by (simp add: APIType_capBits_PageDirectoryObject_pdBits cacheLineBits_leq_pdBits)
+
+lemma cacheLineBits_leq_pbfs:
+  "cacheLineBits \<le> 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/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 \<le> ... 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 78f7debf44..0ead82e81a 100644
--- a/proof/crefine/ARM_HYP/Arch_C.thy
+++ b/proof/crefine/ARM_HYP/Arch_C.thy
@@ -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 \<open>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\<close>),
             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:
 
            \<comment> \<open>cache flush constraints\<close>
            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/Invoke_C.thy b/proof/crefine/ARM_HYP/Invoke_C.thy
index 84432c6231..0811a0756d 100644
--- a/proof/crefine/ARM_HYP/Invoke_C.thy
+++ b/proof/crefine/ARM_HYP/Invoke_C.thy
@@ -1715,7 +1715,7 @@ lemma clearMemory_untyped_ccorres:
                         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 simp
   apply (cases "ptr = 0")
    apply (drule subsetD, rule intvl_self, simp)
    apply (simp split: if_split_asm)
diff --git a/proof/crefine/ARM_HYP/Machine_C.thy b/proof/crefine/ARM_HYP/Machine_C.thy
index 2ad8e55adf..81a08b6acf 100644
--- a/proof/crefine/ARM_HYP/Machine_C.thy
+++ b/proof/crefine/ARM_HYP/Machine_C.thy
@@ -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 \<le> y \<Longrightarrow> lineStart x \<le> 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:
-  "\<lbrakk> x && mask 6 = y && mask 6\<rbrakk> \<Longrightarrow> lineStart (x - y) = lineStart x - lineStart y"
-  apply (clarsimp simp: lineStart_def cacheLineBits_def shiftr_shiftl1)
+  "\<lbrakk> x && mask cacheLineBits = y && mask cacheLineBits\<rbrakk> \<Longrightarrow> 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:
-  "\<lbrakk>w1 \<le> w2; w3 \<le> w3 + (w2 - w1); w1 && mask 6 = w3 && mask 6\<rbrakk>
-   \<Longrightarrow> unat (lineStart w2 - lineStart w1) div 64 =
-           unat (lineStart (w3 + (w2 - w1)) - lineStart w3) div 64"
+  "\<lbrakk>w1 \<le> w2; w3 \<le> w3 + (w2 - w1); w1 && mask cacheLineBits = w3 && mask cacheLineBits\<rbrakk>
+   \<Longrightarrow> 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 \<le> y \<Longrightarrow> lineIndex x \<le> lineIndex y"
-  by (clarsimp simp: lineIndex_def2 cacheLineBits_def le_shiftr)
+  by (clarsimp simp: lineIndex_def2 le_shiftr)
 
 lemma lineIndex_lineStart_diff:
-  "w1 \<le> w2 \<Longrightarrow> (unat (lineStart w2 - lineStart w1) div 64) = unat (lineIndex w2 - lineIndex w1)"
-  apply (subst shiftr_div_2n'[symmetric, where n=6, simplified])
+  "w1 \<le> w2 \<Longrightarrow>
+   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:
   "\<lbrakk>\<And>x y. empty_fail (oper x y);
     \<forall>n. ccorres dc xfdc \<top> (\<lbrace>\<acute>index = lineIndex w1 + of_nat n\<rbrace>) 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;
    \<forall>s. \<Gamma>\<turnstile>\<^bsub>/UNIV\<^esub> {s} f ({t. index_' t = index_' s}) \<rbrakk> \<Longrightarrow>
    ccorres dc xfdc (\<lambda>_. w1 \<le> w2 \<and> w3 \<le> w3 + (w2 - w1)
-                      \<and> w1 && mask 6 = w3 && mask 6)
-                   (\<lbrace>\<acute>index = w1 >> 6\<rbrace>) hs
+                      \<and> w1 && mask cacheLineBits = w3 && mask cacheLineBits)
+                   (\<lbrace>\<acute>index = w1 >> cacheLineBits\<rbrace>) hs
            (doMachineOp (cacheRangeOp oper w1 w2 w3))
-           (While \<lbrace>\<acute>index < (w2 >> 6) + 1\<rbrace>
+           (While \<lbrace>\<acute>index < (w2 >> cacheLineBits) + 1\<rbrace>
              (f;; \<acute>index :== \<acute>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=\<top>, 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 (\<lambda>_. w1 \<le> w2 \<and> w3 \<le> w3 + (w2 - w1)
-                      \<and> w1 && mask 6 = w3 && mask 6)
+                      \<and> w1 && mask cacheLineBits = w3 && mask cacheLineBits)
                    (\<lbrace>\<acute>start = w1\<rbrace> \<inter> \<lbrace>\<acute>end = w2\<rbrace> \<inter> \<lbrace>\<acute>pstart = w3\<rbrace>) []
            (doMachineOp (cleanCacheRange_PoC w1 w2 w3))
            (Call cleanCacheRange_PoC_'proc)"
   apply (rule ccorres_gen_asm[where G=\<top>, 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 ((\<lambda>s. unat (w2 - w1) \<le> gsMaxObjectSize s)
-                      and (\<lambda>_. w1 \<le> w2 \<and> w3 \<le> w3 + (w2 - w1)
-                      \<and> w1 && mask 6 = w3 && mask 6 \<and> unat (w2 - w2) \<le> gsMaxObjectSize s))
-                   (\<lbrace>\<acute>start = w1\<rbrace> \<inter> \<lbrace>\<acute>end = w2\<rbrace> \<inter> \<lbrace>\<acute>pstart = w3\<rbrace>) []
+  "ccorres dc xfdc
+           ((\<lambda>s. unat (w2 - w1) \<le> gsMaxObjectSize s) and
+            (\<lambda>_. w1 \<le> w2 \<and> w3 \<le> w3 + (w2 - w1) \<and>
+            w1 && mask cacheLineBits = w3 && mask cacheLineBits \<and>
+            unat (w2 - w2) \<le> gsMaxObjectSize s))
+           (\<lbrace>\<acute>start = w1\<rbrace> \<inter> \<lbrace>\<acute>end = w2\<rbrace> \<inter> \<lbrace>\<acute>pstart = w3\<rbrace>) []
            (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 (\<lambda>s. w1 \<le> w2 \<and> w3 \<le> w3 + (w2 - w1)
-                      \<and> w1 && mask 6 = w3 && mask 6
+                      \<and> w1 && mask cacheLineBits = w3 && mask cacheLineBits
                       \<and> unat (w2 - w1) \<le> gsMaxObjectSize s)
                    (\<lbrace>\<acute>start = w1\<rbrace> \<inter> \<lbrace>\<acute>end = w2\<rbrace> \<inter> \<lbrace>\<acute>pstart = w3\<rbrace>) []
            (doMachineOp (cleanCacheRange_RAM w1 w2 w3))
@@ -640,12 +649,13 @@ lemma cleanCacheRange_RAM_ccorres:
 lemma cleanCacheRange_PoU_ccorres:
   "ccorres dc xfdc ((\<lambda>s. unat (w2 - w1) \<le> gsMaxObjectSize s)
                     and (\<lambda>_. w1 \<le> w2 \<and> w3 \<le> w3 + (w2 - w1)
-                      \<and> w1 && mask 6 = w3 && mask 6))
+                      \<and> w1 && mask cacheLineBits = w3 && mask cacheLineBits))
                    (\<lbrace>\<acute>start = w1\<rbrace> \<inter> \<lbrace>\<acute>end = w2\<rbrace> \<inter> \<lbrace>\<acute>pstart = w3\<rbrace>) []
            (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 ((\<lambda>s. unat (w2 - w1) \<le> gsMaxObjectSize s)
                     and (\<lambda>_. w1 \<le> w2 \<and> w3 \<le> w3 + (w2 - w1)
-                      \<and> w1 && mask 6 = w3 && mask 6))
+                      \<and> w1 && mask cacheLineBits = w3 && mask cacheLineBits))
                    (\<lbrace>\<acute>start = w1\<rbrace> \<inter> \<lbrace>\<acute>end = w2\<rbrace> \<inter> \<lbrace>\<acute>pstart = w3\<rbrace>) []
            (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=\<top>])
-         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=\<top>])
-           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="\<lambda>s. unat (w2 - w1) \<le> gsMaxObjectSize s"
-          in ccorres_cross_over_guard)
+       apply (rule_tac P="\<lambda>s. unat (w2 - w1) \<le> 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 (\<lambda>_. w1 \<le> w2 \<and> w3 \<le> w3 + (w2 - w1)
-                      \<and> w1 && mask 6 = w3 && mask 6)
+                      \<and> w1 && mask cacheLineBits = w3 && mask cacheLineBits)
                    (\<lbrace>\<acute>start = w1\<rbrace> \<inter> \<lbrace>\<acute>end = w2\<rbrace> \<inter> \<lbrace>\<acute>pstart = w3\<rbrace>) []
            (doMachineOp (invalidateCacheRange_I w1 w2 w3))
            (Call invalidateCacheRange_I_'proc)"
@@ -750,12 +758,13 @@ lemma invalidateCacheRange_I_ccorres:
 
 lemma branchFlushRange_ccorres:
   "ccorres dc xfdc (\<lambda>_. w1 \<le> w2 \<and> w3 \<le> w3 + (w2 - w1)
-                      \<and> w1 && mask 6 = w3 && mask 6)
+                      \<and> w1 && mask cacheLineBits = w3 && mask cacheLineBits)
                    (\<lbrace>\<acute>start = w1\<rbrace> \<inter> \<lbrace>\<acute>end = w2\<rbrace> \<inter> \<lbrace>\<acute>pstart = w3\<rbrace>) []
            (doMachineOp (branchFlushRange w1 w2 w3))
            (Call branchFlushRange_'proc)"
   apply (rule ccorres_gen_asm[where G=\<top>, 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/Retype_C.thy b/proof/crefine/ARM_HYP/Retype_C.thy
index a6762ccc4e..b257c9843c 100644
--- a/proof/crefine/ARM_HYP/Retype_C.thy
+++ b/proof/crefine/ARM_HYP/Retype_C.thy
@@ -5887,7 +5887,8 @@ proof -
     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]
+                              field_simps is_aligned_mask[symmetric] mask_AND_less_0
+                              cacheLineBits_le_ptBits[unfolded ptBits_def pteBits_def, simplified])+)[3]
     \<comment> \<open>VCPU\<close>
     apply (cinit' lift: t_' regionBase_' userSize_' deviceMemory_')
      apply (simp add: object_type_from_H_def Kernel_C_defs)
diff --git a/proof/crefine/ARM_HYP/VSpace_C.thy b/proof/crefine/ARM_HYP/VSpace_C.thy
index ef4d6dd55c..16a7b77a60 100644
--- a/proof/crefine/ARM_HYP/VSpace_C.thy
+++ b/proof/crefine/ARM_HYP/VSpace_C.thy
@@ -2668,10 +2668,12 @@ definition
   | ARM_HYP_H.flush_type.Unify \<Rightarrow> (label = Kernel_C.ARMPageUnify_Instruction \<or> label = Kernel_C.ARMPDUnify_Instruction)"
 
 lemma doFlush_ccorres:
-  "ccorres dc xfdc (\<lambda>s. vs \<le> ve \<and> ps \<le> ps + (ve - vs) \<and> vs && mask 6 = ps && mask 6
-        \<comment> \<open>ahyp version translates ps into kernel virtual before flushing\<close>
-        \<and> ptrFromPAddr ps \<le> ptrFromPAddr ps + (ve - vs)
-        \<and> unat (ve - vs) \<le> gsMaxObjectSize s)
+  "ccorres dc xfdc
+           (\<lambda>s. vs \<le> ve \<and> ps \<le> ps + (ve - vs)
+                \<and> vs && mask cacheLineBits = ps && mask cacheLineBits
+                \<comment> \<open>arm-hyp version translates ps into kernel virtual before flushing\<close>
+                \<and> ptrFromPAddr ps \<le> ptrFromPAddr ps + (ve - vs)
+                \<and> unat (ve - vs) \<le> gsMaxObjectSize s)
      (\<lbrace>flushtype_relation t \<acute>invLabel___int\<rbrace> \<inter> \<lbrace>\<acute>start = vs\<rbrace> \<inter> \<lbrace>\<acute>end = ve\<rbrace> \<inter> \<lbrace>\<acute>pstart = ps\<rbrace>) []
      (doMachineOp (doFlush t vs ve ps)) (Call doFlush_'proc)"
   apply (cinit' lift: pstart_')
@@ -2721,7 +2723,6 @@ 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
@@ -2738,7 +2739,7 @@ context kernel_m begin
 lemma performPageFlush_ccorres:
   "ccorres (K (K \<bottom>) \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
        (invs' and K (asid \<le> mask asid_bits)
-              and (\<lambda>s. ps \<le> ps + (ve - vs) \<and> vs && mask 6 = ps && mask 6
+              and (\<lambda>s. ps \<le> ps + (ve - vs) \<and> vs && mask cacheLineBits = ps && mask cacheLineBits
                   \<and> ptrFromPAddr ps \<le> ptrFromPAddr ps + (ve - vs)
                   \<and> unat (ve - vs) \<le> gsMaxObjectSize s))
        (\<lbrace>\<acute>pd = Ptr pd\<rbrace> \<inter> \<lbrace>\<acute>asid = asid\<rbrace> \<inter>
@@ -2911,7 +2912,7 @@ lemma setMessageInfo_ccorres:
 lemma performPageDirectoryInvocationFlush_ccorres:
   "ccorres (K (K \<bottom>) \<currency> dc) (liftxf errstate id (K ()) ret__unsigned_long_')
        (invs' and K (asid \<le> mask asid_bits)
-              and (\<lambda>s. ps \<le> ps + (ve - vs) \<and> vs && mask 6 = ps && mask 6
+              and (\<lambda>s. ps \<le> ps + (ve - vs) \<and> vs && mask cacheLineBits = ps && mask cacheLineBits
                   \<and> ptrFromPAddr ps \<le> ptrFromPAddr ps + (ve - vs)
                   \<and> unat (ve - vs) \<le> gsMaxObjectSize s))
        (\<lbrace>\<acute>pd = Ptr pd\<rbrace> \<inter> \<lbrace>\<acute>asid = asid\<rbrace> \<inter>
@@ -3129,18 +3130,13 @@ lemma ccorres_return_void_C':
   done
 
 lemma is_aligned_cache_preconds:
-  "\<lbrakk>is_aligned rva n; n \<ge> 7\<rbrakk> \<Longrightarrow> rva \<le> rva + 0x7F \<and>
-          addrFromPPtr rva \<le> addrFromPPtr rva + 0x7F \<and> rva && mask 6 = addrFromPPtr rva && mask 6"
+  "\<lbrakk>is_aligned rva n; n \<ge> 7\<rbrakk> \<Longrightarrow> rva \<le> rva + 0x7F \<and> addrFromPPtr rva \<le> 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 b65fde118e..ec8096e374 100644
--- a/proof/crefine/ARM_HYP/Wellformed_C.thy
+++ b/proof/crefine/ARM_HYP/Wellformed_C.thy
@@ -532,6 +532,52 @@ lemma ucast_irq_array_guard[unfolded irq_array_size_val, simplified]:
 
 text \<open>cacheLineBits interface\<close>
 
+(* 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 \<le> 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 \<le> pageBits"
+  by (simp add: pt_bits_def pte_bits_def pageBits_def)
+
+lemma ptBits_leq_pdBits:
+  "ptBits \<le> pdBits"
+  by (simp add: pt_bits_def pd_bits_def pde_bits_def pte_bits_def)
+
+lemma cacheLineBits_leq_pageBits:
+  "cacheLineBits \<le> pageBits"
+  using ptBits_leq_pageBits cacheLineBits_le_ptBits
+  by simp
+
+lemma cacheLineBits_leq_pdBits:
+  "cacheLineBits \<le> 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 \<le> APIType_capBits PageDirectoryObject us"
+  using APIType_capBits_PageDirectoryObject_pdBits cacheLineBits_leq_pdBits
+  by simp
+
+lemma cacheLineBits_leq_pbfs:
+  "cacheLineBits \<le> pageBitsForSize sz"
+  by (rule order.trans, rule cacheLineBits_leq_pageBits, rule pbfs_atleast_pageBits)
+
 lemma addrFromPPtr_mask_SuperSection:
   "n \<le> pageBitsForSize ARMSuperSection
    \<Longrightarrow> addrFromPPtr ptr && mask n = ptr && mask n"
@@ -550,7 +596,20 @@ lemma ptrFromPAddr_mask_SuperSection:
   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)
+
+(* end of Kernel_Config interface section *)
 
 (* Input abbreviations for API object types *)
 (* disambiguates names *)

From d7d306edb8f0f738e02de2d5d3794db582913b25 Mon Sep 17 00:00:00 2001
From: Gerwin Klein <gerwin.klein@proofcraft.systems>
Date: Sun, 1 Sep 2024 18:03:25 +0100
Subject: [PATCH 08/31] aarch64 crefine: make proof generic in cacheLineBits

On AArch64 we have so far only seen cacheLineBits = 6 in the kernel.

To be future-proof, bring AArch64 proofs into line with AArch32 anyway,
rename cacheLineSize to cacheLineBits to stay consistent, and make proof
generic in cacheLineBits.

Signed-off-by: Gerwin Klein <gerwin.klein@proofcraft.systems>
---
 proof/crefine/AARCH64/Arch_C.thy       |  4 +-
 proof/crefine/AARCH64/Invoke_C.thy     |  2 +-
 proof/crefine/AARCH64/Machine_C.thy    | 10 ++--
 proof/crefine/AARCH64/Recycle_C.thy    |  8 +---
 proof/crefine/AARCH64/Wellformed_C.thy | 64 ++++++++++++++++++--------
 5 files changed, 53 insertions(+), 35 deletions(-)

diff --git a/proof/crefine/AARCH64/Arch_C.thy b/proof/crefine/AARCH64/Arch_C.thy
index e3481189f9..8b7b1c02da 100644
--- a/proof/crefine/AARCH64/Arch_C.thy
+++ b/proof/crefine/AARCH64/Arch_C.thy
@@ -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 \<Rightarrow> machine_word \<Righta
        label \<in> scast ` {Kernel_C.ARMPageUnify_Instruction, Kernel_C.ARMVSpaceUnify_Instruction}"
 
 lemma doFlush_ccorres:
-  "ccorres dc xfdc (\<lambda>s. vs \<le> ve \<and> ps \<le> ps + (ve - vs) \<and> vs && mask cacheLineSize = ps && mask cacheLineSize
+  "ccorres dc xfdc (\<lambda>s. vs \<le> ve \<and> ps \<le> ps + (ve - vs) \<and> vs && mask cacheLineBits = ps && mask cacheLineBits
         \<and> ptrFromPAddr ps \<le> ptrFromPAddr ps + (ve - vs)
         \<and> unat (ve - vs) \<le> gsMaxObjectSize s)
      (\<lbrace>flushtype_relation t \<acute>invLabel\<rbrace> \<inter> \<lbrace>\<acute>start = vs\<rbrace> \<inter> \<lbrace>\<acute>end = ve\<rbrace> \<inter> \<lbrace>\<acute>pstart = ps\<rbrace>) []
diff --git a/proof/crefine/AARCH64/Invoke_C.thy b/proof/crefine/AARCH64/Invoke_C.thy
index e74e29273c..c688ea43f9 100644
--- a/proof/crefine/AARCH64/Invoke_C.thy
+++ b/proof/crefine/AARCH64/Invoke_C.thy
@@ -1685,7 +1685,7 @@ lemma clearMemory_untyped_ccorres:
                         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 (simp add: addrFromPPtr_mask_cacheLineBits pptrBaseOffset_alignment_def)
   apply (cases "ptr = 0"; simp)
   apply (drule subsetD, rule intvl_self, simp)
   apply simp
diff --git a/proof/crefine/AARCH64/Machine_C.thy b/proof/crefine/AARCH64/Machine_C.thy
index 1e02ad82ad..f741dc55f6 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 (\<lambda>s. w1 \<le> w2 \<and> w3 \<le> w3 + (w2 - w1)
-                        \<and> w1 && mask cacheLineSize  = w3 && mask cacheLineSize
+                        \<and> w1 && mask cacheLineBits  = w3 && mask cacheLineBits
                         \<and> unat (w2 - w1) \<le> gsMaxObjectSize s)
                    (\<lbrace>\<acute>start = w1\<rbrace> \<inter> \<lbrace>\<acute>end = w2\<rbrace> \<inter> \<lbrace>\<acute>pstart = w3\<rbrace>) []
            (doMachineOp (cleanCacheRange_RAM w1 w2 w3))
@@ -165,7 +165,7 @@ assumes cleanCacheRange_RAM_ccorres:
 assumes cleanCacheRange_PoU_ccorres:
   "ccorres dc xfdc (\<lambda>s. unat (w2 - w1) \<le> gsMaxObjectSize s
                         \<and> w1 \<le> w2 \<and> w3 \<le> w3 + (w2 - w1)
-                        \<and> w1 && mask cacheLineSize = w3 && mask cacheLineSize)
+                        \<and> w1 && mask cacheLineBits = w3 && mask cacheLineBits)
                    (\<lbrace>\<acute>start = w1\<rbrace> \<inter> \<lbrace>\<acute>end = w2\<rbrace> \<inter> \<lbrace>\<acute>pstart = w3\<rbrace>) []
            (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 (\<lambda>s. unat (w2 - w1) \<le> gsMaxObjectSize s
                         \<and> w1 \<le> w2 \<and> w3 \<le> w3 + (w2 - w1)
-                        \<and> w1 && mask cacheLineSize = w3 && mask cacheLineSize)
+                        \<and> w1 && mask cacheLineBits = w3 && mask cacheLineBits)
                    (\<lbrace>\<acute>start = w1\<rbrace> \<inter> \<lbrace>\<acute>end = w2\<rbrace> \<inter> \<lbrace>\<acute>pstart = w3\<rbrace>) []
            (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 ((\<lambda>s. unat (w2 - w1) \<le> gsMaxObjectSize s)
                     and (\<lambda>_. w1 \<le> w2 \<and> w3 \<le> w3 + (w2 - w1)
-                      \<and> w1 && mask cacheLineSize = w3 && mask cacheLineSize))
+                      \<and> w1 && mask cacheLineBits = w3 && mask cacheLineBits))
                    (\<lbrace>\<acute>start = w1\<rbrace> \<inter> \<lbrace>\<acute>end = w2\<rbrace> \<inter> \<lbrace>\<acute>pstart = w3\<rbrace>) []
            (doMachineOp (invalidateCacheRange_RAM w1 w2 w3))
            (Call invalidateCacheRange_RAM_'proc)"
 
 assumes invalidateCacheRange_I_ccorres:
   "ccorres dc xfdc (\<lambda>_. w1 \<le> w2 \<and> w3 \<le> w3 + (w2 - w1)
-                        \<and> w1 && mask cacheLineSize = w3 && mask cacheLineSize)
+                        \<and> w1 && mask cacheLineBits = w3 && mask cacheLineBits)
                    (\<lbrace>\<acute>start = w1\<rbrace> \<inter> \<lbrace>\<acute>end = w2\<rbrace> \<inter> \<lbrace>\<acute>pstart = w3\<rbrace>) []
            (doMachineOp (invalidateCacheRange_I w1 w2 w3))
            (Call invalidateCacheRange_I_'proc)"
diff --git a/proof/crefine/AARCH64/Recycle_C.thy b/proof/crefine/AARCH64/Recycle_C.thy
index 98055bab5b..d2fbd95eb2 100644
--- a/proof/crefine/AARCH64/Recycle_C.thy
+++ b/proof/crefine/AARCH64/Recycle_C.thy
@@ -387,13 +387,7 @@ lemma clearMemory_PageCap_ccorres:
                         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 \<le> 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: is_aligned_no_overflow' addrFromPPtr_mask_cacheLineBits)
   apply (simp add: pageBitsForSize_def bit_simps split: vmpage_size.splits)
   done
 
diff --git a/proof/crefine/AARCH64/Wellformed_C.thy b/proof/crefine/AARCH64/Wellformed_C.thy
index 76e236b963..26a9aee3b1 100644
--- a/proof/crefine/AARCH64/Wellformed_C.thy
+++ b/proof/crefine/AARCH64/Wellformed_C.thy
@@ -562,6 +562,50 @@ lemma ucast_irq_array_guard[unfolded irq_array_size_val, simplified]:
   done
 
 
+text \<open>cacheLineBits interface\<close>
+
+lemmas cacheLineBits_val =
+  cacheLineBits_def[unfolded Kernel_Config.CONFIG_L1_CACHE_LINE_SIZE_BITS_def]
+
+lemma cacheLineBits_leq_pageBits:
+  "cacheLineBits \<le> pageBits"
+  using cacheLineBits_sanity
+  by (simp add: pageBits_def)
+
+lemma pageBits_leq_pptrBaseOffset_alignment:
+  "pageBits \<le> pptrBaseOffset_alignment"
+  by (simp add: pageBits_def pptrBaseOffset_alignment_def)
+
+lemma cacheLineBits_leq_pptrBaseOffset_alignment:
+  "cacheLineBits \<le> pptrBaseOffset_alignment"
+  by (rule order.trans, rule cacheLineBits_leq_pageBits, rule pageBits_leq_pptrBaseOffset_alignment)
+
+lemma cacheLineBits_leq_pbfs:
+  "cacheLineBits \<le> pageBitsForSize sz"
+  by (rule order.trans, rule cacheLineBits_leq_pageBits, rule pbfs_atleast_pageBits)
+
+lemma addrFromPPtr_mask_pptrBaseOffset_alignment:
+  "n \<le> pptrBaseOffset_alignment
+   \<Longrightarrow> 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)
+
+(* end of Kernel_Config interface section *)
+
 (* Input abbreviations for API object types *)
 (* disambiguates names *)
 
@@ -645,26 +689,6 @@ abbreviation(input)
 where
   "prioInvalid == seL4_InvalidPrio"
 
-(* caches *)
-
-definition cacheLineSize :: nat where
-  "cacheLineSize \<equiv> 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"

From e34ca85dc8a3ab029396d30189ccc2e31eac5499 Mon Sep 17 00:00:00 2001
From: Gerwin Klein <gerwin.klein@proofcraft.systems>
Date: Mon, 2 Sep 2024 21:17:11 +0100
Subject: [PATCH 09/31] arm-hyp+aarch64 spec+proof: make generic in
 CONFIG_DISABLE_WFI_WFE_TRAPS

The config option CONFIG_DISABLE_WFI_WFE_TRAPS influences the value of
HCR_VCPU (hcrVCPU in Haskell).

There is not much to make generic -- it is unfolded exactly once to
compare the value in the spec to the value in C. The main part is
defining hcrVCPU conditionally based on the config setting.

Signed-off-by: Gerwin Klein <gerwin.klein@proofcraft.systems>
---
 proof/crefine/AARCH64/VSpace_C.thy            |  2 +-
 proof/crefine/AARCH64/Wellformed_C.thy        | 13 ++++++++++++
 proof/crefine/ARM_HYP/VSpace_C.thy            |  2 +-
 proof/crefine/ARM_HYP/Wellformed_C.thy        | 13 ++++++++++++
 spec/cspec/c/gen-config-thy.py                |  2 +-
 spec/design/m-skel/AARCH64/MachineTypes.thy   |  1 +
 spec/design/m-skel/ARM_HYP/MachineTypes.thy   |  4 ++--
 .../src/SEL4/Machine/Hardware/AARCH64.hs      | 20 ++++++++++++++++++-
 .../haskell/src/SEL4/Machine/Hardware/ARM.lhs | 20 ++++++++++++++++++-
 9 files changed, 70 insertions(+), 7 deletions(-)

diff --git a/proof/crefine/AARCH64/VSpace_C.thy b/proof/crefine/AARCH64/VSpace_C.thy
index d78dc4a7bd..8381d5c75c 100644
--- a/proof/crefine/AARCH64/VSpace_C.thy
+++ b/proof/crefine/AARCH64/VSpace_C.thy
@@ -2744,7 +2744,7 @@ lemma vcpu_enable_ccorres:
    apply (rule_tac Q'="\<lambda>_. 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 26a9aee3b1..9517cab4bf 100644
--- a/proof/crefine/AARCH64/Wellformed_C.thy
+++ b/proof/crefine/AARCH64/Wellformed_C.thy
@@ -604,8 +604,21 @@ lemma ptrFromPAddr_mask_cacheLineBits[simp]:
   "ptrFromPAddr v && mask cacheLineBits = v && mask cacheLineBits"
   by (simp add: ptrFromPAddr_def add_mask_ignore)
 
+
+text \<open>hcrVCPU interface\<close>
+
+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/ARM_HYP/VSpace_C.thy b/proof/crefine/ARM_HYP/VSpace_C.thy
index 16a7b77a60..6c150749d8 100644
--- a/proof/crefine/ARM_HYP/VSpace_C.thy
+++ b/proof/crefine/ARM_HYP/VSpace_C.thy
@@ -2084,7 +2084,7 @@ lemma vcpu_enable_ccorres:
    apply (rule_tac Q'="\<lambda>_. 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/ARM_HYP/Wellformed_C.thy b/proof/crefine/ARM_HYP/Wellformed_C.thy
index ec8096e374..7cc8b68842 100644
--- a/proof/crefine/ARM_HYP/Wellformed_C.thy
+++ b/proof/crefine/ARM_HYP/Wellformed_C.thy
@@ -609,8 +609,21 @@ lemma shiftr_cacheLineBits_less_mask_word_bits:
   using shiftr_less_max_mask[where n=cacheLineBits and x=x] cacheLineBits_sanity
   by (simp add: word_bits_def)
 
+
+text \<open>hcrVCPU interface\<close>
+
+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/spec/cspec/c/gen-config-thy.py b/spec/cspec/c/gen-config-thy.py
index 3a7e3330c1..1b1972fb25 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 64e4002243..01858f1636 100644
--- a/spec/design/m-skel/AARCH64/MachineTypes.thy
+++ b/spec/design/m-skel/AARCH64/MachineTypes.thy
@@ -115,6 +115,7 @@ definition
   PT_Type \
   VMFaultType HypFaultType vmFaultTypeFSR VMPageSize pageBits ptTranslationBits \
   pageBitsForSize \
+  hcrCommon hcrTWE hcrTWI \
   hcrVCPU hcrNative vgicHCREN sctlrDefault sctlrEL1VM actlrDefault gicVCPUMaxNumLR \
   vcpuBits
 
diff --git a/spec/design/m-skel/ARM_HYP/MachineTypes.thy b/spec/design/m-skel/ARM_HYP/MachineTypes.thy
index 8dcc018502..abcfd83029 100644
--- a/spec/design/m-skel/ARM_HYP/MachineTypes.thy
+++ b/spec/design/m-skel/ARM_HYP/MachineTypes.thy
@@ -11,7 +11,7 @@ imports
   Word_Lib.WordSetup
   Monads.Nondet_Empty_Fail
   Monads.Nondet_Reader_Option
-  Setup_Locale
+  Lib.HaskellLib_H
   Platform
 begin
 context Arch begin arch_global_naming
@@ -136,7 +136,7 @@ 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
 
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 b4044c1cac..936acfea21 100644
--- a/spec/haskell/src/SEL4/Machine/Hardware/ARM.lhs
+++ b/spec/haskell/src/SEL4/Machine/Hardware/ARM.lhs
@@ -875,12 +875,30 @@ 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
 

From c7f74c92ae75b87b4df55a0b1a99ce99e52d5f85 Mon Sep 17 00:00:00 2001
From: Gerwin Klein <gerwin.klein@proofcraft.systems>
Date: Wed, 9 Oct 2024 19:02:51 +1100
Subject: [PATCH 10/31] misc/thydeps: correct regexp escape

Signed-off-by: Gerwin Klein <gerwin.klein@proofcraft.systems>
---
 misc/scripts/thydeps | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

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()

From 007a0861ed215c604d6161e3c18430ade83d2893 Mon Sep 17 00:00:00 2001
From: Gerwin Klein <gerwin.klein@proofcraft.systems>
Date: Wed, 9 Oct 2024 18:13:00 +1100
Subject: [PATCH 11/31] autocorres: update change log and readme for release

Signed-off-by: Gerwin Klein <gerwin.klein@proofcraft.systems>
---
 tools/autocorres/README.md                     | 10 ++++++++--
 tools/autocorres/tools/release_files/ChangeLog |  8 ++++++++
 tools/autocorres/tools/release_files/README    |  8 ++++++--
 3 files changed, 22 insertions(+), 4 deletions(-)

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
 -->
 
+<!--
 Note to maintainer: sync with tools/release_files/README
+-->
 
 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
 

From 0c9f326a51beeb5082520b26db5f8f1b0862f926 Mon Sep 17 00:00:00 2001
From: Gerwin Klein <gerwin.klein@proofcraft.systems>
Date: Wed, 9 Oct 2024 18:34:35 +1100
Subject: [PATCH 12/31] c-parser: update change log and readme for release

Signed-off-by: Gerwin Klein <gerwin.klein@proofcraft.systems>
---
 tools/c-parser/README.md   | 4 +++-
 tools/c-parser/RELEASES.md | 7 +++++++
 2 files changed, 10 insertions(+), 1 deletion(-)

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

From 6122e247d7e4486fa9634d8ded97afc2524de8d3 Mon Sep 17 00:00:00 2001
From: Gerwin Klein <gerwin.klein@proofcraft.systems>
Date: Thu, 10 Oct 2024 19:20:09 +1100
Subject: [PATCH 13/31] c-parser: adjust release script for Makefile changes

The Makefile of the standalone parser has changed, so the patterns used
in the sed script in mkrelease no longer fit the content.

Signed-off-by: Gerwin Klein <gerwin.klein@proofcraft.systems>
---
 tools/c-parser/mkrelease | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/tools/c-parser/mkrelease b/tools/c-parser/mkrelease
index 97afbdddd4..27be698bcb 100755
--- a/tools/c-parser/mkrelease
+++ b/tools/c-parser/mkrelease
@@ -165,10 +165,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"

From 4f1563a8f343e6c7062c55c7d7f16922a2e811ba Mon Sep 17 00:00:00 2001
From: Gerwin Klein <gerwin.klein@proofcraft.systems>
Date: Fri, 11 Oct 2024 09:17:12 +1100
Subject: [PATCH 14/31] c-parser: handle sed backup files uniformly in
 mkrelease

mkrelease was trying to distinguish BSD and GNU sed command line
options, but was using shell substitution incorrectly. Instead, use
backup files for both versions, and then manually remove the backup file
afterwards.

Signed-off-by: Gerwin Klein <gerwin.klein@proofcraft.systems>
---
 tools/c-parser/mkrelease | 12 +++++++-----
 1 file changed, 7 insertions(+), 5 deletions(-)

diff --git a/tools/c-parser/mkrelease b/tools/c-parser/mkrelease
index 27be698bcb..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
@@ -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

From 49f0c84c6e55a378574d18b1c26d95088fa95c08 Mon Sep 17 00:00:00 2001
From: Gerwin Klein <gerwin.klein@proofcraft.systems>
Date: Fri, 16 Aug 2024 09:50:26 +0200
Subject: [PATCH 15/31] lib: stronger version of mapM_x_commute for True guard

mapM_x_commute requires "distinct" even if the operations in the mapM
don't require any guards. Add a separate version without distinct when
guard is \top.

Signed-off-by: Gerwin Klein <gerwin.klein@proofcraft.systems>
---
 lib/Monad_Commute.thy | 15 +++++++++++++++
 1 file changed, 15 insertions(+)

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: "\<And>r. monad_commute \<top> (b r) a"
+  shows "monad_commute \<top> (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 "\<And>s. P s \<Longrightarrow> monad_commute ((=) s) f g"
   shows "monad_commute P f g"

From f4e6622e9483563a9e59aff4c33251090a3bae03 Mon Sep 17 00:00:00 2001
From: Gerwin Klein <gerwin.klein@proofcraft.systems>
Date: Wed, 17 Jul 2024 16:45:53 +1000
Subject: [PATCH 16/31] spec: defer cache flush in retype

Defer the cache flush done in untyped_reset (inside clearMemory) to the
actual retype call, and only flush for the object types where that is
needed. This affects mostly the Arm architectures, but has some minor
changes for adapting the arch interface init_arch_objects in RISCV64 and
X64.

See seL4/seL4#1289 for more detailed rationale.

Signed-off-by: Gerwin Klein <gerwin.klein@proofcraft.systems>
---
 spec/abstract/AARCH64/ArchRetype_A.thy        | 29 ++++++++++++-
 spec/abstract/ARM/ArchRetype_A.thy            | 41 +++++++++++++++----
 spec/abstract/ARM_HYP/ArchRetype_A.thy        | 41 +++++++++++++++----
 spec/abstract/RISCV64/ArchRetype_A.thy        |  4 +-
 spec/abstract/Retype_A.thy                    |  2 +-
 spec/abstract/X64/ArchRetype_A.thy            |  4 +-
 .../skel/AARCH64/ArchIntermediate_H.thy       |  9 +++-
 spec/design/skel/ARM/ArchIntermediate_H.thy   | 12 ++++--
 .../skel/ARM_HYP/ArchIntermediate_H.thy       | 14 ++++---
 .../src/SEL4/Object/ObjectType/AARCH64.hs     | 20 +++++++++
 .../src/SEL4/Object/ObjectType/ARM.lhs        | 23 ++++++++++-
 spec/machine/AARCH64/MachineOps.thy           |  8 ++--
 spec/machine/ARM/MachineOps.thy               |  6 +--
 spec/machine/ARM_HYP/MachineOps.thy           |  6 +--
 14 files changed, 169 insertions(+), 50 deletions(-)

diff --git a/spec/abstract/AARCH64/ArchRetype_A.thy b/spec/abstract/AARCH64/ArchRetype_A.thy
index d358c3e5cb..f3872ef2ae 100644
--- a/spec/abstract/AARCH64/ArchRetype_A.thy
+++ b/spec/abstract/AARCH64/ArchRetype_A.thy
@@ -24,9 +24,34 @@ definition reserve_region :: "obj_ref \<Rightarrow> nat \<Rightarrow> bool \<Rig
 
 text \<open>Initialise architecture-specific objects.\<close>
 
+definition vs_apiobj_size where
+  "vs_apiobj_size ty \<equiv>
+     case ty of
+       ArchObject SmallPageObj \<Rightarrow> pageBitsForSize ARMSmallPage
+     | ArchObject LargePageObj \<Rightarrow> pageBitsForSize ARMLargePage
+     | ArchObject HugePageObj \<Rightarrow> pageBitsForSize ARMHugePage
+     | ArchObject PageTableObj \<Rightarrow> table_size NormalPT_T
+     | ArchObject VSpaceObj \<Rightarrow> table_size VSRootPT_T"
+
 definition init_arch_objects ::
-  "apiobject_type \<Rightarrow> obj_ref \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> obj_ref list \<Rightarrow> (unit,'z::state_ext) s_monad" where
-  "init_arch_objects new_type ptr num_objects obj_sz refs \<equiv> return ()"
+  "apiobject_type \<Rightarrow> bool \<Rightarrow> obj_ref \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> obj_ref list \<Rightarrow> (unit,'z::state_ext) s_monad"
+  where
+  "init_arch_objects new_type is_device ptr num_objects obj_sz refs \<equiv>
+     if \<not>is_device \<and>
+        new_type \<in> {ArchObject SmallPageObj, ArchObject LargePageObj, ArchObject HugePageObj}
+     then
+       mapM_x (\<lambda>ref. do_machine_op $
+                       cleanCacheRange_RAM ref (ref + mask (vs_apiobj_size new_type))
+                                           (addrFromPPtr ref))
+              refs
+     else if new_type \<in> {ArchObject PageTableObj, ArchObject VSpaceObj}
+     then
+       mapM_x (\<lambda>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 \<equiv> UserContext (FPUState (\<lambda>_. 0) 0 0) (\<lambda>_. 0)"
diff --git a/spec/abstract/ARM/ArchRetype_A.thy b/spec/abstract/ARM/ArchRetype_A.thy
index 2087f6831d..81f12f0a24 100644
--- a/spec/abstract/ARM/ArchRetype_A.thy
+++ b/spec/abstract/ARM/ArchRetype_A.thy
@@ -26,15 +26,38 @@ definition
 
 text \<open>Initialise architecture-specific objects.\<close>
 
-definition
-  init_arch_objects :: "apiobject_type \<Rightarrow> obj_ref \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> obj_ref list \<Rightarrow> (unit,'z::state_ext) s_monad"
-where
-  "init_arch_objects new_type ptr num_objects obj_sz refs
-    \<equiv> if new_type = ArchObject PageDirectoryObj then (do
-      mapM_x copy_global_mappings refs;
-      do_machine_op $ mapM_x (\<lambda>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 \<equiv>
+     case ty of
+       ArchObject SmallPageObj \<Rightarrow> pageBitsForSize ARMSmallPage
+     | ArchObject LargePageObj \<Rightarrow> pageBitsForSize ARMLargePage
+     | ArchObject SectionObj \<Rightarrow> pageBitsForSize ARMSection
+     | ArchObject SuperSectionObj \<Rightarrow> pageBitsForSize ARMSuperSection
+     | ArchObject PageTableObj \<Rightarrow> pt_bits
+     | ArchObject PageDirectoryObj \<Rightarrow> pd_bits"
+
+definition init_arch_objects ::
+  "apiobject_type \<Rightarrow> bool \<Rightarrow> obj_ref \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> obj_ref list \<Rightarrow> (unit,'z::state_ext) s_monad"
+  where
+  "init_arch_objects new_type is_device ptr num_objects obj_sz refs \<equiv> do
+     when (new_type = ArchObject PageDirectoryObj) $ mapM_x copy_global_mappings refs;
+     if \<not>is_device \<and>
+        new_type \<in> {ArchObject SmallPageObj, ArchObject LargePageObj,
+                    ArchObject SectionObj, ArchObject SuperSectionObj}
+     then
+       mapM_x (\<lambda>ref. do_machine_op $
+                       cleanCacheRange_RAM ref (ref + mask (vs_apiobj_size new_type))
+                                           (addrFromPPtr ref))
+              refs
+     else if new_type \<in> {ArchObject PageTableObj, ArchObject PageDirectoryObj}
+     then
+       mapM_x (\<lambda>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/ArchRetype_A.thy b/spec/abstract/ARM_HYP/ArchRetype_A.thy
index 52d4e931f5..b076a6097b 100644
--- a/spec/abstract/ARM_HYP/ArchRetype_A.thy
+++ b/spec/abstract/ARM_HYP/ArchRetype_A.thy
@@ -26,15 +26,38 @@ definition
 
 text \<open>Initialise architecture-specific objects.\<close>
 
-definition
-  init_arch_objects :: "apiobject_type \<Rightarrow> obj_ref \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> obj_ref list \<Rightarrow> (unit,'z::state_ext) s_monad"
-where
-  "init_arch_objects new_type ptr num_objects obj_sz refs
-    \<equiv> if new_type = ArchObject PageDirectoryObj then (do
-      mapM_x copy_global_mappings refs;
-      do_machine_op $ mapM_x (\<lambda>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 \<equiv>
+     case ty of
+       ArchObject SmallPageObj \<Rightarrow> pageBitsForSize ARMSmallPage
+     | ArchObject LargePageObj \<Rightarrow> pageBitsForSize ARMLargePage
+     | ArchObject SectionObj \<Rightarrow> pageBitsForSize ARMSection
+     | ArchObject SuperSectionObj \<Rightarrow> pageBitsForSize ARMSuperSection
+     | ArchObject PageTableObj \<Rightarrow> pt_bits
+     | ArchObject PageDirectoryObj \<Rightarrow> pd_bits"
+
+definition init_arch_objects ::
+  "apiobject_type \<Rightarrow> bool \<Rightarrow> obj_ref \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> obj_ref list \<Rightarrow> (unit,'z::state_ext) s_monad"
+  where
+  "init_arch_objects new_type is_device ptr num_objects obj_sz refs \<equiv> do
+     when (new_type = ArchObject PageDirectoryObj) $ mapM_x copy_global_mappings refs;
+     if \<not>is_device \<and>
+        new_type \<in> {ArchObject SmallPageObj, ArchObject LargePageObj,
+                    ArchObject SectionObj, ArchObject SuperSectionObj}
+     then
+       mapM_x (\<lambda>ref. do_machine_op $
+                       cleanCacheRange_RAM ref (ref + mask (vs_apiobj_size new_type))
+                                           (addrFromPPtr ref))
+              refs
+     else if new_type \<in> {ArchObject PageTableObj, ArchObject PageDirectoryObj}
+     then
+       mapM_x (\<lambda>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/RISCV64/ArchRetype_A.thy b/spec/abstract/RISCV64/ArchRetype_A.thy
index 2e1043fd23..9b16a3efa5 100644
--- a/spec/abstract/RISCV64/ArchRetype_A.thy
+++ b/spec/abstract/RISCV64/ArchRetype_A.thy
@@ -25,9 +25,9 @@ definition reserve_region :: "obj_ref \<Rightarrow> nat \<Rightarrow> bool \<Rig
 text \<open>Initialise architecture-specific objects.\<close>
 
 definition init_arch_objects ::
-  "apiobject_type \<Rightarrow> obj_ref \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> obj_ref list \<Rightarrow> (unit,'z::state_ext) s_monad"
+  "apiobject_type \<Rightarrow> bool \<Rightarrow> obj_ref \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> obj_ref list \<Rightarrow> (unit,'z::state_ext) s_monad"
   where
-  "init_arch_objects new_type ptr num_objects obj_sz refs \<equiv> return ()"
+  "init_arch_objects new_type is_device ptr num_objects obj_sz refs \<equiv> return ()"
 
 definition empty_context :: user_context
   where
diff --git a/spec/abstract/Retype_A.thy b/spec/abstract/Retype_A.thy
index cba0f3420b..9a6e6ede7f 100644
--- a/spec/abstract/Retype_A.thy
+++ b/spec/abstract/Retype_A.thy
@@ -189,7 +189,7 @@ doE
 
   \<comment> \<open>Create new objects.\<close>
   orefs \<leftarrow> 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;
   sequence_x (map (create_cap new_type obj_sz src_slot is_device) (zip slots orefs))
 od odE"
 
diff --git a/spec/abstract/X64/ArchRetype_A.thy b/spec/abstract/X64/ArchRetype_A.thy
index 35389f8ebc..3d9ab1ad68 100644
--- a/spec/abstract/X64/ArchRetype_A.thy
+++ b/spec/abstract/X64/ArchRetype_A.thy
@@ -27,10 +27,10 @@ definition
 text \<open>Initialise architecture-specific objects.\<close>
 
 definition
-  init_arch_objects :: "apiobject_type \<Rightarrow> obj_ref \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> obj_ref list
+  init_arch_objects :: "apiobject_type \<Rightarrow> bool \<Rightarrow> obj_ref \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> obj_ref list
    \<Rightarrow> (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
     \<equiv> when (new_type = ArchObject PML4Obj) (mapM_x copy_global_mappings refs)"
 
 definition
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 (\<lambda>ks. ks \<lparr> gsUserPages := (\<lambda> addr.
           if addr `~elem~` map fromPPtr addrs then Just pSize
           else gsUserPages ks addr)\<rparr>);
+        when (\<not>dev) $
+          mapM_x (\<lambda>addr. doMachineOp $
+                            cleanCacheRange_RAM addr
+                                                (addr + mask (pageBitsForSize pSize))
+                                                (addrFromPPtr addr)) addrs;
         return $ map (\<lambda>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)\<rparr>\<rparr>);
       initialiseMappings pts;
+      mapM_x (\<lambda>addr. doMachineOp $
+                       cleanCacheRange_PoU addr (addr + mask tableBits) (addrFromPPtr addr)) addrs;
       return $ map (\<lambda>pt. cap pt Nothing) pts
     od)"
 
@@ -59,7 +66,7 @@ defs Arch_createNewCaps_def:
               (\<lambda>pts. return ())
         | VCPUObject \<Rightarrow> (do
             addrs \<leftarrow> createObjects regionBase numObjects (injectKO (makeObject :: vcpu)) 0;
-            return $ map (\<lambda> addr. VCPUCap addr) addrs
+            return $ map (\<lambda>addr. VCPUCap addr) addrs
             od)
         )"
 
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 (\<lambda>ks. ks \<lparr> gsUserPages := (\<lambda> addr.
           if addr `~elem~` map fromPPtr addrs then Just pSize
           else gsUserPages ks addr)\<rparr>);
+        when (\<not>dev) $
+          mapM_x (\<lambda>addr. doMachineOp $
+                            cleanCacheRange_RAM addr
+                                                (addr + mask (pageBitsForSize pSize))
+                                                (addrFromPPtr addr)) addrs;
         return $ map (\<lambda>n. PageCap dev (PPtr (fromPPtr n)) VMReadWrite pSize Nothing) addrs
      od)"
 
@@ -29,6 +34,8 @@ private abbreviation (input)
       addrs \<leftarrow> createObjects regionBase numObjects (injectKO objectProto) tableSize;
       pts \<leftarrow> return (map (PPtr \<circ> fromPPtr) addrs);
       initialiseMappings pts;
+      mapM_x (\<lambda>addr. doMachineOp $
+                       cleanCacheRange_PoU addr (addr + mask tableBits) (addrFromPPtr addr)) addrs;
       return $ map (\<lambda>pt. cap pt Nothing) pts
     od)"
 
@@ -51,10 +58,7 @@ defs Arch_createNewCaps_def:
         | PageDirectoryObject \<Rightarrow>
             createNewTableCaps regionBase numObjects pdBits (makeObject::pde) PageDirectoryCap
               (\<lambda>pds. do objSize \<leftarrow> return (((1::nat) `~shiftL~` pdBits));
-                        mapM_x copyGlobalMappings pds;
-                        doMachineOp $ mapM_x (\<lambda>x. cleanCacheRange_PoU x
-                                                    (x + (fromIntegral objSize) - 1)
-                                                    (addrFromPPtr x)) pds
+                        mapM_x copyGlobalMappings pds
                      od)
         )"
 
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 (\<lambda>ks. ks \<lparr> gsUserPages := (\<lambda> addr.
           if addr `~elem~` map fromPPtr addrs then Just pSize
           else gsUserPages ks addr)\<rparr>);
+        when (\<not>dev) $
+          mapM_x (\<lambda>addr. doMachineOp $
+                            cleanCacheRange_RAM addr
+                                                (addr + mask (pageBitsForSize pSize))
+                                                (addrFromPPtr addr)) addrs;
         return $ map (\<lambda>n. PageCap dev (PPtr (fromPPtr n)) VMReadWrite pSize Nothing) addrs
      od)"
 
@@ -29,6 +34,8 @@ private abbreviation (input)
       addrs \<leftarrow> createObjects regionBase numObjects (injectKO objectProto) tableSize;
       pts \<leftarrow> return (map (PPtr \<circ> fromPPtr) addrs);
       initialiseMappings pts;
+      mapM_x (\<lambda>addr. doMachineOp $
+                       cleanCacheRange_PoU addr (addr + mask tableBits) (addrFromPPtr addr)) addrs;
       return $ map (\<lambda>pt. cap pt Nothing) pts
     od)"
 
@@ -51,14 +58,11 @@ defs Arch_createNewCaps_def:
         | PageDirectoryObject \<Rightarrow>
             createNewTableCaps regionBase numObjects pdBits (makeObject::pde) PageDirectoryCap
               (\<lambda>pds. do objSize \<leftarrow> return (((1::nat) `~shiftL~` pdBits));
-                        mapM_x copyGlobalMappings pds;
-                        doMachineOp $ mapM_x (\<lambda>x. cleanCacheRange_PoU x
-                                                    (x + (fromIntegral objSize) - 1)
-                                                    (addrFromPPtr x)) pds
+                        mapM_x copyGlobalMappings pds
                      od)
         | VCPUObject \<Rightarrow> (do
             addrs \<leftarrow> createObjects regionBase numObjects (injectKO (makeObject :: vcpu)) 0;
-            return $ map (\<lambda> addr. VCPUCap addr) addrs
+            return $ map (\<lambda>addr. VCPUCap addr) addrs
             od)
         )"
 
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/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 \<open>Clear memory contents to recycle it as user memory\<close>
+text \<open>Clear memory contents to recycle it as user memory. Do not yet flush the cache.\<close>
 definition clearMemory :: "machine_word \<Rightarrow> nat \<Rightarrow> unit machine_monad" where
-  "clearMemory ptr bytelength \<equiv> do
-     mapM_x (\<lambda>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 \<equiv>
+     mapM_x (\<lambda>p. storeWord p 0) [ptr, ptr + word_size .e. ptr + (of_nat bytelength) - 1]"
 
 text \<open>Haskell simulator interface stub.\<close>
 definition clearMemoryVM :: "machine_word \<Rightarrow> nat \<Rightarrow> unit machine_monad" where
diff --git a/spec/machine/ARM/MachineOps.thy b/spec/machine/ARM/MachineOps.thy
index 10247054e7..f074447c48 100644
--- a/spec/machine/ARM/MachineOps.thy
+++ b/spec/machine/ARM/MachineOps.thy
@@ -454,14 +454,12 @@ where
 
 section "Memory Clearance"
 
-text \<open>Clear memory contents to recycle it as user memory\<close>
+text \<open>Clear memory contents to recycle it as user memory. Do not yet flush the cache.\<close>
 definition
   clearMemory :: "machine_word \<Rightarrow> nat \<Rightarrow> unit machine_monad"
   where
  "clearMemory ptr bytelength \<equiv>
-  do mapM_x (\<lambda>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 (\<lambda>p. storeWord p 0) [ptr, ptr + word_size .e. ptr + (of_nat bytelength) - 1]"
 
 definition
   clearMemoryVM :: "machine_word \<Rightarrow> nat \<Rightarrow> unit machine_monad"
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 \<open>Clear memory contents to recycle it as user memory\<close>
+text \<open>Clear memory contents to recycle it as user memory. Do not yet flush the cache.\<close>
 definition
   clearMemory :: "machine_word \<Rightarrow> nat \<Rightarrow> unit machine_monad"
   where
  "clearMemory ptr bytelength \<equiv>
-  do mapM_x (\<lambda>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 (\<lambda>p. storeWord p 0) [ptr, ptr + word_size .e. ptr + (of_nat bytelength) - 1]"
 
 definition
   clearMemoryVM :: "machine_word \<Rightarrow> nat \<Rightarrow> unit machine_monad"

From ef5b6084d9bbf972e55b4aaaa67a0d5738aa7b3d Mon Sep 17 00:00:00 2001
From: Gerwin Klein <gerwin.klein@proofcraft.systems>
Date: Wed, 17 Jul 2024 17:48:32 +1000
Subject: [PATCH 17/31] proofs: proof update for deferred cache flush

Most content is in the Arm architectures, RISCV64 and X64 only have
interface changes, because X64 has different cache requirements and
RISCV64 currently has no caches at level 2.

Signed-off-by: Gerwin Klein <gerwin.klein@proofcraft.systems>
---
 proof/access-control/ARM/ArchRetype_AC.thy    |  47 +-
 proof/access-control/DomainSepInv.thy         |   2 +-
 .../access-control/RISCV64/ArchRetype_AC.thy  |   2 +-
 proof/access-control/Retype_AC.thy            |  10 +-
 proof/access-control/Syscall_AC.thy           |   2 +-
 proof/crefine/AARCH64/Invoke_C.thy            |  55 +-
 proof/crefine/AARCH64/Machine_C.thy           |   7 +
 proof/crefine/AARCH64/Recycle_C.thy           |  60 +-
 proof/crefine/AARCH64/Retype_C.thy            | 314 +++++++---
 proof/crefine/ARM/Invoke_C.thy                |  58 +-
 proof/crefine/ARM/Retype_C.thy                | 499 +++++++++++-----
 proof/crefine/ARM_HYP/Invoke_C.thy            |  58 +-
 proof/crefine/ARM_HYP/Machine_C.thy           |   2 +-
 proof/crefine/ARM_HYP/Recycle_C.thy           | 210 ++++---
 proof/crefine/ARM_HYP/Retype_C.thy            | 528 +++++++++++------
 proof/drefine/Untyped_DR.thy                  |  48 +-
 proof/infoflow/ADT_IF.thy                     |   2 +-
 proof/infoflow/ARM/ArchADT_IF.thy             |   4 +-
 proof/infoflow/ARM/ArchRetype_IF.thy          |  48 +-
 proof/infoflow/FinalCaps.thy                  |   4 +-
 proof/infoflow/PasUpdates.thy                 |   2 +-
 proof/infoflow/RISCV64/ArchIRQMasks_IF.thy    |   2 +-
 proof/infoflow/RISCV64/ArchRetype_IF.thy      |   2 +-
 .../AARCH64/ArchDetSchedAux_AI.thy            |   1 +
 .../AARCH64/ArchRetype_AI.thy                 |   9 +-
 .../AARCH64/ArchUntyped_AI.thy                |  15 +-
 .../AARCH64/ArchVSpaceEntries_AI.thy          |   4 +-
 .../invariant-abstract/ARM/ArchRetype_AI.thy  |  11 +-
 .../invariant-abstract/ARM/ArchUntyped_AI.thy |  61 +-
 .../ARM/ArchVSpaceEntries_AI.thy              |  33 +-
 .../ARM_HYP/ArchRetype_AI.thy                 |  11 +-
 .../ARM_HYP/ArchUntyped_AI.thy                |  53 +-
 .../ARM_HYP/ArchVSpaceEntries_AI.thy          |  33 +-
 proof/invariant-abstract/DetSchedAux_AI.thy   |   4 +-
 .../DetSchedDomainTime_AI.thy                 |   4 +-
 .../RISCV64/ArchRetype_AI.thy                 |   4 +-
 .../RISCV64/ArchUntyped_AI.thy                |   6 +-
 .../RISCV64/ArchVSpaceEntries_AI.thy          |   2 +-
 proof/invariant-abstract/Untyped_AI.thy       |  19 +-
 .../invariant-abstract/X64/ArchRetype_AI.thy  |   4 +-
 .../invariant-abstract/X64/ArchUntyped_AI.thy |   8 +-
 .../X64/ArchVSpaceEntries_AI.thy              |   2 +-
 proof/refine/AARCH64/Detype_R.thy             | 155 +++--
 proof/refine/AARCH64/Retype_R.thy             | 245 +++++---
 proof/refine/ARM/Detype_R.thy                 | 556 +++++++++++-------
 proof/refine/ARM/Retype_R.thy                 | 377 ++++++------
 proof/refine/ARM_HYP/Detype_R.thy             | 409 +++++--------
 proof/refine/ARM_HYP/Retype_R.thy             | 309 ++++++----
 proof/refine/RISCV64/Retype_R.thy             |   8 +-
 proof/refine/X64/Retype_R.thy                 |   8 +-
 50 files changed, 2516 insertions(+), 1801 deletions(-)

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]:
   "\<lbrace>pas_refined aag and post_retype_invs tp refs and (\<lambda>s. \<forall> x\<in>set refs. x \<notin> global_refs s)
                     and K (\<forall>ref \<in> set refs. is_aligned ref (obj_bits_api tp obj_sz))\<rbrace>
-   init_arch_objects tp ptr bits obj_sz refs
+   init_arch_objects tp dev ptr bits obj_sz refs
    \<lbrace>\<lambda>_. pas_refined aag\<rbrace>"
+  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'="\<lambda>rv. pas_refined aag and
+  apply (cases tp;
+         (wpsimp simp: init_arch_objects_def
+                 wp: mapM_x_wp'[where f="\<lambda>r. do_machine_op (m r)" for m]))
+   apply (rule_tac Q'="\<lambda>rv. pas_refined aag and
                             all_invs_but_equal_kernel_mappings_restricted (set refs) and
                             (\<lambda>s. \<forall>x \<in> set refs. x \<notin> 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 \<lbrace>pas_cur_domain aag\<rbrace>"
+  "init_arch_objects tp dev ptr n us refs \<lbrace>pas_cur_domain aag\<rbrace>"
   by wp
 
 lemma retype_region_pas_cur_domain[Retype_AC_assms, wp]:
@@ -366,13 +362,12 @@ lemma dmo_clearMemory_respects'[Retype_AC_assms]:
    \<lbrace>\<lambda>_. integrity aag X st\<rbrace>"
   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) \<lbrace>integrity aag X st\<rbrace>"
   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) \<lbrace>integrity aag X st\<rbrace>"
+  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 (\<lambda>x. cleanCacheRange_PoU (f x) (g x) (h x)) refs) \<lbrace>integrity aag X st\<rbrace>"
   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]:
   "\<lbrace>integrity aag X st and K (\<forall>x\<in>set refs. is_subject aag x)
                        and K (\<forall>ref \<in> set refs. is_aligned ref (obj_bits_api new_type obj_sz))\<rbrace>
-   init_arch_objects new_type ptr num_objects obj_sz refs
+   init_arch_objects new_type dev ptr num_objects obj_sz refs
    \<lbrace>\<lambda>_. integrity aag X st\<rbrace>"
   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/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 \<lbrace>\<lambda>s :: det_ext state. domain_sep_inv irqs st s\<rbrace>"
   and init_arch_objects_domain_sep_inv[wp]:
-    "init_arch_objects typ ptr n sz refs \<lbrace>\<lambda>s :: det_ext state. domain_sep_inv irqs st s\<rbrace>"
+    "init_arch_objects typ dev ptr n sz refs \<lbrace>\<lambda>s :: det_ext state. domain_sep_inv irqs st s\<rbrace>"
   and prepare_thread_delete_domain_sep_inv[wp]:
     "prepare_thread_delete t \<lbrace>\<lambda>s :: det_ext state. domain_sep_inv irqs st s\<rbrace>"
   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 \<lbrace>pas_cur_domain aag\<rbrace>"
+  "init_arch_objects tp dev ptr n us refs \<lbrace>pas_cur_domain aag\<rbrace>"
   by wp
 
 lemma retype_region_pas_cur_domain[Retype_AC_assms, wp]:
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 =
     "\<And>tp. is_aligned p (obj_bits_api (ArchObject tp) n)
            \<Longrightarrow> aobj_ref' (arch_default_cap tp p n dev) \<subseteq> ptr_range p (obj_bits_api (ArchObject tp) n)"
   and init_arch_objects_pas_refined:
-    "\<And>tp. \<lbrace>pas_refined aag and post_retype_invs tp refs
+    "\<And>tp dev. \<lbrace>pas_refined aag and post_retype_invs tp refs
                             and (\<lambda>s. \<forall>x\<in>set refs. x \<notin> global_refs s)
                             and K (\<forall>ref \<in> set refs. is_aligned ref (obj_bits_api tp obj_sz))\<rbrace>
-           init_arch_objects tp ptr bits obj_sz refs
-           \<lbrace>\<lambda>_. pas_refined aag\<rbrace>"
+               init_arch_objects tp dev ptr bits obj_sz refs
+               \<lbrace>\<lambda>_. pas_refined aag\<rbrace>"
   and dmo_freeMemory_invs:
     "do_machine_op (freeMemory ptr bits) \<lbrace>\<lambda>s :: det_ext state. invs s\<rbrace>"
   and init_arch_objects_pas_cur_domain[wp]:
-    "\<And>tp. init_arch_objects tp ptr n us refs \<lbrace>pas_cur_domain aag\<rbrace>"
+    "\<And>tp dev. init_arch_objects tp dev ptr n us refs \<lbrace>pas_cur_domain aag\<rbrace>"
   and retype_region_pas_cur_domain[wp]:
     "\<And>tp. retype_region ptr n us tp dev \<lbrace>pas_cur_domain aag\<rbrace>"
   and reset_untyped_cap_pas_cur_domain[wp]:
@@ -222,7 +222,7 @@ locale Retype_AC_1 =
   and init_arch_objects_integrity:
     "\<lbrace>integrity aag X st and K (\<forall>x\<in>set refs. is_subject aag x)
                          and K (\<forall>ref \<in> set refs. is_aligned ref (obj_bits_api new_type obj_sz))\<rbrace>
-     init_arch_objects new_type ptr num_objects obj_sz refs
+     init_arch_objects new_type dev ptr num_objects obj_sz refs
      \<lbrace>\<lambda>_. integrity aag X st\<rbrace>"
   and integrity_asids_detype:
     "\<forall>r \<in> R. pasObjectAbs aag r \<in> 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]:
     "\<And>P. handle_reserved_irq irq \<lbrace>\<lambda>s :: det_ext state. P (arch_state s)\<rbrace>"
   and init_arch_objects_arch_state[wp]:
-    "\<And>P. init_arch_objects new_type ptr n sz refs \<lbrace>\<lambda>s :: det_ext state. P (arch_state s)\<rbrace>"
+    "\<And>P. init_arch_objects new_type dev ptr n sz refs \<lbrace>\<lambda>s :: det_ext state. P (arch_state s)\<rbrace>"
   and getActiveIRQ_inv:
     "\<And>P. \<forall>f s. P s \<longrightarrow> P (irq_state_update f s)
           \<Longrightarrow> \<lbrace>P\<rbrace> getActiveIRQ in_kernel \<lbrace>\<lambda>rv. P\<rbrace>"
diff --git a/proof/crefine/AARCH64/Invoke_C.thy b/proof/crefine/AARCH64/Invoke_C.thy
index c688ea43f9..08815fe4e4 100644
--- a/proof/crefine/AARCH64/Invoke_C.thy
+++ b/proof/crefine/AARCH64/Invoke_C.thy
@@ -1649,43 +1649,34 @@ lemma clearMemory_untyped_ccorres:
   apply (cinit' lift: bits_' ptr___ptr_to_unsigned_long_')
    apply (rule_tac P="ptr \<noteq> 0 \<and> 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_cacheLineBits pptrBaseOffset_alignment_def)
   apply (cases "ptr = 0"; simp)
   apply (drule subsetD, rule intvl_self, simp)
   apply simp
diff --git a/proof/crefine/AARCH64/Machine_C.thy b/proof/crefine/AARCH64/Machine_C.thy
index f741dc55f6..573d0fdb75 100644
--- a/proof/crefine/AARCH64/Machine_C.thy
+++ b/proof/crefine/AARCH64/Machine_C.thy
@@ -199,6 +199,13 @@ assumes cleanCacheRange_RAM_preserves_kernel_bytes:
           \<and> (\<forall>x. snd (hrs_htd (t_hrs_' (globals s)) x) 0 \<noteq> None
                  \<longrightarrow> hrs_mem (t_hrs_' (globals t)) x = hrs_mem (t_hrs_' (globals s)) x)}"
 
+assumes cleanCacheRange_PoU_preserves_kernel_bytes:
+  "\<forall>s. \<Gamma>\<turnstile>\<^bsub>/UNIV\<^esub> {s} Call cleanCacheRange_PoU_'proc
+       {t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s))
+           \<and> (\<forall>x. snd (hrs_htd (t_hrs_' (globals s)) x) 0 \<noteq> None
+                  \<longrightarrow> 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 d2fbd95eb2..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: "\<And>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 (\<lambda>s. 2 ^ pageBitsForSize sz \<le> 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 \<noteq> 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 \<le> 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 \<noteq> 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 \<le> 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,19 +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' addrFromPPtr_mask_cacheLineBits)
-  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]
diff --git a/proof/crefine/AARCH64/Retype_C.thy b/proof/crefine/AARCH64/Retype_C.thy
index ba8b9a0df9..0916051c60 100644
--- a/proof/crefine/AARCH64/Retype_C.thy
+++ b/proof/crefine/AARCH64/Retype_C.thy
@@ -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 \<Gamma> 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 (\<lambda>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 \<Gamma> 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
+      \<and> (heap_list_is_zero (hrs_mem (t_hrs_' (globals s))) regionBase (2 ^ (pageBits + us)))})
+  hs
+  (placeNewDataObject regionBase us False)
+  (global_htd_update (\<lambda>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]: "\<lambda>s. P (gsMaxObjectSize s)"
+  (simp: crunch_simps)
+
 lemma Arch_createObject_ccorres:
   assumes t: "toAPIType newType = None"
   shows "ccorres (\<lambda>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 \<open>simp add: bit_simps Kernel_Config.config_ARM_PA_SIZE_BITS_40_def mask_def\<close>)
+       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 \<open>clarsimp simp: bit_simps mask_def split: if_splits\<close>)
+     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 \<open>simp add: bit_simps Kernel_Config.config_ARM_PA_SIZE_BITS_40_def mask_def\<close>)
+       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 \<open>clarsimp simp: bit_simps mask_def split: if_splits\<close>)
+     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)
@@ -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 \<open>(solves \<open>simp add: byte_regions_unmodified_def\<close>)?\<close>)
+   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:
+  "\<forall>s. \<Gamma>\<turnstile>\<^bsub>/UNIV\<^esub>
+   {s} Call Arch_createObject_'proc {t. cap_get_tag (ret__struct_cap_C_' t) \<noteq> 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:
   "\<forall>\<sigma>. \<Gamma>\<turnstile>\<^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
          \<longrightarrow> (case untypedZeroRange (cap_to_H (the (cap_lift (ret__struct_cap_C_' t)))) of None \<Rightarrow> True
           | Some (a, b) \<Rightarrow> 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/ARM/Invoke_C.thy b/proof/crefine/ARM/Invoke_C.thy
index 6489c5f838..442e779a55 100644
--- a/proof/crefine/ARM/Invoke_C.thy
+++ b/proof/crefine/ARM/Invoke_C.thy
@@ -1517,45 +1517,37 @@ lemma clearMemory_untyped_ccorres:
   apply (cinit' lift: bits_' ptr___ptr_to_unsigned_long_')
    apply (rule_tac P="ptr \<noteq> 0 \<and> 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
   apply (cases "ptr = 0")
    apply (drule subsetD, rule intvl_self, simp)
    apply (simp split: if_split_asm)
diff --git a/proof/crefine/ARM/Retype_C.thy b/proof/crefine/ARM/Retype_C.thy
index 45dacb619c..8fb637600a 100644
--- a/proof/crefine/ARM/Retype_C.thy
+++ b/proof/crefine/ARM/Retype_C.thy
@@ -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 \<Gamma> 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 (\<lambda>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 \<Gamma> 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
+      \<and> (heap_list_is_zero (hrs_mem (t_hrs_' (globals s))) regionBase (2 ^ (pageBits + us)))})
+  hs
+  (placeNewDataObject regionBase us False)
+  (global_htd_update (\<lambda>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]: "\<lambda>s. P (gsMaxObjectSize s)"
+  (simp: crunch_simps)
+
 lemma Arch_createObject_ccorres:
   assumes t: "toAPIType newType = None"
   shows "ccorres (\<lambda>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)
-
-        \<comment> \<open>Page objects: could possibly fix the duplication here\<close>
+                           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])
-
-     \<comment> \<open>PageTableObject\<close>
+                         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)
-
-    \<comment> \<open>PageDirectoryObject\<close>
+                            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,22 +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
-                            cacheLineBits_le_PageDirectoryObject_sz[unfolded APIType_capBits_def,
-                                                                    simplified])+
+           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
 
@@ -6472,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:
+  "\<forall>s. \<Gamma>\<turnstile>\<^bsub>/UNIV\<^esub> {s} Call cleanByVA_'proc
+      {t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s))
+         \<and> 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:
+  "\<forall>s. \<Gamma>\<turnstile>\<^bsub>/UNIV\<^esub> {s} Call cleanCacheRange_PoC_'proc
+      {t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s))
+         \<and> 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))
+                          \<and> 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:
+  "\<forall>s. \<Gamma>\<turnstile>\<^bsub>/UNIV\<^esub> {s} Call cleanCacheRange_RAM_'proc
+      {t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s))
+         \<and> 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 (\<lambda>_. f (hrs_htd hrs)) hrs = hrs_htd_update f hrs"
   by (cases hrs, simp add: hrs_htd_update_def hrs_htd_def)
@@ -6490,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 \<open>(solves \<open>simp add: mask_def\<close>)?\<close>)
+       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:
@@ -6648,6 +6828,16 @@ lemma insertNewCap_ccorres:
   apply (simp add: untypedZeroRange_def Let_def)
   done
 
+lemma Arch_createObject_not_untyped:
+  "\<forall>s. \<Gamma>\<turnstile>\<^bsub>/UNIV\<^esub>
+   {s} Call Arch_createObject_'proc {t. cap_get_tag (ret__struct_cap_C_' t) \<noteq> 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:
   "\<forall>\<sigma>. \<Gamma>\<turnstile>\<^bsub>/UNIV\<^esub> {s. let tp = (object_type_to_H (t_' s));
           sz = APIType_capBits tp (unat (userSize_' s))
@@ -6659,9 +6849,8 @@ lemma createObject_untyped_region_is_zero_bytes:
    {t. cap_get_tag (ret__struct_cap_C_' t) = scast cap_untyped_cap
          \<longrightarrow> (case untypedZeroRange (cap_to_H (the (cap_lift (ret__struct_cap_C_' t)))) of None \<Rightarrow> True
           | Some (a, b) \<Rightarrow> 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_HYP/Invoke_C.thy b/proof/crefine/ARM_HYP/Invoke_C.thy
index 0811a0756d..f482be0709 100644
--- a/proof/crefine/ARM_HYP/Invoke_C.thy
+++ b/proof/crefine/ARM_HYP/Invoke_C.thy
@@ -1677,45 +1677,37 @@ lemma clearMemory_untyped_ccorres:
   apply (cinit' lift: bits_' ptr___ptr_to_unsigned_long_')
    apply (rule_tac P="ptr \<noteq> 0 \<and> 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
   apply (cases "ptr = 0")
    apply (drule subsetD, rule intvl_self, simp)
    apply (simp split: if_split_asm)
diff --git a/proof/crefine/ARM_HYP/Machine_C.thy b/proof/crefine/ARM_HYP/Machine_C.thy
index 81a08b6acf..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:
 "\<And>in_kernel.
    ccorres (\<lambda>(a::irq option) c::machine_word.
diff --git a/proof/crefine/ARM_HYP/Recycle_C.thy b/proof/crefine/ARM_HYP/Recycle_C.thy
index f6e39812f7..2db441b729 100644
--- a/proof/crefine/ARM_HYP/Recycle_C.thy
+++ b/proof/crefine/ARM_HYP/Recycle_C.thy
@@ -264,121 +264,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 \<le> 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 "\<forall>p<2 ^ (pageBitsForSize sz - pageBits).
-                               x \<Turnstile>\<^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 \<noteq> 0", simp)
+   apply simp
+   apply (prop_tac "2 \<le> 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 "\<forall>p<2 ^ (pageBitsForSize sz - pageBits).
+                            x \<Turnstile>\<^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)
diff --git a/proof/crefine/ARM_HYP/Retype_C.thy b/proof/crefine/ARM_HYP/Retype_C.thy
index b257c9843c..a960eb388c 100644
--- a/proof/crefine/ARM_HYP/Retype_C.thy
+++ b/proof/crefine/ARM_HYP/Retype_C.thy
@@ -5676,6 +5676,40 @@ lemma placeNewObject_vcpu_ccorres:
   apply fastforce
   done
 
+lemma placeNewDataObject_dev_ccorres:
+  "ccorresG rf_sr \<Gamma> 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 (\<lambda>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 \<Gamma> 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
+      \<and> (heap_list_is_zero (hrs_mem (t_hrs_' (globals s))) regionBase (2 ^ (pageBits + us)))})
+  hs
+  (placeNewDataObject regionBase us False)
+  (global_htd_update (\<lambda>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]: "\<lambda>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)
-
-        \<comment> \<open>Page objects: could possibly fix the duplication here\<close>
+          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])
 
-     \<comment> \<open>PageTableObject\<close>
+     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)
-
-    \<comment> \<open>PageDirectoryObject\<close>
-    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,17 +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
-                              cacheLineBits_le_ptBits[unfolded ptBits_def pteBits_def, simplified])+)[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)
     \<comment> \<open>VCPU\<close>
     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)
@@ -7809,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:
+  "\<forall>s. \<Gamma>\<turnstile>\<^bsub>/UNIV\<^esub> {s} Call cleanByVA_'proc
+      {t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s))
+         \<and> 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:
+  "\<forall>s. \<Gamma>\<turnstile>\<^bsub>/UNIV\<^esub> {s} Call cleanCacheRange_PoC_'proc
+      {t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s))
+         \<and> 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))
+                          \<and> 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:
+  "\<forall>s. \<Gamma>\<turnstile>\<^bsub>/UNIV\<^esub> {s} Call cleanCacheRange_RAM_'proc
+      {t. hrs_htd (t_hrs_' (globals t)) = hrs_htd (t_hrs_' (globals s))
+         \<and> 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 (\<lambda>_. f (hrs_htd hrs)) hrs = hrs_htd_update f hrs"
   by (cases hrs, simp add: hrs_htd_update_def hrs_htd_def)
@@ -7822,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 \<open>(solves \<open>simp add: mask_def\<close>)?\<close>)
+        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)
@@ -7991,6 +8180,14 @@ lemma insertNewCap_ccorres:
   apply (simp add: untypedZeroRange_def Let_def)
   done
 
+lemma Arch_createObject_not_untyped:
+  "\<forall>s. \<Gamma>\<turnstile>\<^bsub>/UNIV\<^esub>
+   {s} Call Arch_createObject_'proc {t. cap_get_tag (ret__struct_cap_C_' t) \<noteq> 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:
   "\<forall>\<sigma>. \<Gamma>\<turnstile>\<^bsub>/UNIV\<^esub> {s. let tp = (object_type_to_H (t_' s));
           sz = APIType_capBits tp (unat (userSize_' s))
@@ -8002,16 +8199,13 @@ lemma createObject_untyped_region_is_zero_bytes:
    {t. cap_get_tag (ret__struct_cap_C_' t) = scast cap_untyped_cap
          \<longrightarrow> (case untypedZeroRange (cap_to_H (the (cap_lift (ret__struct_cap_C_' t)))) of None \<Rightarrow> True
           | Some (a, b) \<Rightarrow> 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/drefine/Untyped_DR.thy b/proof/drefine/Untyped_DR.thy
index 9099119f27..9c833a3708 100644
--- a/proof/drefine/Untyped_DR.thy
+++ b/proof/drefine/Untyped_DR.thy
@@ -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:
+  "\<lbrakk> \<And>m r. \<lbrace>\<lambda>ms. underlying_memory ms = m\<rbrace> mop r \<lbrace>\<lambda>rv ms. underlying_memory ms = m\<rbrace> \<rbrakk>
+       \<Longrightarrow> dcorres dc \<top> \<top> (return ()) (mapM_x (\<lambda>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 \<inter> {ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1} = {})
                \<and> valid_objs s \<and> pspace_aligned s \<and> pspace_distinct s \<and> valid_idle s \<and> 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=\<top> 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=\<top> 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 c05b611654..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]:
     "\<And>Q. \<lbrace>\<top>\<rbrace> arch_invoke_irq_control ici -, \<lbrace>\<lambda>rv s :: det_state. Q rv s\<rbrace>"
   and init_arch_objects_irq_state_of_state[wp]:
-    "\<And>P. init_arch_objects new_type ptr num_objects obj_sz refs \<lbrace>\<lambda>s. P (irq_state_of_state s)\<rbrace>"
+    "\<And>P. init_arch_objects new_type dev ptr num_objects obj_sz refs \<lbrace>\<lambda>s. P (irq_state_of_state s)\<rbrace>"
   and getActiveIRQ_None:
     "(None, s') \<in> fst (do_machine_op (getActiveIRQ in_kernel) (s :: det_state))
      \<Longrightarrow> irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s)) = None"
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]:
   "\<lbrace>\<top>\<rbrace> arch_invoke_irq_control a -, \<lbrace>Q\<rbrace>"
   by (cases a; wpsimp)
 
-crunch cleanCacheRange_PoU
+crunch cleanCacheRange_PoU, cleanCacheRange_RAM
   for irq_state[wp]: "\<lambda>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]: "\<lambda>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) (\<lambda>_. 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 \<top> (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="\<top>", simplified, OF dmo_cleanCacheRange_PoU_globals_equiv])
   by simp
 
+lemma dmo_cleanCacheRange_RAM_globals_equiv:
+  "do_machine_op (cleanCacheRange_RAM x y z) \<lbrace>globals_equiv s\<rbrace>"
+  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 \<top> (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 \<top> (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="\<top>", simplified, OF dmo_cleanCacheRange_RAM_globals_equiv])
+  by simp
+
 lemma mol_globals_equiv:
   "machine_op_lift mop \<lbrace>\<lambda>ms. globals_equiv st (s\<lparr>machine_state := ms\<rparr>)\<rbrace>"
   unfolding machine_op_lift_def
@@ -264,15 +281,16 @@ lemma init_arch_objects_reads_respects_g:
                            K (\<forall>x\<in>set refs. new_type = ArchObject PageDirectoryObj
                                            \<longrightarrow> 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:
   "\<lbrace>globals_equiv s and (\<lambda>s. arm_global_pd (arch_state s) \<notin> set refs \<and>
                              pspace_aligned s \<and> valid_arch_state s)
                     and K (\<forall>x\<in>set refs. is_aligned x (obj_bits_api new_type obj_sz))\<rbrace>
-   init_arch_objects new_type ptr num_objects obj_sz refs
+   init_arch_objects new_type dev ptr num_objects obj_sz refs
    \<lbrace>\<lambda>_. globals_equiv s\<rbrace>"
   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'="\<lambda>_. globals_equiv s and (\<lambda> s. arm_global_pd (arch_state s) \<notin> set refs)"
                  in hoare_strengthen_post)
      apply (wp mapM_x_wp[OF _ subset_refl] copy_global_mappings_globals_equiv
diff --git a/proof/infoflow/FinalCaps.thy b/proof/infoflow/FinalCaps.thy
index 3e9c3c0c8c..aac6f1fedf 100644
--- a/proof/infoflow/FinalCaps.thy
+++ b/proof/infoflow/FinalCaps.thy
@@ -347,9 +347,9 @@ locale FinalCaps_1 =
   and arch_switch_to_thread_silc_inv[wp]:
     "arch_switch_to_thread t \<lbrace>silc_inv aag st\<rbrace>"
   and init_arch_objects_silc_inv[wp]:
-    "init_arch_objects typ ptr num sz refs \<lbrace>silc_inv aag st\<rbrace>"
+    "init_arch_objects typ dev ptr num sz refs \<lbrace>silc_inv aag st\<rbrace>"
   and init_arch_objects_cte_wp_at[wp]:
-    "\<And>P. init_arch_objects typ ptr num sz refs \<lbrace>\<lambda>s :: det_state. P (cte_wp_at P' slot s)\<rbrace>"
+    "\<And>P. init_arch_objects typ dev ptr num sz refs \<lbrace>\<lambda>s :: det_state. P (cte_wp_at P' slot s)\<rbrace>"
   and finalise_cap_makes_halted:
     "\<lbrace>invs and valid_cap cap and (\<lambda>s. ex = is_final_cap' cap s) and cte_wp_at ((=) cap) slot\<rbrace>
      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 \<lbrace>domain_fields P\<rbrace>"
   and init_arch_objects_domain_fields[wp]:
-    "init_arch_objects typ ptr num sz refs \<lbrace>domain_fields P\<rbrace>"
+    "init_arch_objects typ dev ptr num sz refs \<lbrace>domain_fields P\<rbrace>"
   and state_asids_to_policy_pasSubject_update:
     "state_asids_to_policy (aag\<lparr>pasSubject := subject\<rparr>) 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 \<lbrace>\<lambda>s. P (irq_masks_of_state s)\<rbrace>"
+  "init_arch_objects new_type dev ptr num_objects obj_sz refs \<lbrace>\<lambda>s. P (irq_masks_of_state s)\<rbrace>"
   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 \<top> (init_arch_objects new_type ptr num_objects obj_sz refs)"
+  "reads_respects_g aag l \<top> (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/invariant-abstract/AARCH64/ArchDetSchedAux_AI.thy b/proof/invariant-abstract/AARCH64/ArchDetSchedAux_AI.thy
index 2439b153b8..637024ae11 100644
--- a/proof/invariant-abstract/AARCH64/ArchDetSchedAux_AI.thy
+++ b/proof/invariant-abstract/AARCH64/ArchDetSchedAux_AI.thy
@@ -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/ArchRetype_AI.thy b/proof/invariant-abstract/AARCH64/ArchRetype_AI.thy
index 1fb9559853..eaa296e016 100644
--- a/proof/invariant-abstract/AARCH64/ArchRetype_AI.thy
+++ b/proof/invariant-abstract/AARCH64/ArchRetype_AI.thy
@@ -147,13 +147,10 @@ lemma init_arch_objects_invs_from_restricted:
   "\<lbrace>post_retype_invs new_type refs
          and (\<lambda>s. global_refs s \<inter> set refs = {})
          and K (\<forall>ref \<in> set refs. is_aligned ref (obj_bits_api new_type obj_sz))\<rbrace>
-     init_arch_objects new_type ptr bits obj_sz refs
+     init_arch_objects new_type dev ptr bits obj_sz refs
    \<lbrace>\<lambda>_. invs\<rbrace>"
   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
 
@@ -981,7 +978,7 @@ crunch init_arch_objects
 
 lemma init_arch_objects_excap:
   "\<lbrace>ex_cte_cap_wp_to P p\<rbrace>
-      init_arch_objects tp ptr bits us refs
+      init_arch_objects tp dev ptr bits us refs
    \<lbrace>\<lambda>rv s. ex_cte_cap_wp_to P p s\<rbrace>"
   by (wp ex_cte_cap_to_pres)
 
diff --git a/proof/invariant-abstract/AARCH64/ArchUntyped_AI.thy b/proof/invariant-abstract/AARCH64/ArchUntyped_AI.thy
index 4c92fcba10..3a60b1f14a 100644
--- a/proof/invariant-abstract/AARCH64/ArchUntyped_AI.thy
+++ b/proof/invariant-abstract/AARCH64/ArchUntyped_AI.thy
@@ -192,15 +192,17 @@ lemma cap_refs_in_kernel_windowD2:
 
 lemma init_arch_objects_descendants_range[wp,Untyped_AI_assms]:
   "\<lbrace>\<lambda>(s::'state_ext::state_ext state). descendants_range x cref s \<rbrace>
-   init_arch_objects ty ptr n us y
+   init_arch_objects ty dev ptr n us y
    \<lbrace>\<lambda>rv s. descendants_range x cref s\<rbrace>"
-  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]:
   "\<lbrace>\<lambda>(s::'state_ext::state_ext state). caps_overlap_reserved S s\<rbrace>
-   init_arch_objects ty ptr n us y
+   init_arch_objects ty dev ptr n us y
    \<lbrace>\<lambda>rv s. caps_overlap_reserved S s\<rbrace>"
-  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]:
   "\<lbrace>\<lambda>s. descendants_range_in {ptr .. ptr+2^sz - 1} cref s \<and> pspace_no_overlap_range_cover ptr sz s \<and> invs s
@@ -325,9 +327,9 @@ lemma init_arch_objects_nonempty_table[Untyped_AI_assms, wp]:
   "\<lbrace>(\<lambda>s. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)
          \<and> valid_global_objs s \<and> valid_arch_state s \<and> pspace_aligned s) and
     K (\<forall>ref\<in>set refs. is_aligned ref (obj_bits_api tp us))\<rbrace>
-        init_arch_objects tp ptr bits us refs
+        init_arch_objects tp dev ptr bits us refs
    \<lbrace>\<lambda>rv s. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)\<rbrace>"
-  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 \<Longrightarrow> caps_of ko = {}"
@@ -344,6 +346,7 @@ lemma nonempty_default[simp, Untyped_AI_assms]:
 
 crunch init_arch_objects
   for cte_wp_at_iin[wp]: "\<lambda>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/ArchVSpaceEntries_AI.thy b/proof/invariant-abstract/AARCH64/ArchVSpaceEntries_AI.thy
index 816b92285f..738278552e 100644
--- a/proof/invariant-abstract/AARCH64/ArchVSpaceEntries_AI.thy
+++ b/proof/invariant-abstract/AARCH64/ArchVSpaceEntries_AI.thy
@@ -176,9 +176,9 @@ lemma init_arch_objects_valid_vspace:
   "\<lbrace>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)\<rbrace>
-     init_arch_objects type ptr n obj_sz orefs
+     init_arch_objects type dev ptr n obj_sz orefs
    \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
-  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]:
   "\<lbrace>valid_vspace_objs'\<rbrace> delete_objects ptr bits \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
diff --git a/proof/invariant-abstract/ARM/ArchRetype_AI.thy b/proof/invariant-abstract/ARM/ArchRetype_AI.thy
index 3ec0e8cc5c..0e191d2b36 100644
--- a/proof/invariant-abstract/ARM/ArchRetype_AI.thy
+++ b/proof/invariant-abstract/ARM/ArchRetype_AI.thy
@@ -599,14 +599,11 @@ lemma init_arch_objects_invs_from_restricted:
   "\<lbrace>post_retype_invs new_type refs
          and (\<lambda>s. global_refs s \<inter> set refs = {})
          and K (\<forall>ref \<in> set refs. is_aligned ref (obj_bits_api new_type obj_sz))\<rbrace>
-     init_arch_objects new_type ptr bits obj_sz refs
+     init_arch_objects new_type dev ptr bits obj_sz refs
    \<lbrace>\<lambda>_. invs\<rbrace>"
   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="\<lambda>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)
@@ -1363,7 +1360,7 @@ crunch init_arch_objects
 
 lemma init_arch_objects_excap:
   "\<lbrace>ex_cte_cap_wp_to P p\<rbrace>
-      init_arch_objects tp ptr bits us refs
+      init_arch_objects tp dev ptr bits us refs
    \<lbrace>\<lambda>rv s. ex_cte_cap_wp_to P p s\<rbrace>"
   by (wp ex_cte_cap_to_pres)
 
diff --git a/proof/invariant-abstract/ARM/ArchUntyped_AI.thy b/proof/invariant-abstract/ARM/ArchUntyped_AI.thy
index 16f220bce4..929f2e97a5 100644
--- a/proof/invariant-abstract/ARM/ArchUntyped_AI.thy
+++ b/proof/invariant-abstract/ARM/ArchUntyped_AI.thy
@@ -191,24 +191,13 @@ lemma copy_global_mappings_hoare_lift:(*FIXME: arch-split  \<rightarrow> these d
   done
 
 lemma init_arch_objects_hoare_lift:
-  assumes wp: "\<And>oper. \<lbrace>(P::'state_ext::state_ext state\<Rightarrow>bool)\<rbrace> do_machine_op oper \<lbrace>\<lambda>rv :: unit. Q\<rbrace>"
-              "\<And>ptr val. \<lbrace>P\<rbrace> store_pde ptr val \<lbrace>\<lambda>rv. P\<rbrace>"
-  shows       "\<lbrace>P and Q\<rbrace> init_arch_objects tp ptr sz us adds \<lbrace>\<lambda>rv. Q\<rbrace>"
-proof -
-  have pres: "\<And>oper. \<lbrace>P and Q\<rbrace> do_machine_op oper \<lbrace>\<lambda>rv :: unit. Q\<rbrace>"
-             "\<lbrace>P and Q\<rbrace> return () \<lbrace>\<lambda>rv. Q\<rbrace>"
-    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: "\<And>oper. \<lbrace>(Q::'state_ext::state_ext state\<Rightarrow>bool)\<rbrace> do_machine_op oper \<lbrace>\<lambda>rv :: unit. Q\<rbrace>"
+              "\<And>ptr val. \<lbrace>Q\<rbrace> store_pde ptr val \<lbrace>\<lambda>rv. Q\<rbrace>"
+  shows       "\<lbrace>Q\<rbrace> init_arch_objects tp dev ptr sz us adds \<lbrace>\<lambda>rv. Q\<rbrace>"
+  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:
   "\<lbrakk> cte_wp_at P p (s::'state_ext::state_ext state); cap_refs_in_kernel_window s \<rbrakk>
@@ -219,30 +208,21 @@ lemma cap_refs_in_kernel_windowD2:
   done
 
 lemma init_arch_objects_descendants_range[wp,Untyped_AI_assms]:
-  "\<lbrace>\<lambda>(s::'state_ext::state_ext state). descendants_range x cref s \<rbrace> init_arch_objects ty ptr n us y
-          \<lbrace>\<lambda>rv s. descendants_range x cref s\<rbrace>"
-  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
+  "\<lbrace>\<lambda>(s::'state_ext::state_ext state). descendants_range x cref s \<rbrace>
+   init_arch_objects ty dev ptr n us y
+   \<lbrace>\<lambda>rv s. descendants_range x cref s\<rbrace>"
+  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]:
   "\<lbrace>\<lambda>(s::'state_ext::state_ext state). caps_overlap_reserved S s\<rbrace>
-   init_arch_objects ty ptr n us y
+   init_arch_objects ty dev ptr n us y
    \<lbrace>\<lambda>rv s. caps_overlap_reserved S s\<rbrace>"
   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]:
@@ -526,12 +506,11 @@ lemma init_arch_objects_nonempty_table[Untyped_AI_assms, wp]:
   "\<lbrace>(\<lambda>s. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)
          \<and> valid_global_objs s \<and> valid_arch_state s \<and> pspace_aligned s) and
     K (\<forall>ref\<in>set refs. is_aligned ref (obj_bits_api tp us))\<rbrace>
-        init_arch_objects tp ptr bits us refs
+        init_arch_objects tp dev ptr bits us refs
    \<lbrace>\<lambda>rv s. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)\<rbrace>"
-  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="\<lambda>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
 
diff --git a/proof/invariant-abstract/ARM/ArchVSpaceEntries_AI.thy b/proof/invariant-abstract/ARM/ArchVSpaceEntries_AI.thy
index e54d26d89a..f8c735edaa 100644
--- a/proof/invariant-abstract/ARM/ArchVSpaceEntries_AI.thy
+++ b/proof/invariant-abstract/ARM/ArchVSpaceEntries_AI.thy
@@ -668,26 +668,25 @@ lemma init_arch_objects_valid_pdpt:
   "\<lbrace>valid_pdpt_objs and pspace_aligned and valid_arch_state
            and K (\<exists>us sz. orefs = retype_addrs ptr type n us
                \<and> range_cover ptr sz (obj_bits_api type us) n)\<rbrace>
-     init_arch_objects type ptr n obj_sz orefs
+     init_arch_objects type dev ptr n obj_sz orefs
    \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
   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'="\<lambda>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'="\<lambda>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/ArchRetype_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchRetype_AI.thy
index f9df43d8e2..3a47c1723b 100644
--- a/proof/invariant-abstract/ARM_HYP/ArchRetype_AI.thy
+++ b/proof/invariant-abstract/ARM_HYP/ArchRetype_AI.thy
@@ -439,14 +439,11 @@ lemma init_arch_objects_invs_from_restricted:
   "\<lbrace>post_retype_invs new_type refs
          and (\<lambda>s. global_refs s \<inter> set refs = {})
          and K (\<forall>ref \<in> set refs. is_aligned ref (obj_bits_api new_type obj_sz))\<rbrace>
-     init_arch_objects new_type ptr bits obj_sz refs
+     init_arch_objects new_type dev ptr bits obj_sz refs
    \<lbrace>\<lambda>_. invs\<rbrace>"
   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="\<lambda>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)
@@ -1213,7 +1210,7 @@ crunch init_arch_objects
 
 lemma init_arch_objects_excap:
   "\<lbrace>ex_cte_cap_wp_to P p\<rbrace>
-      init_arch_objects tp ptr bits us refs
+      init_arch_objects tp dev ptr bits us refs
    \<lbrace>\<lambda>rv s. ex_cte_cap_wp_to P p s\<rbrace>"
   by (wp ex_cte_cap_to_pres)
 
diff --git a/proof/invariant-abstract/ARM_HYP/ArchUntyped_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchUntyped_AI.thy
index 5a13e74107..900d27e25a 100644
--- a/proof/invariant-abstract/ARM_HYP/ArchUntyped_AI.thy
+++ b/proof/invariant-abstract/ARM_HYP/ArchUntyped_AI.thy
@@ -186,24 +186,13 @@ lemma copy_global_mappings_hoare_lift:(*FIXME: arch-split  \<rightarrow> these d
   done
 
 lemma init_arch_objects_hoare_lift:
-  assumes wp: "\<And>oper. \<lbrace>(P::'state_ext::state_ext state\<Rightarrow>bool)\<rbrace> do_machine_op oper \<lbrace>\<lambda>rv :: unit. Q\<rbrace>"
-              "\<And>ptr val. \<lbrace>P\<rbrace> store_pde ptr val \<lbrace>\<lambda>rv. P\<rbrace>"
-  shows       "\<lbrace>P and Q\<rbrace> init_arch_objects tp ptr sz us adds \<lbrace>\<lambda>rv. Q\<rbrace>"
-proof -
-  have pres: "\<And>oper. \<lbrace>P and Q\<rbrace> do_machine_op oper \<lbrace>\<lambda>rv :: unit. Q\<rbrace>"
-             "\<lbrace>P and Q\<rbrace> return () \<lbrace>\<lambda>rv. Q\<rbrace>"
-    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: "\<And>oper. \<lbrace>(Q::'state_ext::state_ext state\<Rightarrow>bool)\<rbrace> do_machine_op oper \<lbrace>\<lambda>rv :: unit. Q\<rbrace>"
+              "\<And>ptr val. \<lbrace>Q\<rbrace> store_pde ptr val \<lbrace>\<lambda>rv. Q\<rbrace>"
+  shows       "\<lbrace>Q\<rbrace> init_arch_objects tp dev ptr sz us adds \<lbrace>\<lambda>rv. Q\<rbrace>"
+  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]:
-  "\<lbrace>\<lambda>(s::'state_ext::state_ext state). descendants_range x cref s \<rbrace> init_arch_objects ty ptr n us y
+  "\<lbrace>\<lambda>(s::'state_ext::state_ext state). descendants_range x cref s \<rbrace> init_arch_objects ty dev ptr n us y
           \<lbrace>\<lambda>rv s. descendants_range x cref s\<rbrace>"
-  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]:
   "\<lbrace>\<lambda>(s::'state_ext::state_ext state). caps_overlap_reserved S s\<rbrace>
-   init_arch_objects ty ptr n us y
+   init_arch_objects ty dev ptr n us y
    \<lbrace>\<lambda>rv s. caps_overlap_reserved S s\<rbrace>"
   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]:
   "\<lbrace>(\<lambda>s. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)
          \<and> valid_global_objs s \<and> valid_arch_state s \<and> pspace_aligned s) and
     K (\<forall>ref\<in>set refs. is_aligned ref (obj_bits_api tp us))\<rbrace>
-        init_arch_objects tp ptr bits us refs
+        init_arch_objects tp dev ptr bits us refs
    \<lbrace>\<lambda>rv s. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)\<rbrace>"
-  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="\<lambda>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/ArchVSpaceEntries_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchVSpaceEntries_AI.thy
index 76704a98cc..5c7cbc4c1f 100644
--- a/proof/invariant-abstract/ARM_HYP/ArchVSpaceEntries_AI.thy
+++ b/proof/invariant-abstract/ARM_HYP/ArchVSpaceEntries_AI.thy
@@ -600,26 +600,25 @@ lemma init_arch_objects_valid_pdpt:
   "\<lbrace>valid_pdpt_objs and pspace_aligned and valid_arch_state
            and K (\<exists>us sz. orefs = retype_addrs ptr type n us
                \<and> range_cover ptr sz (obj_bits_api type us) n)\<rbrace>
-     init_arch_objects type ptr n obj_sz orefs
+     init_arch_objects type dev ptr n obj_sz orefs
    \<lbrace>\<lambda>rv. valid_pdpt_objs\<rbrace>"
   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'="\<lambda>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'="\<lambda>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/DetSchedAux_AI.thy b/proof/invariant-abstract/DetSchedAux_AI.thy
index 5c3bedd1a5..8f1b4eb67b 100644
--- a/proof/invariant-abstract/DetSchedAux_AI.thy
+++ b/proof/invariant-abstract/DetSchedAux_AI.thy
@@ -146,9 +146,9 @@ locale DetSchedAux_AI_det_ext = DetSchedAux_AI "TYPE(det_ext)" +
         invoke_untyped ui
       \<lbrace>\<lambda>r s. st_tcb_at (Not o inactive) t s \<longrightarrow> etcb_at P t s\<rbrace> "
   assumes init_arch_objects_valid_etcbs[wp]:
-    "\<And>t r n sz refs. \<lbrace>valid_etcbs\<rbrace> init_arch_objects t r n sz refs \<lbrace>\<lambda>_. valid_etcbs\<rbrace>"
+    "\<And>t d r n sz refs. \<lbrace>valid_etcbs\<rbrace> init_arch_objects t d r n sz refs \<lbrace>\<lambda>_. valid_etcbs\<rbrace>"
   assumes init_arch_objects_valid_blocked[wp]:
-    "\<And>t r n sz refs. \<lbrace>valid_blocked\<rbrace> init_arch_objects t r n sz refs \<lbrace>\<lambda>_. valid_blocked\<rbrace>"
+    "\<And>t d r n sz refs. \<lbrace>valid_blocked\<rbrace> init_arch_objects t d r n sz refs \<lbrace>\<lambda>_. valid_blocked\<rbrace>"
   assumes invoke_untyped_cur_domain[wp]:
     "\<And>P i. \<lbrace>\<lambda>s. P (cur_domain s)\<rbrace> invoke_untyped i \<lbrace>\<lambda>_ s. P (cur_domain s)\<rbrace>"
   assumes invoke_untyped_ready_queues[wp]:
diff --git a/proof/invariant-abstract/DetSchedDomainTime_AI.thy b/proof/invariant-abstract/DetSchedDomainTime_AI.thy
index 5a65db9c90..249d856540 100644
--- a/proof/invariant-abstract/DetSchedDomainTime_AI.thy
+++ b/proof/invariant-abstract/DetSchedDomainTime_AI.thy
@@ -49,7 +49,7 @@ locale DetSchedDomainTime_AI =
   assumes handle_arch_fault_reply_domain_list_inv'[wp]:
     "\<And>P f t x y. \<lbrace>\<lambda>s. P (domain_list s)\<rbrace> handle_arch_fault_reply f t x y \<lbrace>\<lambda>_ s. P (domain_list s)\<rbrace>"
   assumes init_arch_objects_domain_list_inv'[wp]:
-    "\<And>P t p n s r. \<lbrace>\<lambda>s. P (domain_list s)\<rbrace> init_arch_objects t p n s r \<lbrace>\<lambda>_ s. P (domain_list s)\<rbrace>"
+    "\<And>P t d p n s r. \<lbrace>\<lambda>s. P (domain_list s)\<rbrace> init_arch_objects t d p n s r \<lbrace>\<lambda>_ s. P (domain_list s)\<rbrace>"
   assumes arch_post_modify_registers_domain_list_inv'[wp]:
     "\<And>P t p. \<lbrace>\<lambda>s. P (domain_list s)\<rbrace> arch_post_modify_registers t p \<lbrace>\<lambda>_ s. P (domain_list s)\<rbrace>"
   assumes arch_invoke_irq_control_domain_list_inv'[wp]:
@@ -71,7 +71,7 @@ locale DetSchedDomainTime_AI =
   assumes handle_arch_fault_reply_domain_time_inv'[wp]:
     "\<And>P f t x y. \<lbrace>\<lambda>s. P (domain_time s)\<rbrace> handle_arch_fault_reply f t x y \<lbrace>\<lambda>_ s. P (domain_time s)\<rbrace>"
   assumes init_arch_objects_domain_time_inv'[wp]:
-    "\<And>P t p n s r. \<lbrace>\<lambda>s. P (domain_time s)\<rbrace> init_arch_objects t p n s r \<lbrace>\<lambda>_ s. P (domain_time s)\<rbrace>"
+    "\<And>P t d p n s r. \<lbrace>\<lambda>s. P (domain_time s)\<rbrace> init_arch_objects t d p n s r \<lbrace>\<lambda>_ s. P (domain_time s)\<rbrace>"
   assumes arch_post_modify_registers_domain_time_inv'[wp]:
     "\<And>P t p. \<lbrace>\<lambda>s. P (domain_time s)\<rbrace> arch_post_modify_registers t p \<lbrace>\<lambda>_ s. P (domain_time s)\<rbrace>"
   assumes arch_invoke_irq_control_domain_time_inv'[wp]:
diff --git a/proof/invariant-abstract/RISCV64/ArchRetype_AI.thy b/proof/invariant-abstract/RISCV64/ArchRetype_AI.thy
index 8fb5f9ae6c..f5592d1578 100644
--- a/proof/invariant-abstract/RISCV64/ArchRetype_AI.thy
+++ b/proof/invariant-abstract/RISCV64/ArchRetype_AI.thy
@@ -211,7 +211,7 @@ lemma init_arch_objects_invs_from_restricted:
   "\<lbrace>post_retype_invs new_type refs
          and (\<lambda>s. global_refs s \<inter> set refs = {})
          and K (\<forall>ref \<in> set refs. is_aligned ref (obj_bits_api new_type obj_sz))\<rbrace>
-     init_arch_objects new_type ptr bits obj_sz refs
+     init_arch_objects new_type dev ptr bits obj_sz refs
    \<lbrace>\<lambda>_. invs\<rbrace>"
   apply (simp add: init_arch_objects_def split del: if_split)
   apply (rule hoare_pre)
@@ -1047,7 +1047,7 @@ crunch init_arch_objects
 
 lemma init_arch_objects_excap:
   "\<lbrace>ex_cte_cap_wp_to P p\<rbrace>
-      init_arch_objects tp ptr bits us refs
+      init_arch_objects tp dev ptr bits us refs
    \<lbrace>\<lambda>rv s. ex_cte_cap_wp_to P p s\<rbrace>"
   by (wp ex_cte_cap_to_pres)
 
diff --git a/proof/invariant-abstract/RISCV64/ArchUntyped_AI.thy b/proof/invariant-abstract/RISCV64/ArchUntyped_AI.thy
index 2d0b6b3d22..db56478145 100644
--- a/proof/invariant-abstract/RISCV64/ArchUntyped_AI.thy
+++ b/proof/invariant-abstract/RISCV64/ArchUntyped_AI.thy
@@ -191,13 +191,13 @@ lemma cap_refs_in_kernel_windowD2:
 
 lemma init_arch_objects_descendants_range[wp,Untyped_AI_assms]:
   "\<lbrace>\<lambda>(s::'state_ext::state_ext state). descendants_range x cref s \<rbrace>
-   init_arch_objects ty ptr n us y
+   init_arch_objects ty dev ptr n us y
    \<lbrace>\<lambda>rv s. descendants_range x cref s\<rbrace>"
   unfolding init_arch_objects_def by wp
 
 lemma init_arch_objects_caps_overlap_reserved[wp,Untyped_AI_assms]:
   "\<lbrace>\<lambda>(s::'state_ext::state_ext state). caps_overlap_reserved S s\<rbrace>
-   init_arch_objects ty ptr n us y
+   init_arch_objects ty dev ptr n us y
    \<lbrace>\<lambda>rv s. caps_overlap_reserved S s\<rbrace>"
   unfolding init_arch_objects_def by wp
 
@@ -327,7 +327,7 @@ lemma init_arch_objects_nonempty_table[Untyped_AI_assms, wp]:
   "\<lbrace>(\<lambda>s. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)
          \<and> valid_global_objs s \<and> valid_arch_state s \<and> pspace_aligned s) and
     K (\<forall>ref\<in>set refs. is_aligned ref (obj_bits_api tp us))\<rbrace>
-        init_arch_objects tp ptr bits us refs
+        init_arch_objects tp dev ptr bits us refs
    \<lbrace>\<lambda>rv s. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)\<rbrace>"
   unfolding init_arch_objects_def by wpsimp
 
diff --git a/proof/invariant-abstract/RISCV64/ArchVSpaceEntries_AI.thy b/proof/invariant-abstract/RISCV64/ArchVSpaceEntries_AI.thy
index dc7befa8c9..941ce0c46c 100644
--- a/proof/invariant-abstract/RISCV64/ArchVSpaceEntries_AI.thy
+++ b/proof/invariant-abstract/RISCV64/ArchVSpaceEntries_AI.thy
@@ -202,7 +202,7 @@ lemma init_arch_objects_valid_vspace:
   "\<lbrace>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)\<rbrace>
-     init_arch_objects type ptr n obj_sz orefs
+     init_arch_objects type dev ptr n obj_sz orefs
    \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
   unfolding init_arch_objects_def by wpsimp
 
diff --git a/proof/invariant-abstract/Untyped_AI.thy b/proof/invariant-abstract/Untyped_AI.thy
index 8ba8f5ebef..8891a97681 100644
--- a/proof/invariant-abstract/Untyped_AI.thy
+++ b/proof/invariant-abstract/Untyped_AI.thy
@@ -279,12 +279,15 @@ locale Untyped_AI_arch =
                               (kheap s)\<rparr> \<turnstile> 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]:
-  "\<And>x cref ty ptr n us y. \<lbrace>\<lambda>(s::'state_ext state). descendants_range x cref s \<rbrace> init_arch_objects ty ptr n us y
-          \<lbrace>\<lambda>rv s. descendants_range x cref s\<rbrace>"
+  "\<And>x cref ty dev ptr n us y.
+     \<lbrace>\<lambda>(s::'state_ext state). descendants_range x cref s \<rbrace>
+     init_arch_objects ty dev ptr n us y
+     \<lbrace>\<lambda>rv s. descendants_range x cref s\<rbrace>"
   assumes  init_arch_objects_caps_overlap_reserved[wp]:
-  "\<And>S ty ptr n us y. \<lbrace>\<lambda>(s::'state_ext state). caps_overlap_reserved S s\<rbrace>
-   init_arch_objects ty ptr n us y
-   \<lbrace>\<lambda>rv s. caps_overlap_reserved S s\<rbrace>"
+  "\<And>S ty dev ptr n us y.
+     \<lbrace>\<lambda>(s::'state_ext state). caps_overlap_reserved S s\<rbrace>
+     init_arch_objects ty dev ptr n us y
+     \<lbrace>\<lambda>rv s. caps_overlap_reserved S s\<rbrace>"
   assumes delete_objects_rewrite:
   "\<And>sz ptr. \<lbrakk> word_size_bits \<le> sz; sz\<le> word_bits; ptr && ~~ mask sz = ptr \<rbrakk>
       \<Longrightarrow> delete_objects ptr sz =
@@ -3026,7 +3029,7 @@ locale Untyped_AI_nonempty_table =
   "\<lbrace>(\<lambda>s. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)
          \<and> valid_global_objs s \<and> valid_arch_state s \<and> pspace_aligned s) and
     K (\<forall>ref\<in>set refs. is_aligned ref (obj_bits_api tp us))\<rbrace>
-        init_arch_objects tp ptr bits us refs
+        init_arch_objects tp dev ptr bits us refs
    \<lbrace>\<lambda>rv. \<lambda>s :: 'state_ext state. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)\<rbrace>"
   assumes create_cap_ioports[wp]:
   "\<And>tp oref sz dev cref p. \<lbrace>valid_ioports and cte_wp_at (\<lambda>_. True) cref\<rbrace>
@@ -3607,13 +3610,13 @@ lemma invoke_untyp_invs':
             and K (cref \<in> set slots \<and> oref \<in> set (retype_addrs ptr tp (length slots) us))
             and K (range_cover ptr sz (obj_bits_api tp us) (length slots))\<rbrace>
          create_cap tp us slot dev (cref,oref) \<lbrace>\<lambda>_. Q\<rbrace>"
- assumes init_arch_Q: "\<And>tp slot reset sz slots ptr n us refs dev.
+ assumes init_arch_Q: "\<And>tp dev slot reset sz slots ptr n us refs dev.
    ui = Invocations_A.Retype slot reset (ptr && ~~ mask sz) ptr tp us slots dev
     \<Longrightarrow> \<lbrace>Q and post_retype_invs tp refs
        and cte_wp_at (\<lambda>c. \<exists>idx. c = UntypedCap dev (ptr && ~~ mask sz) sz idx) slot
        and K (refs = retype_addrs ptr tp n us
          \<and> range_cover ptr sz (obj_bits_api tp us) n)\<rbrace>
-     init_arch_objects tp ptr n us refs \<lbrace>\<lambda>_. Q\<rbrace>"
+     init_arch_objects tp dev ptr n us refs \<lbrace>\<lambda>_. Q\<rbrace>"
  assumes retype_region_Q: "\<And>ptr us tp slot reset sz slots dev.
     ui = Invocations_A.Retype slot reset (ptr && ~~ mask sz) ptr tp us slots dev
     \<Longrightarrow> \<lbrace>\<lambda>s. invs s \<and> Q s
diff --git a/proof/invariant-abstract/X64/ArchRetype_AI.thy b/proof/invariant-abstract/X64/ArchRetype_AI.thy
index da95a99243..660b51071e 100644
--- a/proof/invariant-abstract/X64/ArchRetype_AI.thy
+++ b/proof/invariant-abstract/X64/ArchRetype_AI.thy
@@ -538,7 +538,7 @@ lemma init_arch_objects_invs_from_restricted:
   "\<lbrace>post_retype_invs new_type refs
          and (\<lambda>s. global_refs s \<inter> set refs = {})
          and K (\<forall>ref \<in> set refs. is_aligned ref (obj_bits_api new_type obj_sz))\<rbrace>
-     init_arch_objects new_type ptr bits obj_sz refs
+     init_arch_objects new_type dev ptr bits obj_sz refs
    \<lbrace>\<lambda>_. invs\<rbrace>"
   apply (simp add: init_arch_objects_def)
   apply (rule hoare_pre)
@@ -1287,7 +1287,7 @@ crunch init_arch_objects
   (wp: crunch_wps)
 
 lemma init_arch_objects_excap[wp]:
-  "\<lbrace>ex_cte_cap_wp_to P p\<rbrace> init_arch_objects tp ptr bits us refs \<lbrace>\<lambda>rv. ex_cte_cap_wp_to P p\<rbrace>"
+  "\<lbrace>ex_cte_cap_wp_to P p\<rbrace> init_arch_objects tp dev ptr bits us refs \<lbrace>\<lambda>rv. ex_cte_cap_wp_to P p\<rbrace>"
   by (wp ex_cte_cap_to_pres )
 
 crunch init_arch_objects
diff --git a/proof/invariant-abstract/X64/ArchUntyped_AI.thy b/proof/invariant-abstract/X64/ArchUntyped_AI.thy
index b47869a887..5c165920b1 100644
--- a/proof/invariant-abstract/X64/ArchUntyped_AI.thy
+++ b/proof/invariant-abstract/X64/ArchUntyped_AI.thy
@@ -190,7 +190,7 @@ lemma copy_global_mappings_hoare_lift:(*FIXME: arch-split  \<rightarrow> these d
 
 lemma init_arch_objects_hoare_lift:
   assumes wp:  "\<And>ptr val. \<lbrace>P\<rbrace> store_pml4e ptr val \<lbrace>\<lambda>rv. P\<rbrace>"
-  shows       "\<lbrace>P\<rbrace> init_arch_objects tp ptr sz us adds \<lbrace>\<lambda>rv. P\<rbrace>"
+  shows       "\<lbrace>P\<rbrace> init_arch_objects tp dev ptr sz us adds \<lbrace>\<lambda>rv. P\<rbrace>"
 proof -
   have pres: "\<lbrace>P\<rbrace> return () \<lbrace>\<lambda>rv. P\<rbrace>"
     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]:
-  "\<lbrace>\<lambda>(s::'state_ext::state_ext state). descendants_range x cref s \<rbrace> init_arch_objects ty ptr n us y
+  "\<lbrace>\<lambda>(s::'state_ext::state_ext state). descendants_range x cref s \<rbrace> init_arch_objects ty dev ptr n us y
           \<lbrace>\<lambda>rv s. descendants_range x cref s\<rbrace>"
   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]:
   "\<lbrace>\<lambda>(s::'state_ext::state_ext state). caps_overlap_reserved S s\<rbrace>
-   init_arch_objects ty ptr n us y
+   init_arch_objects ty dev ptr n us y
    \<lbrace>\<lambda>rv s. caps_overlap_reserved S s\<rbrace>"
   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]:
   "\<lbrace>(\<lambda>s. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)
          \<and> valid_global_objs s \<and> valid_arch_state s \<and> pspace_aligned s) and
     K (\<forall>ref\<in>set refs. is_aligned ref (obj_bits_api tp us))\<rbrace>
-        init_arch_objects tp ptr bits us refs
+        init_arch_objects tp dev ptr bits us refs
    \<lbrace>\<lambda>rv s. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)\<rbrace>"
   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 45185e8a02..41ab59ae25 100644
--- a/proof/invariant-abstract/X64/ArchVSpaceEntries_AI.thy
+++ b/proof/invariant-abstract/X64/ArchVSpaceEntries_AI.thy
@@ -528,7 +528,7 @@ lemma init_arch_objects_valid_vspace:
   "\<lbrace>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)\<rbrace>
-     init_arch_objects type ptr n obj_sz orefs
+     init_arch_objects type dev ptr n obj_sz orefs
    \<lbrace>\<lambda>rv. valid_vspace_objs'\<rbrace>"
   apply (rule hoare_gen_asm)+
   apply (simp add: init_arch_objects_def)
diff --git a/proof/refine/AARCH64/Detype_R.thy b/proof/refine/AARCH64/Detype_R.thy
index 523a7a5423..cecc4b5bd0 100644
--- a/proof/refine/AARCH64/Detype_R.thy
+++ b/proof/refine/AARCH64/Detype_R.thy
@@ -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:
   "\<lbrace>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]: "\<lambda>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' (\<lambda>_. True) src and
@@ -3252,6 +3268,7 @@ lemma createObject_setCTE_commute:
                      setCTE_modify_gsUserPages_commute[of \<top>]
                      modify_wp[of "%_. \<top>"]
                      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 \<top> (modify (\<lambda>s. s\<lparr>gsUntypedZeroRanges := f (gsUntypedZeroRanges s)\<rparr>))
+                   (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
      \<top>
@@ -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 >>= (\<lambda>_. gets ksPSpace >>= m) =
-   gets ksPSpace >>= (\<lambda>x. doMachineOp f >>= (\<lambda>_. m x))"
+  "doMachineOp f >>= (\<lambda>y. gets ksPSpace >>= m y) =
+   gets ksPSpace >>= (\<lambda>x. doMachineOp f >>= (\<lambda>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 _ \<leftarrow> doMachineOp f; x \<leftarrow> createObjects' ptr n obj us; m x od =
-         do x \<leftarrow> createObjects' ptr n obj us; _ \<leftarrow> 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 \<top> (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 >>= (\<lambda>x. modify (gsUserPages_update g) >>= (\<lambda>_. m x)) =
-         modify (gsUserPages_update g) >>= (\<lambda>_. doMachineOp f >>= m)"
-proof -
-  have ksMachineState_ksPSpace_update:
-    "\<forall>s. ksMachineState (gsUserPages_update g s) = ksMachineState s"
-    by simp
-  have updates_independent:
-    "\<And>f. gsUserPages_update g \<circ> ksMachineState_update f =
-          ksMachineState_update f \<circ> 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 \<top> (doMachineOp m) (modify (\<lambda>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 \<top> (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: "\<And>s. P s \<Longrightarrow> 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
    \<lbrace>\<lambda>archCap. pspace_no_overlap'
                 (ptr + (1 + of_nat n << APIType_capBits ty userSize)) sz\<rbrace>"
-  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/Retype_R.thy b/proof/refine/AARCH64/Retype_R.thy
index 55db166073..6625f1857f 100644
--- a/proof/refine/AARCH64/Retype_R.thy
+++ b/proof/refine/AARCH64/Retype_R.thy
@@ -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 \<open>LargePageObject\<close>)
-        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 \<open>PageTableObject\<close>)
-       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 _ \<Rightarrow> return ()
-   | _ \<Rightarrow> init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs)"
+   | _ \<Rightarrow> 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)
@@ -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]:
   "\<lbrace>pspace_domain_valid and K ({ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1}
             \<inter> 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 (\<lambda>ks. ks\<lparr>gsUserPages := g ks addrs\<rparr>);
+      _ <- when P (mapM_x (\<lambda>addr. doMachineOp (m addr)) addrs);
+      return (f addrs)
+    od) = (do
+      (addrs, faddrs) <- (do
+        addrs <- createObjects y n ko sz;
+        _ <- modify (\<lambda>ks. ks\<lparr>gsUserPages := g ks addrs\<rparr>);
+        return (addrs, f addrs)
+       od);
+      _ <- when P (mapM_x (\<lambda>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 (\<lambda>ks. ks\<lparr>ksArchState := gsPTTypes_update (g ks addrs) (ksArchState ks)\<rparr>);
+      _ <- mapM_x (\<lambda>addr. doMachineOp (m addr)) addrs;
+      return (f addrs)
+    od) = (do
+      (addrs, faddrs) <- (do
+        addrs <- createObjects y n ko sz;
+        _ <- modify (\<lambda>ks. ks\<lparr>ksArchState := gsPTTypes_update (g ks addrs) (ksArchState ks)\<rparr>);
+        return (addrs, f addrs)
+       od);
+      _ <- mapM_x (\<lambda>addr. doMachineOp (m addr)) addrs;
+      return faddrs
+    od)"
+  by (simp add: bind_assoc)
+
 lemma corres_retype_region_createNewCaps:
   "corres ((\<lambda>r r'. length r = length r' \<and> list_all2 cap_relation r r')
                \<circ> map (\<lambda>ref. default_cap (APIType_map2 (Inr ty)) ref us dev))
@@ -5397,7 +5440,7 @@ lemma corres_retype_region_createNewCaps:
                   \<and> valid_pspace' s \<and> valid_arch_state' s
                   \<and> range_cover y sz (obj_bits_api (APIType_map2 (Inr ty)) us) n \<and> n\<noteq> 0)
             (do x \<leftarrow> 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 \<open>VSpaceObject\<close>)
-      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 \<open>SmallPageObject\<close>)
      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 \<open>LargePageObject\<close>)
     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 \<open>PageTableObject\<close>)
    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 \<open>VCPUObject\<close>)
   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/ARM/Detype_R.thy b/proof/refine/ARM/Detype_R.thy
index a7260ec394..5953bf6341 100644
--- a/proof/refine/ARM/Detype_R.thy
+++ b/proof/refine/ARM/Detype_R.thy
@@ -3266,6 +3266,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:
   "\<lbrace>valid_arch_state' and
     pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) and
@@ -3556,6 +3567,7 @@ lemma createObject_setCTE_commute:
                      setCTE_modify_gsUserPages_commute[of \<top>]
                      modify_wp[of "%_. \<top>"]
                      setCTE_doMachineOp_commute
+                     setCTE_when_doMachineOp_commute
                      setCTE_placeNewObject_commute
                      monad_commute_if_weak_r
                      copyGlobalMappings_setCTE_commute[THEN commute_commute]
@@ -3730,6 +3742,13 @@ lemma copyGlobalMappings_gsUntypedZeroRanges_commute':
   apply simp
   done
 
+lemma dmo_gsUntypedZeroRanges_commute:
+  "monad_commute \<top> (modify (\<lambda>s. s\<lparr>gsUntypedZeroRanges := f (gsUntypedZeroRanges s)\<rparr>))
+                   (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
      \<top>
@@ -4533,26 +4552,97 @@ lemma doMachineOp_ksArchState_commute:
     apply clarsimp+
   done
 
+lemma doMachineOp_ksPSpace:
+  "monad_commute \<top> (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 \<Longrightarrow> monad_commute \<top> (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 \<Longrightarrow> monad_commute \<top> (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 \<Longrightarrow> monad_commute \<top> (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 \<Longrightarrow> monad_commute \<top> (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 \<Longrightarrow> monad_commute \<top> (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 \<Longrightarrow> monad_commute \<top> (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 \<Longrightarrow> monad_commute \<top> (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 \<Longrightarrow> monad_commute \<top> (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':
   "\<lbrace>K (range_cover ptr sz 14 (Suc n)) and
     pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz\<rbrace>
@@ -4778,6 +4868,85 @@ proof -
   done
 qed
 
+lemma dmo'_when_fail_comm:
+  assumes "empty_fail f"
+  shows "doMachineOp f >>= (\<lambda>x. when P fail >>= (\<lambda>_. m x)) =
+         when P fail >>= (\<lambda>_. 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 >>= (\<lambda>y. gets ksPSpace >>= m y) =
+   gets ksPSpace >>= (\<lambda>x. doMachineOp f >>= (\<lambda>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 >>= (\<lambda>x. modify (ksPSpace_update g) >>= (\<lambda>_. m x)) =
+         modify (ksPSpace_update g) >>= (\<lambda>_. doMachineOp f >>= m)"
+proof -
+  have ksMachineState_ksPSpace_update:
+    "\<forall>s. ksMachineState (ksPSpace_update g s) = ksMachineState s"
+    by simp
+  have updates_independent:
+    "\<And>f. ksPSpace_update g \<circ> ksMachineState_update f =
+          ksMachineState_update f \<circ> 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 \<top> (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 \<top> (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
    \<Longrightarrow> new_cap_addrs (Suc n) ptr obj
@@ -5023,241 +5192,193 @@ proof -
 
        \<comment> \<open>SmallPageObject\<close>
        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)[6]
-        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)[6]
-        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)+
       \<comment> \<open>LargePageObject\<close>
       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)[6]
-       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)[6]
-      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)+
-     \<comment> \<open>SectionObject\<close>
+    \<comment> \<open>SectionObject\<close>
      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)[6]
-      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)[6]
-     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)+
     \<comment> \<open>SuperSectionObject\<close>
     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)[6]
-     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)[6]
-    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)+
    \<comment> \<open>PageTableObject\<close>
-   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)+)[6]
-         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)
-
-\<comment> \<open>PageDirectoryObject\<close>
-         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 (\<lambda>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)+)[6]
-         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 = "\<lambda>r s. valid_arch_state' s \<and>
-           (\<forall>x\<le>of_nat n. page_directory_at' (ptr + (x << 14)) s) \<and> 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 = "\<lambda> r s.  pspace_aligned' s \<and> pspace_distinct' s
-             \<and> valid_arch_state' s \<and> (\<forall>r \<le> of_nat n. page_directory_at' (ptr + (r << 14)) s)
-             \<and>  page_directory_at' (ptr + ((1 + of_nat n) << 14)) s"])
-           apply (rule monad_eq_split[where Q = "\<lambda> r s.  pspace_aligned' s \<and> pspace_distinct' s
-             \<and> valid_arch_state' s \<and> (\<forall>r \<le> of_nat n. page_directory_at' (ptr + (r << 14)) s)
-             \<and>  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 = "\<lambda> r s.  pspace_aligned' s \<and> pspace_distinct' s
-             \<and> valid_arch_state' s \<and> 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_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)
+
+  \<comment> \<open>PageDirectoryObject\<close>
+   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 = "\<lambda>r s. valid_arch_state' s \<and>
+                             (\<forall>x\<le>of_nat n. page_directory_at' (ptr + (x << 14)) s) \<and> 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 (\<lambda>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:
@@ -5478,21 +5599,20 @@ lemma ArchCreateObject_pspace_no_overlap':
      (ptr + (of_nat n << APIType_capBits ty userSize)) userSize d
    \<lbrace>\<lambda>archCap. pspace_no_overlap'
                 (ptr + (1 + of_nat n << APIType_capBits ty userSize)) sz\<rbrace>"
-  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]
-            | 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)+
-
+  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
@@ -5508,7 +5628,7 @@ lemma ArchCreateObject_pspace_no_overlap':
    apply simp
   apply (frule pspace_no_overlap'_le2)
     apply (rule range_cover_compare_offset)
-     apply simp+
+      apply simp+
    apply (clarsimp simp:word_shiftl_add_distrib
               ,simp add:field_simps)
    apply (clarsimp simp:add.assoc[symmetric])
diff --git a/proof/refine/ARM/Retype_R.thy b/proof/refine/ARM/Retype_R.thy
index dcb50f2bfd..523fb20092 100644
--- a/proof/refine/ARM/Retype_R.thy
+++ b/proof/refine/ARM/Retype_R.thy
@@ -2363,7 +2363,7 @@ proof -
                      split: ARM_H.object_type.splits)
 
        \<comment> \<open>SmallPageObject\<close>
-       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]
@@ -2371,7 +2371,7 @@ proof -
          | simp add: objBits_if_dev pageBits_def ptr range_cover_n_wb)+
        apply (simp add:pageBits_def ptr word_bits_def)
       \<comment> \<open>LargePageObject\<close>
-      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]
@@ -2380,7 +2380,7 @@ proof -
       apply (simp add:pageBits_def ptr word_bits_def)
 
      \<comment> \<open>SectionObject\<close>
-     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]
@@ -2389,7 +2389,7 @@ proof -
      apply (simp add:pageBits_def ptr word_bits_def)
 
     \<comment> \<open>SuperSectionObject\<close>
-    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]
@@ -2398,7 +2398,7 @@ proof -
     apply (simp add:pageBits_def ptr word_bits_def)
 
    \<comment> \<open>PageTableObject\<close>
-    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)
@@ -2418,8 +2418,7 @@ proof -
                           pdeBits_def pteBits_def)
     apply clarsimp
   \<comment> \<open>PageDirectoryObject\<close>
-   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)
@@ -2669,9 +2668,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 _ \<Rightarrow> return ()
-   | _ \<Rightarrow> init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs)"
+   | _ \<Rightarrow> 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)
@@ -4293,9 +4292,6 @@ lemma createNewCaps_idle'[wp]:
 crunch createNewCaps
   for ksArch[wp]: "\<lambda>s. P (ksArchState s)"
   (simp: crunch_simps unless_def wp: crunch_wps)
-crunch createNewCaps
-  for it[wp]: "\<lambda>s. P (ksIdleThread s)"
-  (simp: crunch_simps unless_def wp: crunch_wps updateObject_default_inv)
 crunch createNewCaps
   for gsMaxObjectSize[wp]: "\<lambda>s. P (gsMaxObjectSize s)"
   (simp: crunch_simps unless_def wp: crunch_wps updateObject_default_inv)
@@ -4465,7 +4461,9 @@ lemma createNewCaps_pde_mappings'[wp]:
               split del: if_split cong: option.case_cong
                                         object_type.case_cong)
   apply (rule hoare_pre)
-   apply (wp mapM_x_copyGlobalMappings_pde_mappings' | wpc
+   apply (wp mapM_x_copyGlobalMappings_pde_mappings'
+             mapM_x_wp'[where f="\<lambda>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 \<and> n\<noteq> 0" in hoare_gen_asm)
     apply (rule hoare_strengthen_post)
@@ -4776,6 +4774,9 @@ crunch copyGlobalMappings
   for pspace_domain_valid[wp]: "pspace_domain_valid"
   (wp: crunch_wps)
 
+crunch doMachineOp
+  for pspace_domain_valid[wp]: pspace_domain_valid
+
 lemma createNewCaps_pspace_domain_valid[wp]:
   "\<lbrace>pspace_domain_valid and K ({ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1}
             \<inter> kernel_data_refs = {}
@@ -5502,15 +5503,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 \<noteq> Inr PageDirectoryObject
-   \<longrightarrow> 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"
@@ -5520,6 +5512,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 (\<lambda>ks. ks\<lparr>gsUserPages := g ks addrs\<rparr>);
+      _ <- when P (mapM_x (\<lambda>addr. doMachineOp (m addr)) addrs);
+      return (f addrs)
+    od) = (do
+      (addrs, faddrs) <- (do
+        addrs <- createObjects y n ko sz;
+        _ <- modify (\<lambda>ks. ks\<lparr>gsUserPages := g ks addrs\<rparr>);
+        return (addrs, f addrs)
+       od);
+      _ <- when P (mapM_x (\<lambda>addr. doMachineOp (m addr)) addrs);
+      return faddrs
+    od)"
+  by (simp add: bind_assoc)
+
 lemma corres_retype_region_createNewCaps:
   "corres ((\<lambda>r r'. length r = length r' \<and> list_all2 cap_relation r r')
                \<circ> map (\<lambda>ref. default_cap (APIType_map2 (Inr ty)) ref us dev))
@@ -5532,7 +5541,7 @@ lemma corres_retype_region_createNewCaps:
                   \<and> valid_pspace' s \<and> valid_arch_state' s
                   \<and> range_cover y sz (obj_bits_api (APIType_map2 (Inr ty)) us) n \<and> n\<noteq> 0)
             (do x \<leftarrow> 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
@@ -5635,89 +5644,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)
-          \<comment> \<open>SmallPageObject\<close>
+       \<comment> \<open>SmallPageObject\<close>
        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)
-         \<comment> \<open>LargePageObject\<close>
+       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]
+       \<comment> \<open>LargePageObject\<close>
       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)
-        \<comment> \<open>SectionObject\<close>
+      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]
+     \<comment> \<open>SectionObject\<close>
      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)
+     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]
     \<comment> \<open>SuperSectionObject\<close>
     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)
-  \<comment> \<open>PageTable\<close>
+    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]
+   \<comment> \<open>PageTable\<close>
    apply (subst retype_region2_extra_ext_trivial)
     apply (simp add: APIType_map2_def)
-   apply (simp_all add: corres_liftM2_simp[unfolded liftM_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]
   \<comment> \<open>PageDirectory\<close>
+  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
@@ -5729,87 +5786,71 @@ lemma corres_retype_region_createNewCaps:
                             makeObjectKO_def)[1]
         apply (simp add: range_cover_def)+
        apply (rule pagedirectory_relation_retype)
-      apply (simp add: init_arch_objects_def APIType_map2_def
-                       bind_assoc)
-      apply (rule corres_split_nor)
-         apply (simp add: mapM_x_mapM)
-         apply (rule corres_underlying_split[where r' = dc])
-            apply (rule_tac Q="\<lambda>xs s. (\<forall>x \<in> set xs. page_directory_at x s)
-                                   \<and> valid_arch_state s \<and> pspace_aligned s \<and> valid_etcbs s"
-                         and Q'="\<lambda>xs s. (\<forall>x \<in> set xs. page_directory_at' x s) \<and> 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 =\<top> and P'=\<top>,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
+                            (\<lambda>s. \<forall>pd \<in> set pds. typ_at (AArch APageDirectory) pd s)" and
+                         P'="valid_arch_state' and (\<lambda>s. \<forall>pd \<in> 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_HYP/Detype_R.thy b/proof/refine/ARM_HYP/Detype_R.thy
index 0b3331e35f..f59278435b 100644
--- a/proof/refine/ARM_HYP/Detype_R.thy
+++ b/proof/refine/ARM_HYP/Detype_R.thy
@@ -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:
   "\<lbrace>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 \<top>]
                      modify_wp[of "%_. \<top>"]
                      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 (\<lambda>s. s \<lparr> gsUntypedZeroRanges := f (gsUntypedZeroRanges s) \<rparr> ))"
   by (simp add: copyGlobalMappings_def monad_commute_guard_imp return_commute)
 
+lemma dmo_gsUntypedZeroRanges_commute:
+  "monad_commute \<top> (modify (\<lambda>s. s\<lparr>gsUntypedZeroRanges := f (gsUntypedZeroRanges s)\<rparr>))
+                   (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
      \<top>
@@ -4572,8 +4591,8 @@ lemma dmo'_when_fail_comm:
 
 (* FIXME: move *)
 lemma dmo'_gets_ksPSpace_comm:
-  "doMachineOp f >>= (\<lambda>_. gets ksPSpace >>= m) =
-   gets ksPSpace >>= (\<lambda>x. doMachineOp f >>= (\<lambda>_. m x))"
+  "doMachineOp f >>= (\<lambda>y. gets ksPSpace >>= m y) =
+   gets ksPSpace >>= (\<lambda>x. doMachineOp f >>= (\<lambda>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 _ \<leftarrow> doMachineOp f; x \<leftarrow> createObjects' ptr n obj us; m x od =
-         do x \<leftarrow> createObjects' ptr n obj us; _ \<leftarrow> 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 \<top> (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 >>= (\<lambda>x. modify (gsUserPages_update g) >>= (\<lambda>_. m x)) =
-         modify (gsUserPages_update g) >>= (\<lambda>_. doMachineOp f >>= m)"
-proof -
-  have ksMachineState_ksPSpace_update:
-    "\<forall>s. ksMachineState (gsUserPages_update g s) = ksMachineState s"
-    by simp
-  have updates_independent:
-    "\<And>f. gsUserPages_update g \<circ> ksMachineState_update f =
-          ksMachineState_update f \<circ> 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 \<top> (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: "\<And>s. P s \<Longrightarrow> 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 -
 
        \<comment> \<open>SmallPageObject\<close>
        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)+
       \<comment> \<open>LargePageObject\<close>
-      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)+
      \<comment> \<open>SectionObject\<close>
-     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)+
     \<comment> \<open>SuperSectionObject\<close>
-    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)+
-   \<comment> \<open>PageTableObject\<close>
-   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)
-
-\<comment> \<open>PageDirectoryObject\<close>
-         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 (\<lambda>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 = "\<lambda>r s. valid_arch_state' s \<and>
-           (\<forall>x\<le>of_nat n. page_directory_at' (ptr + (x << 14)) s) \<and> 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 = "\<lambda> r s.  pspace_aligned' s \<and> pspace_distinct' s
-             \<and> valid_arch_state' s \<and> (\<forall>r \<le> of_nat n. page_directory_at' (ptr + (r << 14)) s)
-             \<and>  page_directory_at' (ptr + ((1 + of_nat n) << 14)) s"])
-           apply (rule monad_eq_split[where Q = "\<lambda> r s.  pspace_aligned' s \<and> pspace_distinct' s
-             \<and> valid_arch_state' s \<and> (\<forall>r \<le> of_nat n. page_directory_at' (ptr + (r << 14)) s)
-             \<and>  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 = "\<lambda> r s.  pspace_aligned' s \<and> pspace_distinct' s
-             \<and> valid_arch_state' s \<and> 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)+
-\<comment> \<open>VCPUObject\<close>
-      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
+    \<comment> \<open>PageTableObject\<close>
+    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)
+   \<comment> \<open>PageDirectoryObject\<close>
+   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)
+  \<comment> \<open>VCPUObject\<close>
+  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
    \<lbrace>\<lambda>archCap. pspace_no_overlap'
                 (ptr + (1 + of_nat n << APIType_capBits ty userSize)) sz\<rbrace>"
-  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 \<Longrightarrow> ty = fromAPIType x"
diff --git a/proof/refine/ARM_HYP/Retype_R.thy b/proof/refine/ARM_HYP/Retype_R.thy
index 78b42d61c0..920e2018ab 100644
--- a/proof/refine/ARM_HYP/Retype_R.thy
+++ b/proof/refine/ARM_HYP/Retype_R.thy
@@ -2375,7 +2375,7 @@ proof -
       apply (clarsimp simp: ARM_HYP_H.toAPIType_def APIType_capBits_def
                      split: ARM_HYP_H.object_type.splits)
        \<comment> \<open>SmallPageObject\<close>
-       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)
       \<comment> \<open>LargePageObject\<close>
-      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)
 
      \<comment> \<open>SectionObject\<close>
-     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)
 
     \<comment> \<open>SuperSectionObject\<close>
-    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)
 
    \<comment> \<open>PageTableObject\<close>
-    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
   \<comment> \<open>PageDirectoryObject\<close>
-   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 _ \<Rightarrow> return ()
-   | _ \<Rightarrow> init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs)"
+   | _ \<Rightarrow> 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)
@@ -4369,9 +4368,6 @@ lemma createNewCaps_idle'[wp]:
 crunch createNewCaps
   for ksArch[wp]: "\<lambda>s. P (ksArchState s)"
   (simp: crunch_simps unless_def wp: crunch_wps)
-crunch createNewCaps
-  for it[wp]: "\<lambda>s. P (ksIdleThread s)"
-  (simp: crunch_simps unless_def wp: crunch_wps updateObject_default_inv)
 crunch createNewCaps
   for gsMaxObjectSize[wp]: "\<lambda>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="\<lambda>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 \<and> n\<noteq> 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]:
   "\<lbrace>pspace_domain_valid and K ({ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1}
             \<inter> 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 \<noteq> Inr PageDirectoryObject
-   \<longrightarrow> 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 (\<lambda>ks. ks\<lparr>gsUserPages := g ks addrs\<rparr>);
+      _ <- when P (mapM_x (\<lambda>addr. doMachineOp (m addr)) addrs);
+      return (f addrs)
+    od) = (do
+      (addrs, faddrs) <- (do
+        addrs <- createObjects y n ko sz;
+        _ <- modify (\<lambda>ks. ks\<lparr>gsUserPages := g ks addrs\<rparr>);
+        return (addrs, f addrs)
+       od);
+      _ <- when P (mapM_x (\<lambda>addr. doMachineOp (m addr)) addrs);
+      return faddrs
+    od)"
+  by (simp add: bind_assoc)
+
 lemma corres_retype_region_createNewCaps:
   "corres ((\<lambda>r r'. length r = length r' \<and> list_all2 cap_relation r r')
                \<circ> map (\<lambda>ref. default_cap (APIType_map2 (Inr ty)) ref us dev))
@@ -5573,7 +5587,7 @@ lemma corres_retype_region_createNewCaps:
                   \<and> valid_pspace' s \<and> valid_arch_state' s
                   \<and> range_cover y sz (obj_bits_api (APIType_map2 (Inr ty)) us) n \<and> n\<noteq> 0)
             (do x \<leftarrow> 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)
-          \<comment> \<open>SmallPageObject\<close>
+        \<comment> \<open>SmallPageObject\<close>
+        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]
+       \<comment> \<open>LargePageObject\<close>
        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)
-         \<comment> \<open>LargePageObject\<close>
+       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]
+      \<comment> \<open>SectionObject\<close>
       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)
-        \<comment> \<open>SectionObject\<close>
+      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]
+     \<comment> \<open>SuperSectionObject\<close>
      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)
-    \<comment> \<open>SuperSectionObject\<close>
+     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]
+    \<comment> \<open>PageTable\<close>
     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)
-  \<comment> \<open>PageTable\<close>
-   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
-  \<comment> \<open>PageDirectory\<close>
+   \<comment> \<open>PageDirectory\<close>
+   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 =\<top> and P'=\<top>,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]
   \<comment> \<open>VCPUObject\<close>
-      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/RISCV64/Retype_R.thy b/proof/refine/RISCV64/Retype_R.thy
index f51fdc333a..f8ce48b864 100644
--- a/proof/refine/RISCV64/Retype_R.thy
+++ b/proof/refine/RISCV64/Retype_R.thy
@@ -2615,9 +2615,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 _ \<Rightarrow> return ()
-   | _ \<Rightarrow> init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs)"
+   | _ \<Rightarrow> 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)
@@ -5335,7 +5335,7 @@ lemma createObjects_Not_tcbQueued:
   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
 
@@ -5359,7 +5359,7 @@ lemma corres_retype_region_createNewCaps:
                   \<and> valid_pspace' s \<and> valid_arch_state' s
                   \<and> range_cover y sz (obj_bits_api (APIType_map2 (Inr ty)) us) n \<and> n\<noteq> 0)
             (do x \<leftarrow> 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/Retype_R.thy b/proof/refine/X64/Retype_R.thy
index eea316507a..7c4fb10a3c 100644
--- a/proof/refine/X64/Retype_R.thy
+++ b/proof/refine/X64/Retype_R.thy
@@ -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 _ \<Rightarrow> return ()
-   | _ \<Rightarrow> init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs)"
+   | _ \<Rightarrow> 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)
@@ -5579,7 +5579,7 @@ lemma createObjects_Not_tcbQueued:
 
 lemma init_arch_objects_APIType_map2_noop:
   "tp \<noteq> Inr PML4Object
-   \<longrightarrow> init_arch_objects (APIType_map2 tp) ptr n m addrs
+   \<longrightarrow> 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:
                   \<and> valid_pspace' s \<and> valid_arch_state' s
                   \<and> range_cover y sz (obj_bits_api (APIType_map2 (Inr ty)) us) n \<and> n\<noteq> 0)
             (do x \<leftarrow> 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

From f8016c1403d4a75ccf31111358c567f9d30c9278 Mon Sep 17 00:00:00 2001
From: Gerwin Klein <gerwin.klein@proofcraft.systems>
Date: Wed, 23 Oct 2024 11:42:48 +1100
Subject: [PATCH 18/31] x64 crefine: remove unused lemmas

Signed-off-by: Gerwin Klein <gerwin.klein@proofcraft.systems>
---
 proof/crefine/X64/Arch_C.thy | 15 ---------------
 1 file changed, 15 deletions(-)

diff --git a/proof/crefine/X64/Arch_C.thy b/proof/crefine/X64/Arch_C.thy
index a1ea859c37..ad07f5ffad 100644
--- a/proof/crefine/X64/Arch_C.thy
+++ b/proof/crefine/X64/Arch_C.thy
@@ -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 \<Longrightarrow> (pde_get_tag pde = scast pde_pde_pt \<and> pde_pde_pt_CL.present_CL (pde_pde_pt_lift pde) = 0) = isInvalidPDE pdea"
   apply (simp add: cpde_relation_def Let_def)

From 06ef8fe36df54e36a0867cd1dae51670904c7ab5 Mon Sep 17 00:00:00 2001
From: Rafal Kolanski <rafal.kolanski@proofcraft.systems>
Date: Wed, 27 Nov 2024 19:24:15 +1100
Subject: [PATCH 19/31] x64 design+haskell: add allIOPortsIssued_asrt

Needed in performX64PortInvocation for InvokeIOPortControl in order to
get a hold of all_io_ports_issued' in arch_performInvocation_invs'.

Signed-off-by: Rafal Kolanski <rafal.kolanski@proofcraft.systems>
---
 spec/design/skel/X64/ArchVSpace_H.thy       |  2 +-
 spec/haskell/src/SEL4/Object/IOPort/X64.lhs | 10 ++++++++--
 2 files changed, 9 insertions(+), 3 deletions(-)

diff --git a/spec/design/skel/X64/ArchVSpace_H.thy b/spec/design/skel/X64/ArchVSpace_H.thy
index 88bf5f015f..d8a9f76983 100644
--- a/spec/design/skel/X64/ArchVSpace_H.thy
+++ b/spec/design/skel/X64/ArchVSpace_H.thy
@@ -19,7 +19,7 @@ begin
 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
+#INCLUDE_HASKELL SEL4/Object/IOPort/X64.lhs CONTEXT X64_H bodies_only ArchInv=ArchRetypeDecls_H NOT allIOPortsIssued_asrt
 
 defs checkValidMappingSize_def:
   "checkValidMappingSize sz \<equiv> stateAssert
diff --git a/spec/haskell/src/SEL4/Object/IOPort/X64.lhs b/spec/haskell/src/SEL4/Object/IOPort/X64.lhs
index 5a9b1ea9f8..7a047cadcf 100644
--- a/spec/haskell/src/SEL4/Object/IOPort/X64.lhs
+++ b/spec/haskell/src/SEL4/Object/IOPort/X64.lhs
@@ -19,7 +19,7 @@ This module defines IO port routines, specific to x64.
 > import SEL4.API.Failures
 > import SEL4.Machine.Hardware.X64
 > import SEL4.Model
-> import SEL4.Model.StateData.X64
+> import SEL4.Model.StateData.X64 hiding (KernelState)
 > import SEL4.Object.Structures
 > import SEL4.Object.TCB
 > import SEL4.Object.ObjectType.X64
@@ -120,7 +120,12 @@ This module defines IO port routines, specific to x64.
 >        doMachineOp $ f w
 >        return []
 
->
+We do not need all of IO port validity in the refinement proof, but do need to
+cross over the constraint that all IO port caps in the state have been issued.
+
+> allIOPortsIssued_asrt :: KernelState -> Bool
+> allIOPortsIssued_asrt _ = True
+
 > performX64PortInvocation :: ArchInv.Invocation -> KernelP [Word]
 > performX64PortInvocation (InvokeIOPort (IOPortInvocation port port_data)) = withoutPreemption $
 >     case port_data of
@@ -133,6 +138,7 @@ This module defines IO port routines, specific to x64.
 
 > performX64PortInvocation (InvokeIOPortControl (IOPortControlIssue f l destSlot srcSlot)) =
 >   withoutPreemption $ do
+>     stateAssert allIOPortsIssued_asrt "all_io_ports_issued'"
 >     setIOPortMask f l True
 >     cteInsert (ArchObjectCap (IOPortCap f l)) srcSlot destSlot
 >     return []

From fb10847844e2b43f9760ebd979510b045401e22d Mon Sep 17 00:00:00 2001
From: Rafal Kolanski <rafal.kolanski@proofcraft.systems>
Date: Wed, 27 Nov 2024 02:26:03 +1100
Subject: [PATCH 20/31] x64 refine: remove valid_ioports' from invariants

With the exception of performX64PortInvocation_corres and
arch_performInvocation_invs', the knowledge about IO port cap validity
is unnecessary in Refine. For those two lemmas, we added an assertion
and a cross lemma to re-derive the information from valid_ioports over
the state relation. This leads to a simlified formulation of
post_cap_delete_pre' such that it satisfies the minimum requirements for
the arch-generic formulation of cap finalisation proofs.

Signed-off-by: Rafal Kolanski <rafal.kolanski@proofcraft.systems>
---
 proof/refine/X64/Arch_R.thy             |  57 +++++++++----
 proof/refine/X64/CNodeInv_R.thy         | 105 ++++--------------------
 proof/refine/X64/CSpace_R.thy           |  94 +--------------------
 proof/refine/X64/Detype_R.thy           |   8 --
 proof/refine/X64/Finalise_R.thy         |  90 ++------------------
 proof/refine/X64/InterruptAcc_R.thy     |   1 -
 proof/refine/X64/Interrupt_R.thy        |   2 +-
 proof/refine/X64/InvariantUpdates_H.thy |   4 -
 proof/refine/X64/Invariants_H.thy       |  35 ++------
 proof/refine/X64/IpcCancel_R.thy        |   4 +-
 proof/refine/X64/Ipc_R.thy              |  49 +----------
 proof/refine/X64/KHeap_R.thy            |  14 ----
 proof/refine/X64/Retype_R.thy           |  48 +----------
 proof/refine/X64/Schedule_R.thy         |  11 +--
 proof/refine/X64/Syscall_R.thy          |   2 -
 proof/refine/X64/TcbAcc_R.thy           |   4 +-
 proof/refine/X64/Tcb_R.thy              |  19 +----
 proof/refine/X64/Untyped_R.thy          |  23 +-----
 proof/refine/X64/VSpace_R.thy           |  11 ++-
 19 files changed, 91 insertions(+), 490 deletions(-)

diff --git a/proof/refine/X64/Arch_R.thy b/proof/refine/X64/Arch_R.thy
index 0e6cd1fe4d..50965f4992 100644
--- a/proof/refine/X64/Arch_R.thy
+++ b/proof/refine/X64/Arch_R.thy
@@ -1312,6 +1312,11 @@ lemma port_out_corres[@lift_corres_args, corres]:
      apply wpsimp+
   done
 
+defs allIOPortsIssued_asrt_def:
+  "allIOPortsIssued_asrt \<equiv> \<lambda>s. all_ioports_issued' (cteCaps_of s) (ksArchState s)"
+
+lemmas [simp] = allIOPortsIssued_asrt_def
+
 lemma perform_port_inv_corres:
   "\<lbrakk>archinv_relation ai ai'; ai = arch_invocation.InvokeIOPort x\<rbrakk>
   \<Longrightarrow> corres (dc \<oplus> (=))
@@ -1332,20 +1337,34 @@ crunch setIOPortMask
 
 lemma setIOPortMask_invs':
   "\<lbrace>invs' and (\<lambda>s. \<not> b \<longrightarrow> (\<forall>cap'\<in>ran (cteCaps_of s). cap_ioports' cap' \<inter> {f..l} = {}))\<rbrace> setIOPortMask f l b \<lbrace>\<lambda>rv. invs'\<rbrace>"
-  apply (wpsimp wp: setIOPortMask_ioports' simp: invs'_def valid_state'_def setIOPortMask_def simp_del: fun_upd_apply)
+  apply (wpsimp wp: simp: invs'_def valid_state'_def setIOPortMask_def simp_del: fun_upd_apply)
   apply (clarsimp simp: foldl_map foldl_fun_upd_value valid_global_refs'_def global_refs'_def
                         valid_arch_state'_def valid_machine_state'_def)
-  apply (case_tac b; clarsimp simp: valid_ioports'_simps foldl_fun_upd_value)
-   apply (drule_tac x=cap in bspec, assumption)
-   apply auto[1]
-  apply (drule_tac x=cap in bspec, assumption)
-  by auto
+  done
 
-lemma valid_ioports_issuedD':
-  "\<lbrakk>valid_ioports' s; cteCaps_of s src = Some cap\<rbrakk> \<Longrightarrow> cap_ioports' cap \<subseteq> issued_ioports' (ksArchState s)"
-  apply (clarsimp simp: valid_ioports'_def all_ioports_issued'_def)
+lemma all_ioports_issued_issuedD':
+  "\<lbrakk>all_ioports_issued' (cteCaps_of s) (ksArchState s); cteCaps_of s src = Some cap\<rbrakk> \<Longrightarrow> cap_ioports' cap \<subseteq> issued_ioports' (ksArchState s)"
+  apply (clarsimp simp: all_ioports_issued'_def)
   by auto
 
+lemma all_ioports_issued_cross:
+  "\<lbrakk> (s, s') \<in> state_relation; invs s; all_ioports_issued (caps_of_state s) (arch_state s) \<rbrakk>
+   \<Longrightarrow> all_ioports_issued' (cteCaps_of s') (ksArchState s')"
+  apply (simp add: all_ioports_issued_def all_ioports_issued'_def)
+  apply (prop_tac "issued_ioports' (ksArchState s') = issued_ioports (arch_state s)")
+   apply (drule state_relationD)
+   apply (simp add: arch_state_relation_def issued_ioports_def issued_ioports'_def)
+  apply (clarsimp dest!: ranD del: subsetI simp: cteCaps_of_def)
+  apply (rename_tac p' cte')
+  apply (drule (1) pspace_relation_cte_wp_atI'[OF state_relation_pspace_relation ctes_of_cte_wpD])
+   apply clarsimp
+  apply (clarsimp dest!: Retype_AI.F[THEN iffD2] del: subsetI)
+  apply (rename_tac cap ref idx)
+  apply (drule_tac x=cap in bspec)
+   apply (fastforce simp: ran_def)
+  apply (clarsimp simp: cap_ioports_def split: cap.splits arch_cap.splits)
+  done
+
 lemma performX64PortInvocation_corres:
   "\<lbrakk>archinv_relation ai ai'; ai = arch_invocation.InvokeIOPortControl x\<rbrakk> \<Longrightarrow>
    corres (dc \<oplus> (=))
@@ -1356,6 +1375,9 @@ lemma performX64PortInvocation_corres:
   apply (clarsimp simp: perform_ioport_control_invocation_def performX64PortInvocation_def
                         archinv_relation_def ioport_control_inv_relation_def)
   apply (case_tac x; clarsimp simp: bind_assoc simp del: split_paired_All)
+  apply (rule_tac corres_stateAssert_add_assertion[rotated])
+   apply (rule all_ioports_issued_cross;
+          fastforce dest!: invs_valid_ioports simp: valid_ioports_def)
   apply (rule corres_guard_imp)
     apply (rule corres_split_nor[OF set_ioport_mask_corres])
       apply (rule corres_split_nor[OF cteInsert_simple_corres])
@@ -1380,7 +1402,7 @@ lemma performX64PortInvocation_corres:
   apply (clarsimp simp: safe_parent_for'_def cte_wp_at_ctes_of)
   apply (case_tac ctea)
   apply (clarsimp simp: isCap_simps sameRegionAs_def3)
-  apply (drule_tac src=p in valid_ioports_issuedD'[OF invs_valid_ioports'])
+  apply (drule_tac src=p in all_ioports_issued_issuedD')
    apply (fastforce simp: cteCaps_of_def)
   apply force
   done
@@ -1972,7 +1994,6 @@ lemma invs_asid_table_strengthen':
   apply (rule conjI)
    apply (clarsimp simp: valid_pspace'_def)
   apply (simp add: valid_machine_state'_def)
-  apply (clarsimp simp: valid_ioports'_simps)
   done
 
 lemma ex_cte_not_in_untyped_range:
@@ -2183,13 +2204,13 @@ lemma arch_performInvocation_invs':
                         is_simple_cap'_def isCap_simps)
   apply (clarsimp simp: cte_wp_at_ctes_of)
   apply (rule conjI, clarsimp)
-  apply (rule conjI, clarsimp simp: safe_parent_for'_def)
-   apply (case_tac ctea)
-   apply (clarsimp simp: isCap_simps sameRegionAs_def3)
-   apply (drule_tac src=p in valid_ioports_issuedD'[OF invs_valid_ioports'])
-    apply (fastforce simp: cteCaps_of_def)
-   apply force
-  using ranD valid_ioports_issuedD' by fastforce
+  apply (clarsimp simp: safe_parent_for'_def)
+  apply (case_tac ctea)
+  apply (clarsimp simp: isCap_simps sameRegionAs_def3)
+  apply (drule_tac src=p in all_ioports_issued_issuedD')
+   apply (fastforce simp: cteCaps_of_def)
+  apply force
+  done
 
 end
 
diff --git a/proof/refine/X64/CNodeInv_R.thy b/proof/refine/X64/CNodeInv_R.thy
index ce6a0ebdb5..6af4db67ef 100644
--- a/proof/refine/X64/CNodeInv_R.thy
+++ b/proof/refine/X64/CNodeInv_R.thy
@@ -5074,30 +5074,6 @@ lemma weak_derived_cap_ioports':
   apply (case_tac c; clarsimp)
   by (rename_tac ac, case_tac ac; clarsimp)
 
-lemma cteSwap_ioports'[wp]:
-  "\<lbrace>valid_ioports' and cte_wp_at' (weak_derived' c \<circ> cteCap) c1
-           and cte_wp_at' (weak_derived' c' \<circ> cteCap) c2\<rbrace>
-     cteSwap c c1 c' c2
-   \<lbrace>\<lambda>rv. valid_ioports'\<rbrace>"
-  apply (simp add: valid_ioports'_simps)
-  apply (rule hoare_pre)
-   apply (rule hoare_use_eq [where f=ksArchState, OF cteSwap_ksArch])
-   apply (simp add: cteSwap_def)
-   apply wp
-  apply (clarsimp simp: cte_wp_at_ctes_of cteCaps_of_def ran_def)
-  apply (clarsimp simp add: modify_map_def split: if_split_asm dest!: weak_derived_cap_ioports')
-  apply (rule conjI, clarsimp)
-   apply (rule conjI, clarsimp)
-     apply (force simp: isCap_simps)
-   subgoal by ((auto | blast)+) (* long *)
-  apply clarsimp
-  apply (rule conjI, clarsimp)
-   subgoal by (force simp: isCap_simps) (* long *)
-  apply clarsimp
-  apply safe[1]
-                       apply distinct_subgoals
-  by ((auto | blast)+) (* long *)
-
 lemma weak_derived_untypedZeroRange:
   "\<lbrakk> weak_derived' c c'; isUntypedCap c' \<longrightarrow> c' = c \<rbrakk>
     \<Longrightarrow> untypedZeroRange c = untypedZeroRange c'"
@@ -5635,19 +5611,18 @@ lemma make_zombie_invs':
   apply (simp add: invs'_def valid_state'_def valid_pspace'_def valid_mdb'_def
                    valid_irq_handlers'_def irq_issued'_def)
   apply (wp updateCap_ctes_of_wp sch_act_wf_lift valid_queues_lift cur_tcb_lift
-            updateCap_iflive' updateCap_ifunsafe' updateCap_idle' updateCap_ioports'
+            updateCap_iflive' updateCap_ifunsafe' updateCap_idle'
             valid_arch_state_lift' valid_irq_node_lift ct_idle_or_in_cur_domain'_lift2
             updateCap_untyped_ranges_zero_simple
        | simp split del: if_split)+
   apply (intro conjI[rotated])
-         apply (clarsimp simp: cte_wp_at_ctes_of)
-         apply (auto simp: untypedZeroRange_def isCap_simps)[1]
-        apply clarsimp
-       apply (auto simp: cte_wp_at_ctes_of isCap_simps)[1]
+          apply (clarsimp simp: cte_wp_at_ctes_of)
+          apply (auto simp: untypedZeroRange_def isCap_simps)[1]
+         apply clarsimp
         apply (clarsimp simp: modify_map_def ran_def split del: if_split
                        split: if_split_asm)
          apply (clarsimp simp: cteCaps_of_def cte_wp_at_ctes_of isCap_simps)
-      apply (auto)[1]
+        apply (auto)[1]
        apply (clarsimp simp: disj_comms cte_wp_at_ctes_of
                       dest!: ztc_phys capBits_capUntyped_capRange)
        apply (frule(1) capBits_capUntyped_capRange, simp)
@@ -6322,18 +6297,11 @@ proof (induct arbitrary: P p rule: finalise_spec_induct2)
     apply fastforce
     done
   have final_IOPort_no_copy:
-    "\<And>c f l cap' cte  sl sl' sa . \<lbrakk>valid_ioports' sa; ctes_of sa sl = Some cte; cteCap cte = c;
-                        isFinal c sl (cteCaps_of sa); sl \<noteq> sl'; cteCaps_of sa sl' = Some cap';
-                        c = ArchObjectCap (IOPortCap f l)\<rbrakk>
-                     \<Longrightarrow> cap_ioports' c \<inter> cap_ioports' cap' = {}"
-    apply (clarsimp simp: isFinal_def sameObjectAs_def2 isCap_simps valid_ioports'_def ioports_no_overlap'_def)
-    apply (drule_tac x=sl' in spec)
-    apply (drule_tac x="cap'" in spec)
-    apply clarsimp
-    apply (drule_tac x=cap' in bspec, fastforce)
-    apply (drule_tac x="cteCap cte" in bspec, fastforce simp: cteCaps_of_def)
-    apply (case_tac "cap'"; clarsimp)
-    by (rename_tac az, case_tac az; clarsimp)
+    "\<And>f l sl sl' s. \<lbrakk> isFinal (ArchObjectCap (IOPortCap f l)) sl (cteCaps_of s); sl \<noteq> sl' \<rbrakk>
+                    \<Longrightarrow> cteCaps_of s sl' \<noteq> Some (ArchObjectCap (IOPortCap f l))"
+    apply (clarsimp simp: isFinal_def sameObjectAs_def2 isCap_simps)
+    apply fastforce
+    done
   from stuff have stuff':
     "finalise_prop_stuff (no_cte_prop Pr)"
     by (simp add: no_cte_prop_def finalise_prop_stuff_def)
@@ -6384,10 +6352,9 @@ proof (induct arbitrary: P p rule: finalise_spec_induct2)
          apply (clarsimp simp: final_IRQHandler_no_copy)
          apply (drule (1) ctes_of_valid'[OF _ invs_valid_objs'])
          apply (clarsimp simp: valid_cap'_def)
-        apply (rename_tac ac, case_tac ac; clarsimp simp: isCap_simps)
-         apply (rule context_conjI, drule (1) ctes_of_valid'[OF _ invs_valid_objs'], clarsimp simp: valid_cap'_def)
+        apply (rename_tac ac, case_tac ac; clarsimp simp: isCap_simps final_IOPort_no_copy)
+         apply (drule (1) ctes_of_valid'[OF _ invs_valid_objs'], clarsimp simp: valid_cap'_def)
         apply clarsimp
-        apply (drule_tac sl=sl in final_IOPort_no_copy[OF invs_valid_ioports'], assumption+, simp+)
        apply (clarsimp dest!: isCapDs)
        apply (rule conjI)
         apply (clarsimp simp: capRemovable_def)
@@ -8688,30 +8655,6 @@ lemma cteMove_irq_handlers' [wp]:
   apply (auto simp: cteCaps_of_def weak_derived'_def)
   done
 
-lemma cteMove_ioports' [wp]:
-  "\<lbrace>\<lambda>s. valid_ioports' s
-      \<and> cte_wp_at' (\<lambda>c. weak_derived' (cteCap c) cap) src s
-      \<and> cte_wp_at' (\<lambda>c. cteCap c = NullCap) dest s\<rbrace>
-     cteMove cap src dest
-   \<lbrace>\<lambda>rv. valid_ioports'\<rbrace>"
-  apply (simp add: valid_ioports'_simps)
-  apply (rule hoare_pre)
-   apply (rule hoare_use_eq [where f=ksArchState, OF cteMove_ksArch])
-   apply (simp add: cteMove_def)
-   apply (wp getCTE_wp)
-  apply (clarsimp simp: cte_wp_at_ctes_of cteCaps_of_def ran_def)
-  apply (clarsimp simp add: modify_map_def split: if_split_asm dest!: weak_derived_cap_ioports')
-  apply (rule conjI, clarsimp)
-   apply (rule conjI, clarsimp)
-    apply blast
-   subgoal by ((auto | blast)+)
-  apply clarsimp
-  apply (rule conjI, clarsimp)
-   subgoal by (auto | blast)+
-  apply clarsimp
-  apply safe
-  by distinct_subgoals ((auto | blast)+)
-
 lemmas cteMove_valid_irq_node'[wp]
     = valid_irq_node_lift[OF cteMove_ksInterrupt cteMove_typ_at']
 
@@ -9059,19 +9002,6 @@ lemma updateCap_noop_irq_handlers:
                 add: modify_map_apply fun_upd_idem)
   done
 
-lemma updateCap_noop_ioports':
-  "\<lbrace>valid_ioports' and cte_wp_at' (\<lambda>cte. cteCap cte = cap) slot\<rbrace>
-     updateCap slot cap
-   \<lbrace>\<lambda>rv. valid_ioports'\<rbrace>"
-  apply (simp add: valid_ioports'_simps irq_issued'_def)
-  apply (rule hoare_pre)
-   apply (rule hoare_use_eq[where f=ksArchState, OF updateCap_arch])
-   apply wp
-  apply (simp, subst(asm) tree_cte_cteCap_eq[unfolded o_def])
-  apply (simp split: option.split_asm
-                add: modify_map_apply fun_upd_idem)
-  done
-
 crunch updateCap
   for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain'
   (rule: ct_idle_or_in_cur_domain'_lift2)
@@ -9084,7 +9014,7 @@ lemma updateCap_noop_invs:
                    valid_pspace'_def valid_mdb'_def)
   apply (rule hoare_pre)
    apply (wp updateCap_ctes_of_wp updateCap_iflive'
-             updateCap_ifunsafe' updateCap_idle' updateCap_noop_ioports'
+             updateCap_ifunsafe' updateCap_idle'
              valid_arch_state_lift' valid_irq_node_lift
              updateCap_noop_irq_handlers sch_act_wf_lift
              untyped_ranges_zero_lift)
@@ -9113,12 +9043,9 @@ lemma invokeCNode_invs' [wp]:
   unfolding invokeCNode_def
   apply (cases cinv)
         apply (wp cteRevoke_invs' cteInsert_invs | simp split del: if_split)+
-        apply (rule conjI)
-         apply (clarsimp simp: cte_wp_at_ctes_of is_derived'_def isCap_simps badge_derived'_def)
-         apply (erule(1) valid_irq_handlers_ctes_ofD)
-         apply (clarsimp simp: invs'_def valid_state'_def)
-        apply clarsimp
-        apply (erule (1) valid_ioports'_derivedD[OF invs_valid_ioports'])
+        apply (clarsimp simp: cte_wp_at_ctes_of is_derived'_def isCap_simps badge_derived'_def)
+        apply (erule(1) valid_irq_handlers_ctes_ofD)
+        apply (clarsimp simp: invs'_def valid_state'_def)
        defer
        apply (wp cteRevoke_invs' | simp)+
       apply (clarsimp simp:cte_wp_at_ctes_of)
diff --git a/proof/refine/X64/CSpace_R.thy b/proof/refine/X64/CSpace_R.thy
index 101b3d92b3..f6a4384519 100644
--- a/proof/refine/X64/CSpace_R.thy
+++ b/proof/refine/X64/CSpace_R.thy
@@ -2991,21 +2991,6 @@ lemma cteInsert_valid_irq_handlers'[wp]:
   apply (clarsimp simp:modify_map_def split:if_splits)
 done
 
-lemma setUntypedCapAsFull_ioports'[wp]:
-  "\<lbrace>valid_ioports' and cte_wp_at' ((=) srcCTE) slot\<rbrace> setUntypedCapAsFull (cteCap srcCTE) c slot \<lbrace>\<lambda>rv. valid_ioports'\<rbrace>"
-  apply (clarsimp simp: setUntypedCapAsFull_def valid_ioports'_def split: if_splits)
-  apply (intro conjI impI)
-   apply (clarsimp simp:valid_def)
-   apply (drule updateCap_stuff)
-   apply (clarsimp simp: cteCaps_of_def cte_wp_at_ctes_of valid_ioports'_simps isCap_simps modify_map_def
-                         ran_dom modify_map_dom cap_ioports'_def[split_simps capability.split])
-  apply (wp|clarsimp)+
-  done
-
-lemma updateMDB_ioports'[wp]:
-  "\<lbrace>valid_ioports'\<rbrace> updateMDB a b \<lbrace>\<lambda>rv. valid_ioports'\<rbrace>"
-  by (wpsimp wp: valid_ioports_lift')
-
 definition
   "safe_ioport_insert' newcap oldcap \<equiv> \<lambda>s.  (cap_ioports' newcap = {} \<or>
       (\<forall>cap''\<in>ran (cteCaps_of s).
@@ -3036,56 +3021,6 @@ lemma setCTE_arch_ctes_of_wp [wp]:
 
 lemmas cap_ioports'_simps[simp] = cap_ioports'_def[split_simps capability.split arch_capability.split]
 
-lemma setCTE_ioports':
-  "\<lbrace>valid_ioports' and (\<lambda>s. cte_wp_at' (\<lambda>c. safe_ioport_insert' (cteCap v) (cteCap c) s) dest s)\<rbrace>
-     setCTE dest v
-   \<lbrace>\<lambda>rv. valid_ioports'\<rbrace>"
-  apply (clarsimp simp: valid_ioports'_simps updateCap_def cteCaps_of_def)
-  apply (rule hoare_pre)
-   apply (wpsimp wp: setCTE_arch_ctes_of_wp getCTE_wp)
-    apply (clarsimp simp: cte_wp_at_ctes_of)
-  apply (rule conjI)
-   apply (thin_tac "\<forall>cap\<in>ran (S (ctes_of s)). \<forall>cap'\<in>ran (S (ctes_of s)). P cap cap'" for P S)
-   apply (clarsimp simp: safe_ioport_insert'_def issued_ioports'_def elim!: ranE split: if_split_asm)
-   apply (auto simp: ran_def cteCaps_of_def split: if_splits)[2]
-  apply (thin_tac "\<forall>cap\<in>ran (S (ctes_of s)). P cap (ksArchState s)" for P S)
-  apply (clarsimp simp: safe_ioport_insert'_def issued_ioports'_def elim!: ranE split: if_split_asm)
-    apply (erule disjE)
-     apply (force simp: ran_def cteCaps_of_def split: if_splits)
-    apply (clarsimp simp: cteCaps_of_def elim!: ranE)
-    apply (metis o_apply option.simps(9) ranI)
-   apply (clarsimp simp: cteCaps_of_def elim!: ranE)
-   apply (erule disjE)
-    apply (force simp: ran_def split: if_splits)
-   apply (metis Diff_disjoint Diff_triv o_apply option.simps(9) ranI)
-  by (metis (mono_tags, opaque_lifting) o_apply option.simps(9) ranI)
-
-lemma updateCap_ioports':
-  "\<lbrace>valid_ioports' and (\<lambda>s. cte_wp_at' (\<lambda>c. safe_ioport_insert' v (cteCap c) s) dest s)\<rbrace>
-     updateCap dest v
-   \<lbrace>\<lambda>rv. valid_ioports'\<rbrace>"
-  apply (clarsimp simp: updateCap_def)
-  apply (rule hoare_pre)
-   apply (wpsimp wp: setCTE_ioports' getCTE_wp)
-  apply (clarsimp simp: cte_wp_at_ctes_of)
-  done
-
-lemma setUntypedCapAsFull_safe_ioport_insert'[wp]:
-  "\<lbrace>\<lambda>s. cte_wp_at' (\<lambda>c. safe_ioport_insert' cap (cteCap c) s) dest s\<rbrace>
-      setUntypedCapAsFull (cteCap srcCTE) cap src
-   \<lbrace>\<lambda>rv s. cte_wp_at' (\<lambda>c. safe_ioport_insert' cap (cteCap c) s) dest s\<rbrace>"
-  apply (case_tac cap; clarsimp simp: setUntypedCapAsFull_def safe_ioport_insert'_def)
-  by wpsimp
-
-lemma cteInsert_ioports'[wp]:
-  "\<lbrace>valid_ioports' and safe_ioport_insert' cap NullCap\<rbrace>
-     cteInsert cap src dest
-   \<lbrace>\<lambda>rv. valid_ioports'\<rbrace>"
-  apply (simp add: cteInsert_def)
-  apply (wp getCTE_wp updateCap_ioports')
-  apply (clarsimp simp:cte_wp_at_ctes_of)
-  done
-
 lemma setCTE_irq_states' [wp]:
   "\<lbrace>valid_irq_states'\<rbrace> setCTE x y \<lbrace>\<lambda>_. valid_irq_states'\<rbrace>"
   apply (rule valid_irq_states_lift')
@@ -3473,8 +3408,7 @@ lemma cteInsert_invs:
  "\<lbrace>invs' and cte_wp_at' (\<lambda>c. cteCap c=NullCap) dest and valid_cap' cap and
   (\<lambda>s. src \<noteq> dest) and (\<lambda>s. cte_wp_at' (is_derived' (ctes_of s) src cap \<circ> cteCap) src s)
   and cte_wp_at' (untyped_derived_eq cap o cteCap) src
-  and ex_cte_cap_to' dest and (\<lambda>s. \<forall>irq. cap = IRQHandlerCap irq \<longrightarrow> irq_issued' irq s)
-  and safe_ioport_insert' cap NullCap\<rbrace>
+  and ex_cte_cap_to' dest and (\<lambda>s. \<forall>irq. cap = IRQHandlerCap irq \<longrightarrow> irq_issued' irq s) \<rbrace>
   cteInsert cap src dest
   \<lbrace>\<lambda>rv. invs'\<rbrace>"
   apply (simp add: invs'_def valid_state'_def valid_pspace'_def)
@@ -4405,21 +4339,12 @@ lemma setupReplyMaster_urz[wp]:
   apply (clarsimp simp: cteCaps_of_def untypedZeroRange_def Let_def isCap_simps)
   done
 
-crunch locateSlotTCB
-  for ioports'[wp]: "valid_ioports'"
-
 lemma not_ioport_cap_cap_ioports'[simp]:"\<not>isArchIOPortCap cap \<Longrightarrow> cap_ioports' cap = {}"
   by (clarsimp simp: isCap_simps cap_ioports'_def split: capability.splits arch_capability.splits)
 
 lemma not_ioport_cap_safe_ioport_insert'[simp]: "\<not>isArchIOPortCap cap \<Longrightarrow> safe_ioport_insert' cap cap' s"
   by (clarsimp simp: safe_ioport_insert'_def isCap_simps)
 
-lemma setupReplyMaster_ioports'[wp]:
-  "\<lbrace>valid_ioports'\<rbrace> setupReplyMaster t \<lbrace>\<lambda>rv. valid_ioports'\<rbrace>"
-  apply (wpsimp simp: setupReplyMaster_def locateSlot_conv
-                  wp: setCTE_ioports' getCTE_wp hoare_vcg_ex_lift)
-  by (clarsimp simp: cte_wp_at_ctes_of isCap_simps)
-
 lemma setupReplyMaster_invs'[wp]:
   "\<lbrace>invs' and tcb_at' t and ex_nonz_cap_to' t\<rbrace>
      setupReplyMaster t
@@ -4689,14 +4614,6 @@ lemma setCTE_vms'[wp]:
   apply wp+
   done
 
-lemma safe_ioport_insert_same':
-  "\<lbrakk>valid_ioports' s; cte_wp_at' (\<lambda>cte. cteCap cte = cap) p s\<rbrakk> \<Longrightarrow> safe_ioport_insert' cap cap s"
-  apply (clarsimp simp: safe_ioport_insert'_def cte_wp_at_ctes_of valid_ioports'_simps
-                        cteCaps_of_def
-                 elim!: ranE)
-  apply (thin_tac "\<forall>cap\<in>ran (S (ctes_of s)). P cap (ksArchState s)" for P S)
-  by (auto simp: ran_def split: if_splits)
-
 lemma arch_update_setCTE_invs:
   "\<lbrace>cte_wp_at' (is_arch_update' cap) p and cte_wp_at' ((=) oldcte) p and invs' and valid_cap' cap\<rbrace>
   setCTE p (cteCap_update (\<lambda>_. cap) oldcte)
@@ -4705,7 +4622,7 @@ lemma arch_update_setCTE_invs:
   apply (wp arch_update_setCTE_mdb valid_queues_lift sch_act_wf_lift tcb_in_cur_domain'_lift ct_idle_or_in_cur_domain'_lift
              arch_update_setCTE_iflive arch_update_setCTE_ifunsafe
              valid_irq_node_lift setCTE_typ_at' setCTE_irq_handlers'
-             setCTE_pred_tcb_at' irqs_masked_lift setCTE_ioports'
+             setCTE_pred_tcb_at' irqs_masked_lift
              hoare_vcg_disj_lift untyped_ranges_zero_lift valid_bitmaps_lift
            | simp add: pred_tcb_at'_def)+
   apply (clarsimp simp: valid_global_refs'_def is_arch_update'_def fun_upd_def[symmetric]
@@ -4719,9 +4636,7 @@ lemma arch_update_setCTE_invs:
                          untypedZeroRange_def Let_def
                          isCap_simps(1-11)[where v="ArchObjectCap ac" for ac])
   apply (rule conjI, fastforce)
-  apply (rule conjI, fastforce)
-  apply (case_tac v0; clarsimp simp: isCap_simps)
-  apply (erule_tac p=p in safe_ioport_insert_same', clarsimp simp: cte_wp_at_ctes_of)
+  apply fastforce
   done
 
 definition
@@ -6148,7 +6063,6 @@ lemma cteInsert_simple_invs:
  "\<lbrace>invs' and cte_wp_at' (\<lambda>c. cteCap c=NullCap) dest and valid_cap' cap and
   (\<lambda>s. src \<noteq> dest) and (\<lambda>s. safe_parent_for' (ctes_of s) src cap)
   and (\<lambda>s. \<forall>irq. cap = IRQHandlerCap irq \<longrightarrow> irq_issued' irq s)
-  and safe_ioport_insert' cap NullCap
   and cte_at' src
   and ex_cte_cap_to' dest and K (is_simple_cap' cap)\<rbrace>
   cteInsert cap src dest
@@ -6579,7 +6493,7 @@ lemma updateFreeIndex_forward_invs':
        apply (wp setCTE_irq_handlers' getCTE_wp)
       apply (simp add:updateCap_def)
       apply (wp irqs_masked_lift cur_tcb_lift ct_idle_or_in_cur_domain'_lift
-                hoare_vcg_disj_lift untyped_ranges_zero_lift getCTE_wp setCTE_ioports'
+                hoare_vcg_disj_lift untyped_ranges_zero_lift getCTE_wp
                 sym_heap_sched_pointers_lift valid_bitmaps_lift
                | wp (once) hoare_use_eq[where f="gsUntypedZeroRanges"]
                | simp add: getSlotCap_def)+
diff --git a/proof/refine/X64/Detype_R.thy b/proof/refine/X64/Detype_R.thy
index e78d37b963..74a6c24d25 100644
--- a/proof/refine/X64/Detype_R.thy
+++ b/proof/refine/X64/Detype_R.thy
@@ -636,7 +636,6 @@ lemma valid_objs: "valid_objs' s'"
   and      arch: "valid_arch_state' s'"
   and      virq: "valid_irq_node' (irq_node' s') s'"
   and     virqh: "valid_irq_handlers' s'"
-  and  vioports: "valid_ioports' s'"
   and     virqs: "valid_irq_states' s'"
   and no_0_objs: "no_0_obj' s'"
   and  ctnotinQ: "ct_not_inQ s'"
@@ -1579,13 +1578,6 @@ proof (simp add: invs'_def valid_state'_def valid_pspace'_def
     apply (clarsimp simp: ran_def)
     done
 
-  show "valid_ioports' ?s" using vioports
-    apply (simp add: valid_ioports'_simps Ball_def cteCaps_of_def, clarsimp)
-    apply (rule conjI, rule allEI, assumption, (auto simp: ran_def)[1])
-    apply (erule allEI)
-    apply (auto simp: ran_def)
-    done
-
   from irq_ctrl
   show "irq_control ?ctes'"
     by (clarsimp simp: irq_control_def)
diff --git a/proof/refine/X64/Finalise_R.thy b/proof/refine/X64/Finalise_R.thy
index 9e91269b5a..7a86169c7b 100644
--- a/proof/refine/X64/Finalise_R.thy
+++ b/proof/refine/X64/Finalise_R.thy
@@ -1392,40 +1392,13 @@ lemma postCapDeletion_irq_handlers'[wp]:
    \<lbrace>\<lambda>rv. valid_irq_handlers'\<rbrace>"
   by (wpsimp simp: Retype_H.postCapDeletion_def X64_H.postCapDeletion_def)
 
-crunch deletedIRQHandler
-  for ioports'[wp]: valid_ioports'
-  (wp: valid_ioports_lift'')
-
+(* extra constraints on IO ports are not needed since there is no valid_ioports to preserve in
+   Refine *)
 definition
-  "post_cap_delete_pre' cap sl cs \<equiv> case cap of
-     IRQHandlerCap irq \<Rightarrow> irq \<le> maxIRQ \<and> (\<forall>sl'. sl \<noteq> sl' \<longrightarrow> cs sl' \<noteq> Some cap)
-   | ArchObjectCap (IOPortCap f l) \<Rightarrow> f \<le> l \<and> (\<forall>sl'. sl \<noteq> sl' \<longrightarrow> (\<forall>cap'. cs sl' = Some cap' \<longrightarrow> cap_ioports' cap \<inter> cap_ioports' cap' = {}))
-   | _ \<Rightarrow> False"
-
-lemma setIOPortMask_ioports':
-  "\<lbrace>valid_ioports' and (\<lambda>s. \<not> b \<longrightarrow> (\<forall>cap' \<in> ran (cteCaps_of s). cap_ioports' cap' \<inter> {f..l} = {}))\<rbrace>
-     setIOPortMask f l b
-   \<lbrace>\<lambda>rv. valid_ioports'\<rbrace>"
-  supply fun_upd_apply[simp del]
-  apply (clarsimp simp: setIOPortMask_def)
-  apply wpsimp
-  apply (clarsimp simp: valid_ioports'_simps foldl_map)
-  apply (case_tac b; clarsimp simp: foldl_fun_upd_value)
-   apply (drule_tac x=cap in bspec, assumption)
-   apply (clarsimp simp: subset_eq)
-  apply (drule_tac x=cap in bspec, assumption)
-  by auto
-
-lemma postCapDeletion_ioports':
-  "\<lbrace>valid_ioports' and cte_wp_at' (\<lambda>cte. cteCap cte = NullCap) sl and (\<lambda>s. c \<noteq> NullCap \<longrightarrow> post_cap_delete_pre' c sl (cteCaps_of s))\<rbrace>
-     global.postCapDeletion c
-   \<lbrace>\<lambda>rv. valid_ioports'\<rbrace>"
-  apply (clarsimp simp: Retype_H.postCapDeletion_def)
-  apply (wpsimp simp: freeIOPortRange_def X64_H.postCapDeletion_def wp: setIOPortMask_ioports')
-  apply (clarsimp simp: post_cap_delete_pre'_def cte_wp_at_ctes_of elim!: ranE)
-  apply (drule_tac x=x in spec)
-  apply (clarsimp simp: valid_ioports'_simps cteCaps_of_def)
-  by (auto simp: ran_def split: if_split_asm)
+  "post_cap_delete_pre' cap sl cs \<equiv> case cap
+     of IRQHandlerCap irq \<Rightarrow> irq \<le> maxIRQ \<and> (\<forall>sl'. sl \<noteq> sl' \<longrightarrow> cs sl' \<noteq> Some cap)
+     | ArchObjectCap (IOPortCap f l) \<Rightarrow> f \<le> l \<and> (\<forall>sl'. sl \<noteq> sl' \<longrightarrow> cs sl' \<noteq> Some cap)
+     | _ \<Rightarrow> False"
 
 end
 
@@ -1447,49 +1420,6 @@ lemma emptySlot_valid_irq_handlers'[wp]:
   apply auto
   done
 
-lemma updateMDB_safe_ioport_insert'[wp]:
-  "\<lbrace>\<lambda>s. cte_wp_at' (\<lambda>cte. safe_ioport_insert' c (cteCap cte) s) sl s\<rbrace>
-     updateMDB a b
-   \<lbrace>\<lambda>rv s. cte_wp_at' (\<lambda>cte. safe_ioport_insert' c (cteCap cte) s) sl s\<rbrace>"
-  apply (clarsimp simp: safe_ioport_insert'_def)
-  apply (rule hoare_pre)
-   apply wps
-   apply (wpsimp wp: updateMDB_weak_cte_wp_at)
-  by (clarsimp simp: cte_wp_at_ctes_of)
-
-lemma clearUntypedFreeIndex_ioports'[wp]:
-  "\<lbrace>valid_ioports'\<rbrace> clearUntypedFreeIndex f \<lbrace>\<lambda>rv. valid_ioports'\<rbrace>"
-  by (wpsimp wp: valid_ioports_lift')
-
-lemma clearUntypedFreeIndex_safe_ioport_insert'[wp]:
-  "\<lbrace>safe_ioport_insert' c c'\<rbrace> clearUntypedFreeIndex f \<lbrace>\<lambda>rv. safe_ioport_insert' c c'\<rbrace>"
-  apply (clarsimp simp: safe_ioport_insert'_def)
-  apply (rule hoare_pre)
-   apply wps
-  by wpsimp+
-
-context begin interpretation Arch .
-lemma emptySlot_ioports'[wp]:
-  "\<lbrace>\<lambda>s. valid_ioports' s \<and> cte_at' sl s
-          \<and> (info \<noteq> NullCap \<longrightarrow> post_cap_delete_pre' info sl (cteCaps_of s))\<rbrace>
-     emptySlot sl info
-   \<lbrace>\<lambda>rv. valid_ioports'\<rbrace>"
-  apply (simp add: emptySlot_def case_Null_If)
-  apply (rule hoare_pre)
-   apply (wpsimp wp: postCapDeletion_ioports'[where sl=sl] updateCap_ioports' updateCap_no_0
-                     updateMDB_weak_cte_wp_at hoare_vcg_const_imp_lift updateCap_cte_wp_at' getCTE_wp
-                     hoare_vcg_ex_lift
-               simp: cte_wp_at_ctes_of
-              | wp (once) hoare_drop_imps)+
-  apply (clarsimp simp: valid_ioports'_simps)
-  apply (rule conjI)
-   apply (clarsimp simp: safe_ioport_insert'_def)
-  apply (clarsimp simp: post_cap_delete_pre'_def split: capability.splits arch_capability.splits)
-   apply (auto simp: modify_map_def ran_def capAligned_def word_bits_def
-              split: if_split_asm)
-  done
-end
-
 declare setIRQState_irq_states' [wp]
 
 context begin interpretation Arch .
@@ -1629,10 +1559,8 @@ lemma emptySlot_invs'[wp]:
      emptySlot sl info
    \<lbrace>\<lambda>rv. invs'\<rbrace>"
   apply (simp add: invs'_def valid_state'_def valid_pspace'_def)
-  apply (rule hoare_pre)
-   apply (wp valid_irq_node_lift cur_tcb_lift)
-  apply (clarsimp simp: cte_wp_at_ctes_of)
-  apply (clarsimp simp: post_cap_delete_pre'_def cteCaps_of_def
+  apply (wpsimp wp: valid_irq_node_lift cur_tcb_lift)
+  apply (clarsimp simp: post_cap_delete_pre'_def cteCaps_of_def cte_wp_at_ctes_of
                  split: capability.split_asm arch_capability.split_asm)
   by auto
 
@@ -2557,7 +2485,7 @@ lemma invs_asid_update_strg':
   apply (simp add: valid_state'_def)
   apply (simp add: valid_global_refs'_def global_refs'_def valid_arch_state'_def
                    valid_asid_table'_def valid_machine_state'_def ct_idle_or_in_cur_domain'_def
-                   tcb_in_cur_domain'_def valid_ioports'_simps)
+                   tcb_in_cur_domain'_def)
   apply (auto simp add: ran_def split: if_split_asm)
   done
 
diff --git a/proof/refine/X64/InterruptAcc_R.thy b/proof/refine/X64/InterruptAcc_R.thy
index e2f7c27817..87442c03e2 100644
--- a/proof/refine/X64/InterruptAcc_R.thy
+++ b/proof/refine/X64/InterruptAcc_R.thy
@@ -55,7 +55,6 @@ lemma setIRQState_invs[wp]:
                         if_unsafe_then_cap'_def ex_cte_cap_to'_def
                         valid_irq_handlers'_def irq_issued'_def
                         cteCaps_of_def valid_irq_masks'_def
-                        valid_ioports'_simps
                         bitmapQ_defs valid_bitmaps_def)
   apply (rule conjI, clarsimp)
   apply (clarsimp simp: irqs_masked'_def ct_not_inQ_def)
diff --git a/proof/refine/X64/Interrupt_R.thy b/proof/refine/X64/Interrupt_R.thy
index af90929ad9..f9937b0c73 100644
--- a/proof/refine/X64/Interrupt_R.thy
+++ b/proof/refine/X64/Interrupt_R.thy
@@ -602,7 +602,7 @@ lemma updateIRQState_invs'[wp]:
                          valid_irq_handlers'_def irq_issued'_def
                          cteCaps_of_def valid_irq_masks'_def
                          bitmapQ_defs  valid_x64_irq_state'_def
-                         valid_ioports'_def all_ioports_issued'_def issued_ioports'_def)
+                         all_ioports_issued'_def issued_ioports'_def)
   done
 
 lemma dmo_ioapicMapPinToVector_invs'[wp]:
diff --git a/proof/refine/X64/InvariantUpdates_H.thy b/proof/refine/X64/InvariantUpdates_H.thy
index c2daa7de54..b24ab1932d 100644
--- a/proof/refine/X64/InvariantUpdates_H.thy
+++ b/proof/refine/X64/InvariantUpdates_H.thy
@@ -272,10 +272,6 @@ lemma valid_arch_state'_interrupt[simp]:
 
 context begin interpretation Arch . (*FIXME: arch-split*)
 
-lemma valid_ioports_cr3_update[simp]:
-  "valid_ioports' (s\<lparr>ksArchState := x64KSCurrentUserCR3_update (\<lambda>_. c) (ksArchState s)\<rparr>) = valid_ioports' s"
-  by (clarsimp simp: valid_ioports'_simps)
-
 end
 
 lemma valid_bitmapQ_ksSchedulerAction_upd[simp]:
diff --git a/proof/refine/X64/Invariants_H.thy b/proof/refine/X64/Invariants_H.thy
index 64124182bc..f07469f9af 100644
--- a/proof/refine/X64/Invariants_H.thy
+++ b/proof/refine/X64/Invariants_H.thy
@@ -1235,22 +1235,6 @@ definition
 where
   "all_ioports_issued' \<equiv> \<lambda>cs as. \<forall>cap \<in> ran cs. cap_ioports' cap \<subseteq> issued_ioports' as"
 
-definition
-  ioports_no_overlap' :: "(machine_word \<Rightarrow> capability option) \<Rightarrow> bool"
-where
-  "ioports_no_overlap' \<equiv> \<lambda>cs. \<forall>cap \<in> ran cs. \<forall>cap' \<in> ran cs.
-                                 cap_ioports' cap \<inter> cap_ioports' cap' \<noteq> {} \<longrightarrow>
-                                        cap_ioports' cap = cap_ioports' cap'"
-
-definition
-  valid_ioports' :: "kernel_state \<Rightarrow> bool"
-where
-  "valid_ioports' \<equiv> \<lambda>s. all_ioports_issued' (cteCaps_of s) (ksArchState s)
-                      \<and> ioports_no_overlap' (cteCaps_of s)"
-
-lemmas valid_ioports'_simps = valid_ioports'_def all_ioports_issued'_def ioports_no_overlap'_def
-                              issued_ioports'_def
-
 definition
   "irqs_masked' \<equiv> \<lambda>s. \<forall>irq > maxIRQ. intStateIRQTable (ksInterruptState s) irq = IRQInactive"
 
@@ -1302,7 +1286,6 @@ where
                       \<and> valid_irq_states' s
                       \<and> valid_machine_state' s
                       \<and> irqs_masked' s
-                      \<and> valid_ioports' s
                       \<and> sym_heap_sched_pointers s
                       \<and> valid_sched_pointers s
                       \<and> valid_bitmaps s
@@ -1386,7 +1369,7 @@ abbreviation(input)
            \<and> valid_machine_state' s
            \<and> cur_tcb' s \<and> ct_idle_or_in_cur_domain' s
            \<and> cur_tcb' s \<and> ct_idle_or_in_cur_domain' s
-           \<and> pspace_domain_valid s \<and> valid_ioports' s
+           \<and> pspace_domain_valid s
            \<and> ksCurDomain s \<le> maxDomain
            \<and> valid_dom_schedule' s \<and> untyped_ranges_zero' s"
 
@@ -1401,7 +1384,7 @@ abbreviation(input)
            \<and> sym_heap_sched_pointers s \<and> valid_sched_pointers s \<and> valid_bitmaps s
            \<and> valid_machine_state' s
            \<and> cur_tcb' s \<and> ct_idle_or_in_cur_domain' s
-           \<and> pspace_domain_valid s \<and> valid_ioports' s
+           \<and> pspace_domain_valid s
            \<and> ksCurDomain s \<le> maxDomain
            \<and> valid_dom_schedule' s \<and> untyped_ranges_zero' s"
 
@@ -1424,7 +1407,7 @@ definition
            \<and> sym_heap_sched_pointers s \<and> valid_sched_pointers s \<and> valid_bitmaps s
            \<and> valid_machine_state' s
            \<and> cur_tcb' s \<and> ct_not_inQ s
-           \<and> pspace_domain_valid s \<and> valid_ioports' s
+           \<and> pspace_domain_valid s
            \<and> ksCurDomain s \<le> maxDomain
            \<and> valid_dom_schedule' s \<and> untyped_ranges_zero' s"
 
@@ -3012,10 +2995,6 @@ locale P_Int_Cur_update_eq =
 locale P_Arch_Idle_Int_update_eq = P_Arch_Idle_update_eq + P_Int_update_eq
 begin
 
-lemma valid_ioports_update'[iff]:
-  "valid_ioports' (f s) = valid_ioports' s"
-  by (simp add: valid_ioports'_def cteCaps_of_def pspace arch)
-
 end
 
 locale P_Arch_Idle_Int_Cur_update_eq =
@@ -3415,10 +3394,6 @@ lemma invs_arch_state' [elim!]:
   "invs' s \<Longrightarrow> valid_arch_state' s"
   by (simp add: invs'_def valid_state'_def)
 
-lemma invs_valid_ioports' [elim!]:
-  "invs' s \<Longrightarrow> valid_ioports' s"
-  by (simp add: invs'_def valid_state'_def)
-
 lemma invs_cur' [elim!]:
   "invs' s \<Longrightarrow> cur_tcb' s"
   by (simp add: invs'_def)
@@ -3508,7 +3483,7 @@ lemma invs_no_0_obj'[elim!]:
 
 lemma invs'_gsCNodes_update[simp]:
   "invs' (gsCNodes_update f s') = invs' s'"
-  apply (clarsimp simp: invs'_def valid_state'_def valid_bitmaps_def bitmapQ_defs valid_ioports'_def
+  apply (clarsimp simp: invs'_def valid_state'_def valid_bitmaps_def bitmapQ_defs
                         valid_irq_node'_def valid_irq_handlers'_def irq_issued'_def irqs_masked'_def
                         valid_machine_state'_def cur_tcb'_def)
   apply (cases "ksSchedulerAction s'";
@@ -3518,7 +3493,7 @@ lemma invs'_gsCNodes_update[simp]:
 
 lemma invs'_gsUserPages_update[simp]:
   "invs' (gsUserPages_update f s') = invs' s'"
-  apply (clarsimp simp: invs'_def valid_state'_def valid_bitmaps_def bitmapQ_defs valid_ioports'_def
+  apply (clarsimp simp: invs'_def valid_state'_def valid_bitmaps_def bitmapQ_defs
                         valid_irq_node'_def valid_irq_handlers'_def irq_issued'_def irqs_masked'_def
                         valid_machine_state'_def cur_tcb'_def)
   apply (cases "ksSchedulerAction s'";
diff --git a/proof/refine/X64/IpcCancel_R.thy b/proof/refine/X64/IpcCancel_R.thy
index f599dd7f35..9944c416b7 100644
--- a/proof/refine/X64/IpcCancel_R.thy
+++ b/proof/refine/X64/IpcCancel_R.thy
@@ -1655,7 +1655,7 @@ lemma cancel_all_invs'_helper:
   apply (rule mapM_x_inv_wp2)
    apply clarsimp
   apply (rule hoare_pre)
-   apply (wp valid_irq_node_lift valid_irq_handlers_lift'' irqs_masked_lift valid_ioports_lift''
+   apply (wp valid_irq_node_lift valid_irq_handlers_lift'' irqs_masked_lift
              hoare_vcg_const_Ball_lift untyped_ranges_zero_lift sts_st_tcb'
           | simp add: cteCaps_of_def o_def)+
   apply (unfold fun_upd_apply Invariants_H.tcb_st_refs_of'_simps)
@@ -2133,7 +2133,7 @@ lemma cancelBadgedSends_filterM_helper':
   apply (rule hoare_pre)
    apply (wp valid_irq_node_lift hoare_vcg_const_Ball_lift sts_sch_act'
              sch_act_wf_lift valid_irq_handlers_lift'' cur_tcb_lift irqs_masked_lift
-             sts_st_tcb' valid_ioports_lift''
+             sts_st_tcb'
              untyped_ranges_zero_lift
         | clarsimp simp: cteCaps_of_def o_def)+
   apply (frule insert_eqD, frule state_refs_of'_elemD)
diff --git a/proof/refine/X64/Ipc_R.thy b/proof/refine/X64/Ipc_R.thy
index 0f295b273f..bfc4d23ae6 100644
--- a/proof/refine/X64/Ipc_R.thy
+++ b/proof/refine/X64/Ipc_R.thy
@@ -884,39 +884,6 @@ lemma transferCapsToSlots_irq_handlers[wp]:
   apply (fastforce simp:valid_cap'_def)
   done
 
-crunch setExtraBadge
-  for ioports'[wp]: valid_ioports'
-
-lemma valid_ioports'_derivedD:
-  "\<lbrakk>valid_ioports' s; cte_wp_at' (is_derived' (ctes_of s) src cap \<circ> cteCap) src s\<rbrakk> \<Longrightarrow>
-     safe_ioport_insert' cap NullCap s"
-  apply (clarsimp simp: is_derived'_def cte_wp_at_ctes_of safe_ioport_insert'_def badge_derived'_def)
-  apply (case_tac cap; clarsimp)
-  apply (rename_tac acap, case_tac acap; clarsimp simp: isCap_simps)
-  apply (clarsimp simp: valid_ioports'_def cteCaps_of_def
-                 elim!: ranE
-                 split: capability.splits arch_capability.splits)
-  apply (rule conjI, force simp: ioports_no_overlap'_def ran_def split: if_splits)
-  apply (force simp: ran_def issued_ioports'_def all_ioports_issued'_def split: if_splits)
-  done
-
-lemma transferCapsToSlots_ioports'[wp]:
-  "\<lbrace>valid_ioports' and valid_objs' and valid_mdb' and pspace_distinct' and pspace_aligned'
-         and K(distinct slots \<and> length slots \<le> 1)
-         and (\<lambda>s. \<forall>x \<in> set slots. real_cte_at' x s \<and> cte_wp_at' (\<lambda>cte. cteCap cte = capability.NullCap) x s)
-         and transferCaps_srcs caps\<rbrace>
-     transferCapsToSlots ep buffer n caps slots mi
-  \<lbrace>\<lambda>rv. valid_ioports'\<rbrace>"
-  apply (wpsimp wp: transferCapsToSlots_presM[where vo=True and emx=False and drv=True and pad=False])
-     apply (clarsimp simp: valid_ioports'_derivedD)
-    apply wp
-  apply (clarsimp simp:cte_wp_at_ctes_of | intro ballI conjI)+
-  apply (drule(1) bspec,clarsimp)
-  apply (case_tac cte,clarsimp)
-  apply (frule(1) CSpace_I.ctes_of_valid_cap')
-  apply (fastforce simp:valid_cap'_def)
-  done
-
 crunch setExtraBadge
   for irq_state'[wp]: "\<lambda>s. P (ksInterruptState s)"
 
@@ -1879,11 +1846,6 @@ crunch doIPCTransfer
        transferCapsToSlots_irq_handlers
        simp: zipWithM_x_mapM ball_conj_distrib )
 
-crunch doIPCTransfer
-  for ioports'[wp]: "valid_ioports'"
-  (wp: crunch_wps hoare_vcg_const_Ball_lift
-       simp: zipWithM_x_mapM ball_conj_distrib)
-
 crunch doIPCTransfer
   for irq_states'[wp]: "valid_irq_states'"
   (wp: crunch_wps no_irq no_irq_mapM no_irq_storeWord no_irq_loadWord
@@ -3635,14 +3597,6 @@ lemma setupCallerCap_irq_handlers'[wp]:
             getThreadReplySlot_def locateSlot_conv
   by (wp hoare_drop_imps | simp)+
 
-lemma setupCallerCap_ioports'[wp]:
-  "\<lbrace>valid_ioports'\<rbrace>
-   setupCallerCap sender rcvr grant
-   \<lbrace>\<lambda>rv. valid_ioports'\<rbrace>"
-  unfolding setupCallerCap_def getThreadCallerSlot_def
-            getThreadReplySlot_def locateSlot_conv
-  by (wp hoare_drop_imps | simp add: isCap_simps)+
-
 lemma cteInsert_cap_to':
   "\<lbrace>ex_nonz_cap_to' p and cte_wp_at' (\<lambda>c. cteCap c = NullCap) dest\<rbrace>
      cteInsert cap src dest
@@ -3824,8 +3778,7 @@ lemmas possibleSwitchToTo_cteCaps_of[wp]
 
 crunch possibleSwitchTo
    for ksArch[wp]: "\<lambda>s. P (ksArchState s)"
-   and ioports'[wp]: valid_ioports'
-  (wp: valid_ioports_lift' possibleSwitchTo_ctes_of crunch_wps ignore: constOnFailure)
+  (wp: possibleSwitchTo_ctes_of crunch_wps ignore: constOnFailure)
 
 crunch asUser
   for valid_bitmaps[wp]: valid_bitmaps
diff --git a/proof/refine/X64/KHeap_R.thy b/proof/refine/X64/KHeap_R.thy
index 81e3f8de71..4b2418dd90 100644
--- a/proof/refine/X64/KHeap_R.thy
+++ b/proof/refine/X64/KHeap_R.thy
@@ -2220,19 +2220,6 @@ lemmas set_ntfn_irq_handlers'[wp] = valid_irq_handlers_lift'' [OF set_ntfn_ctes_
 
 lemmas set_ntfn_irq_states' [wp] = valid_irq_states_lift' [OF set_ntfn_ksInterrupt set_ntfn_ksMachine]
 
-lemma valid_ioports_lift':
-  assumes x: "\<And>P. \<lbrace>\<lambda>s. P (cteCaps_of s)\<rbrace> f \<lbrace>\<lambda>rv s. P (cteCaps_of s)\<rbrace>"
-  assumes y: "\<And>P. \<lbrace>\<lambda>s. P (ksArchState s)\<rbrace> f \<lbrace>\<lambda>rv s. P (ksArchState s)\<rbrace>"
-  shows      "\<lbrace>valid_ioports'\<rbrace> f \<lbrace>\<lambda>rv. valid_ioports'\<rbrace>"
-  apply (clarsimp simp: valid_ioports'_def)
-  apply (rule hoare_use_eq [where f="\<lambda>s. ksArchState s"], rule y)
-  apply (rule hoare_use_eq [where f="\<lambda>s. cteCaps_of s"], rule x)
-  apply wp
-  done
-
-lemmas valid_ioports_lift'' = valid_ioports_lift'[unfolded cteCaps_of_def]
-lemmas set_ntfn_ioports'[wp] = valid_ioports_lift''[OF set_ntfn_ctes_of set_ntfn_arch']
-
 lemma set_ntfn_vms'[wp]:
   "\<lbrace>valid_machine_state'\<rbrace> setNotification ptr val \<lbrace>\<lambda>rv. valid_machine_state'\<rbrace>"
   apply (simp add: setNotification_def valid_machine_state'_def pointerInDeviceData_def pointerInUserData_def)
@@ -2451,7 +2438,6 @@ lemma setEndpoint_ksMachine:
 
 lemmas setEndpoint_valid_irq_states'  =
   valid_irq_states_lift' [OF setEndpoint_ksInterruptState setEndpoint_ksMachine]
-lemmas setEndpoint_ioports'[wp] = valid_ioports_lift''[OF set_ep_ctes_of set_ep_arch']
 
 lemma setEndpoint_ct':
   "\<lbrace>\<lambda>s. P (ksCurThread s)\<rbrace> setEndpoint a b \<lbrace>\<lambda>rv s. P (ksCurThread s)\<rbrace>"
diff --git a/proof/refine/X64/Retype_R.thy b/proof/refine/X64/Retype_R.thy
index 7c4fb10a3c..a5ed6542e0 100644
--- a/proof/refine/X64/Retype_R.thy
+++ b/proof/refine/X64/Retype_R.thy
@@ -4501,30 +4501,6 @@ lemma createNewCaps_irq_handlers':
   apply auto
   done
 
-lemma valid_ioports_cte_wp_at_form':
-  "(\<lambda>s. all_ioports_issued' (cteCaps_of s) f \<and> ioports_no_overlap' (cteCaps_of s)) = (\<lambda>s. (\<forall>irq. irq \<in> issued_ioports' f \<or>
-                               (\<forall>p. \<not> cte_wp_at' (\<lambda>cte. irq \<in> cap_ioports' (cteCap cte)) p s)) \<and>
-     (\<forall>sl sl' cap cap'. cte_wp_at' (\<lambda>cte. cteCap cte = cap) sl s
-                      \<and> cte_wp_at' (\<lambda>cte. cteCap cte = cap') sl' s \<longrightarrow>
-                         cap_ioports' cap = cap_ioports' cap' \<or> cap_ioports' cap \<inter> cap_ioports' cap' = {}))"
-  by (auto simp: valid_ioports'_simps cteCaps_of_def cte_wp_at_ctes_of
-                        fun_eq_iff ran_def | blast)+
-
-lemma createNewCaps_ioports':
-  "\<lbrace>valid_ioports' and pspace_no_overlap' ptr sz
-       and pspace_aligned' and pspace_distinct'
-       and K (range_cover ptr sz (APIType_capBits ty us) n \<and> n \<noteq> 0)\<rbrace>
-     createNewCaps ty ptr n us d
-   \<lbrace>\<lambda>rv. valid_ioports'\<rbrace>"
-  apply (clarsimp simp: valid_ioports'_def)
-  apply (rule hoare_pre)
-   apply (rule hoare_use_eq [where f=ksArchState, OF createNewCaps_ksArch])
-   apply (simp add: valid_ioports_cte_wp_at_form')
-   apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift hoare_vcg_imp_lift' |
-              wp createNewCaps_cte_wp_at2)+
-  apply (clarsimp simp: makeObject_cte)
-  by (auto simp: valid_ioports'_simps cte_wp_at_ctes_of ran_def cteCaps_of_def | blast)+
-
 lemma createObjects'_irq_states' [wp]:
   "\<lbrace>valid_irq_states'\<rbrace> createObjects' a b c d \<lbrace>\<lambda>_. valid_irq_states'\<rbrace>"
   apply (simp add: createObjects'_def split_def)
@@ -5085,7 +5061,7 @@ proof (rule hoare_gen_asm, elim conjE)
                createNewCaps_global_refs'
                createNewCaps_valid_arch_state
                valid_irq_node_lift_asm [unfolded pred_conj_def, OF _ createNewCaps_obj_at']
-               createNewCaps_irq_handlers' createNewCaps_vms createNewCaps_ioports'
+               createNewCaps_irq_handlers' createNewCaps_vms
                createNewCaps_pred_tcb_at' cnc_ct_not_inQ
                createNewCaps_ct_idle_or_in_cur_domain'
                createNewCaps_sch_act_wf
@@ -5302,26 +5278,6 @@ lemma createObjects_no_cte_irq_handlers:
   apply auto
   done
 
-lemma createObjects_no_cte_ioports:
-  assumes no_cte: "\<And>c. projectKO_opt val \<noteq> Some (c::cte)"
-  assumes no_tcb: "\<And>t. projectKO_opt val \<noteq> Some (t::tcb)"
-  shows
-  "\<lbrace>\<lambda>s. pspace_aligned' s \<and> pspace_distinct' s \<and>
-        pspace_no_overlap' ptr sz s \<and>
-        range_cover ptr sz (objBitsKO val + gbits) n \<and> n \<noteq> 0 \<and>
-        valid_ioports' s\<rbrace>
-      createObjects ptr n val gbits
-   \<lbrace>\<lambda>rv s.  valid_ioports' s\<rbrace>"
-  apply (simp add: valid_ioports'_def)
-  apply (rule hoare_pre)
-   apply (rule hoare_use_eq[where f=ksArchState, OF createObjects_ksArch])
-   apply (clarsimp simp: valid_ioports_cte_wp_at_form' createObjects_def)
-   apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift hoare_vcg_imp_lift' |
-             wp createObjects_orig_cte_wp_at2')+
-  apply (clarsimp simp: no_cte no_tcb split_def split: option.splits)
-  apply (auto simp: valid_ioports'_simps cteCaps_of_def cte_wp_at_ctes_of ran_def | blast)+
-  done
-
 lemma createObjects_cur':
   "\<lbrace>\<lambda>s. pspace_aligned' s \<and> pspace_distinct' s \<and>
         pspace_no_overlap' ptr sz s \<and> range_cover ptr sz (objBitsKO val + gbits) n \<and> n \<noteq> 0 \<and>
@@ -5451,7 +5407,7 @@ proof -
        apply (wp createObjects_idle')
       apply (wp irqs_masked_lift createObjects_no_cte_valid_global
                 createObjects_valid_arch createObjects_irq_state
-                createObjects_no_cte_irq_handlers createObjects_no_cte_ioports assms
+                createObjects_no_cte_irq_handlers assms
             | simp)+
       apply (rule hoare_vcg_conj_lift)
        apply (simp add: createObjects_def)
diff --git a/proof/refine/X64/Schedule_R.thy b/proof/refine/X64/Schedule_R.thy
index 2fa59346eb..00134c2c98 100644
--- a/proof/refine/X64/Schedule_R.thy
+++ b/proof/refine/X64/Schedule_R.thy
@@ -459,7 +459,7 @@ lemma tcbSchedEnqueue_invs'[wp]:
    \<lbrace>\<lambda>_. invs'\<rbrace>"
   apply (simp add: invs'_def valid_state'_def valid_pspace'_def)
   apply (wpsimp wp: valid_irq_node_lift valid_irq_handlers_lift'' irqs_masked_lift
-                    untyped_ranges_zero_lift tcbSchedEnqueue_ct_not_inQ valid_ioports_lift'
+                    untyped_ranges_zero_lift tcbSchedEnqueue_ct_not_inQ
               simp: cteCaps_of_def o_def)
   done
 
@@ -499,8 +499,7 @@ lemma tcbSchedAppend_tcb_in_cur_domain'[wp]:
 
 crunch tcbSchedAppend, tcbSchedDequeue
   for arch'[wp]: "\<lambda>s. P (ksArchState s)"
-  and ioports'[wp]: valid_ioports'
-  (simp: unless_def wp: valid_ioports_lift'')
+  (simp: unless_def)
 
 lemma tcbSchedAppend_sch_act_wf[wp]:
   "tcbSchedAppend thread \<lbrace>\<lambda>s. sch_act_wf (ksSchedulerAction s) s\<rbrace>"
@@ -994,12 +993,6 @@ lemma asUser_utr[wp]:
   apply (simp add: o_def)
   done
 
-lemma asUser_ioports'[wp]:
-  "\<lbrace>valid_ioports'\<rbrace> asUser t f \<lbrace>\<lambda>rv. valid_ioports'\<rbrace>"
-  apply (simp add: asUser_def split_def)
-  apply (wpsimp wp: valid_ioports_lift'' select_f_inv threadSet_ctes_of)
-  done
-
 lemma Arch_switchToThread_invs_no_cicd':
   "\<lbrace>invs_no_cicd'\<rbrace> Arch.switchToThread t \<lbrace>\<lambda>rv. invs_no_cicd'\<rbrace>"
   apply (simp add: X64_H.switchToThread_def)
diff --git a/proof/refine/X64/Syscall_R.thy b/proof/refine/X64/Syscall_R.thy
index 4db9157811..411a93b7d4 100644
--- a/proof/refine/X64/Syscall_R.thy
+++ b/proof/refine/X64/Syscall_R.thy
@@ -883,7 +883,6 @@ abbreviation (input) "all_invs_but_sch_extra \<equiv>
     valid_irq_handlers' s \<and>
     valid_irq_states' s \<and>
     irqs_masked' s \<and>
-    valid_ioports' s \<and>
     valid_machine_state' s \<and>
     cur_tcb' s \<and>
     untyped_ranges_zero' s \<and>
@@ -917,7 +916,6 @@ lemma threadSet_all_invs_but_sch_extra:
      irqs_masked_lift
      valid_irq_node_lift
      valid_irq_handlers_lift''
-     valid_ioports_lift''
      threadSet_ctes_ofT
      threadSet_not_inQ
      threadSet_tcbDomain_update_ct_idle_or_in_cur_domain'
diff --git a/proof/refine/X64/TcbAcc_R.thy b/proof/refine/X64/TcbAcc_R.thy
index 51850dfb45..4d57f179c1 100644
--- a/proof/refine/X64/TcbAcc_R.thy
+++ b/proof/refine/X64/TcbAcc_R.thy
@@ -1358,7 +1358,7 @@ lemma threadSet_invs_trivialT:
             threadSet_global_refsT
             irqs_masked_lift
             valid_irq_node_lift
-            valid_irq_handlers_lift'' valid_ioports_lift''
+            valid_irq_handlers_lift''
             threadSet_ctes_ofT
             threadSet_not_inQ
             threadSet_ct_idle_or_in_cur_domain'
@@ -5272,8 +5272,6 @@ lemma setBoundNotification_ksDomSchedule[wp]:
 crunch rescheduleRequired, setBoundNotification, setThreadState
   for ksDomScheduleIdx[wp]: "\<lambda>s. P (ksDomScheduleIdx s)"
   and gsUntypedZeroRanges[wp]: "\<lambda>s. P (gsUntypedZeroRanges s)"
-  and ioports'[wp]: valid_ioports'
-  (wp: valid_ioports_lift'')
 
 lemma sts_utr[wp]:
   "\<lbrace>untyped_ranges_zero'\<rbrace> setThreadState st t \<lbrace>\<lambda>_. untyped_ranges_zero'\<rbrace>"
diff --git a/proof/refine/X64/Tcb_R.thy b/proof/refine/X64/Tcb_R.thy
index 1417cb99ef..6169ba5fcf 100644
--- a/proof/refine/X64/Tcb_R.thy
+++ b/proof/refine/X64/Tcb_R.thy
@@ -681,10 +681,6 @@ lemma out_corresT:
 
 lemmas out_corres = out_corresT [OF _ all_tcbI, OF ball_tcb_cap_casesI ball_tcb_cte_casesI]
 
-crunch tcbSchedEnqueue
-  for ioports'[wp]: valid_ioports'
-  (wp: crunch_wps valid_ioports_lift'' simp: crunch_simps)
-
 lemma tcbSchedDequeue_sch_act_simple[wp]:
   "tcbSchedDequeue t \<lbrace>sch_act_simple\<rbrace>"
   by (wpsimp simp: sch_act_simple_def)
@@ -708,7 +704,6 @@ lemma threadSet_priority_invs':
             threadSet_idle'T
             valid_irq_node_lift
             valid_irq_handlers_lift''
-            valid_ioports_lift'
             threadSet_ctes_ofT
             threadSet_not_inQ
             threadSet_ct_idle_or_in_cur_domain'
@@ -911,17 +906,6 @@ lemma untyped_derived_eq_from_sameObjectAs:
 lemmas vspace_asid'_simps [simp] =
   vspace_asid'_def [split_simps capability.split arch_capability.split option.split prod.split]
 
-lemma badge_derived_safe_ioport_insert':
-  "\<lbrakk>valid_ioports' s; cteCaps_of s src_slot = Some c; badge_derived' new_cap c\<rbrakk>
-       \<Longrightarrow> safe_ioport_insert' new_cap capability.NullCap s"
-  apply (case_tac new_cap; clarsimp simp: isCap_simps)
-  apply (rename_tac ac, case_tac ac; clarsimp simp: isCap_simps)
-  apply (clarsimp simp: badge_derived'_def)
-  apply (clarsimp simp: safe_ioport_insert'_def valid_ioports'_def)
-  apply (rule conjI, clarsimp elim!: ranE simp: ioports_no_overlap'_def)
-   apply(force simp: ran_def cteCaps_of_def)
-  by (force simp: all_ioports_issued'_def ran_def cteCaps_of_def)
-
 lemma checked_insert_tcb_invs'[wp]:
   "\<lbrace>invs' and cte_wp_at' (\<lambda>cte. cteCap cte = NullCap) slot
          and valid_cap' new_cap
@@ -943,7 +927,6 @@ lemma checked_insert_tcb_invs'[wp]:
                         is_derived'_def untyped_derived_eq_from_sameObjectAs
                         ex_cte_cap_to'_cteCap)
   apply (erule sameObjectAsE)+
-  apply (clarsimp simp: badge_derived_safe_ioport_insert'[OF invs_valid_ioports'])
   apply (clarsimp simp: badge_derived'_def)
   apply (frule capBadgeNone_masters, simp)
   apply (rule conjI)
@@ -1090,7 +1073,7 @@ lemma threadSet_invs_trivialT2:
              threadSet_ifunsafe'T
              threadSet_global_refsT
              valid_irq_node_lift
-             valid_irq_handlers_lift'' valid_ioports_lift''
+             valid_irq_handlers_lift''
              threadSet_ctes_ofT
              threadSet_valid_dom_schedule'
              untyped_ranges_zero_lift
diff --git a/proof/refine/X64/Untyped_R.thy b/proof/refine/X64/Untyped_R.thy
index 37391c6c25..e9e314e61d 100644
--- a/proof/refine/X64/Untyped_R.thy
+++ b/proof/refine/X64/Untyped_R.thy
@@ -3717,7 +3717,7 @@ lemma updateFreeIndex_clear_invs':
        apply (simp add:updateCap_def)
        apply (wp setCTE_irq_handlers' getCTE_wp)
       apply (simp add:updateCap_def)
-      apply (wp irqs_masked_lift cur_tcb_lift ct_idle_or_in_cur_domain'_lift setCTE_ioports'
+      apply (wp irqs_masked_lift cur_tcb_lift ct_idle_or_in_cur_domain'_lift
                 hoare_vcg_disj_lift untyped_ranges_zero_lift getCTE_wp valid_bitmaps_lift
                | wp (once) hoare_use_eq[where f="gsUntypedZeroRanges"]
                | simp add: getSlotCap_def
@@ -5321,17 +5321,6 @@ lemma insertNewCap_valid_irq_handlers:
   apply auto
   done
 
-crunch updateNewFreeIndex
-  for ioports[wp]: "valid_ioports'"
-
-lemma insertNewCap_ioports':
-  "\<lbrace>valid_ioports' and safe_ioport_insert' cap NullCap\<rbrace>
-     insertNewCap parent slot cap
-   \<lbrace>\<lambda>rv. valid_ioports'\<rbrace>"
-  apply (simp add: insertNewCap_def)
-  apply (wpsimp wp: setCTE_ioports' getCTE_wp)
-  by (clarsimp simp: cte_wp_at_ctes_of)
-
 crunch insertNewCap
   for irq_states'[wp]: valid_irq_states'
   and irqs_masked' [wp]: irqs_masked'
@@ -5400,12 +5389,6 @@ lemma insertNewCap_urz[wp]:
     apply (auto simp add: cteCaps_of_def untypedZeroRange_def isCap_simps)
   done
 
-lemma safe_ioport_insert'_capRange:
-  "capRange cap \<noteq> {} \<Longrightarrow> safe_ioport_insert' cap cap' s"
-  apply (clarsimp simp: safe_ioport_insert'_def)
-  apply (case_tac cap; clarsimp)
-  by (rename_tac ac, case_tac ac; clarsimp simp: capRange_def)
-
 lemma insertNewCap_invs':
   "\<lbrace>invs' and ct_active'
           and valid_cap' cap
@@ -5424,13 +5407,13 @@ lemma insertNewCap_invs':
    apply (wp insertNewCap_valid_pspace' sch_act_wf_lift
              cur_tcb_lift tcb_in_cur_domain'_lift sym_heap_sched_pointers_lift
              insertNewCap_valid_global_refs' valid_bitmaps_lift
-             valid_arch_state_lift' insertNewCap_ioports'
+             valid_arch_state_lift'
              valid_irq_node_lift insertNewCap_valid_irq_handlers)
   apply (clarsimp simp: cte_wp_at_ctes_of)
   apply (frule ctes_of_valid[rotated, where p=parent, OF valid_pspace_valid_objs'])
    apply (fastforce simp: cte_wp_at_ctes_of)
   apply (auto simp: isCap_simps sameRegionAs_def3
-            intro!: capRange_subset_capBits safe_ioport_insert'_capRange
+            intro!: capRange_subset_capBits
               elim: valid_capAligned)
   done
 
diff --git a/proof/refine/X64/VSpace_R.thy b/proof/refine/X64/VSpace_R.thy
index 5c2dd59d12..d73bd1be77 100644
--- a/proof/refine/X64/VSpace_R.thy
+++ b/proof/refine/X64/VSpace_R.thy
@@ -1524,7 +1524,6 @@ crunch doMachineOp
   and irq_node'[wp]: "\<lambda>s. P (irq_node' s)"
   and gsMaxObjectSize[wp]: "\<lambda>s. P (gsMaxObjectSize s)"
   and ksInterruptState[wp]: "\<lambda>s. P (ksInterruptState s)"
-  and ioports'[wp]: valid_ioports'
 
 lemma setCurrentUserCR3_invs' [wp]:
   "\<lbrace>invs' and K (valid_cr3' c)\<rbrace> setCurrentUserCR3 c \<lbrace>\<lambda>rv. invs'\<rbrace>"
@@ -2102,7 +2101,7 @@ lemma storePDE_invs[wp]:
    apply (wp sch_act_wf_lift valid_global_refs_lift'
              irqs_masked_lift
              valid_arch_state_lift' valid_irq_node_lift
-             cur_tcb_lift valid_irq_handlers_lift'' valid_ioports_lift''
+             cur_tcb_lift valid_irq_handlers_lift''
              untyped_ranges_zero_lift valid_bitmaps_lift
            | simp add: cteCaps_of_def o_def)+
   apply clarsimp
@@ -2117,7 +2116,7 @@ lemma storePDPTE_invs[wp]:
    apply (wp sch_act_wf_lift valid_global_refs_lift'
              irqs_masked_lift
              valid_arch_state_lift' valid_irq_node_lift
-             cur_tcb_lift valid_irq_handlers_lift'' valid_ioports_lift''
+             cur_tcb_lift valid_irq_handlers_lift''
              untyped_ranges_zero_lift valid_bitmaps_lift
            | simp add: cteCaps_of_def o_def)+
   apply clarsimp
@@ -2132,7 +2131,7 @@ lemma storePML4E_invs[wp]:
    apply (wp sch_act_wf_lift valid_global_refs_lift'
              irqs_masked_lift
              valid_arch_state_lift' valid_irq_node_lift
-             cur_tcb_lift valid_irq_handlers_lift'' valid_ioports_lift''
+             cur_tcb_lift valid_irq_handlers_lift''
              untyped_ranges_zero_lift valid_bitmaps_lift
            | simp add: cteCaps_of_def o_def)+
   apply clarsimp
@@ -2282,7 +2281,7 @@ lemma storePTE_invs [wp]:
   apply (rule hoare_pre)
    apply (wp sch_act_wf_lift valid_global_refs_lift' irqs_masked_lift
              valid_arch_state_lift' valid_irq_node_lift
-             cur_tcb_lift valid_irq_handlers_lift'' valid_ioports_lift''
+             cur_tcb_lift valid_irq_handlers_lift''
              untyped_ranges_zero_lift valid_bitmaps_lift
            | simp add: cteCaps_of_def o_def)+
   apply clarsimp
@@ -2444,7 +2443,7 @@ lemma setASIDPool_invs [wp]:
   apply (rule hoare_pre)
    apply (wp sch_act_wf_lift valid_global_refs_lift' irqs_masked_lift
              valid_arch_state_lift' valid_irq_node_lift
-             cur_tcb_lift valid_irq_handlers_lift'' valid_ioports_lift''
+             cur_tcb_lift valid_irq_handlers_lift''
              untyped_ranges_zero_lift
              updateObject_default_inv valid_bitmaps_lift
            | simp add: cteCaps_of_def

From c9c4d494dfb96b698c45611b6b0d94cda6242844 Mon Sep 17 00:00:00 2001
From: Rafal Kolanski <rafal.kolanski@proofcraft.systems>
Date: Wed, 27 Nov 2024 23:18:52 +1100
Subject: [PATCH 21/31] x64 crefine: handle allIOPortsIssued_asrt

Signed-off-by: Rafal Kolanski <rafal.kolanski@proofcraft.systems>
---
 proof/crefine/X64/Arch_C.thy | 1 +
 1 file changed, 1 insertion(+)

diff --git a/proof/crefine/X64/Arch_C.thy b/proof/crefine/X64/Arch_C.thy
index ad07f5ffad..be0fd7ec18 100644
--- a/proof/crefine/X64/Arch_C.thy
+++ b/proof/crefine/X64/Arch_C.thy
@@ -4869,6 +4869,7 @@ lemma invokeX86PortControl_ccorres:
    apply (clarsimp cong: StateSpace.state.fold_congs globals.fold_congs)
    apply (rule ccorres_Guard_Seq)
    apply (clarsimp simp: liftE_def bind_assoc return_returnOk)
+   apply (rule ccorres_stateAssert)
    apply (ctac add: setIOPortMask_ccorres)
      apply csymbr
      apply (ctac(no_vcg) add: cteInsert_ccorres)

From 11653d6f7394922b6b5e0dcb69acd77eabf66fc6 Mon Sep 17 00:00:00 2001
From: Gerwin Klein <gerwin.klein@proofcraft.systems>
Date: Mon, 2 Dec 2024 18:46:00 +1100
Subject: [PATCH 22/31] lib/monads: use `experiment` for demo lemmas

Use the experiment context to discard demo lemmas from the theory in the
Monad session. Some of these demo lemmas confuse sledgehammer.

Signed-off-by: Gerwin Klein <gerwin.klein@proofcraft.systems>
---
 lib/Monads/wp/Datatype_Schematic.thy |  2 +-
 lib/Monads/wp/WPBang.thy             |  5 +++++
 lib/Monads/wp/WPFix.thy              | 11 +++++++++--
 lib/Monads/wp/WP_Pre.thy             |  5 +++++
 4 files changed, 20 insertions(+), 3 deletions(-)

diff --git a/lib/Monads/wp/Datatype_Schematic.thy b/lib/Monads/wp/Datatype_Schematic.thy
index 9701c97e0b..9396a7fb94 100644
--- a/lib/Monads/wp/Datatype_Schematic.thy
+++ b/lib/Monads/wp/Datatype_Schematic.thy
@@ -263,7 +263,7 @@ declare option.sel[datatype_schematic]
 declare list.sel(1,3)[datatype_schematic]
 declare sum.sel[datatype_schematic]
 
-locale datatype_schem_demo begin
+experiment begin
 
 lemma handles_nested_constructors:
   "\<exists>f. \<forall>y. f True (Some [x, (y, z)]) = y"
diff --git a/lib/Monads/wp/WPBang.thy b/lib/Monads/wp/WPBang.thy
index e7f21e2d3a..0d845cb3dd 100644
--- a/lib/Monads/wp/WPBang.thy
+++ b/lib/Monads/wp/WPBang.thy
@@ -53,6 +53,9 @@ method_setup wpe = \<open>WP_Safe.wpe_args\<close>
 
 text \<open>Testing.\<close>
 
+experiment
+begin
+
 lemma
   assumes x: "\<lbrace> P \<rbrace> f \<lbrace> \<lambda>rv. Q \<rbrace>"
        and y: "\<lbrace> P \<rbrace> f \<lbrace> \<lambda>rv. R \<rbrace>"
@@ -71,3 +74,5 @@ lemma
   done
 
 end
+
+end
diff --git a/lib/Monads/wp/WPFix.thy b/lib/Monads/wp/WPFix.thy
index 619d43a0b9..c008cbdd2e 100644
--- a/lib/Monads/wp/WPFix.thy
+++ b/lib/Monads/wp/WPFix.thy
@@ -217,6 +217,9 @@ end
 
 method_setup wpfix = \<open>WPFix.method\<close>
 
+experiment
+begin
+
 lemma demo1:
   "(\<exists>Ia Ib Ic Id Ra.
     (Ia (Suc 0) \<longrightarrow> Qa)
@@ -260,10 +263,14 @@ lemma demo2:
 \<comment> \<open>
   Shows how to use @{attribute datatype_schematic} rules as "accessors".
 \<close>
-lemma (in datatype_schem_demo) demo3:
+datatype foo = basic (a:nat) (b:int) | another nat
+
+lemma demo3:
   "\<exists>x. \<forall>a b. x (basic a b) = a"
   apply (rule exI, (rule allI)+)
-  apply (wpfix add: get_basic_0.simps) \<comment> \<open>Only exposes `a` to the schematic.\<close>
+  apply (wpfix add: foo.sel(1)) \<comment> \<open>Only exposes `a` to the schematic.\<close>
   by (rule refl)
 
 end
+
+end
diff --git a/lib/Monads/wp/WP_Pre.thy b/lib/Monads/wp/WP_Pre.thy
index 82879d7d68..836435343f 100644
--- a/lib/Monads/wp/WP_Pre.thy
+++ b/lib/Monads/wp/WP_Pre.thy
@@ -102,6 +102,9 @@ named_theorems wp_pre
 method wp_pre0 = pre_tac wp_pre
 method wp_pre = wp_pre0?
 
+experiment
+begin
+
 definition
   test_wp_pre :: "bool \<Rightarrow> bool \<Rightarrow> bool"
 where
@@ -121,3 +124,5 @@ lemma demo:
   done
 
 end
+
+end

From 8cfc7662ca66dffb820cedf0fff90c51b2868af5 Mon Sep 17 00:00:00 2001
From: Nick Spinale <nick@nickspinale.com>
Date: Mon, 4 Nov 2024 01:50:17 -0800
Subject: [PATCH 23/31] x64 crefine: proof update after change to C

decodeX86PortInvocation was modified to include some explicit variable
initialization to satisfy GCC.

Signed-off-by: Nick Spinale <nick@nickspinale.com>
---
 proof/crefine/X64/Arch_C.thy | 1 +
 1 file changed, 1 insertion(+)

diff --git a/proof/crefine/X64/Arch_C.thy b/proof/crefine/X64/Arch_C.thy
index be0fd7ec18..6097839389 100644
--- a/proof/crefine/X64/Arch_C.thy
+++ b/proof/crefine/X64/Arch_C.thy
@@ -5424,6 +5424,7 @@ proof -
     apply (clarsimp simp: isCap_simps decodeX64PortInvocation_def Let_def)
     apply (cinit' lift: invLabel_' length___unsigned_long_' slot_' current_extra_caps_' cap_' buffer_' call_')
      apply (clarsimp cong: StateSpace.state.fold_congs globals.fold_congs)
+     apply csymbr
      apply (rule ccorres_Cond_rhs) (* IN invocations *)
       apply (erule ccorres_disj_division)
        \<comment> \<open>In8\<close>

From 40a737f96ecc56e6c1d0847730e655114bc99e1b Mon Sep 17 00:00:00 2001
From: Rafal Kolanski <rafal.kolanski@proofcraft.systems>
Date: Wed, 13 Nov 2024 23:34:03 +1100
Subject: [PATCH 24/31] x64 ainvs: fold valid_ioports into valid_arch_state

Having valid_ioports as a part of non-arch predicates caused its leakage
into all other architectures, which do not have IO ports.
By folding valid_ioports into valid_arch_state, the latter becomes
a predicate affected by caps, causing changes in the generic interface
in order to avoid any mentions of IO ports in non-arch-specific proofs.

Signed-off-by: Rafal Kolanski <rafal.kolanski@proofcraft.systems>
---
 proof/invariant-abstract/CNodeInv_AI.thy      |  19 +-
 proof/invariant-abstract/CSpace_AI.thy        |  23 +-
 proof/invariant-abstract/Detype_AI.thy        |   7 -
 proof/invariant-abstract/Finalise_AI.thy      |   2 +-
 proof/invariant-abstract/InterruptAcc_AI.thy  |   1 -
 proof/invariant-abstract/Invariants_AI.thy    |  15 +-
 proof/invariant-abstract/IpcCancel_AI.thy     |  22 +-
 proof/invariant-abstract/Ipc_AI.thy           | 848 ++++++++----------
 proof/invariant-abstract/KHeap_AI.thy         |  23 +-
 proof/invariant-abstract/Retype_AI.thy        |   2 +-
 proof/invariant-abstract/TcbAcc_AI.thy        |  19 +-
 proof/invariant-abstract/Tcb_AI.thy           |   8 +-
 proof/invariant-abstract/Untyped_AI.thy       |  48 +-
 proof/invariant-abstract/X64/ArchAcc_AI.thy   |   2 +-
 proof/invariant-abstract/X64/ArchArch_AI.thy  |  14 +-
 proof/invariant-abstract/X64/ArchBits_AI.thy  |   4 +
 .../X64/ArchCNodeInv_AI.thy                   |  24 +-
 .../X64/ArchCSpaceInv_AI.thy                  |  28 +-
 .../invariant-abstract/X64/ArchCSpace_AI.thy  |  35 +-
 .../invariant-abstract/X64/ArchDetype_AI.thy  |  20 +-
 .../X64/ArchFinalise_AI.thy                   |   3 +-
 .../X64/ArchInvariants_AI.thy                 |  38 +-
 proof/invariant-abstract/X64/ArchIpc_AI.thy   | 149 ++-
 proof/invariant-abstract/X64/ArchKHeap_AI.thy |  50 +-
 .../X64/ArchKernelInit_AI.thy                 |  20 +-
 .../invariant-abstract/X64/ArchRetype_AI.thy  |  24 +-
 .../invariant-abstract/X64/ArchTcbAcc_AI.thy  |  17 +
 .../invariant-abstract/X64/ArchUntyped_AI.thy |  15 +-
 .../invariant-abstract/X64/ArchVSpace_AI.thy  |  17 +-
 29 files changed, 815 insertions(+), 682 deletions(-)

diff --git a/proof/invariant-abstract/CNodeInv_AI.thy b/proof/invariant-abstract/CNodeInv_AI.thy
index c41336582f..c794841f48 100644
--- a/proof/invariant-abstract/CNodeInv_AI.thy
+++ b/proof/invariant-abstract/CNodeInv_AI.thy
@@ -67,7 +67,6 @@ where
        (cte_wp_at ((=) cap) slot and is_final_cap' cap
             and K (is_zombie cap))"
 
-
 locale CNodeInv_AI =
   fixes state_ext_t :: "'state_ext::state_ext itself"
   assumes derive_cap_objrefs:
@@ -165,10 +164,10 @@ locale CNodeInv_AI =
       \<lbrace>cap_refs_in_kernel_window and cte_wp_at (weak_derived c) a and cte_wp_at (weak_derived c') b\<rbrace>
         cap_swap c a c' b
       \<lbrace>\<lambda>rv. cap_refs_in_kernel_window :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes cap_swap_ioports[wp]:
-  "\<lbrace>valid_ioports and cte_wp_at (weak_derived c) a and cte_wp_at (weak_derived c') b\<rbrace>
+  assumes cap_swap_valid_arch[wp]:
+  "\<lbrace>valid_arch_state and cte_wp_at (weak_derived c) a and cte_wp_at (weak_derived c') b\<rbrace>
      cap_swap c a c' b
-   \<lbrace>\<lambda>rv (s::'state_ext state). valid_ioports s\<rbrace>"
+   \<lbrace>\<lambda>rv (s::'state_ext state). valid_arch_state s\<rbrace>"
   assumes cap_swap_vms[wp]:
     "\<And>c a c' b.
       \<lbrace>valid_machine_state :: 'state_ext state \<Rightarrow> bool\<rbrace>
@@ -1915,6 +1914,11 @@ lemma cap_refs_respects_device_region_original_cap[wp]:
                 (s\<lparr>is_original_cap := ocp\<rparr>) = cap_refs_respects_device_region s"
   by (simp add:cap_refs_respects_device_region_def)
 
+lemma cap_swap_aobj_at:
+  "arch_obj_pred P' \<Longrightarrow>
+  \<lbrace>\<lambda>s. P (obj_at P' pd s)\<rbrace> cap_swap c a c' b \<lbrace>\<lambda>r s. P (obj_at P' pd s)\<rbrace>"
+  unfolding cap_swap_def set_cdt_def by (wpsimp wp: set_cap.aobj_at)
+
 context CNodeInv_AI begin
 lemma cap_swap_cap_refs_respects_device_region[wp]:
   "\<lbrace>cap_refs_respects_device_region and cte_wp_at (weak_derived c) a and cte_wp_at (weak_derived c') b\<rbrace>
@@ -1950,11 +1954,6 @@ lemma cap_swap_cap_refs_respects_device_region[wp]:
   apply fastforce
   done
 
-lemma cap_swap_aobj_at:
-  "arch_obj_pred P' \<Longrightarrow>
-  \<lbrace>\<lambda>s. P (obj_at P' pd s)\<rbrace> cap_swap c (a, b) c' (aa, ba) \<lbrace>\<lambda>r s. P (obj_at P' pd s)\<rbrace>"
-  unfolding cap_swap_def set_cdt_def by (wpsimp wp: set_cap.aobj_at)
-
 lemma cap_swap_invs[wp]:
   "\<And>c' a c b.
   \<lbrace>invs and ex_cte_cap_wp_to (appropriate_cte_cap c') a
@@ -1968,7 +1967,7 @@ lemma cap_swap_invs[wp]:
     K (a \<noteq> b \<and> \<not> is_master_reply_cap c \<and> \<not> is_master_reply_cap c')\<rbrace>
    cap_swap c a c' b \<lbrace>\<lambda>rv. invs :: 'state_ext state \<Rightarrow> bool\<rbrace>"
   unfolding invs_def valid_state_def valid_pspace_def
-  apply (wp cap_swap_replies cap_swap_reply_masters valid_arch_state_lift_aobj_at
+  apply (wp cap_swap_replies cap_swap_reply_masters
             cap_swap_typ_at valid_irq_node_typ cap_swap_aobj_at
          | simp
          | erule disjE
diff --git a/proof/invariant-abstract/CSpace_AI.thy b/proof/invariant-abstract/CSpace_AI.thy
index ce1073f672..28e7dd8431 100644
--- a/proof/invariant-abstract/CSpace_AI.thy
+++ b/proof/invariant-abstract/CSpace_AI.thy
@@ -3617,10 +3617,6 @@ lemma cap_insert_aobj_at:
   unfolding cap_insert_def update_cdt_def set_cdt_def set_untyped_cap_as_full_def
   by (wpsimp wp: set_cap.aobj_at get_cap_wp)
 
-lemma cap_insert_valid_arch [wp]:
-  "\<lbrace>valid_arch_state\<rbrace> cap_insert cap src dest \<lbrace>\<lambda>_. valid_arch_state\<rbrace>"
-  by (rule valid_arch_state_lift_aobj_at; wp cap_insert_aobj_at)
-
 
 crunch update_cdt
   for caps[wp]: "\<lambda>s. P (caps_of_state s)"
@@ -3745,11 +3741,11 @@ locale CSpace_AI_cap_insert =
             and cte_wp_at (\<lambda>c. cap_range cap \<subseteq> cap_range c) src\<rbrace>
         cap_insert cap src dest
       \<lbrace>\<lambda>rv. cap_refs_in_kernel_window :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes cap_insert_derived_ioports:
+  assumes cap_insert_derived_valid_arch_state:
     "\<And>src cap dest.
-      \<lbrace>valid_ioports and (\<lambda>s::'state_ext state. cte_wp_at (is_derived (cdt s) src cap) src s)\<rbrace>
+      \<lbrace>valid_arch_state and (\<lambda>s::'state_ext state. cte_wp_at (is_derived (cdt s) src cap) src s)\<rbrace>
         cap_insert cap src dest
-      \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
+      \<lbrace>\<lambda>rv. valid_arch_state\<rbrace>"
 
 lemma cap_is_device_free_index_update_simp[simp]:
   "is_untyped_cap c \<Longrightarrow> cap_is_device (max_free_index_update c) = cap_is_device c"
@@ -3902,7 +3898,7 @@ lemma cap_insert_invs[wp]:
   apply (simp add: invs_def valid_state_def)
   apply (rule hoare_pre)
    apply (wp cap_insert_valid_pspace cap_insert_ifunsafe cap_insert_idle
-             valid_irq_node_typ cap_insert_valid_arch_caps cap_insert_derived_ioports)
+             valid_irq_node_typ cap_insert_valid_arch_caps cap_insert_derived_valid_arch_state)
   apply (auto simp: cte_wp_at_caps_of_state is_derived_cap_is_device
                         is_derived_cap_range valid_pspace_def)
   done
@@ -4057,11 +4053,11 @@ locale CSpace_AI
         \<Longrightarrow> (is_physical cap \<and> cap_range cap \<noteq> {} \<and> cap_range cap \<subseteq> cap_range pcap)"
   assumes same_region_as_cap_class:
     "\<And>a b. same_region_as a b \<Longrightarrow> cap_class a = cap_class b"
-  assumes setup_reply_master_ioports[wp]:
+  assumes setup_reply_master_valid_arch[wp]:
     "\<And>t.
-      \<lbrace>valid_ioports\<rbrace>
-        setup_reply_master t
-      \<lbrace>\<lambda>rv. valid_ioports :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+      \<lbrace>valid_arch_state\<rbrace>
+      setup_reply_master t
+      \<lbrace>\<lambda>rv. valid_arch_state :: 'state_ext state \<Rightarrow> bool\<rbrace>"
 
 
 lemma lookup_cap_valid:
@@ -4381,8 +4377,7 @@ lemma setup_reply_master_globals[wp]:
 
 
 crunch setup_reply_master
-  for arch[wp]: "valid_arch_state"
-  and vspace_objs[wp]: "valid_vspace_objs"
+  for vspace_objs[wp]: "valid_vspace_objs"
   (simp: crunch_simps)
 
 lemma setup_reply_master_irq_handlers[wp]:
diff --git a/proof/invariant-abstract/Detype_AI.thy b/proof/invariant-abstract/Detype_AI.thy
index 2e54f67f22..9770e2f243 100644
--- a/proof/invariant-abstract/Detype_AI.thy
+++ b/proof/invariant-abstract/Detype_AI.thy
@@ -37,8 +37,6 @@ locale Detype_AI =
                 (\<lambda>m x. if \<exists>k. x = ptr + of_nat k \<and> k < n * word_size then 0 else m x))"
   assumes empty_fail_freeMemory:
     "empty_fail (freeMemory ptr bits)"
-  assumes valid_ioports_detype:
-    "valid_ioports (s::'a state) \<Longrightarrow> valid_ioports (detype (untyped_range cap) s)"
 
 lemma obj_at_detype[simp]:
   "obj_at P p (detype S s) = (p \<notin> S \<and> obj_at P p s)"
@@ -686,11 +684,6 @@ lemma valid_mdb_detype[detype_invs_lemmas]: "valid_mdb (detype (untyped_range ca
   apply (simp add: valid_arch_mdb_detype)
   done
 
-lemma valid_ioports_detype[detype_invs_lemmas]:
-  "valid_ioports (detype (untyped_range cap) s)"
-  apply (insert invs, drule invs_valid_ioports)
-  by (clarsimp simp: valid_ioports_detype)
-
 lemma untype_children_detype[detype_invs_lemmas]: "untyped_children_in_mdb (detype (untyped_range cap) s)"
   apply (insert child)
   apply (simp add: untyped_children_in_mdb_def)
diff --git a/proof/invariant-abstract/Finalise_AI.thy b/proof/invariant-abstract/Finalise_AI.thy
index 310653546c..2db2928bf3 100644
--- a/proof/invariant-abstract/Finalise_AI.thy
+++ b/proof/invariant-abstract/Finalise_AI.thy
@@ -631,7 +631,7 @@ lemma (in Finalise_AI_1) unbind_maybe_notification_invs:
   apply (simp add: unbind_maybe_notification_def invs_def valid_state_def valid_pspace_def)
   apply (rule bind_wp [OF _ get_simple_ko_sp])
   apply (rule hoare_pre)
-   apply (wpsimp wp: valid_irq_node_typ set_simple_ko_valid_objs valid_ioports_lift)
+   apply (wpsimp wp: valid_irq_node_typ set_simple_ko_valid_objs)
   apply simp
   apply safe
   defer 3 defer 6
diff --git a/proof/invariant-abstract/InterruptAcc_AI.thy b/proof/invariant-abstract/InterruptAcc_AI.thy
index da968d292b..7a2b4cb6df 100644
--- a/proof/invariant-abstract/InterruptAcc_AI.thy
+++ b/proof/invariant-abstract/InterruptAcc_AI.thy
@@ -51,7 +51,6 @@ definition all_invs_but_valid_irq_states_for where
   equal_kernel_mappings and
   valid_asid_map and
   valid_global_objs and
-  valid_ioports and
   valid_global_vspace_mappings and
   pspace_in_kernel_window and
   cap_refs_in_kernel_window and
diff --git a/proof/invariant-abstract/Invariants_AI.thy b/proof/invariant-abstract/Invariants_AI.thy
index 005db58cf7..ea79aab60d 100644
--- a/proof/invariant-abstract/Invariants_AI.thy
+++ b/proof/invariant-abstract/Invariants_AI.thy
@@ -47,7 +47,6 @@ arch_requalify_consts
   valid_vspace_objs
   valid_arch_caps
   valid_global_objs
-  valid_ioports
   valid_kernel_mappings
   equal_kernel_mappings
   valid_global_vspace_mappings
@@ -75,7 +74,6 @@ arch_requalify_facts
   valid_vspace_obj_typ
   arch_kobj_size_bounded
   global_refs_lift
-  valid_arch_state_lift
   aobj_at_default_arch_cap_valid
   aobj_ref_default
   wf_acap_rights_update_id
@@ -1005,7 +1003,6 @@ where
                   and valid_irq_node
                   and valid_irq_handlers
                   and valid_irq_states
-                  and valid_ioports
                   and valid_machine_state
                   and valid_vspace_objs
                   and valid_arch_caps
@@ -1086,8 +1083,7 @@ abbreviation(input)
        and valid_arch_state and valid_machine_state and valid_irq_states
        and valid_irq_node and valid_irq_handlers and valid_vspace_objs
        and valid_arch_caps and valid_global_objs and valid_kernel_mappings
-       and equal_kernel_mappings and valid_asid_map and valid_ioports
-       and valid_global_vspace_mappings
+       and equal_kernel_mappings and valid_asid_map and valid_global_vspace_mappings
        and pspace_in_kernel_window and cap_refs_in_kernel_window
        and pspace_respects_device_region and cap_refs_respects_device_region
        and cur_tcb"
@@ -2675,10 +2671,6 @@ lemma cap_refs_in_kernel_window_update [iff]:
   "cap_refs_in_kernel_window (f s) = cap_refs_in_kernel_window s"
   by (simp add: cap_refs_in_kernel_window_def arch pspace)
 
-lemma valid_ioports_update[iff]:
-  "valid_ioports (f s) = valid_ioports s"
-  by (simp add: valid_ioports_def arch)
-
 end
 
 
@@ -3351,10 +3343,6 @@ lemma invs_valid_asid_map[elim!]:
   "invs s \<Longrightarrow> valid_asid_map s"
   by (simp add: invs_def valid_state_def)
 
-lemma invs_valid_ioports[elim!]:
-  "invs s \<Longrightarrow> valid_ioports s"
-  by (simp add: invs_def valid_state_def)
-
 lemma invs_equal_kernel_mappings[elim!]:
   "invs s \<Longrightarrow> equal_kernel_mappings s"
   by (simp add:invs_def valid_state_def)
@@ -3473,7 +3461,6 @@ lemmas invs_implies =
   invs_arch_state
   invs_valid_asid_map
   invs_valid_global_objs
-  invs_valid_ioports
   invs_vspace_objs
   invs_psp_aligned
   invs_distinct
diff --git a/proof/invariant-abstract/IpcCancel_AI.thy b/proof/invariant-abstract/IpcCancel_AI.thy
index 30c49f0710..e7fc1db6b6 100644
--- a/proof/invariant-abstract/IpcCancel_AI.thy
+++ b/proof/invariant-abstract/IpcCancel_AI.thy
@@ -356,7 +356,7 @@ lemma blocked_cancel_ipc_invs:
    apply (simp add: valid_tcb_state_def)
    apply (strengthen reply_cap_doesnt_exist_strg)
    apply simp
-   apply (wp valid_irq_node_typ valid_ioports_lift)
+   apply (wp valid_irq_node_typ)
   apply (subgoal_tac "ep \<noteq> Structures_A.IdleEP")
    apply (clarsimp simp: ep_redux_simps2 cong: if_cong)
    apply (frule(1) if_live_then_nonz_capD, (clarsimp simp: live_def)+)
@@ -365,10 +365,10 @@ lemma blocked_cancel_ipc_invs:
    apply (frule st_tcb_at_state_refs_ofD)
    apply (subgoal_tac "epptr \<notin> set (remove1 t queue)")
     apply (case_tac ep, simp_all add: valid_ep_def)[1]
-     apply (auto elim!: delta_sym_refs pred_tcb_weaken_strongerE
-                 simp: obj_at_def is_ep_def2 idle_not_queued refs_in_tcb_bound_refs
-                 dest: idle_no_refs
-                 split: if_split_asm)[2]
+     apply (timeit \<open>auto elim!: delta_sym_refs pred_tcb_weaken_strongerE
+                         simp: obj_at_def is_ep_def2 idle_not_queued refs_in_tcb_bound_refs
+                         dest: idle_no_refs
+                         split: if_split_asm\<close>)[2] (* slow: ~100s *)
    apply (case_tac ep, simp_all add: valid_ep_def)[1]
     apply (clarsimp, drule(1) bspec, clarsimp simp: obj_at_def is_tcb_def)+
   apply fastforce
@@ -387,7 +387,7 @@ lemma cancel_signal_invs:
   apply (rule bind_wp [OF _ get_simple_ko_sp])
   apply (case_tac "ntfn_obj ntfna", simp_all)[1]
   apply (rule hoare_pre)
-   apply (wp set_simple_ko_valid_objs valid_irq_node_typ sts_only_idle valid_ioports_lift
+   apply (wp set_simple_ko_valid_objs valid_irq_node_typ sts_only_idle
            | simp add: valid_tcb_state_def
            | strengthen reply_cap_doesnt_exist_strg
            | wpc)+
@@ -878,7 +878,7 @@ lemma cancel_all_ipc_invs_helper:
    apply wp
    apply simp
   apply (rule hoare_pre)
-   apply (wp cancel_all_invs_helper hoare_vcg_const_Ball_lift valid_irq_node_typ valid_ioports_lift)
+   apply (wp cancel_all_invs_helper hoare_vcg_const_Ball_lift valid_irq_node_typ)
   apply (clarsimp simp: invs_def valid_state_def valid_pspace_def valid_ep_def live_def)
   apply (rule conjI)
    apply (fastforce simp: live_def is_ep_def elim!: obj_at_weakenE split: kernel_object.splits)
@@ -979,7 +979,7 @@ lemma unbind_notification_invs:
   apply (case_tac ntfnptr, clarsimp, wp, simp)
   apply clarsimp
   apply (rule bind_wp [OF _ get_simple_ko_sp])
-  apply (wp valid_irq_node_typ set_simple_ko_valid_objs valid_ioports_lift
+  apply (wp valid_irq_node_typ set_simple_ko_valid_objs
          | clarsimp split del: if_split)+
   apply (intro conjI impI;
     (match conclusion in "sym_refs r" for r \<Rightarrow> \<open>-\<close>
@@ -1036,7 +1036,7 @@ lemma cancel_all_signals_invs:
   apply (rule bind_wp [OF _ get_simple_ko_sp])
   apply (rule hoare_pre)
    apply (wp cancel_all_invs_helper set_simple_ko_valid_objs valid_irq_node_typ
-             hoare_vcg_const_Ball_lift valid_ioports_lift
+             hoare_vcg_const_Ball_lift
         | wpc
         | simp add: live_def)+
   apply (clarsimp simp: invs_def valid_state_def valid_pspace_def)
@@ -1199,13 +1199,13 @@ lemma cancel_badged_sends_invs[wp]:
   apply (case_tac ep; simp)
     apply wpsimp
    apply (simp add: invs_def valid_state_def valid_pspace_def)
-   apply (wpsimp wp: valid_irq_node_typ valid_ioports_lift)
+   apply (wpsimp wp: valid_irq_node_typ)
      apply (simp add: fun_upd_def[symmetric] ep_redux_simps ep_at_def2[symmetric, simplified]
                 cong: list.case_cong)
      apply (rule hoare_strengthen_post,
             rule cancel_badged_sends_filterM_helper[where epptr=epptr])
      apply (auto intro:obj_at_weakenE)[1]
-    apply (wpsimp wp: valid_irq_node_typ set_endpoint_ep_at valid_ioports_lift)
+    apply (wpsimp wp: valid_irq_node_typ set_endpoint_ep_at)
    apply (clarsimp simp: valid_ep_def conj_comms)
    apply (subst obj_at_weakenE, simp, fastforce)
     apply (clarsimp simp: is_ep_def)
diff --git a/proof/invariant-abstract/Ipc_AI.thy b/proof/invariant-abstract/Ipc_AI.thy
index 1db26a08b9..be488de1f4 100644
--- a/proof/invariant-abstract/Ipc_AI.thy
+++ b/proof/invariant-abstract/Ipc_AI.thy
@@ -14,13 +14,6 @@ arch_requalify_consts
   in_device_frame
 
 arch_requalify_facts
-  setup_caller_cap_ioports
-  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
   lookup_ipc_buffer_inv
@@ -31,7 +24,6 @@ arch_requalify_facts
 declare lookup_ipc_buffer_inv[wp]
 declare set_mi_invs[wp]
 declare as_user_hyp_refs_of[wp]
-declare setup_caller_cap_ioports[wp]
 
 declare if_cong[cong del]
 
@@ -154,211 +146,6 @@ lemma update_cap_data_closedform:
                         the_cnode_cap_def fst_conv snd_conv fun_app_def the_arch_cap_def
                   cong: if_cong)
 
-definition
-  "valid_message_info mi \<equiv>
-     mi_length mi \<le> of_nat msg_max_length \<and>
-     mi_extra_caps mi \<le> of_nat msg_max_extra_caps"
-
-(* FIXME: can some of these assumptions be proved with lifting lemmas? *)
-locale Ipc_AI =
-  fixes state_ext_t :: "'state_ext::state_ext itself"
-  fixes some_t :: "'t itself"
-  assumes derive_cap_is_derived:
-    "\<And>c' slot.
-      \<lbrace>\<lambda>s::'state_ext state. c'\<noteq> cap.NullCap \<longrightarrow>
-            cte_wp_at (\<lambda>cap. cap_master_cap cap = cap_master_cap c'
-                           \<and> (cap_badge cap, cap_badge c') \<in> capBadge_ordering False
-                           \<and> cap_asid cap = cap_asid c'
-                           \<and> vs_cap_ref cap = vs_cap_ref c') slot s
-                           \<and> valid_objs s\<rbrace>
-        derive_cap slot c'
-      \<lbrace>\<lambda>rv s. rv \<noteq> cap.NullCap \<longrightarrow> cte_wp_at (is_derived (cdt s) slot rv) slot s\<rbrace>, -"
-  assumes is_derived_cap_rights [simp]:
-    "\<And>m p R c. is_derived m p (cap_rights_update R c) = is_derived m p c"
-  assumes data_to_message_info_valid:
-    "\<And>w. valid_message_info (data_to_message_info w)"
-  assumes get_extra_cptrs_length[wp]:
-    "\<And>mi buf.
-      \<lbrace>\<lambda>s::'state_ext state. valid_message_info mi\<rbrace>
-         get_extra_cptrs buf mi
-      \<lbrace>\<lambda>rv s. length rv \<le> msg_max_extra_caps\<rbrace>"
-  assumes cap_asid_rights_update [simp]:
-    "\<And>R c. cap_asid (cap_rights_update R c) = cap_asid c"
-  assumes cap_rights_update_vs_cap_ref[simp]:
-    "\<And>rs cap. vs_cap_ref (cap_rights_update rs cap) = vs_cap_ref cap"
-  assumes is_derived_cap_rights2[simp]:
-    "\<And>m p c R c'. is_derived m p c (cap_rights_update R c') = is_derived m p c c'"
-  assumes cap_range_update [simp]:
-    "\<And>R cap. cap_range (cap_rights_update R cap) = cap_range cap"
-  assumes derive_cap_idle[wp]:
-    "\<And>cap slot.
-      \<lbrace>\<lambda>s::'state_ext state. global_refs s \<inter> cap_range cap = {}\<rbrace>
-        derive_cap slot cap
-      \<lbrace>\<lambda>c s. global_refs s \<inter> cap_range c = {}\<rbrace>, -"
-  assumes arch_derive_cap_objrefs_iszombie:
-    "\<And>P cap.
-      \<lbrace>\<lambda>s::'state_ext state. P (set_option (aobj_ref cap)) False s\<rbrace>
-        arch_derive_cap cap
-      \<lbrace>\<lambda>rv s. rv \<noteq> NullCap \<longrightarrow> P (obj_refs rv) (is_zombie rv) s\<rbrace>,-"
-  assumes obj_refs_remove_rights[simp]:
-    "\<And>rs cap. obj_refs (remove_rights rs cap) = obj_refs cap"
-  assumes store_word_offs_vms[wp]:
-    "\<And>ptr offs v.
-      \<lbrace>valid_machine_state :: 'state_ext state \<Rightarrow> bool\<rbrace>
-        store_word_offs ptr offs v
-      \<lbrace>\<lambda>_. valid_machine_state\<rbrace>"
-  assumes is_zombie_update_cap_data[simp]:
-    "\<And>P data cap. is_zombie (update_cap_data P data cap) = is_zombie cap"
-  assumes valid_msg_length_strengthen:
-    "\<And>mi. valid_message_info mi \<longrightarrow> unat (mi_length mi) \<le> msg_max_length"
-  assumes copy_mrs_in_user_frame[wp]:
-    "\<And>p t buf t' buf' n.
-      \<lbrace>in_user_frame p :: 'state_ext state \<Rightarrow> bool\<rbrace>
-        copy_mrs t buf t' buf' n
-      \<lbrace>\<lambda>rv. in_user_frame p\<rbrace>"
-  assumes make_arch_fault_msg_invs[wp]:
-    "\<And>ft t. make_arch_fault_msg ft t \<lbrace>invs :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_aligned[wp]:
-    "\<And>ft t. make_arch_fault_msg  ft t \<lbrace>pspace_aligned :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_distinct[wp]:
-    "\<And>ft t. make_arch_fault_msg  ft t \<lbrace>pspace_distinct :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_vmdb[wp]:
-    "\<And>ft t. make_arch_fault_msg  ft t \<lbrace>valid_mdb :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_ifunsafe[wp]:
-    "\<And>ft t. make_arch_fault_msg  ft t \<lbrace>if_unsafe_then_cap :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_iflive[wp]:
-    "\<And>ft t. make_arch_fault_msg  ft t \<lbrace>if_live_then_nonz_cap :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_state_refs_of[wp]:
-    "\<And>P ft t. make_arch_fault_msg ft t \<lbrace>\<lambda>s:: 'state_ext state. P (state_refs_of s)\<rbrace>"
-  assumes make_arch_fault_msg_ct[wp]:
-    "\<And>ft t.   make_arch_fault_msg ft t \<lbrace>cur_tcb :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_zombies[wp]:
-    "\<And>ft t.   make_arch_fault_msg ft t \<lbrace>zombies_final :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_it[wp]:
-    "\<And>P ft t. make_arch_fault_msg ft t \<lbrace>\<lambda>s :: 'state_ext state. P (idle_thread s)\<rbrace>"
-  assumes make_arch_fault_msg_valid_globals[wp]:
-    "\<And>ft t.   make_arch_fault_msg ft t \<lbrace>valid_global_refs :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_valid_reply[wp]:
-    "\<And> ft t. make_arch_fault_msg ft t\<lbrace>valid_reply_caps :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_reply_masters[wp]:
-    "\<And>ft t. make_arch_fault_msg ft t \<lbrace>valid_reply_masters :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_valid_idle[wp]:
-    "\<And>ft t. make_arch_fault_msg ft t \<lbrace>valid_idle :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_arch[wp]:
-    "\<And>P ft t. make_arch_fault_msg ft t \<lbrace>\<lambda>s::'state_ext state. P (arch_state s)\<rbrace>"
-  assumes make_arch_fault_msg_typ_at[wp]:
-    "\<And>P ft t T p. make_arch_fault_msg ft t \<lbrace>\<lambda>s::'state_ext state. P (typ_at T p s)\<rbrace>"
-  assumes make_arch_fault_msg_irq_node[wp]:
-    "\<And>P ft t. make_arch_fault_msg ft t \<lbrace>\<lambda>s::'state_ext state. P (interrupt_irq_node s)\<rbrace>"
-  assumes make_arch_fault_msg_obj_at[wp]:
-    "\<And> P P' pd ft t. make_arch_fault_msg ft t \<lbrace>\<lambda>s::'state_ext state. P (obj_at P' pd s)\<rbrace>"
-  assumes make_arch_fault_msg_irq_handlers[wp]:
-    "\<And>ft t. make_arch_fault_msg ft t \<lbrace>valid_irq_handlers :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_vspace_objs[wp]:
-    "\<And>ft t. make_arch_fault_msg ft t \<lbrace>valid_vspace_objs :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_arch_caps[wp]:
-    "\<And>ft t. make_arch_fault_msg ft t \<lbrace>valid_arch_caps :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_v_ker_map[wp]:
-    "\<And>ft t. make_arch_fault_msg ft t \<lbrace>valid_kernel_mappings :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_eq_ker_map[wp]:
-    "\<And>ft t. make_arch_fault_msg ft t \<lbrace>equal_kernel_mappings :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_asid_map [wp]:
-    "\<And>ft t. make_arch_fault_msg ft t \<lbrace>valid_asid_map :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_only_idle [wp]:
-    "\<And> ft t. make_arch_fault_msg ft t \<lbrace>only_idle :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_pspace_in_kernel_window[wp]:
-    "\<And> ft t. make_arch_fault_msg ft t \<lbrace>pspace_in_kernel_window :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_cap_refs_in_kernel_window[wp]:
-    "\<And> ft t. make_arch_fault_msg ft t \<lbrace>cap_refs_in_kernel_window :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_valid_objs[wp]:
-    "\<And> ft t. make_arch_fault_msg ft t \<lbrace>valid_objs :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_valid_global_objs[wp]:
-    "\<And> ft t. make_arch_fault_msg ft t \<lbrace>valid_global_objs :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_valid_global_vspace_mappings[wp]:
-    "\<And> ft t. make_arch_fault_msg ft t \<lbrace>valid_global_vspace_mappings :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_valid_ioc[wp]:
-    "\<And> ft t. make_arch_fault_msg ft t \<lbrace>valid_ioc :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_vms[wp]:
-    "\<And> ft t. make_arch_fault_msg ft t \<lbrace>valid_machine_state :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_st_tcb_at'[wp]:
-    "\<And> P p ft t . make_arch_fault_msg ft t \<lbrace>st_tcb_at P p :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_cap_to[wp]:
-    "\<And> ft t p. make_arch_fault_msg ft t \<lbrace>ex_nonz_cap_to p :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_valid_irq_states[wp]:
-    "\<And> ft t. make_arch_fault_msg ft t \<lbrace>valid_irq_states :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_cap_refs_respects_device_region[wp]:
-    "\<And> ft t. make_arch_fault_msg ft t \<lbrace>cap_refs_respects_device_region :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes make_arch_fault_msg_pred_tcb[wp]:
-    "\<And> P (proj :: itcb \<Rightarrow> 't) ft t . make_arch_fault_msg ft t \<lbrace>pred_tcb_at proj P t :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  assumes do_fault_transfer_invs[wp]:
-    "\<And>receiver badge sender recv_buf.
-      \<lbrace>invs and tcb_at receiver :: 'state_ext state \<Rightarrow> bool\<rbrace>
-        do_fault_transfer badge sender receiver recv_buf
-      \<lbrace>\<lambda>rv. invs\<rbrace>"
-  assumes lookup_ipc_buffer_in_user_frame[wp]:
-    "\<And>t b.
-      \<lbrace>valid_objs and tcb_at t :: 'state_ext state \<Rightarrow> bool\<rbrace>
-        lookup_ipc_buffer b t
-      \<lbrace>case_option (\<lambda>_. True) in_user_frame\<rbrace>"
-  assumes do_normal_transfer_non_null_cte_wp_at:
-    "\<And>P ptr st send_buffer ep b gr rt recv_buffer.
-      (\<And>c. P c \<Longrightarrow> \<not> is_untyped_cap c) \<Longrightarrow>
-        \<lbrace>valid_objs and cte_wp_at (P and ((\<noteq>) cap.NullCap)) ptr :: 'state_ext state \<Rightarrow> bool\<rbrace>
-          do_normal_transfer st send_buffer ep b gr rt recv_buffer
-        \<lbrace>\<lambda>_. cte_wp_at (P and ((\<noteq>) cap.NullCap)) ptr\<rbrace>"
-  assumes is_derived_ReplyCap [simp]:
-    "\<And>m p t R. is_derived m p (cap.ReplyCap t False R) = (\<lambda>c. is_master_reply_cap c \<and> obj_ref_of c = t)"
-  assumes do_ipc_transfer_tcb_caps:
-    "\<And>P t ref st ep b gr rt.
-      (\<And>c. P c \<Longrightarrow> \<not> is_untyped_cap c) \<Longrightarrow>
-        \<lbrace>valid_objs and cte_wp_at P (t, ref) and tcb_at t :: 'state_ext state \<Rightarrow> bool\<rbrace>
-          do_ipc_transfer st ep b gr rt
-        \<lbrace>\<lambda>rv. cte_wp_at P (t, ref)\<rbrace>"
-  assumes setup_caller_cap_valid_global_objs[wp]:
-    "\<And>send recv grant.
-      \<lbrace>valid_global_objs :: 'state_ext state \<Rightarrow> bool\<rbrace>
-        setup_caller_cap send recv grant
-      \<lbrace>\<lambda>rv. valid_global_objs\<rbrace>"
-  assumes handle_arch_fault_reply_typ_at[wp]:
-    "\<And> P T p x4 t label msg.
-      \<lbrace>\<lambda>s::'state_ext state. P (typ_at T p s)\<rbrace>
-        handle_arch_fault_reply x4 t label msg
-      \<lbrace>\<lambda>rv s. P (typ_at T p s)\<rbrace>"
- assumes do_fault_transfer_cte_wp_at[wp]:
-  "\<And> P p x t label msg.
-      \<lbrace>cte_wp_at P p :: 'state_ext state \<Rightarrow> bool\<rbrace>
-        do_fault_transfer x t label msg
-      \<lbrace> \<lambda>rv. cte_wp_at P p \<rbrace>"
-  assumes transfer_caps_loop_valid_vspace_objs:
-  "\<And>ep buffer n caps slots mi.
-    \<lbrace>valid_vspace_objs::'state_ext state \<Rightarrow> bool\<rbrace>
-      transfer_caps_loop ep buffer n caps slots mi
-    \<lbrace>\<lambda>rv. valid_vspace_objs\<rbrace>"
-  assumes arch_get_sanitise_register_info_typ_at[wp]:
-  "\<And> P T p t.
-      \<lbrace>\<lambda>s::'state_ext state. P (typ_at T p s)\<rbrace>
-        arch_get_sanitise_register_info t
-      \<lbrace>\<lambda>rv s. P (typ_at T p s)\<rbrace>"
-
-
-
-context Ipc_AI begin
-
-lemma is_derived_mask [simp]:
-  "is_derived m p (mask_cap R c) = is_derived m p c"
-  by (simp add: mask_cap_def)
-
-lemma is_derived_remove_rights [simp]:
-  "is_derived m p (remove_rights R c) = is_derived m p c"
-  by (simp add: remove_rights_def)
-
-lemma get_mi_valid[wp]:
-  "\<lbrace>valid_mdb\<rbrace> get_message_info a \<lbrace>\<lambda>rv s. valid_message_info rv\<rbrace>"
-  apply (simp add: get_message_info_def)
-  apply (wp | simp add: data_to_message_info_valid)+
-  done
-
-end
 
 crunch get_extra_cptr
   for inv[wp]: P (wp: dmo_inv loadWord_inv)
@@ -399,24 +186,8 @@ lemma lsfco_cte_wp_at_univ:
   apply (clarsimp simp: cte_wp_at_def)
   done
 
-
-lemma bits_low_high_eq:
-  assumes low: "x && mask bits = y && mask bits"
-  and    high: "x >> bits = y >> bits"
-  shows        "x = y"
-  apply (rule word_eqI[rule_format])
-  apply (case_tac "n < bits")
-   apply (cut_tac x=n in word_eqD[OF low])
-   apply (simp add: word_size)
-  apply (cut_tac x="n - bits" in word_eqD[OF high])
-  apply (simp add: nth_shiftr)
-  done
-
-context Ipc_AI begin
-lemma mask_cap_vs_cap_ref[simp]:
-  "vs_cap_ref (mask_cap msk cap) = vs_cap_ref cap"
-  by (simp add: mask_cap_def)
-end
+(* FIXME rename other occurrences *)
+lemmas bits_low_high_eq = word_mask_shift_eqI
 
 lemma set_extra_badge_typ_at[wp]:
   "\<lbrace>\<lambda>s. P (typ_at T p s)\<rbrace> set_extra_badge buffer b n \<lbrace>\<lambda>_ s. P (typ_at T p s)\<rbrace>"
@@ -569,103 +340,344 @@ lemma valid_remove_rights_If[simp]:
 
 declare const_on_failure_wp [wp]
 
-crunch set_extra_badge
-  for ex_cte_cap_wp_to[wp]: "ex_cte_cap_wp_to P p"
-  (rule: ex_cte_cap_to_pres)
+crunch set_extra_badge
+  for ex_cte_cap_wp_to[wp]: "ex_cte_cap_wp_to P p"
+  (rule: ex_cte_cap_to_pres)
+
+lemma cap_insert_assume_null:
+  "\<lbrace>P\<rbrace> cap_insert cap src dest \<lbrace>Q\<rbrace> \<Longrightarrow>
+   \<lbrace>\<lambda>s. cte_wp_at ((=) cap.NullCap) dest s \<longrightarrow> P s\<rbrace> cap_insert cap src dest \<lbrace>Q\<rbrace>"
+  apply (rule hoare_name_pre_state)
+  apply (erule impCE)
+   apply (simp add: cap_insert_def)
+   apply (rule bind_wp[OF _ get_cap_sp])+
+   apply (clarsimp simp: valid_def cte_wp_at_caps_of_state in_monad
+              split del: if_split)
+  apply (erule hoare_weaken_pre)
+  apply simp
+  done
+
+crunch set_extra_badge
+  for arch[wp]: "\<lambda>s. P (arch_state s)"
+
+definition
+  "valid_message_info mi \<equiv>
+     mi_length mi \<le> of_nat msg_max_length \<and>
+     mi_extra_caps mi \<le> of_nat msg_max_extra_caps"
+
+abbreviation (input)
+  "transfer_caps_srcs caps s \<equiv>
+    (\<forall>x \<in> set caps. cte_wp_at (\<lambda>cp. fst x \<noteq> cap.NullCap \<longrightarrow> cp = fst x) (snd x) s
+                                           \<and> real_cte_at (snd x) s)"
+
+(* transfer_caps_loop_presM is needed to satisfy assumptions of Ipc_AI_2,
+   thus needs to come before Ipc_AI_2 *)
+locale Ipc_AI =
+  fixes state_ext_t :: "'state_ext::state_ext itself"
+  fixes some_t :: "'t itself"
+  assumes derive_cap_is_derived:
+    "\<And>c' slot.
+      \<lbrace>\<lambda>s::'state_ext state. c'\<noteq> cap.NullCap \<longrightarrow>
+            cte_wp_at (\<lambda>cap. cap_master_cap cap = cap_master_cap c'
+                           \<and> (cap_badge cap, cap_badge c') \<in> capBadge_ordering False
+                           \<and> cap_asid cap = cap_asid c'
+                           \<and> vs_cap_ref cap = vs_cap_ref c') slot s
+                           \<and> valid_objs s\<rbrace>
+        derive_cap slot c'
+      \<lbrace>\<lambda>rv s. rv \<noteq> cap.NullCap \<longrightarrow> cte_wp_at (is_derived (cdt s) slot rv) slot s\<rbrace>, -"
+
+context Ipc_AI begin
+
+lemma transfer_caps_loop_presM:
+  fixes P vo em ex buffer slots caps n mi
+  assumes x: "\<And>cap src dest.
+              \<lbrace>\<lambda>s::'state_ext state.
+                               P s \<and> (vo \<longrightarrow> valid_objs s \<and> valid_mdb s \<and> real_cte_at dest s \<and> s \<turnstile> cap \<and> tcb_cap_valid cap dest s
+                                   \<and> real_cte_at src s
+                                   \<and> cte_wp_at (is_derived (cdt s) src cap) src s \<and> cap \<noteq> cap.NullCap)
+                       \<and> (em \<longrightarrow> cte_wp_at ((=) cap.NullCap) dest s)
+                       \<and> (ex \<longrightarrow> ex_cte_cap_wp_to (appropriate_cte_cap cap) dest s)\<rbrace>
+                 cap_insert cap src dest \<lbrace>\<lambda>rv. P\<rbrace>"
+  assumes eb: "\<And>b n. \<lbrace>P\<rbrace> set_extra_badge buffer b n \<lbrace>\<lambda>_. P\<rbrace>"
+  shows      "\<lbrace>\<lambda>s. P s \<and> (vo \<longrightarrow> valid_objs s \<and> valid_mdb s \<and> distinct slots \<and>
+                                 (\<forall>x \<in> set slots.  cte_wp_at (\<lambda>cap. cap = cap.NullCap) x s \<and> real_cte_at x s) \<and>
+                                 (\<forall>x \<in> set caps. valid_cap (fst x) s \<and>
+                                  cte_wp_at (\<lambda>cp. fst x \<noteq> cap.NullCap \<longrightarrow> cp \<noteq> fst x \<longrightarrow> cp = masked_as_full (fst x) (fst x)) (snd x) s
+                                           \<and> real_cte_at (snd x) s))
+                       \<and> (ex \<longrightarrow> (\<forall>x \<in> set slots. ex_cte_cap_wp_to is_cnode_cap x s))\<rbrace>
+                  transfer_caps_loop ep buffer n caps slots mi
+              \<lbrace>\<lambda>rv. P\<rbrace>"
+  apply (induct caps arbitrary: slots n mi)
+   apply (simp, wp, simp)
+  apply (clarsimp simp add: Let_def split_def whenE_def
+                      cong: if_cong list.case_cong split del: if_split)
+  apply (rule hoare_pre)
+   apply (wp eb hoare_vcg_const_imp_lift hoare_vcg_const_Ball_lift hoare_weak_lift_imp
+           | assumption | simp split del: if_split)+
+      apply (rule cap_insert_assume_null)
+      apply (wp x hoare_vcg_const_Ball_lift cap_insert_cte_wp_at hoare_weak_lift_imp)+
+      apply (rule hoare_vcg_conj_liftE_R')
+       apply (rule derive_cap_is_derived_foo)
+      apply (rule_tac Q' ="\<lambda>cap' s. (vo \<longrightarrow> cap'\<noteq> cap.NullCap \<longrightarrow>
+          cte_wp_at (is_derived (cdt s) (aa, b) cap') (aa, b) s)
+          \<and> (cap'\<noteq> cap.NullCap \<longrightarrow> QM s cap')" for QM
+          in hoare_strengthen_postE_R)
+        prefer 2
+        apply clarsimp
+        apply assumption
+       apply (rule hoare_vcg_conj_liftE_R')
+         apply (rule hoare_vcg_const_imp_liftE_R)
+        apply (rule derive_cap_is_derived)
+      apply (wp derive_cap_is_derived_foo)+
+  apply (clarsimp simp: cte_wp_at_caps_of_state
+                        ex_cte_cap_to_cnode_always_appropriate_strg
+                        real_cte_tcb_valid caps_of_state_valid
+             split del: if_split)
+  apply (clarsimp simp: remove_rights_def caps_of_state_valid
+                        neq_Nil_conv cte_wp_at_caps_of_state
+                        imp_conjR[symmetric] conj_comms
+                 split del: if_split)
+  apply (intro conjI)
+   apply clarsimp
+   apply (case_tac "cap = a",clarsimp)
+   apply (clarsimp simp:masked_as_full_def is_cap_simps)
+   apply (clarsimp simp: cap_master_cap_simps split:if_splits)
+  apply (clarsimp split del: if_split)
+  apply (intro conjI)
+    apply (clarsimp split: if_split)
+   apply (clarsimp)
+  apply (rule ballI)
+  apply (drule(1) bspec)
+  apply clarsimp
+  apply (intro conjI)
+   apply (case_tac "capa = ac",clarsimp+)
+  apply (case_tac "capa = ac")
+   apply (clarsimp simp:masked_as_full_def is_cap_simps split:if_splits)+
+  done
+
+lemmas transfer_caps_loop_pres =
+    transfer_caps_loop_presM[where vo=False and ex=False and em=False, simplified]
+
+lemma transfer_caps_loop_arch[wp]:
+  "\<And>P ep buffer n caps slots mi.
+    \<lbrace>\<lambda>s::'state_ext state. P (arch_state s)\<rbrace>
+      transfer_caps_loop ep buffer n caps slots mi
+    \<lbrace>\<lambda>rv s. P (arch_state s)\<rbrace>"
+  by (rule transfer_caps_loop_pres) wp+
+
+lemma transfer_caps_loop_aobj_at:
+  "arch_obj_pred P' \<Longrightarrow>
+  \<lbrace>\<lambda>s. P (obj_at P' pd s)\<rbrace> transfer_caps_loop ep buffer n caps slots mi \<lbrace>\<lambda>r s::'state_ext state. P (obj_at P' pd s)\<rbrace>"
+  apply (rule hoare_pre)
+   apply (rule transfer_caps_loop_presM[where em=False and ex=False and vo=False, simplified, where P="\<lambda>s. P (obj_at P' pd s)"])
+    apply (wp cap_insert_aobj_at)
+   apply (wpsimp simp: set_extra_badge_def)
+  apply assumption
+  done
+
+end
+
+(* FIXME: can some of these assumptions be proved with lifting lemmas? *)
+locale Ipc_AI_2 = Ipc_AI state_ext_t some_t
+  for state_ext_t :: "'state_ext::state_ext itself"  and some_t :: "'t itself"+
+  assumes is_derived_cap_rights [simp]:
+    "\<And>m p R c. is_derived m p (cap_rights_update R c) = is_derived m p c"
+  assumes data_to_message_info_valid:
+    "\<And>w. valid_message_info (data_to_message_info w)"
+  assumes get_extra_cptrs_length[wp]:
+    "\<And>mi buf.
+      \<lbrace>\<lambda>s::'state_ext state. valid_message_info mi\<rbrace>
+         get_extra_cptrs buf mi
+      \<lbrace>\<lambda>rv s. length rv \<le> msg_max_extra_caps\<rbrace>"
+  assumes cap_asid_rights_update [simp]:
+    "\<And>R c. cap_asid (cap_rights_update R c) = cap_asid c"
+  assumes cap_rights_update_vs_cap_ref[simp]:
+    "\<And>rs cap. vs_cap_ref (cap_rights_update rs cap) = vs_cap_ref cap"
+  assumes is_derived_cap_rights2[simp]:
+    "\<And>m p c R c'. is_derived m p c (cap_rights_update R c') = is_derived m p c c'"
+  assumes cap_range_update [simp]:
+    "\<And>R cap. cap_range (cap_rights_update R cap) = cap_range cap"
+  assumes derive_cap_idle[wp]:
+    "\<And>cap slot.
+      \<lbrace>\<lambda>s::'state_ext state. global_refs s \<inter> cap_range cap = {}\<rbrace>
+        derive_cap slot cap
+      \<lbrace>\<lambda>c s. global_refs s \<inter> cap_range c = {}\<rbrace>, -"
+  assumes arch_derive_cap_objrefs_iszombie:
+    "\<And>P cap.
+      \<lbrace>\<lambda>s::'state_ext state. P (set_option (aobj_ref cap)) False s\<rbrace>
+        arch_derive_cap cap
+      \<lbrace>\<lambda>rv s. rv \<noteq> NullCap \<longrightarrow> P (obj_refs rv) (is_zombie rv) s\<rbrace>,-"
+  assumes obj_refs_remove_rights[simp]:
+    "\<And>rs cap. obj_refs (remove_rights rs cap) = obj_refs cap"
+  assumes store_word_offs_vms[wp]:
+    "\<And>ptr offs v.
+      \<lbrace>valid_machine_state :: 'state_ext state \<Rightarrow> bool\<rbrace>
+        store_word_offs ptr offs v
+      \<lbrace>\<lambda>_. valid_machine_state\<rbrace>"
+  assumes is_zombie_update_cap_data[simp]:
+    "\<And>P data cap. is_zombie (update_cap_data P data cap) = is_zombie cap"
+  assumes valid_msg_length_strengthen:
+    "\<And>mi. valid_message_info mi \<longrightarrow> unat (mi_length mi) \<le> msg_max_length"
+  assumes copy_mrs_in_user_frame[wp]:
+    "\<And>p t buf t' buf' n.
+      \<lbrace>in_user_frame p :: 'state_ext state \<Rightarrow> bool\<rbrace>
+        copy_mrs t buf t' buf' n
+      \<lbrace>\<lambda>rv. in_user_frame p\<rbrace>"
+  assumes make_arch_fault_msg_invs[wp]:
+    "\<And>ft t. make_arch_fault_msg ft t \<lbrace>invs :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_aligned[wp]:
+    "\<And>ft t. make_arch_fault_msg  ft t \<lbrace>pspace_aligned :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_distinct[wp]:
+    "\<And>ft t. make_arch_fault_msg  ft t \<lbrace>pspace_distinct :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_vmdb[wp]:
+    "\<And>ft t. make_arch_fault_msg  ft t \<lbrace>valid_mdb :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_ifunsafe[wp]:
+    "\<And>ft t. make_arch_fault_msg  ft t \<lbrace>if_unsafe_then_cap :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_iflive[wp]:
+    "\<And>ft t. make_arch_fault_msg  ft t \<lbrace>if_live_then_nonz_cap :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_state_refs_of[wp]:
+    "\<And>P ft t. make_arch_fault_msg ft t \<lbrace>\<lambda>s:: 'state_ext state. P (state_refs_of s)\<rbrace>"
+  assumes make_arch_fault_msg_ct[wp]:
+    "\<And>ft t.   make_arch_fault_msg ft t \<lbrace>cur_tcb :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_zombies[wp]:
+    "\<And>ft t.   make_arch_fault_msg ft t \<lbrace>zombies_final :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_it[wp]:
+    "\<And>P ft t. make_arch_fault_msg ft t \<lbrace>\<lambda>s :: 'state_ext state. P (idle_thread s)\<rbrace>"
+  assumes make_arch_fault_msg_valid_globals[wp]:
+    "\<And>ft t.   make_arch_fault_msg ft t \<lbrace>valid_global_refs :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_valid_reply[wp]:
+    "\<And> ft t. make_arch_fault_msg ft t\<lbrace>valid_reply_caps :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_reply_masters[wp]:
+    "\<And>ft t. make_arch_fault_msg ft t \<lbrace>valid_reply_masters :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_valid_idle[wp]:
+    "\<And>ft t. make_arch_fault_msg ft t \<lbrace>valid_idle :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_arch[wp]:
+    "\<And>P ft t. make_arch_fault_msg ft t \<lbrace>\<lambda>s::'state_ext state. P (arch_state s)\<rbrace>"
+  assumes make_arch_fault_msg_typ_at[wp]:
+    "\<And>P ft t T p. make_arch_fault_msg ft t \<lbrace>\<lambda>s::'state_ext state. P (typ_at T p s)\<rbrace>"
+  assumes make_arch_fault_msg_irq_node[wp]:
+    "\<And>P ft t. make_arch_fault_msg ft t \<lbrace>\<lambda>s::'state_ext state. P (interrupt_irq_node s)\<rbrace>"
+  assumes make_arch_fault_msg_obj_at[wp]:
+    "\<And> P P' pd ft t. make_arch_fault_msg ft t \<lbrace>\<lambda>s::'state_ext state. P (obj_at P' pd s)\<rbrace>"
+  assumes make_arch_fault_msg_irq_handlers[wp]:
+    "\<And>ft t. make_arch_fault_msg ft t \<lbrace>valid_irq_handlers :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_vspace_objs[wp]:
+    "\<And>ft t. make_arch_fault_msg ft t \<lbrace>valid_vspace_objs :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_arch_caps[wp]:
+    "\<And>ft t. make_arch_fault_msg ft t \<lbrace>valid_arch_caps :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_v_ker_map[wp]:
+    "\<And>ft t. make_arch_fault_msg ft t \<lbrace>valid_kernel_mappings :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_eq_ker_map[wp]:
+    "\<And>ft t. make_arch_fault_msg ft t \<lbrace>equal_kernel_mappings :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_asid_map [wp]:
+    "\<And>ft t. make_arch_fault_msg ft t \<lbrace>valid_asid_map :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_only_idle [wp]:
+    "\<And> ft t. make_arch_fault_msg ft t \<lbrace>only_idle :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_pspace_in_kernel_window[wp]:
+    "\<And> ft t. make_arch_fault_msg ft t \<lbrace>pspace_in_kernel_window :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_cap_refs_in_kernel_window[wp]:
+    "\<And> ft t. make_arch_fault_msg ft t \<lbrace>cap_refs_in_kernel_window :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_valid_objs[wp]:
+    "\<And> ft t. make_arch_fault_msg ft t \<lbrace>valid_objs :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_valid_global_objs[wp]:
+    "\<And> ft t. make_arch_fault_msg ft t \<lbrace>valid_global_objs :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_valid_global_vspace_mappings[wp]:
+    "\<And> ft t. make_arch_fault_msg ft t \<lbrace>valid_global_vspace_mappings :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_valid_ioc[wp]:
+    "\<And> ft t. make_arch_fault_msg ft t \<lbrace>valid_ioc :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_vms[wp]:
+    "\<And> ft t. make_arch_fault_msg ft t \<lbrace>valid_machine_state :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_st_tcb_at'[wp]:
+    "\<And> P p ft t . make_arch_fault_msg ft t \<lbrace>st_tcb_at P p :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_cap_to[wp]:
+    "\<And> ft t p. make_arch_fault_msg ft t \<lbrace>ex_nonz_cap_to p :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_valid_irq_states[wp]:
+    "\<And> ft t. make_arch_fault_msg ft t \<lbrace>valid_irq_states :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_cap_refs_respects_device_region[wp]:
+    "\<And> ft t. make_arch_fault_msg ft t \<lbrace>cap_refs_respects_device_region :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes make_arch_fault_msg_pred_tcb[wp]:
+    "\<And> P (proj :: itcb \<Rightarrow> 't) ft t . make_arch_fault_msg ft t \<lbrace>pred_tcb_at proj P t :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+  assumes do_fault_transfer_invs[wp]:
+    "\<And>receiver badge sender recv_buf.
+      \<lbrace>invs and tcb_at receiver :: 'state_ext state \<Rightarrow> bool\<rbrace>
+        do_fault_transfer badge sender receiver recv_buf
+      \<lbrace>\<lambda>rv. invs\<rbrace>"
+  assumes lookup_ipc_buffer_in_user_frame[wp]:
+    "\<And>t b.
+      \<lbrace>valid_objs and tcb_at t :: 'state_ext state \<Rightarrow> bool\<rbrace>
+        lookup_ipc_buffer b t
+      \<lbrace>case_option (\<lambda>_. True) in_user_frame\<rbrace>"
+  assumes do_normal_transfer_non_null_cte_wp_at:
+    "\<And>P ptr st send_buffer ep b gr rt recv_buffer.
+      (\<And>c. P c \<Longrightarrow> \<not> is_untyped_cap c) \<Longrightarrow>
+        \<lbrace>valid_objs and cte_wp_at (P and ((\<noteq>) cap.NullCap)) ptr :: 'state_ext state \<Rightarrow> bool\<rbrace>
+          do_normal_transfer st send_buffer ep b gr rt recv_buffer
+        \<lbrace>\<lambda>_. cte_wp_at (P and ((\<noteq>) cap.NullCap)) ptr\<rbrace>"
+  assumes is_derived_ReplyCap [simp]:
+    "\<And>m p t R. is_derived m p (cap.ReplyCap t False R) = (\<lambda>c. is_master_reply_cap c \<and> obj_ref_of c = t)"
+  assumes do_ipc_transfer_tcb_caps:
+    "\<And>P t ref st ep b gr rt.
+      (\<And>c. P c \<Longrightarrow> \<not> is_untyped_cap c) \<Longrightarrow>
+        \<lbrace>valid_objs and cte_wp_at P (t, ref) and tcb_at t :: 'state_ext state \<Rightarrow> bool\<rbrace>
+          do_ipc_transfer st ep b gr rt
+        \<lbrace>\<lambda>rv. cte_wp_at P (t, ref)\<rbrace>"
+  assumes setup_caller_cap_valid_global_objs[wp]:
+    "\<And>send recv grant.
+      \<lbrace>valid_global_objs :: 'state_ext state \<Rightarrow> bool\<rbrace>
+        setup_caller_cap send recv grant
+      \<lbrace>\<lambda>rv. valid_global_objs\<rbrace>"
+  assumes setup_caller_cap_valid_arch[wp]:
+    "\<And>send recv grant.
+      \<lbrace>valid_arch_state :: 'state_ext state \<Rightarrow> bool\<rbrace>
+        setup_caller_cap send recv grant
+      \<lbrace>\<lambda>rv. valid_arch_state\<rbrace>"
+  assumes handle_arch_fault_reply_typ_at[wp]:
+    "\<And> P T p x4 t label msg.
+      \<lbrace>\<lambda>s::'state_ext state. P (typ_at T p s)\<rbrace>
+        handle_arch_fault_reply x4 t label msg
+      \<lbrace>\<lambda>rv s. P (typ_at T p s)\<rbrace>"
+ assumes do_fault_transfer_cte_wp_at[wp]:
+  "\<And> P p x t label msg.
+      \<lbrace>cte_wp_at P p :: 'state_ext state \<Rightarrow> bool\<rbrace>
+        do_fault_transfer x t label msg
+      \<lbrace> \<lambda>rv. cte_wp_at P p \<rbrace>"
+  assumes transfer_caps_loop_valid_vspace_objs:
+  "\<And>ep buffer n caps slots mi.
+    \<lbrace>valid_vspace_objs::'state_ext state \<Rightarrow> bool\<rbrace>
+      transfer_caps_loop ep buffer n caps slots mi
+    \<lbrace>\<lambda>rv. valid_vspace_objs\<rbrace>"
+  assumes arch_get_sanitise_register_info_typ_at[wp]:
+  "\<And> P T p t.
+      \<lbrace>\<lambda>s::'state_ext state. P (typ_at T p s)\<rbrace>
+        arch_get_sanitise_register_info t
+      \<lbrace>\<lambda>rv s. P (typ_at T p s)\<rbrace>"
+  assumes transfer_caps_loop_valid_arch:
+  "\<And>slots caps ep buffer n mi.
+    \<lbrace>valid_arch_state and valid_objs and valid_mdb and K (distinct slots)
+     and (\<lambda>s. \<forall>x \<in> set slots. real_cte_at x s \<and> cte_wp_at (\<lambda>cap. cap = cap.NullCap) x s)
+     and transfer_caps_srcs caps\<rbrace>
+    transfer_caps_loop ep buffer n caps slots mi
+    \<lbrace>\<lambda>rv. valid_arch_state :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+
+context Ipc_AI_2 begin
 
-lemma cap_insert_assume_null:
-  "\<lbrace>P\<rbrace> cap_insert cap src dest \<lbrace>Q\<rbrace> \<Longrightarrow>
-   \<lbrace>\<lambda>s. cte_wp_at ((=) cap.NullCap) dest s \<longrightarrow> P s\<rbrace> cap_insert cap src dest \<lbrace>Q\<rbrace>"
-  apply (rule hoare_name_pre_state)
-  apply (erule impCE)
-   apply (simp add: cap_insert_def)
-   apply (rule bind_wp[OF _ get_cap_sp])+
-   apply (clarsimp simp: valid_def cte_wp_at_caps_of_state in_monad
-              split del: if_split)
-  apply (erule hoare_weaken_pre)
-  apply simp
-  done
+lemma is_derived_mask [simp]:
+  "is_derived m p (mask_cap R c) = is_derived m p c"
+  by (simp add: mask_cap_def)
 
-context Ipc_AI begin
+lemma is_derived_remove_rights [simp]:
+  "is_derived m p (remove_rights R c) = is_derived m p c"
+  by (simp add: remove_rights_def)
 
-lemma transfer_caps_loop_presM:
-  fixes P vo em ex buffer slots caps n mi
-  assumes x: "\<And>cap src dest.
-              \<lbrace>\<lambda>s::'state_ext state.
-                               P s \<and> (vo \<longrightarrow> valid_objs s \<and> valid_mdb s \<and> real_cte_at dest s \<and> s \<turnstile> cap \<and> tcb_cap_valid cap dest s
-                                   \<and> real_cte_at src s
-                                   \<and> cte_wp_at (is_derived (cdt s) src cap) src s \<and> cap \<noteq> cap.NullCap)
-                       \<and> (em \<longrightarrow> cte_wp_at ((=) cap.NullCap) dest s)
-                       \<and> (ex \<longrightarrow> ex_cte_cap_wp_to (appropriate_cte_cap cap) dest s)\<rbrace>
-                 cap_insert cap src dest \<lbrace>\<lambda>rv. P\<rbrace>"
-  assumes eb: "\<And>b n. \<lbrace>P\<rbrace> set_extra_badge buffer b n \<lbrace>\<lambda>_. P\<rbrace>"
-  shows      "\<lbrace>\<lambda>s. P s \<and> (vo \<longrightarrow> valid_objs s \<and> valid_mdb s \<and> distinct slots \<and>
-                                 (\<forall>x \<in> set slots.  cte_wp_at (\<lambda>cap. cap = cap.NullCap) x s \<and> real_cte_at x s) \<and>
-                                 (\<forall>x \<in> set caps. valid_cap (fst x) s \<and>
-                                  cte_wp_at (\<lambda>cp. fst x \<noteq> cap.NullCap \<longrightarrow> cp \<noteq> fst x \<longrightarrow> cp = masked_as_full (fst x) (fst x)) (snd x) s
-                                           \<and> real_cte_at (snd x) s))
-                       \<and> (ex \<longrightarrow> (\<forall>x \<in> set slots. ex_cte_cap_wp_to is_cnode_cap x s))\<rbrace>
-                  transfer_caps_loop ep buffer n caps slots mi
-              \<lbrace>\<lambda>rv. P\<rbrace>"
-  apply (induct caps arbitrary: slots n mi)
-   apply (simp, wp, simp)
-  apply (clarsimp simp add: Let_def split_def whenE_def
-                      cong: if_cong list.case_cong split del: if_split)
-  apply (rule hoare_pre)
-   apply (wp eb hoare_vcg_const_imp_lift hoare_vcg_const_Ball_lift hoare_weak_lift_imp
-           | assumption | simp split del: if_split)+
-      apply (rule cap_insert_assume_null)
-      apply (wp x hoare_vcg_const_Ball_lift cap_insert_cte_wp_at hoare_weak_lift_imp)+
-      apply (rule hoare_vcg_conj_liftE_R')
-       apply (rule derive_cap_is_derived_foo)
-      apply (rule_tac Q' ="\<lambda>cap' s. (vo \<longrightarrow> cap'\<noteq> cap.NullCap \<longrightarrow>
-          cte_wp_at (is_derived (cdt s) (aa, b) cap') (aa, b) s)
-          \<and> (cap'\<noteq> cap.NullCap \<longrightarrow> QM s cap')" for QM
-          in hoare_strengthen_postE_R)
-        prefer 2
-        apply clarsimp
-        apply assumption
-       apply (rule hoare_vcg_conj_liftE_R')
-         apply (rule hoare_vcg_const_imp_liftE_R)
-        apply (rule derive_cap_is_derived)
-      apply (wp derive_cap_is_derived_foo)+
-  apply (clarsimp simp: cte_wp_at_caps_of_state
-                        ex_cte_cap_to_cnode_always_appropriate_strg
-                        real_cte_tcb_valid caps_of_state_valid
-             split del: if_split)
-  apply (clarsimp simp: remove_rights_def caps_of_state_valid
-                        neq_Nil_conv cte_wp_at_caps_of_state
-                        imp_conjR[symmetric] conj_comms
-                 split del: if_split)
-  apply (intro conjI)
-   apply clarsimp
-   apply (case_tac "cap = a",clarsimp)
-   apply (clarsimp simp:masked_as_full_def is_cap_simps)
-   apply (clarsimp simp: cap_master_cap_simps split:if_splits)
-  apply (clarsimp split del: if_split)
-  apply (intro conjI)
-    apply (clarsimp split: if_split)
-   apply (clarsimp)
-  apply (rule ballI)
-  apply (drule(1) bspec)
-  apply clarsimp
-  apply (intro conjI)
-   apply (case_tac "capa = ac",clarsimp+)
-  apply (case_tac "capa = ac")
-   apply (clarsimp simp:masked_as_full_def is_cap_simps split:if_splits)+
+lemma get_mi_valid[wp]:
+  "\<lbrace>valid_mdb\<rbrace> get_message_info a \<lbrace>\<lambda>rv s. valid_message_info rv\<rbrace>"
+  apply (simp add: get_message_info_def)
+  apply (wp | simp add: data_to_message_info_valid)+
   done
 
-end
-
-abbreviation (input)
-  "transfer_caps_srcs caps s \<equiv>
-    (\<forall>x \<in> set caps. cte_wp_at (\<lambda>cp. fst x \<noteq> cap.NullCap \<longrightarrow> cp = fst x) (snd x) s
-                                           \<and> real_cte_at (snd x) s)"
-
-context Ipc_AI begin
-
-lemmas transfer_caps_loop_pres =
-    transfer_caps_loop_presM[where vo=False and ex=False and em=False, simplified]
+lemma mask_cap_vs_cap_ref[simp]:
+  "vs_cap_ref (mask_cap msk cap) = vs_cap_ref cap"
+  by (simp add: mask_cap_def)
 
 lemma transfer_caps_loop_typ_at[wp]:
    "\<And>P T p ep buffer n caps slots mi.
@@ -688,9 +700,7 @@ lemma transfer_loop_distinct[wp]:
     \<lbrace>\<lambda>rv. pspace_distinct\<rbrace>"
   by (wp transfer_caps_loop_pres)
 
-lemma invs_valid_objs2:
-  "\<And>s. invs s \<longrightarrow> valid_objs s"
-  by clarsimp
+lemmas invs_valid_objs2 = invs_vobjs_strgs
 
 lemma transfer_caps_loop_valid_objs[wp]:
   "\<And>slots caps ep buffer n mi.
@@ -793,21 +803,21 @@ lemma (in Ipc_AI) tcl_idle[wp]:
 crunch set_extra_badge
   for cur_tcb[wp]: cur_tcb
 
-lemma (in Ipc_AI) tcl_ct[wp]:
+lemma (in Ipc_AI_2) tcl_ct[wp]:
   "\<And>ep buffer n caps slots mi.
     \<lbrace>cur_tcb::'state_ext state \<Rightarrow> bool\<rbrace>
       transfer_caps_loop ep buffer n caps slots mi
     \<lbrace>\<lambda>rv. cur_tcb\<rbrace>"
   by (wp transfer_caps_loop_pres)
 
-lemma (in Ipc_AI) tcl_it[wp]:
+lemma (in Ipc_AI_2) tcl_it[wp]:
   "\<And>P ep buffer n caps slots mi.
     \<lbrace>\<lambda>s::'state_ext state. P (idle_thread s)\<rbrace>
       transfer_caps_loop ep buffer n caps slots mi
     \<lbrace>\<lambda>rv s. P (idle_thread s)\<rbrace>"
   by (wp transfer_caps_loop_pres)
 
-lemma (in Ipc_AI) derive_cap_objrefs_iszombie:
+lemma (in Ipc_AI_2) derive_cap_objrefs_iszombie:
   "\<And>cap P slot.
     \<lbrace>\<lambda>s::'state_ext state. \<not> is_zombie cap \<longrightarrow> P (obj_refs cap) False s\<rbrace>
       derive_cap slot cap
@@ -830,7 +840,7 @@ lemma set_extra_badge_zombies_final[wp]:
   apply (wp hoare_vcg_all_lift final_cap_lift)
   done
 
-lemma (in Ipc_AI) tcl_zombies[wp]:
+lemma (in Ipc_AI_2) tcl_zombies[wp]:
   "\<And>slots caps ep buffer n mi.
     \<lbrace>zombies_final and valid_objs and valid_mdb and K (distinct slots)
           and (\<lambda>s::'state_ext state. \<forall>slot \<in> set slots. real_cte_at slot s
@@ -864,13 +874,10 @@ lemma (in Ipc_AI) tcl_zombies[wp]:
 lemmas derive_cap_valid_globals [wp]
   = derive_cap_inv[where P=valid_global_refs and slot = r and c = cap for r cap]
 
-crunch set_extra_badge
-  for arch[wp]: "\<lambda>s. P (arch_state s)"
-
 crunch set_extra_badge
   for irq[wp]: "\<lambda>s. P (interrupt_irq_node s)"
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 
 lemma transfer_caps_loop_valid_globals [wp]:
   "\<And>slots caps ep buffer n mi.
@@ -894,31 +901,6 @@ lemma transfer_caps_loop_valid_globals [wp]:
   apply (clarsimp simp:cte_wp_at_caps_of_state)
   done
 
-lemma transfer_caps_loop_arch[wp]:
-  "\<And>P ep buffer n caps slots mi.
-    \<lbrace>\<lambda>s::'state_ext state. P (arch_state s)\<rbrace>
-      transfer_caps_loop ep buffer n caps slots mi
-    \<lbrace>\<lambda>rv s. P (arch_state s)\<rbrace>"
-  by (rule transfer_caps_loop_pres) wp+
-
-
-lemma transfer_caps_loop_aobj_at:
-  "arch_obj_pred P' \<Longrightarrow>
-  \<lbrace>\<lambda>s. P (obj_at P' pd s)\<rbrace> transfer_caps_loop ep buffer n caps slots mi \<lbrace>\<lambda>r s::'state_ext state. P (obj_at P' pd s)\<rbrace>"
-  apply (rule hoare_pre)
-   apply (rule transfer_caps_loop_presM[where em=False and ex=False and vo=False, simplified, where P="\<lambda>s. P (obj_at P' pd s)"])
-    apply (wp cap_insert_aobj_at)
-   apply (wpsimp simp: set_extra_badge_def)
-  apply assumption
-  done
-
-lemma transfer_caps_loop_valid_arch[wp]:
-  "\<And>ep buffer n caps slots mi.
-    \<lbrace>valid_arch_state::'state_ext state \<Rightarrow> bool\<rbrace>
-      transfer_caps_loop ep buffer n caps slots mi
-    \<lbrace>\<lambda>rv. valid_arch_state\<rbrace>"
-  by (rule valid_arch_state_lift_aobj_at; wp transfer_caps_loop_aobj_at)
-
 lemma tcl_reply':
   "\<And>slots caps ep buffer n mi.
     \<lbrace>valid_reply_caps and valid_reply_masters and valid_objs and valid_mdb and K(distinct slots)
@@ -995,26 +977,6 @@ lemma transfer_caps_loop_irq_handlers[wp]:
 crunch set_extra_badge
   for valid_arch_caps[wp]: valid_arch_caps
 
-lemma transfer_caps_loop_ioports[wp]:
-  "\<And>slots caps ep buffer n mi.
-    \<lbrace>valid_ioports and valid_objs and valid_mdb and K (distinct slots)
-         and (\<lambda>s. \<forall>x \<in> set slots. real_cte_at x s \<and> cte_wp_at (\<lambda>cap. cap = cap.NullCap) x s)
-         and transfer_caps_srcs caps\<rbrace>
-      transfer_caps_loop ep buffer n caps slots mi
-    \<lbrace>\<lambda>rv. valid_ioports :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  apply (rule hoare_pre)
-   apply (rule transfer_caps_loop_presM[where vo=True and em=False and ex=False])
-     apply (wp cap_insert_derived_ioports)
-     apply (clarsimp simp: cte_wp_at_caps_of_state)
-    apply (wp valid_ioports_lift)
-   apply (clarsimp simp:cte_wp_at_caps_of_state|intro conjI ballI)+
-   apply (drule(1) bspec,clarsimp)
-   apply (frule(1) caps_of_state_valid)
-   apply (fastforce simp:valid_cap_def)
-  apply (drule(1) bspec)
-  apply clarsimp
-  done
-
 lemma transfer_caps_loop_valid_arch_caps[wp]:
   "\<And>slots caps ep buffer n mi.
     \<lbrace>valid_arch_caps and valid_objs and valid_mdb and K(distinct slots)
@@ -1213,7 +1175,8 @@ lemma transfer_caps_loop_invs[wp]:
       transfer_caps_loop ep buffer n caps slots mi
     \<lbrace>\<lambda>rv. invs\<rbrace>"
   unfolding invs_def valid_state_def valid_pspace_def
-  by (wpsimp wp: valid_irq_node_typ transfer_caps_loop_valid_vspace_objs)
+  by (wpsimp wp: valid_irq_node_typ transfer_caps_loop_valid_vspace_objs
+                 transfer_caps_loop_valid_arch)
 
 end
 
@@ -1258,7 +1221,7 @@ lemma transfer_caps_mi_label[wp]:
   by (wpsimp simp: transfer_caps_def)
 
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 
 lemma transfer_cap_typ_at[wp]:
   "\<And>P T p mi caps ep receiver recv_buf.
@@ -1338,7 +1301,7 @@ lemma get_cap_zombies_helper:
   apply clarsimp
   done
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 
 lemma random_helper[simp]:
   "\<And>ct_send_data ct ms cap.
@@ -1558,7 +1521,7 @@ lemma mapME_length:
    apply (wp | simp | assumption)+
   done
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 
 crunch do_normal_transfer
   for typ_at[wp]: "\<lambda>s::'state_ext state. P (typ_at T p s)"
@@ -1636,7 +1599,7 @@ lemma set_mrs_valid_globals[wp]:
   by (wp set_mrs_thread_set_dmo thread_set_global_refs_triv
          ball_tcb_cap_casesI valid_global_refs_cte_lift | simp)+
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 
 crunch do_ipc_transfer
   for aligned[wp]: "pspace_aligned :: 'state_ext state \<Rightarrow> bool"
@@ -1703,7 +1666,7 @@ crunch copy_mrs
   for reply_masters[wp]: valid_reply_masters
   (wp: crunch_wps)
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 
 crunch do_ipc_transfer
   for reply[wp]: "valid_reply_caps :: 'state_ext state \<Rightarrow> bool"
@@ -1751,11 +1714,6 @@ lemma do_ipc_transfer_aobj_at:
           apply (wpsimp wp: as_user.aobj_at hoare_drop_imps)+
   done
 
-lemma do_ipc_transfer_valid_arch[wp]:
-  "\<lbrace>valid_arch_state\<rbrace>
-    do_ipc_transfer s ep bg grt r \<lbrace>\<lambda>rv. valid_arch_state :: 'state_ext state \<Rightarrow> bool\<rbrace>"
-  by (rule valid_arch_state_lift_aobj_at; wp do_ipc_transfer_aobj_at)
-
 end
 
 lemma set_mrs_irq_handlers[wp]:
@@ -1775,7 +1733,7 @@ lemma copy_mrs_irq_handlers[wp]:
   done
 
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 
 crunch do_ipc_transfer
   for irq_handlers[wp]: "valid_irq_handlers :: 'state_ext state \<Rightarrow> bool"
@@ -1798,11 +1756,6 @@ crunch do_ipc_transfer
   (wp: crunch_wps hoare_vcg_const_Ball_lift transfer_caps_loop_valid_arch_caps
    simp: zipWithM_x_mapM crunch_simps ball_conj_distrib )
 
-crunch do_ipc_transfer
-  for ioports[wp]: "valid_ioports :: 'state_ext state \<Rightarrow> bool"
-  (wp: crunch_wps hoare_vcg_const_Ball_lift transfer_caps_loop_ioports
-   simp: zipWithM_x_mapM crunch_simps ball_conj_distrib )
-
 crunch do_ipc_transfer
   for v_ker_map[wp]: "valid_kernel_mappings :: 'state_ext state \<Rightarrow> bool"
   (wp: crunch_wps simp: zipWithM_x_mapM crunch_simps)
@@ -1835,7 +1788,7 @@ lemma set_mrs_only_idle [wp]:
    apply (fastforce simp: obj_at_def)
   by (simp add: get_tcb_rev)
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 
 crunch do_ipc_transfer
   for only_idle[wp]: "only_idle :: 'state_ext state \<Rightarrow> bool"
@@ -1869,7 +1822,7 @@ lemmas set_mrs_cap_refs_respects_device_region[wp]
                                 VSpace_AI.cap_refs_respects_device_region_dmo[OF storeWord_device_state_inv],
                                 simplified tcb_cap_cases_def, simplified]
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 
 crunch do_ipc_transfer
   for cap_refs_in_kernel_window[wp]: "cap_refs_in_kernel_window :: 'state_ext state \<Rightarrow> bool"
@@ -1894,7 +1847,7 @@ lemma as_user_valid_ioc[wp]:
   apply (simp add: tcb_cap_cases_def split: if_split_asm)
   done
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 
 lemma set_mrs_valid_ioc[wp]:
   "\<And>thread buf msgs.
@@ -1943,7 +1896,7 @@ lemma set_mrs_def2:
    od"
   by (rule eq_reflection) (simp add: set_mrs_def thread_set_def bind_assoc)
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 
 lemma set_mrs_vms[wp]:
   notes if_split [split del]
@@ -1986,17 +1939,17 @@ lemma dit_cte_at [wp]:
 
 end
 
-lemma (in Ipc_AI) handle_fault_reply_typ_at[wp]:
+lemma (in Ipc_AI_2) handle_fault_reply_typ_at[wp]:
   "\<lbrace>\<lambda>s :: 'state_ext state. P (typ_at T p s)\<rbrace> handle_fault_reply ft t label msg \<lbrace>\<lambda>rv s. P (typ_at T p s)\<rbrace>"
   by(cases ft, simp_all, wp+)
 
-lemma (in Ipc_AI) handle_fault_reply_tcb[wp]:
+lemma (in Ipc_AI_2) handle_fault_reply_tcb[wp]:
   "\<lbrace>tcb_at t' :: 'state_ext state \<Rightarrow> bool\<rbrace>
      handle_fault_reply ft t label msg
    \<lbrace>\<lambda>rv. tcb_at t'\<rbrace>"
   by (simp add: tcb_at_typ, wp)
 
-lemma (in Ipc_AI) handle_fault_reply_cte[wp]:
+lemma (in Ipc_AI_2) handle_fault_reply_cte[wp]:
   "\<lbrace>cte_at t' :: 'state_ext state \<Rightarrow> bool\<rbrace> handle_fault_reply ft t label msg \<lbrace>\<lambda>rv. cte_at t'\<rbrace>"
   by (wp valid_cte_at_typ)
 
@@ -2010,7 +1963,7 @@ lemma valid_reply_caps_awaiting_reply:
 
 lemmas cap_insert_typ_ats [wp] = abs_typ_at_lifts [OF cap_insert_typ_at]
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 
 lemma do_ipc_transfer_non_null_cte_wp_at:
   fixes P ptr st ep b gr rt
@@ -2055,7 +2008,7 @@ lemma cte_wp_at_reply_cap_can_fast_finalise:
   "cte_wp_at ((=) (cap.ReplyCap tcb v R)) slot s \<longrightarrow> cte_wp_at can_fast_finalise slot s"
   by (clarsimp simp: cte_wp_at_caps_of_state can_fast_finalise_def)
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 
 crunch do_ipc_transfer
   for st_tcb_at[wp]: "st_tcb_at  P t :: 'state_ext state \<Rightarrow> bool"
@@ -2115,7 +2068,7 @@ lemma update_waiting_invs:
    apply (simp add: valid_tcb_state_def conj_comms)
    apply (simp add: cte_wp_at_caps_of_state)
    apply (wp set_simple_ko_valid_objs hoare_post_imp [OF disjI1]
-            valid_irq_node_typ valid_ioports_lift | assumption | simp |
+            valid_irq_node_typ | assumption | simp |
             strengthen reply_cap_doesnt_exist_strg)+
   apply (clarsimp simp: invs_def valid_state_def valid_pspace_def
                         ep_redux_simps neq_Nil_conv
@@ -2298,7 +2251,7 @@ lemma gts_eq_ts:
 
 declare lookup_cap_valid [wp]
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 
 crunch send_ipc
   for typ_at[wp]: "\<lambda>s::'state_ext state. P (typ_at T p s)"
@@ -2421,7 +2374,7 @@ lemma setup_caller_cap_objs[wp]:
   apply (clarsimp simp: valid_tcb_state_def st_tcb_def2)
   done
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 
 lemma setup_caller_cap_mdb[wp]:
   "\<And>sender.
@@ -2478,13 +2431,13 @@ lemma setup_caller_cap_ifunsafe[wp]:
   by (wpsimp wp: cap_insert_ifunsafe ex_cte_cap_to_pres
            simp: ex_nonz_tcb_cte_caps dom_tcb_cap_cases)
 
-lemmas (in Ipc_AI) transfer_caps_loop_cap_to[wp]
+lemmas (in Ipc_AI_2) transfer_caps_loop_cap_to[wp]
   = transfer_caps_loop_pres [OF cap_insert_ex_cap]
 
 crunch set_extra_badge
   for cap_to[wp]: "ex_nonz_cap_to p"
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 
 crunch do_ipc_transfer
   for cap_to[wp]: "ex_nonz_cap_to p :: 'state_ext state \<Rightarrow> bool"
@@ -2522,18 +2475,6 @@ crunch setup_caller_cap
 crunch set_thread_state
   for Pmdb[wp]: "\<lambda>s. P (cdt s)"
 
-
-lemma setup_caller_cap_valid_arch [wp]:
-  "\<lbrace>valid_arch_state\<rbrace> setup_caller_cap st rt grant \<lbrace>\<lambda>_. valid_arch_state\<rbrace>"
-  apply (rule valid_arch_state_lift_aobj_at; wp?)
-  unfolding setup_caller_cap_def cap_insert_def update_cdt_def set_cdt_def set_untyped_cap_as_full_def
-  apply simp
-  apply (intro conjI impI)
-   apply (wpsimp wp: set_cap.aobj_at get_cap_wp hoare_drop_imps sts.aobj_at)+
-  done
-
-
-
 lemma setup_caller_cap_reply[wp]:
   "\<lbrace>valid_reply_caps and pspace_aligned and
     st_tcb_at (Not \<circ> awaiting_reply) st and tcb_at rt\<rbrace>
@@ -2571,7 +2512,7 @@ lemma setup_caller_cap_irq_handlers[wp]:
   unfolding setup_caller_cap_def
   by (wpsimp simp: is_cap_simps tcb_at_cte_at dom_tcb_cap_cases)
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 
 lemma setup_caller_cap_valid_arch_caps[wp]:
   "\<lbrace>valid_arch_caps and valid_objs and st_tcb_at (Not o halted) sender\<rbrace>
@@ -2683,7 +2624,7 @@ lemma setup_caller_cap_refs_respects_device_region[wp]:
 
 
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 crunch do_ipc_transfer
   for valid_irq_states[wp]: "valid_irq_states :: 'state_ext state \<Rightarrow> bool"
   (wp: crunch_wps  simp: crunch_simps)
@@ -2707,7 +2648,7 @@ lemma invs_respects_device_region:
 
 end
 
-locale Ipc_AI_cont = Ipc_AI state_ext_t some_t
+locale Ipc_AI_3 = Ipc_AI_2 state_ext_t some_t
   for state_ext_t :: "'state_ext::state_ext itself"  and some_t :: "'t itself"+
   assumes do_ipc_transfer_pspace_respects_device_region[wp]:
     "\<And> t ep bg grt r.
@@ -2723,6 +2664,12 @@ locale Ipc_AI_cont = Ipc_AI state_ext_t some_t
    "\<lbrace>\<lambda>s::'state_ext state. P (state_hyp_refs_of s)\<rbrace>
      do_ipc_transfer t ep bg grt r
       \<lbrace>\<lambda>_ s::'state_ext state. P (state_hyp_refs_of s)\<rbrace>"
+  assumes do_ipc_transfer_valid_arch:
+    "\<And>ep bg grt r.
+      \<lbrace>valid_arch_state and valid_objs and valid_mdb \<rbrace>
+      do_ipc_transfer s ep bg grt r
+      \<lbrace>\<lambda>rv. valid_arch_state :: 'state_ext state \<Rightarrow> bool\<rbrace>"
+
 
 
 lemma complete_signal_invs:
@@ -2748,7 +2695,9 @@ crunch as_user
   for pspace_respects_device_region[wp]: "pspace_respects_device_region"
   (simp: crunch_simps wp: crunch_wps set_object_pspace_respects_device_region pspace_respects_device_region_dmo)
 
-context Ipc_AI_cont begin
+lemmas [wp] = as_user.valid_arch_state
+
+context Ipc_AI_3 begin
 lemma ri_invs':
   fixes Q t cap is_blocking
   notes if_split[split del]
@@ -2778,7 +2727,7 @@ lemma ri_invs':
    apply (case_tac rv)
      apply (wp | rule hoare_pre, wpc | simp)+
            apply (simp add: invs_def valid_state_def valid_pspace_def)
-           apply (rule hoare_pre, wp valid_irq_node_typ valid_ioports_lift)
+           apply (rule hoare_pre, wp valid_irq_node_typ)
            apply (simp add: valid_ep_def)
           apply (wp valid_irq_node_typ sts_only_idle sts_ep_at_inv[simplified ep_at_def2, simplified]
                     failed_transfer_Q[simplified do_nbrecv_failed_transfer_def, simplified]
@@ -2801,11 +2750,10 @@ lemma ri_invs':
                       simp: st_tcb_def2)
     apply (simp add: invs_def valid_state_def valid_pspace_def)
     apply (wp hoare_drop_imps valid_irq_node_typ hoare_post_imp[OF disjI1]
-              sts_only_idle
+              sts_only_idle do_ipc_transfer_valid_arch
          | simp add: valid_tcb_state_def cap_range_def
          | strengthen reply_cap_doesnt_exist_strg | wpc
-         | (wp hoare_vcg_conj_lift | wp dxo_wp_weak | simp)+
-         | wp valid_ioports_lift)+
+         | (wp hoare_vcg_conj_lift | wp dxo_wp_weak | simp)+)+
     apply (clarsimp simp: st_tcb_at_tcb_at neq_Nil_conv)
     apply (frule(1) sym_refs_obj_atD)
     apply (frule(1) hyp_sym_refs_obj_atD)
@@ -2841,7 +2789,7 @@ lemma ri_invs':
    apply (simp add: invs_def valid_state_def valid_pspace_def)
    apply (rule hoare_pre)
     apply (wp hoare_vcg_const_Ball_lift valid_irq_node_typ sts_only_idle
-              sts_ep_at_inv[simplified ep_at_def2, simplified] valid_ioports_lift
+              sts_ep_at_inv[simplified ep_at_def2, simplified]
               failed_transfer_Q[unfolded do_nbrecv_failed_transfer_def, simplified]
               | simp add: live_def valid_ep_def do_nbrecv_failed_transfer_def
               | wpc)+
@@ -2894,10 +2842,8 @@ crunch set_message_info
 
 lemma set_message_info_valid_arch [wp]:
   "\<lbrace>valid_arch_state\<rbrace> set_message_info a b \<lbrace>\<lambda>_. valid_arch_state\<rbrace>"
-  apply (rule valid_arch_state_lift_aobj_at; wp?)
   unfolding set_message_info_def
-  apply (wp as_user.aobj_at)
-  done
+  by wp
 
 crunch set_message_info
   for caps[wp]: "\<lambda>s. P (caps_of_state s)"
@@ -2946,7 +2892,7 @@ crunch set_thread_state, set_message_info, set_mrs, as_user
   for bound_tcb[wp]: "valid_bound_tcb t"
   (rule: valid_bound_tcb_typ_at)
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 
 lemma rai_invs':
   assumes set_notification_Q[wp]: "\<And>a b.\<lbrace> Q\<rbrace> set_notification a b \<lbrace>\<lambda>_.Q\<rbrace>"
@@ -2969,7 +2915,7 @@ lemma rai_invs':
   apply (case_tac "ntfn_obj rv")
     apply (simp add: invs_def valid_state_def valid_pspace_def)
     apply (rule hoare_pre)
-     apply (wp set_simple_ko_valid_objs valid_irq_node_typ sts_only_idle valid_ioports_lift
+     apply (wp set_simple_ko_valid_objs valid_irq_node_typ sts_only_idle
               sts_ntfn_at_inv[simplified ntfn_at_def2, simplified] | wpc
           | simp add: live_def valid_ntfn_def do_nbrecv_failed_transfer_def)+
     apply (clarsimp simp: valid_tcb_state_def st_tcb_at_tcb_at)
@@ -2994,7 +2940,7 @@ lemma rai_invs':
                     simp: st_tcb_at_reply_cap_valid st_tcb_def2)
    apply (simp add: invs_def valid_state_def valid_pspace_def)
    apply (rule hoare_pre)
-    apply (wpsimp wp: set_simple_ko_valid_objs hoare_vcg_const_Ball_lift sts_only_idle valid_ioports_lift
+    apply (wpsimp wp: set_simple_ko_valid_objs hoare_vcg_const_Ball_lift sts_only_idle
                       valid_irq_node_typ sts_ntfn_at_inv[simplified ntfn_at_def2, simplified]
                simp: live_def valid_ntfn_def do_nbrecv_failed_transfer_def)
    apply (clarsimp simp: valid_tcb_state_def st_tcb_at_tcb_at)
@@ -3022,7 +2968,7 @@ lemma rai_invs':
                   split: option.splits)
   apply (simp add: invs_def valid_state_def valid_pspace_def)
   apply (rule hoare_pre)
-   apply (wp set_simple_ko_valid_objs hoare_vcg_const_Ball_lift valid_ioports_lift
+   apply (wp set_simple_ko_valid_objs hoare_vcg_const_Ball_lift
              as_user_no_del_ntfn[simplified ntfn_at_def2, simplified]
              valid_irq_node_typ ball_tcb_cap_casesI hoare_weak_lift_imp
              valid_bound_tcb_typ_at[rule_format]
@@ -3068,7 +3014,7 @@ lemma clear_revokable [iff]:
   "pspace_clear t (is_original_cap_update f s) = is_original_cap_update f (pspace_clear t s)"
   by (simp add: pspace_clear_def)
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 crunch receive_ipc
   for cap_to[wp]: "ex_nonz_cap_to p :: 'state_ext state \<Rightarrow> bool"
   (wp: cap_insert_ex_cap hoare_drop_imps simp: crunch_simps)
@@ -3098,7 +3044,7 @@ lemma ep_queue_cap_to:
   apply (erule st_tcb_ex_cap, clarsimp+)
   done
 
-context Ipc_AI_cont begin
+context Ipc_AI_3 begin
 
 lemma si_invs':
   assumes set_endpoint_Q[wp]: "\<And>a b.\<lbrace>Q\<rbrace> set_endpoint a b \<lbrace>\<lambda>_.Q\<rbrace>"
@@ -3117,7 +3063,7 @@ lemma si_invs':
     (* ep=IdleEP, bl *)
     apply (cases bl, simp_all)[1]
      apply (simp add: invs_def valid_state_def valid_pspace_def)
-     apply (wpsimp wp: valid_irq_node_typ valid_ioports_lift)
+     apply (wpsimp wp: valid_irq_node_typ)
       apply (simp add: live_def valid_ep_def)
       apply (wp valid_irq_node_typ sts_only_idle sts_ep_at_inv[simplified ep_at_def2, simplified])
      apply (clarsimp simp: valid_tcb_state_def st_tcb_at_tcb_at)+
@@ -3141,7 +3087,7 @@ lemma si_invs':
    apply (cases bl, simp_all)[1]
     (* bl *)
     apply (simp add: invs_def valid_state_def valid_pspace_def)
-    apply (wpsimp wp: valid_irq_node_typ valid_ioports_lift)
+    apply (wpsimp wp: valid_irq_node_typ)
     apply (simp add: live_def valid_ep_def)
     apply (wp hoare_vcg_const_Ball_lift valid_irq_node_typ sts_only_idle
               sts_ep_at_inv[simplified ep_at_def2, simplified])
@@ -3173,12 +3119,12 @@ lemma si_invs':
   apply (wp valid_irq_node_typ)
           apply (simp add: if_apply_def2)
           apply (wp hoare_drop_imps sts_st_tcb_at_cases valid_irq_node_typ do_ipc_transfer_tcb_caps
-                    sts_only_idle hoare_vcg_if_lift hoare_vcg_disj_lift thread_get_wp' hoare_vcg_all_lift
+                    sts_only_idle hoare_vcg_if_lift hoare_vcg_disj_lift thread_get_wp'
+                    hoare_vcg_all_lift do_ipc_transfer_valid_arch
                | clarsimp simp:is_cap_simps | wpc
                | strengthen reply_cap_doesnt_exist_strg
                             disjI2_strg[where Q="cte_wp_at (\<lambda>cp. is_master_reply_cap cp \<and> R cp) p s"]
-               | (wp hoare_vcg_conj_lift hoare_weak_lift_imp | wp dxo_wp_weak | simp)+
-               | wp valid_ioports_lift)+
+               | (wp hoare_vcg_conj_lift hoare_weak_lift_imp | wp dxo_wp_weak | simp)+)+
   apply (clarsimp simp: ep_redux_simps conj_ac cong: list.case_cong if_cong)
   apply (frule(1) sym_refs_ko_atD)
   apply (clarsimp simp: st_tcb_at_refs_of_rev st_tcb_at_tcb_at ep_at_def2)
@@ -3263,13 +3209,13 @@ lemma rai_pred_tcb_neq:
   apply (rule hoare_pre)
    by (wp sts_st_tcb_at_neq get_simple_ko_wp | wpc | clarsimp simp add: do_nbrecv_failed_transfer_def)+
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 crunch set_mrs
   for ct[wp]: "\<lambda>s::'state_ext state. P (cur_thread s)"
   (wp: case_option_wp mapM_wp simp: crunch_simps)
 end
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 
 crunch receive_ipc
   for typ_at[wp]: "\<lambda>s::'state_ext state. P (typ_at T p s)"
@@ -3293,7 +3239,7 @@ lemma rai_tcb [wp]:
   "\<lbrace>tcb_at t'\<rbrace> receive_signal t cap is_blocking \<lbrace>\<lambda>rv. tcb_at t'\<rbrace>"
   by (simp add: tcb_at_typ) wp
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 
 lemmas transfer_caps_loop_pred_tcb_at[wp] =
     transfer_caps_loop_pres [OF cap_insert_pred_tcb_at]
@@ -3309,7 +3255,7 @@ lemma setup_caller_cap_makes_simple:
   apply (wp sts_st_tcb_at_cases | simp)+
   done
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 
 lemma si_blk_makes_simple:
   "\<lbrace>st_tcb_at simple t and K (t \<noteq> t') :: 'state_ext state \<Rightarrow> bool\<rbrace>
@@ -3344,7 +3290,7 @@ lemma ep_ntfn_cap_case_helper:
       R)"
   by (cases x, simp_all)
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 
 lemma sfi_makes_simple:
   "\<lbrace>st_tcb_at simple t and K (t \<noteq> t') :: 'state_ext state \<Rightarrow> bool\<rbrace>
@@ -3370,7 +3316,7 @@ end
 crunch complete_signal
   for pred_tcb_at[wp]: "pred_tcb_at proj t p"
 
-context Ipc_AI begin
+context Ipc_AI_2 begin
 
 lemma ri_makes_simple:
   "\<lbrace>st_tcb_at simple t' and K (t \<noteq> t') :: 'state_ext state \<Rightarrow> bool\<rbrace>
diff --git a/proof/invariant-abstract/KHeap_AI.thy b/proof/invariant-abstract/KHeap_AI.thy
index 81f0520c59..b19dd2929e 100644
--- a/proof/invariant-abstract/KHeap_AI.thy
+++ b/proof/invariant-abstract/KHeap_AI.thy
@@ -24,7 +24,6 @@ arch_requalify_facts
   valid_arch_caps_lift_weak
   valid_global_objs_lift_weak
   valid_asid_map_lift
-  valid_ioports_lift
   valid_kernel_mappings_lift
   equal_kernel_mappings_lift
   valid_global_vspace_mappings_lift
@@ -1000,7 +999,7 @@ crunch do_machine_op
   and irq_states[wp]: "\<lambda>s. P (interrupt_states s)"
   and kheap[wp]: "\<lambda>s. P (kheap s)"
   (simp: cur_tcb_def zombies_final_pspaceI state_refs_of_pspaceI ex_nonz_cap_to_def ct_in_state_def
-   wp: crunch_wps valid_arch_state_lift vs_lookup_vspace_obj_at_lift)
+   wp: crunch_wps valid_arch_state_lift_aobj_at vs_lookup_vspace_obj_at_lift)
 
 lemma dmo_inv:
   assumes "\<And>P. \<lbrace>P\<rbrace> f \<lbrace>\<lambda>_. P\<rbrace>"
@@ -1023,14 +1022,6 @@ locale non_aobj_op = fixes f
                               \<lbrace>\<lambda>s. P (obj_at P' p s)\<rbrace> f \<lbrace>\<lambda>r s. P (obj_at P' p s)\<rbrace>" and
           arch_state[wp]: "\<And>P. \<lbrace>\<lambda>s. P (arch_state s)\<rbrace> f \<lbrace>\<lambda>r s. P (arch_state s)\<rbrace>"
 
-context non_aobj_op begin
-
-lemma valid_arch_state[wp]:"\<lbrace>valid_arch_state\<rbrace> f \<lbrace>\<lambda>_. valid_arch_state\<rbrace>"
-  by (rule valid_arch_state_lift_aobj_at; wp aobj_at; simp)
-
-end
-
-
 locale non_vspace_op = fixes f
   assumes vsobj_at: "\<And>P P' p. vspace_obj_pred P' \<Longrightarrow>
                               \<lbrace>\<lambda>s. P (obj_at P' p s)\<rbrace> f \<lbrace>\<lambda>r s. P (obj_at P' p s)\<rbrace>" and
@@ -1110,6 +1101,14 @@ locale non_aobj_non_cap_op = non_aobj_op f + non_cap_op f for f
 
 sublocale non_aobj_non_cap_op < non_vspace_non_cap_op ..
 
+context non_aobj_non_cap_op begin
+
+lemma valid_arch_state[wp]:
+  "\<lbrace>valid_arch_state\<rbrace> f \<lbrace>\<lambda>_. valid_arch_state\<rbrace>"
+  by (rule valid_arch_state_lift_aobj_at; wp aobj_at; simp)
+
+end
+
 (* non_vspace_op version *)
 locale non_vspace_non_cap_non_mem_op = non_vspace_non_mem_op f + non_vspace_non_cap_op f for f
 locale non_aobj_non_cap_non_mem_op = non_aobj_non_mem_op f + non_aobj_non_cap_op f for f
@@ -1304,15 +1303,13 @@ lemma set_ntfn_minor_invs:
      set_notification ptr val
    \<lbrace>\<lambda>rv. invs\<rbrace>"
   apply (simp add: invs_def valid_state_def valid_pspace_def)
-  apply (wp set_simple_ko_valid_objs valid_irq_node_typ
-                    valid_irq_handlers_lift valid_ioports_lift)
+  apply (wp set_simple_ko_valid_objs valid_irq_node_typ valid_irq_handlers_lift)
   apply (clarsimp simp: ntfn_at_def2
                   elim!: rsubst[where P=sym_refs]
                  intro!: ext
                   dest!: obj_at_state_refs_ofD)
   done
 
-
 lemma tcb_cap_wp_at:
   "\<lbrakk>tcb_at t s; valid_objs s; ref \<in> dom tcb_cap_cases;
     \<forall>cap st getF setF restr.
diff --git a/proof/invariant-abstract/Retype_AI.thy b/proof/invariant-abstract/Retype_AI.thy
index 6091a83335..82fa141c7f 100644
--- a/proof/invariant-abstract/Retype_AI.thy
+++ b/proof/invariant-abstract/Retype_AI.thy
@@ -893,7 +893,7 @@ abbreviation(input)
        and valid_asid_map and valid_global_vspace_mappings
        and pspace_in_kernel_window and cap_refs_in_kernel_window
        and pspace_respects_device_region and cap_refs_respects_device_region
-       and cur_tcb and valid_ioc and valid_machine_state and valid_ioports"
+       and cur_tcb and valid_ioc and valid_machine_state"
 
 
 lemma all_invs_but_equal_kernel_mappings_restricted_eq:
diff --git a/proof/invariant-abstract/TcbAcc_AI.thy b/proof/invariant-abstract/TcbAcc_AI.thy
index 57c2351394..e9e6f8b799 100644
--- a/proof/invariant-abstract/TcbAcc_AI.thy
+++ b/proof/invariant-abstract/TcbAcc_AI.thy
@@ -172,7 +172,9 @@ locale TcbAcc_AI_valid_ipc_buffer_cap_0 =
     "(\<And>tcb. tcb_state  (f tcb) = tcb_state  tcb) \<Longrightarrow>
         (\<And>tcb. tcb_arch_ref (f tcb) = tcb_arch_ref tcb) \<Longrightarrow>
          \<lbrace>\<lambda>(s::'state_ext state). P (state_hyp_refs_of s)\<rbrace> thread_set f t \<lbrace>\<lambda>rv s. P (state_hyp_refs_of s)\<rbrace>"
-
+  assumes thread_set_valid_arch_state:
+    "(\<And>tcb. \<forall>(getF, v) \<in> ran tcb_cap_cases. getF (f tcb) = getF tcb) \<Longrightarrow>
+       \<lbrace>\<lambda>s::'state_ext state. valid_arch_state s\<rbrace> thread_set f t \<lbrace>\<lambda>rv s. valid_arch_state s\<rbrace>"
 
 context TcbAcc_AI_valid_ipc_buffer_cap_0 begin
 
@@ -422,13 +424,6 @@ lemma thread_set_cap_refs_respects_device_region:
   apply (erule sym)
   done
 
-lemma thread_set_ioports:
-  assumes y: "\<And>tcb. \<forall>(getF, v) \<in> ran tcb_cap_cases.
-                  getF (f tcb) = getF tcb"
-  shows
-  "\<lbrace>valid_ioports\<rbrace> thread_set f t \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by (wpsimp wp: valid_ioports_lift thread_set_caps_of_state_trivial y)
-
 (* NOTE: The function "thread_set f p" updates a TCB at p using function f.
    It should not be used to change capabilities, though. *)
 lemma thread_set_valid_ioc_trivial:
@@ -468,7 +463,7 @@ lemma thread_set_invs_trivial:
   shows      "\<lbrace>invs::'state_ext state \<Rightarrow> bool\<rbrace> thread_set f t \<lbrace>\<lambda>rv. invs\<rbrace>"
   apply (simp add: invs_def valid_state_def valid_pspace_def)
   apply (rule hoare_weaken_pre)
-   apply (wp thread_set_valid_objs_triv thread_set_ioports
+   apply (wp thread_set_valid_objs_triv thread_set_valid_arch_state
              thread_set_refs_trivial
              thread_set_hyp_refs_trivial
              thread_set_iflive_trivial
@@ -1338,7 +1333,6 @@ locale TcbAcc_AI_pred_tcb_cap_wp_at =
         \<forall>cap. (pred_tcb_at proj P t s \<and> tcb_cap_valid cap (t, ref) s) \<longrightarrow> Q cap\<rbrakk>
       \<Longrightarrow> cte_wp_at Q (t, ref) s"
 
-
 locale TcbAcc_AI_st_tcb_at_cap_wp_at = TcbAcc_AI_pred_tcb_cap_wp_at itcb_state state_ext_t
   for state_ext_t :: "'state_ext::state_ext itself"
 
@@ -1494,9 +1488,7 @@ lemma set_bound_notification_valid_ioc[wp]:
                         if_split_asm)
   done
 
-crunch set_thread_state, set_bound_notification
-  for valid_ioports[wp]: valid_ioports
-  (wp: valid_ioports_lift)
+lemmas [wp] = sts.valid_arch_state sbn.valid_arch_state
 
 lemma sts_invs_minor:
   "\<lbrace>st_tcb_at (\<lambda>st'. tcb_st_refs_of st' = tcb_st_refs_of st) t
@@ -1564,7 +1556,6 @@ lemma sts_invs_minor2:
   apply (clarsimp simp: pred_tcb_at_def obj_at_def)
   done (* FIXME tidy *)
 
-
 lemma sbn_invs_minor:
   "\<lbrace>bound_tcb_at (\<lambda>ntfn'. tcb_bound_refs ntfn' = tcb_bound_refs ntfn) t
     and (\<lambda>s. bound ntfn \<longrightarrow> ex_nonz_cap_to t s)
diff --git a/proof/invariant-abstract/Tcb_AI.thy b/proof/invariant-abstract/Tcb_AI.thy
index bb98806023..6892a6f34e 100644
--- a/proof/invariant-abstract/Tcb_AI.thy
+++ b/proof/invariant-abstract/Tcb_AI.thy
@@ -610,8 +610,8 @@ lemma thread_set_tcb_ipc_buffer_cap_cleared_invs:
              thread_set_valid_reply_caps_trivial
              thread_set_valid_reply_masters_trivial
              valid_irq_node_typ valid_irq_handlers_lift
-             thread_set_caps_of_state_trivial valid_ioports_lift
-             thread_set_arch_caps_trivial
+             thread_set_caps_of_state_trivial thread_set_valid_arch_state
+             thread_set_arch_caps_trivial thread_set_irq_node
              thread_set_only_idle
              thread_set_cap_refs_in_kernel_window
              thread_set_valid_ioc_trivial
@@ -704,7 +704,7 @@ lemma set_mcpriority_invs[wp]:
              thread_set_arch_caps_trivial
              thread_set_only_idle
              thread_set_cap_refs_in_kernel_window
-             thread_set_valid_ioc_trivial valid_ioports_lift
+             thread_set_valid_ioc_trivial thread_set_valid_arch_state
              thread_set_cap_refs_respects_device_region
               | simp add: ran_tcb_cap_cases invs_def valid_state_def valid_pspace_def
               | rule conjI | erule disjE)+
@@ -800,7 +800,7 @@ lemma bind_notification_invs:
    \<lbrace>\<lambda>_. invs\<rbrace>"
   apply (simp add: bind_notification_def invs_def valid_state_def valid_pspace_def)
   apply (rule bind_wp[OF _ get_simple_ko_sp])
-  apply (wp valid_irq_node_typ set_simple_ko_valid_objs simple_obj_set_prop_at valid_ioports_lift
+  apply (wp valid_irq_node_typ set_simple_ko_valid_objs simple_obj_set_prop_at
          | clarsimp simp:idle_no_ex_cap split del: if_split)+
   apply (intro conjI;
     (clarsimp simp: is_ntfn idle_no_ex_cap elim!: obj_at_weakenE)?)
diff --git a/proof/invariant-abstract/Untyped_AI.thy b/proof/invariant-abstract/Untyped_AI.thy
index 8891a97681..5297871ef6 100644
--- a/proof/invariant-abstract/Untyped_AI.thy
+++ b/proof/invariant-abstract/Untyped_AI.thy
@@ -17,11 +17,6 @@ unbundle l4v_word_context (* because of Lib.MonadicRewrite *)
 
 arch_requalify_consts
   second_level_tables
-  safe_ioport_insert
-
-arch_requalify_facts
-  set_cap_ioports'
-  safe_ioport_insert_triv
 
 primrec
   valid_untyped_inv_wcap :: "Invocations_A.untyped_invocation \<Rightarrow> cap option
@@ -299,6 +294,11 @@ locale Untyped_AI_arch =
     \<Longrightarrow> case ui of
         Retype slot reset ptr_base ptr tp us slots dev
         \<Rightarrow> obj_is_device tp dev = dev"
+  assumes set_cap_non_arch_valid_arch_state:
+  "\<And>cap ptr.
+     \<lbrace>\<lambda>s. valid_arch_state s \<and> cte_wp_at (\<lambda>_. \<not>is_arch_cap cap) ptr s\<rbrace>
+     set_cap cap ptr
+     \<lbrace>\<lambda>rv. valid_arch_state :: 'state_ext state \<Rightarrow> _ \<rbrace>"
 
 lemmas is_aligned_triv2 = Aligned.is_aligned_triv
 
@@ -2686,6 +2686,7 @@ lemma caps_of_state_pspace_no_overlapD:
   apply simp
   done
 
+context Untyped_AI_arch begin
 
 lemma set_untyped_cap_invs_simple:
   "\<lbrace>\<lambda>s. descendants_range_in {ptr .. ptr+2^sz - 1} cref s
@@ -2693,7 +2694,7 @@ lemma set_untyped_cap_invs_simple:
   \<and> cte_wp_at (\<lambda>c. is_untyped_cap c \<and> cap_bits c = sz
       \<and> cap_is_device c = dev\<and> obj_ref_of c = ptr) cref s \<and> idx \<le> 2^ sz\<rbrace>
   set_cap (UntypedCap dev ptr sz idx) cref
- \<lbrace>\<lambda>rv s. invs s\<rbrace>"
+ \<lbrace>\<lambda>rv. invs :: 'state_ext state \<Rightarrow> bool \<rbrace>"
   apply (rule hoare_name_pre_state)
   apply (clarsimp simp:cte_wp_at_caps_of_state invs_def valid_state_def)
   apply (rule hoare_pre)
@@ -2702,23 +2703,22 @@ lemma set_untyped_cap_invs_simple:
    apply (simp add:valid_irq_node_def)
    apply wps
    apply (wp hoare_vcg_all_lift set_cap_irq_handlers
-     set_cap_irq_handlers cap_table_at_lift_valid set_cap_ioports'
+     set_cap_irq_handlers cap_table_at_lift_valid set_cap_non_arch_valid_arch_state
      set_cap_typ_at set_cap_valid_arch_caps_simple set_cap_kernel_window_simple
      set_cap_cap_refs_respects_device_region)
   apply (clarsimp simp del: split_paired_Ex)
   apply (strengthen exI[where x=cref])
   apply (clarsimp simp:cte_wp_at_caps_of_state is_cap_simps valid_pspace_def)
   apply (intro conjI; clarsimp?)
-        apply (clarsimp simp: fun_eq_iff)
-       apply (clarsimp split:cap.splits simp:is_cap_simps appropriate_cte_cap_def)
-      apply (drule(1) if_unsafe_then_capD[OF caps_of_state_cteD])
-       apply clarsimp
-      apply (clarsimp simp: is_cap_simps ex_cte_cap_wp_to_def appropriate_cte_cap_def
-                            cte_wp_at_caps_of_state)
-     apply (clarsimp dest!:valid_global_refsD2 simp:cap_range_def)
-    apply (simp add:valid_irq_node_def)
-   apply (clarsimp simp:valid_irq_node_def)
-  apply (clarsimp intro!: safe_ioport_insert_triv simp: is_cap_simps)
+       apply (clarsimp simp: fun_eq_iff)
+      apply (clarsimp split:cap.splits simp:is_cap_simps appropriate_cte_cap_def)
+     apply (drule(1) if_unsafe_then_capD[OF caps_of_state_cteD])
+      apply clarsimp
+     apply (clarsimp simp: is_cap_simps ex_cte_cap_wp_to_def appropriate_cte_cap_def
+                           cte_wp_at_caps_of_state)
+    apply (clarsimp dest!:valid_global_refsD2 simp:cap_range_def)
+   apply (simp add:valid_irq_node_def)
+  apply (clarsimp simp:valid_irq_node_def)
   done
 
 lemma reset_untyped_cap_invs_etc:
@@ -2729,7 +2729,7 @@ lemma reset_untyped_cap_invs_etc:
     reset_untyped_cap slot
   \<lbrace>\<lambda>_. invs and valid_untyped_inv_wcap ui (Some (UntypedCap dev ptr sz 0))
       and ct_active
-      and pspace_no_overlap {ptr .. ptr + 2 ^ sz - 1}\<rbrace>, \<lbrace>\<lambda>_. invs\<rbrace>"
+      and pspace_no_overlap {ptr .. ptr + 2 ^ sz - 1}\<rbrace>, \<lbrace>\<lambda>_. invs :: 'state_ext state \<Rightarrow> bool\<rbrace>"
   (is "\<lbrace>invs and valid_untyped_inv_wcap ?ui (Some ?cap) and ct_active and _\<rbrace>
     ?f \<lbrace>\<lambda>_. invs and ?vu2 and ct_active and ?psp\<rbrace>, \<lbrace>\<lambda>_. invs\<rbrace>")
   apply (simp add: reset_untyped_cap_def)
@@ -2817,6 +2817,8 @@ lemma reset_untyped_cap_invs_etc:
   apply (clarsimp simp: cte_wp_at_caps_of_state)
   done
 
+end
+
 lemma get_cap_prop_known:
   "\<lbrace>cte_wp_at (\<lambda>cp. f cp = v) slot and Q v\<rbrace> get_cap slot \<lbrace>\<lambda>rv. Q (f rv)\<rbrace>"
   apply (wp get_cap_wp)
@@ -2975,10 +2977,6 @@ lemma create_cap_aobj_at:
   unfolding create_cap_def split_def set_cdt_def
   by (wpsimp wp: set_cap.aobj_at)
 
-lemma create_cap_valid_arch_state[wp]:
-  "\<lbrace>valid_arch_state\<rbrace> create_cap type bits ut is_dev cref \<lbrace>\<lambda>_. valid_arch_state\<rbrace>"
-  by (wp valid_arch_state_lift_aobj_at create_cap_aobj_at)
-
 crunch create_cap
   for irq_node[wp]: "\<lambda>s. P (interrupt_irq_node s)"
   (simp: crunch_simps)
@@ -3031,9 +3029,9 @@ locale Untyped_AI_nonempty_table =
     K (\<forall>ref\<in>set refs. is_aligned ref (obj_bits_api tp us))\<rbrace>
         init_arch_objects tp dev ptr bits us refs
    \<lbrace>\<lambda>rv. \<lambda>s :: 'state_ext state. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)\<rbrace>"
-  assumes create_cap_ioports[wp]:
-  "\<And>tp oref sz dev cref p. \<lbrace>valid_ioports and cte_wp_at (\<lambda>_. True) cref\<rbrace>
-        create_cap tp sz p dev (cref,oref) \<lbrace>\<lambda>rv (s::'state_ext state). valid_ioports s\<rbrace>"
+  assumes create_cap_valid_arch_state[wp]:
+  "\<And>tp oref sz dev cref p. \<lbrace>valid_arch_state and cte_wp_at (\<lambda>_. True) cref\<rbrace>
+        create_cap tp sz p dev (cref,oref) \<lbrace>\<lambda>rv (s::'state_ext state). valid_arch_state s\<rbrace>"
 
 
 crunch create_cap
diff --git a/proof/invariant-abstract/X64/ArchAcc_AI.thy b/proof/invariant-abstract/X64/ArchAcc_AI.thy
index 558ecfc6b2..9fc6263b57 100644
--- a/proof/invariant-abstract/X64/ArchAcc_AI.thy
+++ b/proof/invariant-abstract/X64/ArchAcc_AI.thy
@@ -1576,7 +1576,7 @@ lemma set_object_invs[wp]:
     set_object ptr (ArchObj obj)
   \<lbrace> \<lambda>_. invs \<rbrace>"
   apply (clarsimp simp: invs_def valid_state_def valid_pspace_def valid_asid_map_def)
-  apply (wp valid_irq_node_typ valid_irq_handlers_lift valid_ioports_lift
+  apply (wp valid_irq_node_typ valid_irq_handlers_lift valid_arch_state_lift
             set_aobj_valid_global_vspace_mappings set_object_valid_objs)
   apply (clarsimp simp: valid_arch_state_def valid_obj_def)
   done
diff --git a/proof/invariant-abstract/X64/ArchArch_AI.thy b/proof/invariant-abstract/X64/ArchArch_AI.thy
index 9f60cbbaf2..94c32186b4 100644
--- a/proof/invariant-abstract/X64/ArchArch_AI.thy
+++ b/proof/invariant-abstract/X64/ArchArch_AI.thy
@@ -586,11 +586,19 @@ lemma cap_insert_ioports_ap:
      cap_insert cap src dest
    \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
   apply (simp add: cap_insert_def)
-  apply (wp get_cap_wp set_cap_ioports' set_untyped_cap_as_full_ioports
+  apply (wp get_cap_wp set_cap_ioports_safe set_untyped_cap_as_full_ioports
             set_untyped_cap_as_full_gross_ioports
-         | wpc | simp split del: if_splits)+
+         | wpc | simp split del: if_split)+
   done
 
+lemma cap_insert_valid_arch_state_ap:
+  "\<lbrace>valid_arch_state and (\<lambda>s. cte_wp_at (\<lambda>cap'. safe_ioport_insert cap cap' s) dest s) and
+    K (is_ap_cap cap)\<rbrace>
+   cap_insert cap src dest
+   \<lbrace>\<lambda>rv. valid_arch_state\<rbrace>"
+  by (wp valid_arch_state_lift_ioports_aobj_at cap_insert_aobj_at cap_insert_ioports_ap)+
+     (simp add: valid_arch_state_def)
+
 lemma cap_insert_ap_invs:
   "\<lbrace>invs and valid_cap cap and tcb_cap_valid cap dest and
     ex_cte_cap_wp_to (appropriate_cte_cap cap) dest and
@@ -611,7 +619,7 @@ lemma cap_insert_ap_invs:
   apply (simp cong: conj_cong)
   apply (rule hoare_pre)
    apply (wp cap_insert_simple_mdb cap_insert_iflive
-             cap_insert_zombies cap_insert_ifunsafe cap_insert_ioports_ap
+             cap_insert_zombies cap_insert_ifunsafe cap_insert_valid_arch_state_ap
              cap_insert_valid_global_refs cap_insert_idle
              valid_irq_node_typ cap_insert_simple_arch_caps_ap)
   apply (clarsimp simp: is_simple_cap_def cte_wp_at_caps_of_state is_cap_simps)
diff --git a/proof/invariant-abstract/X64/ArchBits_AI.thy b/proof/invariant-abstract/X64/ArchBits_AI.thy
index 80df51803b..2f10d732ab 100644
--- a/proof/invariant-abstract/X64/ArchBits_AI.thy
+++ b/proof/invariant-abstract/X64/ArchBits_AI.thy
@@ -10,6 +10,10 @@ begin
 
 context Arch begin arch_global_naming
 
+lemma invs_valid_ioports[elim!]:
+  "invs s \<Longrightarrow> valid_ioports s"
+  by (simp add: invs_def valid_state_def valid_arch_state_def)
+
 lemma invs_unique_table_caps[elim!]:
   "invs s \<Longrightarrow> unique_table_caps (caps_of_state s)"
   by (clarsimp simp: invs_def valid_state_def valid_arch_caps_def)
diff --git a/proof/invariant-abstract/X64/ArchCNodeInv_AI.thy b/proof/invariant-abstract/X64/ArchCNodeInv_AI.thy
index 3acd010003..be426f12bb 100644
--- a/proof/invariant-abstract/X64/ArchCNodeInv_AI.thy
+++ b/proof/invariant-abstract/X64/ArchCNodeInv_AI.thy
@@ -431,7 +431,7 @@ lemma cap_swap_cap_refs_in_kernel_window[wp, CNodeInv_AI_assms]:
   done
 
 
-lemma cap_swap_ioports[wp, CNodeInv_AI_assms]:
+lemma cap_swap_ioports[wp]:
   "\<lbrace>valid_ioports and cte_wp_at (weak_derived c) a and cte_wp_at (weak_derived c') b\<rbrace>
      cap_swap c a c' b
    \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
@@ -444,8 +444,15 @@ lemma cap_swap_ioports[wp, CNodeInv_AI_assms]:
                  dest!: weak_derived_cap_ioports)
   by (fastforce elim!: ranE split: if_split_asm)
 
+lemma cap_swap_valid_arch_state[wp, CNodeInv_AI_assms]:
+  "\<lbrace>valid_arch_state and cte_wp_at (weak_derived c) a and cte_wp_at (weak_derived c') b\<rbrace>
+   cap_swap c a c' b
+   \<lbrace>\<lambda>_. valid_arch_state\<rbrace>"
+  by (wp valid_arch_state_lift_ioports_aobj_at cap_swap_aobj_at)+
+     (simp add: valid_arch_state_def)
+
 lemma cap_swap_vms[wp, CNodeInv_AI_assms]:
-  "\<lbrace>valid_machine_state\<rbrace>  cap_swap c a c' b \<lbrace>\<lambda>rv. valid_machine_state\<rbrace>"
+  "\<lbrace>valid_machine_state\<rbrace> cap_swap c a c' b \<lbrace>\<lambda>rv. valid_machine_state\<rbrace>"
   apply (simp add: valid_machine_state_def in_user_frame_def)
   apply (wp cap_swap_typ_at
             hoare_vcg_all_lift hoare_vcg_ex_lift hoare_vcg_disj_lift)
@@ -982,6 +989,15 @@ lemma cap_move_ioports:
                  dest!: weak_derived_cap_ioports)
   by (fastforce elim!: ranE split: if_split_asm)
 
+lemma cap_move_valid_arch:
+  "\<lbrace>valid_arch_state and cte_wp_at ((=) cap.NullCap) ptr'
+    and cte_wp_at (weak_derived cap) ptr
+    and cte_wp_at (\<lambda>c. c \<noteq> cap.NullCap) ptr and K (ptr \<noteq> ptr')\<rbrace>
+   cap_move cap ptr ptr'
+   \<lbrace>\<lambda>rv. valid_arch_state\<rbrace>"
+  by (wp valid_arch_state_lift_ioports_typ_at cap_move_ioports cap_move_typ_at)
+     (simp add: valid_arch_state_def)
+
 lemma cap_move_invs[wp, CNodeInv_AI_assms]:
   "\<lbrace>invs and valid_cap cap and cte_wp_at ((=) cap.NullCap) ptr'
          and tcb_cap_valid cap ptr'
@@ -1001,7 +1017,7 @@ lemma cap_move_invs[wp, CNodeInv_AI_assms]:
    apply (wpe cap_move_replies)
    apply (wpe cap_move_valid_arch_caps)
    apply (wpe cap_move_valid_ioc)
-   apply (wpe cap_move_ioports)
+   apply (wpe cap_move_valid_arch)
    apply (simp add: cap_move_def set_cdt_def)
    apply (rule hoare_pre)
     apply (wp set_cap_valid_objs set_cap_idle set_cap_typ_at
@@ -1020,7 +1036,7 @@ lemma cap_move_invs[wp, CNodeInv_AI_assms]:
    apply (simp add: cap_range_NullCap valid_ipc_buffer_cap_def[where c=cap.NullCap])
    apply (simp add: is_cap_simps)
    apply (subgoal_tac "tcb_cap_valid cap.NullCap ptr s")
-    apply (simp add: tcb_cap_valid_def weak_derived_cap_is_device)
+    apply (simp add: tcb_cap_valid_def weak_derived_cap_is_device is_cap_simps)
    apply (rule tcb_cap_valid_NullCapD)
     apply (erule(1) tcb_cap_valid_caps_of_stateD)
    apply (simp add: is_cap_simps)
diff --git a/proof/invariant-abstract/X64/ArchCSpaceInv_AI.thy b/proof/invariant-abstract/X64/ArchCSpaceInv_AI.thy
index 097199048f..36defd6de2 100644
--- a/proof/invariant-abstract/X64/ArchCSpaceInv_AI.thy
+++ b/proof/invariant-abstract/X64/ArchCSpaceInv_AI.thy
@@ -32,7 +32,7 @@ lemma safe_ioport_insert_triv:
   "\<not>is_arch_cap newcap \<Longrightarrow> safe_ioport_insert newcap oldcap s"
   by (clarsimp simp: safe_ioport_insert_def)
 
-lemma set_cap_ioports':
+lemma set_cap_ioports_safe:
  "\<lbrace>\<lambda>s. valid_ioports s
       \<and> cte_wp_at (\<lambda>cap'. safe_ioport_insert cap cap' s) ptr s\<rbrace>
     set_cap cap ptr
@@ -49,6 +49,15 @@ lemma set_cap_ioports':
     apply blast+
   done
 
+lemma set_cap_non_arch_valid_arch_state:
+ "\<lbrace>\<lambda>s. valid_arch_state s \<and> cte_wp_at (\<lambda>_. \<not>is_arch_cap cap) ptr s\<rbrace>
+  set_cap cap ptr
+  \<lbrace>\<lambda>rv. valid_arch_state \<rbrace>"
+  unfolding valid_arch_state_def
+  by (wp set_cap.aobj_at valid_asid_table_lift valid_global_pts_lift valid_global_pds_lift
+         valid_global_pdpts_lift typ_at_lift set_cap_ioports_safe)+
+     (clarsimp simp: cte_wp_at_caps_of_state is_cap_simps valid_pspace_def safe_ioport_insert_triv)
+
 lemma set_cap_ioports_no_new_ioports:
  "\<lbrace>\<lambda>s. valid_ioports s
       \<and> cte_wp_at (\<lambda>cap'. cap_ioports cap = {} \<or> cap_ioports cap = cap_ioports cap') ptr s\<rbrace>
@@ -69,6 +78,16 @@ lemma set_cap_ioports_no_new_ioports:
    apply (metis Int_empty_right ranI)
   by (meson ranI)
 
+lemma set_cap_no_new_ioports_arch_valid_arch_state:
+ "\<lbrace>\<lambda>s. valid_arch_state s
+       \<and> cte_wp_at (\<lambda>cap'. cap_ioports cap = {} \<or> cap_ioports cap = cap_ioports cap') ptr s\<rbrace>
+  set_cap cap ptr
+  \<lbrace>\<lambda>rv. valid_arch_state \<rbrace>"
+  unfolding valid_arch_state_def
+  by (wp set_cap.aobj_at valid_asid_table_lift valid_global_pts_lift valid_global_pds_lift
+         valid_global_pdpts_lift typ_at_lift set_cap_ioports_no_new_ioports)+
+     (clarsimp simp: cte_wp_at_caps_of_state is_cap_simps valid_pspace_def)
+
 lemma valid_ioportsD:
   "\<lbrakk>valid_ioports s; caps_of_state s p = Some cap; cap' \<in> ran (caps_of_state s);
       cap_ioports cap \<inter> cap_ioports cap' \<noteq> {}\<rbrakk>
@@ -105,7 +124,7 @@ lemma replace_cap_invs:
              set_cap_caps_of_state2 set_cap_idle
              replace_cap_ifunsafe valid_irq_node_typ
              set_cap_typ_at set_cap_irq_handlers
-             set_cap_valid_arch_caps set_cap_ioports_no_new_ioports
+             set_cap_valid_arch_caps set_cap_no_new_ioports_arch_valid_arch_state
              set_cap_cap_refs_respects_device_region_replaceable)
   apply (clarsimp simp: valid_pspace_def cte_wp_at_caps_of_state
                         replaceable_def)
@@ -194,8 +213,9 @@ lemma replace_cap_invs:
    apply (clarsimp simp: valid_table_capsD[OF caps_of_state_cteD]
                     valid_arch_caps_def unique_table_refs_no_cap_asidE)
   apply clarsimp
-  apply (rule conjI, rule Ball_emptyI, simp add: gen_obj_refs_subset)
-  by clarsimp
+  apply (rule conjI, solves clarsimp)
+  apply (rule Ball_emptyI, simp add: gen_obj_refs_subset)
+  done
 
 
 definition
diff --git a/proof/invariant-abstract/X64/ArchCSpace_AI.thy b/proof/invariant-abstract/X64/ArchCSpace_AI.thy
index a08a3acbcb..5ab4847157 100644
--- a/proof/invariant-abstract/X64/ArchCSpace_AI.thy
+++ b/proof/invariant-abstract/X64/ArchCSpace_AI.thy
@@ -91,12 +91,12 @@ lemma set_free_index_invs [CSpace_AI_assms]:
   apply (simp add:invs_def valid_state_def)
   apply (rule hoare_pre)
   apply (wp set_free_index_valid_pspace[where cap = cap] set_free_index_valid_mdb
-    set_cap_idle update_cap_ifunsafe)
+            set_cap_idle update_cap_ifunsafe set_cap_no_new_ioports_arch_valid_arch_state)
   apply (simp add:valid_irq_node_def)
   apply wps
   apply (wp hoare_vcg_all_lift set_cap_irq_handlers set_cap.valid_vspace_obj set_cap_valid_arch_caps
             set_cap.valid_global_objs set_cap_irq_handlers cap_table_at_lift_valid set_cap_typ_at
-            set_cap_cap_refs_respects_device_region_spec[where ptr = cref] set_cap_ioports_no_new_ioports)
+            set_cap_cap_refs_respects_device_region_spec[where ptr = cref])
   apply (clarsimp simp:cte_wp_at_caps_of_state)
   apply (rule conjI,simp add:valid_pspace_def)
   apply (rule conjI,clarsimp simp:is_cap_simps)
@@ -401,12 +401,12 @@ lemma valid_ioports_issuedD:
        \<Longrightarrow> cap_ioports cap \<subseteq> issued_ioports (arch_state s)"
   by (auto simp: valid_ioports_def all_ioports_issued_def)
 
-lemma cap_insert_derived_ioports[CSpace_AI_assms]:
+lemma cap_insert_derived_ioports:
   "\<lbrace>valid_ioports and (\<lambda>s. cte_wp_at (is_derived (cdt s) src cap) src s)\<rbrace>
      cap_insert cap src dest
    \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
   apply (simp add: cap_insert_def)
-  apply (wp get_cap_wp set_cap_ioports' set_untyped_cap_as_full_ioports
+  apply (wp get_cap_wp set_cap_ioports_safe set_untyped_cap_as_full_ioports
             set_untyped_cap_as_full_gross_ioports
          | wpc | simp split del: if_splits)+
   apply (rule impI, erule exE, rule impI)
@@ -419,17 +419,32 @@ lemma cap_insert_derived_ioports[CSpace_AI_assms]:
   apply (drule_tac cap=cap in valid_ioports_issuedD, simp+)
   done
 
+lemma cap_insert_derived_valid_arch_state[CSpace_AI_assms]:
+  "\<lbrace>valid_arch_state and (\<lambda>s. cte_wp_at (is_derived (cdt s) src cap) src s)\<rbrace>
+   cap_insert cap src dest
+   \<lbrace>\<lambda>rv. valid_arch_state \<rbrace>"
+  by (wp valid_arch_state_lift_ioports_aobj_at cap_insert_aobj_at cap_insert_derived_ioports)+
+     (simp add: cap_insert_aobj_at valid_arch_state_def)
+
 lemma cap_insert_simple_ioports:
   "\<lbrace>valid_ioports and (\<lambda>s. cte_wp_at (\<lambda>cap'. safe_ioport_insert cap cap' s) dest s) and
         K (is_simple_cap cap \<and> \<not>is_ap_cap cap)\<rbrace>
      cap_insert cap src dest
    \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
   apply (simp add: cap_insert_def)
-  apply (wp get_cap_wp set_cap_ioports' set_untyped_cap_as_full_ioports
+  apply (wp get_cap_wp set_cap_ioports_safe set_untyped_cap_as_full_ioports
             set_untyped_cap_as_full_gross_ioports
          | wpc | simp split del: if_splits)+
   done
 
+lemma cap_insert_simple_valid_arch_state:
+  "\<lbrace>valid_arch_state and (\<lambda>s. cte_wp_at (\<lambda>cap'. safe_ioport_insert cap cap' s) dest s) and
+    K (is_simple_cap cap \<and> \<not>is_ap_cap cap)\<rbrace>
+   cap_insert cap src dest
+   \<lbrace>\<lambda>rv. valid_arch_state\<rbrace>"
+  by (wp valid_arch_state_lift_ioports_aobj_at cap_insert_aobj_at cap_insert_simple_ioports)+
+     (simp add: valid_arch_state_def)
+
 end
 
 
@@ -609,11 +624,16 @@ lemma cap_insert_simple_arch_caps_no_ap:
   apply (clarsimp simp: cte_wp_at_caps_of_state)
   by (auto simp: is_simple_cap_def[simplified is_simple_cap_arch_def] is_cap_simps)
 
-lemma setup_reply_master_ioports[wp, CSpace_AI_assms]:
+lemma setup_reply_master_ioports[wp]:
   "\<lbrace>valid_ioports\<rbrace> setup_reply_master c \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
   apply (wpsimp simp: setup_reply_master_def wp: set_cap_ioports_no_new_ioports get_cap_wp)
   by (clarsimp simp: cte_wp_at_caps_of_state)
 
+lemma setup_reply_master_arch[CSpace_AI_assms]:
+  "setup_reply_master t \<lbrace> valid_arch_state \<rbrace>"
+  by (wp valid_arch_state_lift_ioports_typ_at setup_reply_master_ioports)+
+     (auto simp: valid_arch_state_def)
+
 end
 
 
@@ -636,10 +656,11 @@ lemma cap_insert_simple_invs:
     K (is_simple_cap cap \<and> \<not>is_ap_cap cap) and (\<lambda>s. \<forall>irq \<in> cap_irqs cap. irq_issued irq s)
     and (\<lambda>s. cte_wp_at (\<lambda>c. safe_ioport_insert cap c s) dest s)\<rbrace>
   cap_insert cap src dest \<lbrace>\<lambda>rv. invs\<rbrace>"
+  supply cap_insert_derived_valid_arch_state[wp del]
   apply (simp add: invs_def valid_state_def valid_pspace_def)
   apply (rule hoare_pre)
    apply (wp cap_insert_simple_mdb cap_insert_iflive
-             cap_insert_zombies cap_insert_ifunsafe cap_insert_simple_ioports
+             cap_insert_zombies cap_insert_ifunsafe cap_insert_simple_valid_arch_state
              cap_insert_valid_global_refs cap_insert_idle
              valid_irq_node_typ cap_insert_simple_arch_caps_no_ap)
   apply (clarsimp simp: is_simple_cap_def cte_wp_at_caps_of_state)
diff --git a/proof/invariant-abstract/X64/ArchDetype_AI.thy b/proof/invariant-abstract/X64/ArchDetype_AI.thy
index c23696d6fc..2cd93f1bb6 100644
--- a/proof/invariant-abstract/X64/ArchDetype_AI.thy
+++ b/proof/invariant-abstract/X64/ArchDetype_AI.thy
@@ -107,14 +107,6 @@ lemma state_hyp_refs_of_detype:
   "state_hyp_refs_of (detype S s) = (\<lambda>x. if x \<in> 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_assms]:
-  "valid_ioports s \<Longrightarrow> 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)
-  apply (rule conjI)
-   apply (force simp: ran_def)
-  by (metis (full_types) ranI)
-
 end
 
 interpretation Detype_AI?: Detype_AI
@@ -187,10 +179,20 @@ lemma tcb_arch_detype[detype_invs_proofs]:
   apply (clarsimp simp: valid_arch_tcb_def)
   done
 
+lemma valid_ioports_detype:
+  "valid_ioports s \<Longrightarrow> 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)
+  apply (rule conjI)
+   apply (force simp: ran_def)
+  by (metis (full_types) ranI)
+
 lemma valid_arch_state_detype[detype_invs_proofs]:
   "valid_arch_state (detype (untyped_range cap) s)"
   using valid_vs_lookup valid_arch_state ut_mdb valid_global_refsD [OF globals cap] cap
-  apply (simp add: valid_arch_state_def valid_asid_table_def
+  unfolding valid_arch_state_def
+  apply (strengthen valid_ioports_detype,
+         simp add: valid_arch_state_def valid_asid_table_def
                    valid_global_pdpts_def valid_global_pds_def valid_global_pts_def
                    global_refs_def cap_range_def)
   apply (clarsimp simp: ran_def arch_state_det)
diff --git a/proof/invariant-abstract/X64/ArchFinalise_AI.thy b/proof/invariant-abstract/X64/ArchFinalise_AI.thy
index dc101958c7..1cfd5f7b9c 100644
--- a/proof/invariant-abstract/X64/ArchFinalise_AI.thy
+++ b/proof/invariant-abstract/X64/ArchFinalise_AI.thy
@@ -79,7 +79,6 @@ lemma invs_x64_asid_table_unmap:
   apply (simp add: valid_irq_node_def valid_kernel_mappings_def
                    valid_global_objs_arch_update valid_asid_map_def)
   apply (simp add: valid_table_caps_def valid_machine_state_def second_level_tables_def)
-  apply (simp add: valid_ioports_def all_ioports_issued_def issued_ioports_def)
   done
 
 lemma delete_asid_pool_invs[wp]:
@@ -232,7 +231,7 @@ lemma (* empty_slot_invs *) [Finalise_AI_assms]:
                   set_cap_idle valid_irq_node_typ set_cap_typ_at
                   set_cap_irq_handlers set_cap_valid_arch_caps
                   set_cap_cap_refs_respects_device_region_NullCap
-                  set_cap_ioports_no_new_ioports
+                  set_cap_no_new_ioports_arch_valid_arch_state
       | simp add: trans_state_update[symmetric]
              del: trans_state_update fun_upd_apply
        split del: if_split )+
diff --git a/proof/invariant-abstract/X64/ArchInvariants_AI.thy b/proof/invariant-abstract/X64/ArchInvariants_AI.thy
index fe1f0dca2d..fa28edb4f9 100644
--- a/proof/invariant-abstract/X64/ArchInvariants_AI.thy
+++ b/proof/invariant-abstract/X64/ArchInvariants_AI.thy
@@ -1039,10 +1039,14 @@ where
      cap_ioports cap \<inter> cap_ioports cap' \<noteq> {} \<longrightarrow> cap_ioports cap = cap_ioports cap'"
 
 definition
-  valid_ioports :: "'z::state_ext state \<Rightarrow> bool"
+  valid_ioports_2 :: "(cslot_ptr \<Rightarrow> cap option) \<Rightarrow> arch_state \<Rightarrow> bool"
 where
-  "valid_ioports \<equiv> \<lambda>s. all_ioports_issued (caps_of_state s) (arch_state s) \<and>
-                      ioports_no_overlap (caps_of_state s)"
+  "valid_ioports_2 caps as \<equiv> all_ioports_issued caps as \<and> ioports_no_overlap caps"
+
+abbreviation valid_ioports where
+  "valid_ioports s \<equiv> valid_ioports_2 (caps_of_state s) (arch_state s)"
+
+lemmas valid_ioports_def = valid_ioports_2_def
 
 definition
   valid_x64_irq_state :: "(8 word \<Rightarrow> X64IRQState) \<Rightarrow> bool"
@@ -1059,7 +1063,8 @@ where
       \<and> valid_global_pds s
       \<and> valid_global_pdpts s
       \<and> valid_cr3 (x64_current_cr3 (arch_state s))
-      \<and> valid_x64_irq_state (x64_irq_state (arch_state s))"
+      \<and> valid_x64_irq_state (x64_irq_state (arch_state s))
+      \<and> valid_ioports s"
 
 definition
   vs_cap_ref_arch :: "arch_cap \<Rightarrow> vs_ref list option"
@@ -1734,7 +1739,7 @@ lemma valid_table_caps_update [iff]:
 
 lemma valid_ioports_update[iff]:
   "valid_ioports (f s) = valid_ioports s"
-  by (clarsimp simp: valid_ioports_def arch)
+  by (simp add: arch)
 
 end
 
@@ -1763,14 +1768,35 @@ lemma global_refs_lift:
   apply (rule hoare_vcg_prop)
   done
 
+(* this is the obvious version that doesn't expose IO ports, exported to generic theory *)
 lemma valid_arch_state_lift:
   assumes typs: "\<And>T p. \<lbrace>typ_at (AArch T) p\<rbrace> f \<lbrace>\<lambda>_. typ_at (AArch T) p\<rbrace>"
   assumes arch: "\<And>P. \<lbrace>\<lambda>s. P (arch_state s)\<rbrace> f \<lbrace>\<lambda>_ s. P (arch_state s)\<rbrace>"
+  assumes caps: "\<And>P. \<lbrace>\<lambda>s. P (caps_of_state s)\<rbrace> f \<lbrace>\<lambda>_ s. P (caps_of_state s)\<rbrace>"
   shows "\<lbrace>valid_arch_state\<rbrace> f \<lbrace>\<lambda>_. valid_arch_state\<rbrace>"
   apply (simp add: valid_arch_state_def valid_asid_table_def
                    valid_global_pts_def valid_global_pds_def valid_global_pdpts_def)
   apply (rule hoare_lift_Pf[where f="\<lambda>s. arch_state s"])
-   apply (wp arch typs hoare_vcg_conj_lift hoare_vcg_const_Ball_lift)+
+   apply (wp arch typs caps hoare_vcg_conj_lift hoare_vcg_const_Ball_lift)+
+  done
+
+(* we usually have a rule for valid_ioports, but it often comes with side-conditions *)
+lemma valid_arch_state_lift_ioports_typ_at:
+  fixes Q
+  assumes typs: "\<And>T p. \<lbrace>typ_at (AArch T) p\<rbrace> f \<lbrace>\<lambda>_. typ_at (AArch T) p\<rbrace>"
+  assumes arch: "\<And>P. \<lbrace>\<lambda>s. P (arch_state s)\<rbrace> f \<lbrace>\<lambda>_ s. P (arch_state s)\<rbrace>"
+  assumes ports: "\<lbrace> Q \<rbrace> f \<lbrace>\<lambda>_. valid_ioports \<rbrace>"
+  shows "\<lbrace>valid_arch_state and Q\<rbrace> f \<lbrace>\<lambda>_. valid_arch_state\<rbrace>"
+  apply (simp add: valid_arch_state_def pred_conj_def)
+  apply (simp add: valid_arch_state_def valid_asid_table_def
+                   valid_global_pts_def valid_global_pds_def valid_global_pdpts_def)
+  (* we need to do this piece-wise so we can grab
+     `valid_ioports_2 (caps_of_state x) (arch_state x) \<and> Q x` at the end *)
+  apply (rule hoare_vcg_conj_lift[rotated])+
+  apply (solves \<open>wpsimp wp: ports\<close>)
+  (* the rest are trivial once arch_state is lifted out *)
+  apply (rule hoare_lift_Pf2[where f="\<lambda>s. arch_state s", OF _ arch],
+         solves \<open>wp typs hoare_vcg_conj_lift hoare_vcg_const_Ball_lift\<close>)+
   done
 
 lemma aobj_at_default_arch_cap_valid:
diff --git a/proof/invariant-abstract/X64/ArchIpc_AI.thy b/proof/invariant-abstract/X64/ArchIpc_AI.thy
index f3d5e977cb..d99816f59d 100644
--- a/proof/invariant-abstract/X64/ArchIpc_AI.thy
+++ b/proof/invariant-abstract/X64/ArchIpc_AI.thy
@@ -10,11 +10,7 @@ begin
 
 context Arch begin arch_global_naming
 
-named_theorems Ipc_AI_assms
-
-lemma cap_asid_PageCap_None [simp]:
-  "cap_asid (ArchObjectCap (PageCap d r R typ pgsz None)) = None"
-  by (simp add: cap_asid_def)
+named_theorems Ipc_AI_1_assms
 
 lemma arch_derive_cap_is_derived:
   "\<lbrace>\<lambda>s. cte_wp_at (\<lambda>cap . cap_master_cap cap =
@@ -36,7 +32,7 @@ lemma arch_derive_cap_is_derived:
              | rule conjI)+)
   done
 
-lemma derive_cap_is_derived [Ipc_AI_assms]:
+lemma derive_cap_is_derived [Ipc_AI_1_assms]:
   "\<lbrace>\<lambda>s. c'\<noteq> cap.NullCap \<longrightarrow> cte_wp_at (\<lambda>cap. cap_master_cap cap = cap_master_cap c'
                      \<and> (cap_badge cap, cap_badge c') \<in> capBadge_ordering False
                      \<and> cap_asid cap = cap_asid c'
@@ -62,7 +58,23 @@ lemma derive_cap_is_derived [Ipc_AI_assms]:
   apply(clarsimp simp: valid_cap_def)
   done
 
-lemma is_derived_cap_rights [simp, Ipc_AI_assms]:
+end
+
+interpretation Ipc_AI?: Ipc_AI
+proof goal_cases
+  interpret Arch .
+  case 1 show ?case by (unfold_locales; (fact Ipc_AI_1_assms)?)
+qed
+
+context Arch begin arch_global_naming
+
+named_theorems Ipc_AI_2_assms
+
+lemma cap_asid_PageCap_None [simp]:
+  "cap_asid (ArchObjectCap (PageCap d r R typ pgsz None)) = None"
+  by (simp add: cap_asid_def)
+
+lemma is_derived_cap_rights [simp, Ipc_AI_2_assms]:
   "is_derived m p (cap_rights_update R c) = is_derived m p c"
   apply (rule ext)
   apply (simp add: cap_rights_update_def is_derived_def is_cap_simps)
@@ -74,12 +86,12 @@ lemma is_derived_cap_rights [simp, Ipc_AI_assms]:
            split: arch_cap.split cap.split bool.splits)
 
 
-lemma data_to_message_info_valid [Ipc_AI_assms]:
+lemma data_to_message_info_valid [Ipc_AI_2_assms]:
   "valid_message_info (data_to_message_info w)"
   by (simp add: valid_message_info_def data_to_message_info_def  word_and_le1 msg_max_length_def
                 msg_max_extra_caps_def Let_def not_less mask_def)
 
-lemma get_extra_cptrs_length[wp, Ipc_AI_assms]:
+lemma get_extra_cptrs_length[wp, Ipc_AI_2_assms]:
   "\<lbrace>\<lambda>s . valid_message_info mi\<rbrace>
    get_extra_cptrs buf mi
    \<lbrace>\<lambda>rv s. length rv \<le> msg_max_extra_caps\<rbrace>"
@@ -94,19 +106,19 @@ lemma get_extra_cptrs_length[wp, Ipc_AI_assms]:
                  intro: length_upt)
   done
 
-lemma cap_asid_rights_update [simp, Ipc_AI_assms]:
+lemma cap_asid_rights_update [simp, Ipc_AI_2_assms]:
   "cap_asid (cap_rights_update R c) = cap_asid c"
   apply (simp add: cap_rights_update_def acap_rights_update_def split: cap.splits arch_cap.splits)
   apply (clarsimp simp: cap_asid_def)
   done
 
-lemma cap_rights_update_vs_cap_ref[simp, Ipc_AI_assms]:
+lemma cap_rights_update_vs_cap_ref[simp, Ipc_AI_2_assms]:
   "vs_cap_ref (cap_rights_update rs cap) = vs_cap_ref cap"
   by (simp add: vs_cap_ref_def cap_rights_update_def
                 acap_rights_update_def
          split: cap.split arch_cap.split)
 
-lemma is_derived_cap_rights2[simp, Ipc_AI_assms]:
+lemma is_derived_cap_rights2[simp, Ipc_AI_2_assms]:
   "is_derived m p c (cap_rights_update R c') = is_derived m p c c'"
   apply (case_tac c')
   apply (simp_all add:cap_rights_update_def)
@@ -116,12 +128,12 @@ lemma is_derived_cap_rights2[simp, Ipc_AI_assms]:
   apply (case_tac acap1)
    by (auto simp: acap_rights_update_def)
 
-lemma cap_range_update [simp, Ipc_AI_assms]:
+lemma cap_range_update [simp, Ipc_AI_2_assms]:
   "cap_range (cap_rights_update R cap) = cap_range cap"
   by (simp add: cap_range_def cap_rights_update_def acap_rights_update_def
          split: cap.splits arch_cap.splits)
 
-lemma derive_cap_idle[wp, Ipc_AI_assms]:
+lemma derive_cap_idle[wp, Ipc_AI_2_assms]:
   "\<lbrace>\<lambda>s. global_refs s \<inter> cap_range cap = {}\<rbrace>
    derive_cap slot cap
   \<lbrace>\<lambda>c s. global_refs s \<inter> cap_range c = {}\<rbrace>, -"
@@ -133,7 +145,7 @@ lemma derive_cap_idle[wp, Ipc_AI_assms]:
   apply (case_tac arch_cap, simp_all)
   done
 
-lemma arch_derive_cap_objrefs_iszombie [Ipc_AI_assms]:
+lemma arch_derive_cap_objrefs_iszombie [Ipc_AI_2_assms]:
   "\<lbrace>\<lambda>s . P (set_option (aobj_ref cap)) False s\<rbrace>
      arch_derive_cap cap
    \<lbrace>\<lambda>rv s. rv \<noteq> NullCap \<longrightarrow> P (obj_refs rv) (is_zombie rv) s\<rbrace>,-"
@@ -141,7 +153,7 @@ lemma arch_derive_cap_objrefs_iszombie [Ipc_AI_assms]:
       apply(rule hoare_pre, wpc?, wp+, simp)+
   done
 
-lemma obj_refs_remove_rights[simp, Ipc_AI_assms]:
+lemma obj_refs_remove_rights[simp, Ipc_AI_2_assms]:
   "obj_refs (remove_rights rs cap) = obj_refs cap"
   by (auto simp add: remove_rights_def cap_rights_update_def
                 acap_rights_update_def
@@ -156,7 +168,7 @@ lemma storeWord_um_inv:
   apply (simp add: upto0_7_def)
   done
 
-lemma store_word_offs_vms[wp, Ipc_AI_assms]:
+lemma store_word_offs_vms[wp, Ipc_AI_2_assms]:
   "\<lbrace>valid_machine_state\<rbrace> store_word_offs ptr offs v \<lbrace>\<lambda>_. valid_machine_state\<rbrace>"
 proof -
   have aligned_offset_ignore:
@@ -195,12 +207,12 @@ proof -
     done
 qed
 
-lemma is_zombie_update_cap_data[simp, Ipc_AI_assms]:
+lemma is_zombie_update_cap_data[simp, Ipc_AI_2_assms]:
   "is_zombie (update_cap_data P data cap) = is_zombie cap"
   by (clarsimp simp: update_cap_data_closedform arch_update_cap_data_def is_zombie_def Let_def
          split: cap.splits arch_cap.splits)
 
-lemma valid_msg_length_strengthen [Ipc_AI_assms]:
+lemma valid_msg_length_strengthen [Ipc_AI_2_assms]:
   "valid_message_info mi \<longrightarrow> unat (mi_length mi) \<le> msg_max_length"
   apply (clarsimp simp: valid_message_info_def)
   apply (subgoal_tac "unat (mi_length mi) \<le> unat (of_nat msg_max_length :: machine_word)")
@@ -208,7 +220,7 @@ lemma valid_msg_length_strengthen [Ipc_AI_assms]:
   apply (clarsimp simp: un_ui_le word_le_def)
   done
 
-lemma copy_mrs_in_user_frame[wp, Ipc_AI_assms]:
+lemma copy_mrs_in_user_frame[wp, Ipc_AI_2_assms]:
   "\<lbrace>in_user_frame p\<rbrace> copy_mrs t buf t' buf' n \<lbrace>\<lambda>rv. in_user_frame p\<rbrace>"
   by (simp add: in_user_frame_def) (wp hoare_vcg_ex_lift)
 
@@ -222,21 +234,21 @@ lemma make_arch_fault_msg_invs[wp]: "\<lbrace>P\<rbrace> make_arch_fault_msg f t
   apply wp
   done
 
-lemma make_fault_message_inv[wp, Ipc_AI_assms]:
+lemma make_fault_message_inv[wp, Ipc_AI_2_assms]:
   "\<lbrace>P\<rbrace> make_fault_msg ft t \<lbrace>\<lambda>rv. P\<rbrace>"
   apply (cases ft, simp_all split del: if_split)
      apply (wp as_user_inv getRestartPC_inv mapM_wp'
               | simp add: getRegister_def)+
   done
 
-lemma do_fault_transfer_invs[wp, Ipc_AI_assms]:
+lemma do_fault_transfer_invs[wp, Ipc_AI_2_assms]:
   "\<lbrace>invs and tcb_at receiver\<rbrace>
       do_fault_transfer badge sender receiver recv_buf
    \<lbrace>\<lambda>rv. invs\<rbrace>"
   by (simp add: do_fault_transfer_def split_def | wp
     | clarsimp split: option.split)+
 
-lemma lookup_ipc_buffer_in_user_frame[wp, Ipc_AI_assms]:
+lemma lookup_ipc_buffer_in_user_frame[wp, Ipc_AI_2_assms]:
   "\<lbrace>valid_objs and tcb_at t\<rbrace> lookup_ipc_buffer b t
    \<lbrace>case_option (\<lambda>_. True) in_user_frame\<rbrace>"
   apply (simp add: lookup_ipc_buffer_def)
@@ -338,9 +350,9 @@ lemma transfer_caps_non_null_cte_wp_at:
   done
 
 crunch do_fault_transfer
-  for cte_wp_at[wp,Ipc_AI_assms]: "cte_wp_at P p"
+  for cte_wp_at[wp,Ipc_AI_2_assms]: "cte_wp_at P p"
 
-lemma do_normal_transfer_non_null_cte_wp_at [Ipc_AI_assms]:
+lemma do_normal_transfer_non_null_cte_wp_at [Ipc_AI_2_assms]:
   assumes imp: "\<And>c. P c \<Longrightarrow> \<not> is_untyped_cap c"
   shows  "\<lbrace>valid_objs and cte_wp_at (P and ((\<noteq>) cap.NullCap)) ptr\<rbrace>
    do_normal_transfer st send_buffer ep b gr rt recv_buffer
@@ -351,7 +363,7 @@ lemma do_normal_transfer_non_null_cte_wp_at [Ipc_AI_assms]:
     | clarsimp simp:imp)+
   done
 
-lemma is_derived_ReplyCap [simp, Ipc_AI_assms]:
+lemma is_derived_ReplyCap [simp, Ipc_AI_2_assms]:
   "\<And>m p R. is_derived m p (cap.ReplyCap t False R) = (\<lambda>c. is_master_reply_cap c \<and> obj_ref_of c = t)"
   apply (subst fun_eq_iff)
   apply clarsimp
@@ -372,7 +384,7 @@ lemma do_normal_transfer_tcb_caps:
      | simp add:imp)+
   done
 
-lemma do_ipc_transfer_tcb_caps [Ipc_AI_assms]:
+lemma do_ipc_transfer_tcb_caps [Ipc_AI_2_assms]:
   assumes imp: "\<And>c. P c \<Longrightarrow> \<not> is_untyped_cap c"
   shows
   "\<lbrace>valid_objs and cte_wp_at P (t, ref) and tcb_at t\<rbrace>
@@ -384,14 +396,14 @@ lemma do_ipc_transfer_tcb_caps [Ipc_AI_assms]:
        | wpc | simp add:imp)+
   done
 
-lemma setup_caller_cap_valid_global_objs[wp, Ipc_AI_assms]:
+lemma setup_caller_cap_valid_global_objs[wp, Ipc_AI_2_assms]:
   "\<lbrace>valid_global_objs\<rbrace> setup_caller_cap send recv grant \<lbrace>\<lambda>rv. valid_global_objs\<rbrace>"
   apply (wp valid_global_objs_lift valid_vso_at_lift)
   apply (simp_all add: setup_caller_cap_def split del: if_split)
    apply (wp sts_obj_at_impossible | simp add: tcb_not_empty_table)+
   done
 
-lemma transfer_caps_loop_valid_vspace_objs[wp, Ipc_AI_assms]:
+lemma transfer_caps_loop_valid_vspace_objs[wp, Ipc_AI_2_assms]:
   "\<lbrace>valid_vspace_objs\<rbrace>
       transfer_caps_loop ep buffer n caps slots mi
     \<lbrace>\<lambda>rv. valid_vspace_objs\<rbrace>"
@@ -406,27 +418,82 @@ lemma transfer_caps_loop_valid_vspace_objs[wp, Ipc_AI_assms]:
         | assumption | simp split del: if_split)+
   done
 
-declare make_arch_fault_msg_invs[Ipc_AI_assms]
+declare make_arch_fault_msg_invs[Ipc_AI_2_assms]
 crunch handle_arch_fault_reply, arch_get_sanitise_register_info
-  for typ_at[Ipc_AI_assms]: "P (typ_at T p s)"
+  for typ_at[Ipc_AI_2_assms]: "P (typ_at T p s)"
+
+lemma transfer_caps_loop_ioports:
+  "\<And>slots caps ep buffer n mi.
+    \<lbrace>valid_ioports and valid_objs and valid_mdb and K (distinct slots)
+         and (\<lambda>s. \<forall>x \<in> set slots. real_cte_at x s \<and> cte_wp_at (\<lambda>cap. cap = cap.NullCap) x s)
+         and transfer_caps_srcs caps\<rbrace>
+      transfer_caps_loop ep buffer n caps slots mi
+    \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
+  apply (rule hoare_pre)
+   apply (rule transfer_caps_loop_presM[where vo=True and em=False and ex=False])
+     apply (wp cap_insert_derived_ioports)
+     apply (clarsimp simp: cte_wp_at_caps_of_state)
+    apply (wp valid_ioports_lift)
+   apply (clarsimp simp:cte_wp_at_caps_of_state|intro conjI ballI)+
+   apply (drule(1) bspec,clarsimp)
+   apply (frule(1) caps_of_state_valid)
+   apply (fastforce simp:valid_cap_def)
+  apply (drule(1) bspec)
+  apply clarsimp
+  done
+
+lemma transfer_caps_loop_valid_arch[Ipc_AI_2_assms]:
+  "\<And>slots caps ep buffer n mi.
+    \<lbrace>valid_arch_state and valid_objs and valid_mdb and K (distinct slots)
+         and (\<lambda>s. \<forall>x \<in> set slots. real_cte_at x s \<and> cte_wp_at (\<lambda>cap. cap = cap.NullCap) x s)
+         and transfer_caps_srcs caps\<rbrace>
+      transfer_caps_loop ep buffer n caps slots mi
+    \<lbrace>\<lambda>_. valid_arch_state\<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_ioports_aobj_at transfer_caps_loop_ioports
+                 transfer_caps_loop_aobj_at)
+     (simp add: valid_arch_state_def)
+
+lemma setup_caller_cap_aobj_at:
+  "arch_obj_pred P' \<Longrightarrow>
+  \<lbrace>\<lambda>s. P (obj_at P' pd s)\<rbrace> setup_caller_cap st rt grant \<lbrace>\<lambda>r s. P (obj_at P' pd s)\<rbrace>"
+  unfolding setup_caller_cap_def
+  by (wpsimp wp: cap_insert_aobj_at sts.aobj_at)
+
+lemma setup_caller_cap_valid_arch[Ipc_AI_2_assms, wp]:
+  "setup_caller_cap st rt grant \<lbrace>valid_arch_state\<rbrace>"
+  by (wp valid_arch_state_lift_ioports_aobj_at[rotated -1] setup_caller_cap_ioports
+         setup_caller_cap_aobj_at)
+     (simp add: valid_arch_state_def)
+
+crunch do_ipc_transfer
+  for ioports[wp]: "valid_ioports"
+  (wp: crunch_wps hoare_vcg_const_Ball_lift transfer_caps_loop_ioports
+   simp: zipWithM_x_mapM crunch_simps ball_conj_distrib )
 
 end
 
-interpretation Ipc_AI?: Ipc_AI
+interpretation Ipc_AI?: Ipc_AI_2
 proof goal_cases
   interpret Arch .
-  case 1 show ?case by (unfold_locales; (fact Ipc_AI_assms)?)
+  case 1 show ?case by (unfold_locales; (fact Ipc_AI_2_assms)?)
 qed
 
 context Arch begin arch_global_naming
 
-named_theorems Ipc_AI_cont_assms
+named_theorems Ipc_AI_3_assms
 
 crunch do_ipc_transfer
-  for pspace_respects_device_region[wp, Ipc_AI_cont_assms]: "pspace_respects_device_region"
+  for pspace_respects_device_region[wp, Ipc_AI_3_assms]: "pspace_respects_device_region"
   (wp: crunch_wps ignore: const_on_failure simp: crunch_simps)
 
-lemma do_ipc_transfer_respects_device_region[Ipc_AI_cont_assms]:
+lemma do_ipc_transfer_valid_arch[Ipc_AI_3_assms]:
+  "\<lbrace>valid_arch_state and valid_objs and valid_mdb \<rbrace>
+   do_ipc_transfer s ep bg grt r
+   \<lbrace>\<lambda>rv. valid_arch_state\<rbrace>"
+  by (wp valid_arch_state_lift_ioports_aobj_at do_ipc_transfer_ioports do_ipc_transfer_aobj_at)+
+     (simp add: valid_arch_state_def)
+
+lemma do_ipc_transfer_respects_device_region[Ipc_AI_3_assms]:
   "\<lbrace>cap_refs_respects_device_region and tcb_at t and  valid_objs and valid_mdb\<rbrace>
    do_ipc_transfer t ep bg grt r
    \<lbrace>\<lambda>rv. cap_refs_respects_device_region\<rbrace>"
@@ -453,7 +520,7 @@ lemma set_mrs_state_hyp_refs_of[wp]:
   by (wp set_mrs_thread_set_dmo thread_set_hyp_refs_trivial | simp)+
 
 crunch do_ipc_transfer
-  for state_hyp_refs_of[wp, Ipc_AI_cont_assms]: "\<lambda> s. P (state_hyp_refs_of s)"
+  for state_hyp_refs_of[wp, Ipc_AI_3_assms]: "\<lambda> s. P (state_hyp_refs_of s)"
   (wp: crunch_wps simp: zipWithM_x_mapM)
 
 lemma arch_derive_cap_untyped:
@@ -478,10 +545,10 @@ lemma valid_arch_mdb_cap_swap:
 
 end
 
-interpretation Ipc_AI?: Ipc_AI_cont
-  proof goal_cases
+interpretation Ipc_AI?: Ipc_AI_3
+proof goal_cases
   interpret Arch .
-  case 1 show ?case by (unfold_locales; (fact Ipc_AI_cont_assms)?)
-  qed
+  case 1 show ?case by (unfold_locales; (fact Ipc_AI_3_assms)?)
+qed
 
 end
diff --git a/proof/invariant-abstract/X64/ArchKHeap_AI.thy b/proof/invariant-abstract/X64/ArchKHeap_AI.thy
index 49b82438f1..b2551e9b08 100644
--- a/proof/invariant-abstract/X64/ArchKHeap_AI.thy
+++ b/proof/invariant-abstract/X64/ArchKHeap_AI.thy
@@ -303,10 +303,6 @@ lemma set_object_vs_lookup_pages:
   apply simp
   done
 
-lemma set_aobject_valid_arch [wp]:
-  "set_object ptr (ArchObj obj) \<lbrace>valid_arch_state\<rbrace>"
-  by (wpsimp wp: valid_arch_state_lift set_object_wp)
-
 lemma set_object_atyp_at:
   "\<lbrace>\<lambda>s. typ_at (AArch (aa_type ako)) p s \<and> P (typ_at (AArch T) p' s)\<rbrace>
     set_object p (ArchObj ako)
@@ -531,16 +527,44 @@ lemma valid_global_pdpts_lift:
   apply clarsimp
   done
 
-lemma valid_arch_state_lift_aobj_at:
-    "\<lbrace>valid_arch_state\<rbrace> f \<lbrace>\<lambda>rv. valid_arch_state\<rbrace>"
-  apply (simp add: valid_arch_state_def valid_asid_table_def)
+lemma valid_asid_table_lift:
+  "f \<lbrace>\<lambda>s. valid_asid_table (x64_asid_table (arch_state s)) s\<rbrace>"
+  apply (simp add: valid_asid_table_def)
   apply (rule hoare_lift_Pf[where f="arch_state", OF _ arch])
-  apply (wp hoare_vcg_conj_lift hoare_vcg_ball_lift
-            valid_global_pts_lift valid_global_pds_lift valid_global_pdpts_lift
-        | (rule aobj_at, clarsimp))+
+  apply (wp hoare_vcg_conj_lift hoare_vcg_ball_lift aobj_at)
+    apply wpsimp+
+  done
+
+lemma typ_at_lift:
+  "f \<lbrace>\<lambda>s. typ_at (AArch aty) (P (arch_state s)) s\<rbrace>"
+  by (rule hoare_lift_Pf2[where f="arch_state", OF _ arch])
+     (wpsimp wp: aobj_at)
+
+lemma valid_arch_state_lift_ioports_aobj_at:
+  fixes P
+  assumes ioports: "\<lbrace> P \<rbrace> f \<lbrace>\<lambda>_. valid_ioports \<rbrace>"
+  shows "\<lbrace>valid_arch_state and P\<rbrace> f \<lbrace>\<lambda>rv. valid_arch_state\<rbrace>"
+  apply (simp add: valid_arch_state_def)
+  apply (rule hoare_vcg_conj_lift
+         | wp valid_asid_table_lift typ_at_lift valid_global_pts_lift valid_global_pds_lift
+            valid_global_pdpts_lift)+
+  apply (rule hoare_lift_Pf[where f="arch_state", OF _ arch], wp)
+  apply (rule hoare_vcg_conj_lift)
+  apply (rule hoare_lift_Pf[where f="arch_state", OF _ arch], wp)
+  apply (wp ioports)
   apply simp
   done
 
+(* interface lemma *)
+lemma valid_arch_state_lift_aobj_at:
+  assumes caps: "\<And>P. \<lbrace>\<lambda>s. P (caps_of_state s)\<rbrace> f \<lbrace>\<lambda>_ s. P (caps_of_state s)\<rbrace>"
+  shows "f \<lbrace>valid_arch_state\<rbrace>"
+  apply (simp add: valid_arch_state_def valid_asid_table_def
+                   valid_global_pts_def valid_global_pds_def valid_global_pdpts_def)
+  apply (rule hoare_lift_Pf[where f="\<lambda>s. arch_state s"])
+   apply (wp arch typ_at_lift caps hoare_vcg_conj_lift hoare_vcg_const_Ball_lift)+
+  done
+
 end
 end
 
@@ -885,9 +909,9 @@ lemma valid_arch_tcb_same_type:
 lemma valid_ioports_lift:
   assumes x: "\<And>P. \<lbrace>\<lambda>s. P (caps_of_state s)\<rbrace> f \<lbrace>\<lambda>rv s. P (caps_of_state s)\<rbrace>"
   assumes y: "\<And>P. \<lbrace>\<lambda>s. P (arch_state s)\<rbrace> f \<lbrace>\<lambda>rv s. P (arch_state s)\<rbrace>"
-  shows      "\<lbrace>valid_ioports\<rbrace> f \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  apply (simp add: valid_ioports_def)
-  apply (rule hoare_use_eq [where f=caps_of_state, OF x y])
+  shows      "f \<lbrace> valid_ioports \<rbrace>"
+  apply (simp add: valid_ioports_2_def)
+  apply (rule hoare_use_eq[where f=caps_of_state, OF x y])
   done
 
 lemma valid_arch_mdb_lift:
diff --git a/proof/invariant-abstract/X64/ArchKernelInit_AI.thy b/proof/invariant-abstract/X64/ArchKernelInit_AI.thy
index 42bab0aa5b..a60898c122 100644
--- a/proof/invariant-abstract/X64/ArchKernelInit_AI.thy
+++ b/proof/invariant-abstract/X64/ArchKernelInit_AI.thy
@@ -301,13 +301,17 @@ lemma invs_A:
                          valid_reply_masters_def valid_global_refs_def
                          valid_refs_def[unfolded cte_wp_at_caps_of_state])
   apply (clarsimp, (thin_tac "_")+) (* use new proven assumptions, then drop them *)
-  apply (rule conjI)
-   apply (clarsimp simp: valid_arch_state_def)
    apply (rule conjI)
-    apply (clarsimp simp: valid_asid_table_def state_defs)
-   apply (simp add: valid_global_pts_def valid_global_pds_def valid_global_pdpts_def
-                    valid_arch_state_def state_defs obj_at_def a_type_def
-                    valid_cr3_def valid_x64_irq_state_def asid_wf_0)
+    apply (clarsimp simp: valid_arch_state_def)
+    apply (rule conjI)
+     apply (clarsimp simp: valid_asid_table_def state_defs)
+    apply (subgoal_tac "valid_ioports init_A_st")
+     apply (simp add: valid_global_pts_def valid_global_pds_def valid_global_pdpts_def
+                      valid_arch_state_def state_defs obj_at_def a_type_def
+                      valid_cr3_def valid_x64_irq_state_def asid_wf_0)
+    apply (clarsimp simp: valid_ioports_def caps_of_state_init_A_st_Null all_ioports_issued_def ran_def
+                          issued_ioports_def ioports_no_overlap_def
+                    cong: rev_conj_cong)
   apply (rule conjI)
    apply (clarsimp simp: valid_irq_node_def obj_at_def state_defs
                          is_cap_table_def wf_empty_bits
@@ -322,10 +326,6 @@ lemma invs_A:
   apply (rule conjI)
    apply (clarsimp simp: valid_irq_states_def state_defs init_machine_state_def
                          valid_irq_masks_def init_irq_masks_def)
-  apply (rule conjI)
-   apply (clarsimp simp: valid_ioports_def caps_of_state_init_A_st_Null all_ioports_issued_def ran_def
-                         issued_ioports_def ioports_no_overlap_def
-                   cong: rev_conj_cong)
   apply (rule conjI)
    apply (clarsimp simp: valid_machine_state_def state_defs
                          init_machine_state_def init_underlying_memory_def)
diff --git a/proof/invariant-abstract/X64/ArchRetype_AI.thy b/proof/invariant-abstract/X64/ArchRetype_AI.thy
index 660b51071e..4fda34a834 100644
--- a/proof/invariant-abstract/X64/ArchRetype_AI.thy
+++ b/proof/invariant-abstract/X64/ArchRetype_AI.thy
@@ -122,6 +122,10 @@ crunch init_arch_objects
   for valid_objs[wp]: "valid_objs"
   (ignore: clearMemory wp: crunch_wps simp: unless_def)
 
+crunch store_pml4e
+  for valid_arch_state[wp]: "valid_arch_state"
+  (wp: valid_arch_state_lift)
+
 crunch init_arch_objects
   for valid_arch_state[wp]: "valid_arch_state"
   (ignore: clearMemory set_pml4 set_object wp: crunch_wps simp: unless_def crunch_simps set_arch_obj_simps)
@@ -399,13 +403,17 @@ lemma set_object_ioports[wp]:
   by (wpsimp simp: set_object_def get_object_def valid_ioports_def caps_of_state_after_update)
 
 lemma update_aobj_ioports[wp]:
-  "\<lbrace>valid_ioports\<rbrace> set_object ptr (ArchObj obj) \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
+  "set_object ptr (ArchObj obj) \<lbrace>\<lambda>s. P (valid_ioports s) \<rbrace> "
   apply (subst set_object_def)
   apply (wpsimp wp: get_object_wp)
   apply (clarsimp simp: obj_at_def a_type_def valid_ioports_def caps_of_state_after_update
                  split: kernel_object.split_asm if_splits arch_kernel_obj.split_asm)
   done
 
+lemma set_object_arch_valid_arch_state[wp]:
+  "set_object ptr (ArchObj obj) \<lbrace> valid_arch_state \<rbrace> "
+  by (wp valid_arch_state_lift)
+
 lemma copy_global_invs_mappings_restricted:
   "\<lbrace>(\<lambda>s. all_invs_but_equal_kernel_mappings_restricted (insert pm S) s)
           and (\<lambda>s. insert pm S \<inter> global_refs s = {})
@@ -733,11 +741,6 @@ lemma valid_global_refs:
   apply (simp add: cte_retype cap_range_def)
   done
 
-lemma valid_arch_state:
-  "valid_arch_state s \<Longrightarrow> valid_arch_state s'"
-  by (clarsimp simp: valid_arch_state_def obj_at_pres
-                     valid_asid_table_def valid_global_pts_def valid_global_pds_def valid_global_pdpts_def)
-
 lemma vs_refs_default [simp]:
   "vs_refs (default_object ty dev us) = {}"
   by (simp add: default_object_def default_arch_object_def tyunt vs_refs_def
@@ -1007,6 +1010,13 @@ lemma valid_ioports:
   "valid_ioports s \<Longrightarrow> valid_ioports s'"
   by (clarsimp simp: valid_ioports_def ioports_no_overlap_eq all_ioports_issued_eq)
 
+lemma valid_arch_state:
+  "valid_arch_state s \<Longrightarrow> valid_arch_state s'"
+  unfolding valid_arch_state_def
+  by (strengthen valid_ioports,
+      clarsimp simp: valid_arch_state_def obj_at_pres valid_asid_table_def valid_global_pts_def
+                     valid_global_pds_def valid_global_pdpts_def)
+
 lemma valid_global_objs:
   "valid_global_objs s \<Longrightarrow> valid_global_objs s'"
   apply (simp add: valid_global_objs_def valid_vso_at_def)
@@ -1148,7 +1158,7 @@ lemma post_retype_invs:
                      valid_arch_caps valid_global_objs
                      valid_vspace_objs' valid_irq_handlers
                      valid_mdb_rep2 mdb_and_revokable
-                     valid_pspace cur_tcb only_idle valid_ioports
+                     valid_pspace cur_tcb only_idle
                      valid_kernel_mappings valid_asid_map_def
                      valid_global_vspace_mappings valid_ioc vms
                      pspace_in_kernel_window pspace_respects_device_region
diff --git a/proof/invariant-abstract/X64/ArchTcbAcc_AI.thy b/proof/invariant-abstract/X64/ArchTcbAcc_AI.thy
index 0e99b89850..a635a890db 100644
--- a/proof/invariant-abstract/X64/ArchTcbAcc_AI.thy
+++ b/proof/invariant-abstract/X64/ArchTcbAcc_AI.thy
@@ -173,6 +173,23 @@ lemma tcb_context_update_aux: "arch_tcb_context_set (P (arch_tcb_context_get atc
                                = tcb_context_update (\<lambda>ctx. P ctx) atcb"
   by (simp add: arch_tcb_context_set_def arch_tcb_context_get_def)
 
+crunch set_thread_state, set_bound_notification
+  for valid_ioports[wp]: valid_ioports
+  (wp: valid_ioports_lift)
+
+lemma thread_set_ioports:
+  assumes y: "\<And>tcb. \<forall>(getF, v) \<in> ran tcb_cap_cases.
+                  getF (f tcb) = getF tcb"
+  shows
+  "\<lbrace>valid_ioports\<rbrace> thread_set f t \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
+  by (wpsimp wp: valid_ioports_lift thread_set_caps_of_state_trivial y)
+
+lemma thread_set_valid_arch_state[TcbAcc_AI_assms]:
+  "(\<And>tcb. \<forall>(getF, v) \<in> ran tcb_cap_cases. getF (f tcb) = getF tcb)
+   \<Longrightarrow> thread_set f t \<lbrace> valid_arch_state \<rbrace>"
+  by (wp valid_arch_state_lift_ioports_aobj_at thread_set_ioports thread_set.aobj_at
+      | simp add: valid_arch_state_def)+
+
 end
 
 global_interpretation TcbAcc_AI?: TcbAcc_AI
diff --git a/proof/invariant-abstract/X64/ArchUntyped_AI.thy b/proof/invariant-abstract/X64/ArchUntyped_AI.thy
index 5c165920b1..65a303877f 100644
--- a/proof/invariant-abstract/X64/ArchUntyped_AI.thy
+++ b/proof/invariant-abstract/X64/ArchUntyped_AI.thy
@@ -266,7 +266,7 @@ lemma set_untyped_cap_invs_simple[Untyped_AI_assms]:
   apply wps
   apply (wp hoare_vcg_all_lift set_cap_irq_handlers set_cap_valid_arch_caps
     set_cap_irq_handlers cap_table_at_lift_valid set_cap_typ_at
-    set_untyped_cap_refs_respects_device_simple set_cap_ioports_no_new_ioports)
+    set_untyped_cap_refs_respects_device_simple set_cap_no_new_ioports_arch_valid_arch_state)
   apply (clarsimp simp:cte_wp_at_caps_of_state is_cap_simps)
   apply (intro conjI,clarsimp)
         apply (rule ext,clarsimp simp:is_cap_simps)
@@ -381,11 +381,18 @@ lemma create_cap_cap_refs_in_kernel_window[wp, Untyped_AI_assms]:
   apply blast
   done
 
-lemma create_cap_ioports[wp, Untyped_AI_assms]:
+lemma create_cap_ioports[wp]:
   "\<lbrace>valid_ioports and cte_wp_at (\<lambda>_. True) cref\<rbrace> create_cap tp sz p dev (cref,oref) \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by (wpsimp wp: set_cap_ioports' set_cdt_cte_wp_at
+  by (wpsimp wp: set_cap_ioports_safe set_cdt_cte_wp_at
               simp: safe_ioport_insert_not_ioport[OF default_cap_not_ioport] create_cap_def)
 
+lemma create_cap_valid_arch_state[wp, Untyped_AI_assms]:
+  "\<lbrace>valid_arch_state and cte_wp_at (\<lambda>_. True) cref\<rbrace>
+   create_cap tp sz p dev (cref,oref)
+   \<lbrace>\<lambda>rv. valid_arch_state\<rbrace>"
+  by (wp valid_arch_state_lift_ioports_aobj_at create_cap_aobj_at)+
+     (simp add: valid_arch_state_def)
+
 (* FIXME: move *)
 lemma simpler_store_pml4e_def:
   "store_pml4e p pde s =
@@ -585,6 +592,8 @@ lemma obj_is_device_vui_eq[Untyped_AI_assms]:
   apply (auto simp: arch_is_frame_type_def)
   done
 
+lemmas [Untyped_AI_assms] = set_cap_non_arch_valid_arch_state
+
 end
 
 global_interpretation Untyped_AI? : Untyped_AI
diff --git a/proof/invariant-abstract/X64/ArchVSpace_AI.thy b/proof/invariant-abstract/X64/ArchVSpace_AI.thy
index f542f1d43b..d8cae2e16f 100644
--- a/proof/invariant-abstract/X64/ArchVSpace_AI.thy
+++ b/proof/invariant-abstract/X64/ArchVSpace_AI.thy
@@ -244,6 +244,11 @@ lemma vs_lookup_pages_clear_asid_table:
   apply (clarsimp split: if_split_asm)
   done
 
+lemma valid_ioports_arch_state_simp[simp]:
+  "x64_allocated_io_ports (f (arch_state s)) = x64_allocated_io_ports (arch_state s)
+   \<Longrightarrow> valid_ioports_2 (caps_of_state s) (f (arch_state s)) = valid_ioports s"
+  unfolding valid_ioports_def ioports_no_overlap_def all_ioports_issued_def issued_ioports_def
+  by simp
 
 lemma valid_arch_state_unmap_strg:
   "valid_arch_state s \<longrightarrow>
@@ -252,7 +257,7 @@ lemma valid_arch_state_unmap_strg:
   apply (rule conjI)
    apply (clarsimp simp add: ran_def)
    apply blast
-  apply (clarsimp simp: inj_on_def)
+  apply (clarsimp simp: inj_on_def valid_ioports_def)
   done
 
 lemma valid_vspace_objs_unmap_strg:
@@ -1339,7 +1344,7 @@ lemma arch_update_cap_invs_map:
   apply (rule hoare_pre)
    apply (wp arch_update_cap_pspace arch_update_cap_valid_mdb set_cap_idle
              update_cap_ifunsafe valid_irq_node_typ set_cap_typ_at
-             set_cap_irq_handlers set_cap_valid_arch_caps set_cap_ioports_no_new_ioports
+             set_cap_irq_handlers set_cap_valid_arch_caps set_cap_no_new_ioports_arch_valid_arch_state
              set_cap_cap_refs_respects_device_region_spec[where ptr = p])
   apply (clarsimp simp: cte_wp_at_caps_of_state
               simp del: imp_disjL)
@@ -1418,7 +1423,7 @@ lemma arch_update_cap_invs_unmap_page:
   apply (rule hoare_pre)
    apply (wp arch_update_cap_pspace arch_update_cap_valid_mdb set_cap_idle
              update_cap_ifunsafe valid_irq_node_typ set_cap_typ_at
-             set_cap_irq_handlers set_cap_valid_arch_caps set_cap_ioports_no_new_ioports
+             set_cap_irq_handlers set_cap_valid_arch_caps set_cap_no_new_ioports_arch_valid_arch_state
              set_cap_cap_refs_respects_device_region_spec[where ptr = p])
   apply clarsimp
   apply (clarsimp simp: cte_wp_at_caps_of_state is_arch_update_def
@@ -1457,7 +1462,7 @@ lemma arch_update_cap_invs_unmap_page_table:
   apply (rule hoare_pre)
    apply (wp arch_update_cap_pspace arch_update_cap_valid_mdb set_cap_idle
              update_cap_ifunsafe valid_irq_node_typ set_cap_typ_at
-             set_cap_irq_handlers set_cap_valid_arch_caps set_cap_ioports_no_new_ioports
+             set_cap_irq_handlers set_cap_valid_arch_caps set_cap_no_new_ioports_arch_valid_arch_state
              set_cap_cap_refs_respects_device_region_spec[where ptr = p])
   apply (simp add: final_cap_at_eq)
   apply (clarsimp simp: cte_wp_at_caps_of_state is_arch_update_def
@@ -1501,7 +1506,7 @@ lemma arch_update_cap_invs_unmap_page_directory:
   apply (rule hoare_pre)
    apply (wp arch_update_cap_pspace arch_update_cap_valid_mdb set_cap_idle
              update_cap_ifunsafe valid_irq_node_typ set_cap_typ_at
-             set_cap_irq_handlers set_cap_valid_arch_caps set_cap_ioports_no_new_ioports
+             set_cap_irq_handlers set_cap_valid_arch_caps set_cap_no_new_ioports_arch_valid_arch_state
              set_cap_cap_refs_respects_device_region_spec[where ptr = p])
   apply (simp add: final_cap_at_eq)
   apply (clarsimp simp: cte_wp_at_caps_of_state is_arch_update_def
@@ -1545,7 +1550,7 @@ lemma arch_update_cap_invs_unmap_pd_pointer_table:
   apply (rule hoare_pre)
    apply (wp arch_update_cap_pspace arch_update_cap_valid_mdb set_cap_idle
              update_cap_ifunsafe valid_irq_node_typ set_cap_typ_at
-             set_cap_irq_handlers set_cap_valid_arch_caps set_cap_ioports_no_new_ioports
+             set_cap_irq_handlers set_cap_valid_arch_caps set_cap_no_new_ioports_arch_valid_arch_state
              set_cap_cap_refs_respects_device_region_spec[where ptr = p])
   apply (simp add: final_cap_at_eq)
   apply (clarsimp simp: cte_wp_at_caps_of_state is_arch_update_def

From 0a8b47d74c84090e9020b74c270da84f912c9426 Mon Sep 17 00:00:00 2001
From: Rafal Kolanski <rafal.kolanski@proofcraft.systems>
Date: Wed, 20 Nov 2024 21:30:32 +1100
Subject: [PATCH 25/31] arm+arm-hyp+riscv+aarch64 ainvs: conform to new
 valid_arch_state' interface

Previously valid_ioports was present on all arches. With it being
migrated to valid_arch_state on X64, the interface changed to include
valid_arch_state depending on caps. Update proofs to conform to the new
interface, removing all mentions of IO ports from non-X64 arches.

Signed-off-by: Rafal Kolanski <rafal.kolanski@proofcraft.systems>
---
 .../invariant-abstract/AARCH64/ArchAcc_AI.thy |   3 +-
 .../AARCH64/ArchArch_AI.thy                   |   9 +-
 .../AARCH64/ArchCNodeInv_AI.thy               |  26 +--
 .../AARCH64/ArchCSpaceInv_AI.thy              |  17 +-
 .../AARCH64/ArchCSpace_AI.thy                 |  20 +-
 .../AARCH64/ArchDetype_AI.thy                 |   4 -
 .../AARCH64/ArchFinalise_AI.thy               |   4 -
 .../AARCH64/ArchInvariants_AI.thy             |   7 -
 .../invariant-abstract/AARCH64/ArchIpc_AI.thy | 178 ++++++++++-------
 .../AARCH64/ArchKHeap_AI.thy                  |  18 +-
 .../AARCH64/ArchTcbAcc_AI.thy                 |   5 +
 .../AARCH64/ArchUntyped_AI.thy                |  16 +-
 .../ARM/ArchCNodeInv_AI.thy                   |  14 +-
 .../ARM/ArchCSpaceInv_AI.thy                  |  22 +--
 .../invariant-abstract/ARM/ArchCSpace_AI.thy  |  20 +-
 .../invariant-abstract/ARM/ArchDetype_AI.thy  |   4 -
 .../ARM/ArchFinalise_AI.thy                   |   4 -
 .../ARM/ArchInvariants_AI.thy                 |   7 +-
 proof/invariant-abstract/ARM/ArchIpc_AI.thy   | 111 +++++++----
 proof/invariant-abstract/ARM/ArchKHeap_AI.thy |  25 +--
 .../invariant-abstract/ARM/ArchTcbAcc_AI.thy  |   5 +
 .../invariant-abstract/ARM/ArchUntyped_AI.thy |  12 +-
 .../ARM_HYP/ArchCNodeInv_AI.thy               |  14 +-
 .../ARM_HYP/ArchCSpaceInv_AI.thy              |  22 +--
 .../ARM_HYP/ArchCSpace_AI.thy                 |  20 +-
 .../ARM_HYP/ArchDetype_AI.thy                 |   4 -
 .../ARM_HYP/ArchFinalise_AI.thy               |   4 -
 .../ARM_HYP/ArchInvariants_AI.thy             |   7 +-
 .../invariant-abstract/ARM_HYP/ArchIpc_AI.thy | 182 +++++++++++-------
 .../ARM_HYP/ArchKHeap_AI.thy                  |  24 +--
 .../ARM_HYP/ArchTcbAcc_AI.thy                 |   5 +-
 .../ARM_HYP/ArchUntyped_AI.thy                |  12 +-
 .../RISCV64/ArchArch_AI.thy                   |   9 +-
 .../RISCV64/ArchCNodeInv_AI.thy               |  26 +--
 .../RISCV64/ArchCSpaceInv_AI.thy              |  17 +-
 .../RISCV64/ArchCSpace_AI.thy                 |  20 +-
 .../RISCV64/ArchDetype_AI.thy                 |   4 -
 .../RISCV64/ArchFinalise_AI.thy               |   4 -
 .../RISCV64/ArchInvariants_AI.thy             |   7 -
 .../invariant-abstract/RISCV64/ArchIpc_AI.thy | 182 +++++++++++-------
 .../RISCV64/ArchKHeap_AI.thy                  |  18 +-
 .../RISCV64/ArchTcbAcc_AI.thy                 |   5 +
 .../RISCV64/ArchUntyped_AI.thy                |  16 +-
 43 files changed, 605 insertions(+), 528 deletions(-)

diff --git a/proof/invariant-abstract/AARCH64/ArchAcc_AI.thy b/proof/invariant-abstract/AARCH64/ArchAcc_AI.thy
index 7ff2c2d231..beb1772d77 100644
--- a/proof/invariant-abstract/AARCH64/ArchAcc_AI.thy
+++ b/proof/invariant-abstract/AARCH64/ArchAcc_AI.thy
@@ -2821,8 +2821,7 @@ lemma cap_refs_respects_device_region_dmo:
   done
 
 crunch do_machine_op
-  for valid_ioports[wp]: valid_ioports
-  and valid_vspace_objs[wp]: valid_vspace_objs
+  for valid_vspace_objs[wp]: valid_vspace_objs
   and valid_kernel_mappings[wp]: valid_kernel_mappings
   and equal_kernel_mappings[wp]: equal_kernel_mappings
   and valid_asid_map[wp]: valid_asid_map
diff --git a/proof/invariant-abstract/AARCH64/ArchArch_AI.thy b/proof/invariant-abstract/AARCH64/ArchArch_AI.thy
index 969da0e922..d64ceccfe9 100644
--- a/proof/invariant-abstract/AARCH64/ArchArch_AI.thy
+++ b/proof/invariant-abstract/AARCH64/ArchArch_AI.thy
@@ -611,13 +611,6 @@ lemma safe_parent_cap_is_device:
   "safe_parent_for m p cap pcap \<Longrightarrow> cap_is_device cap = cap_is_device pcap"
   by (simp add: safe_parent_for_def)
 
-lemma cap_insert_ioports_ap:
-  "\<lbrace>valid_ioports and (\<lambda>s. cte_wp_at (\<lambda>cap'. safe_ioport_insert cap cap' s) dest s) and
-        K (is_ap_cap cap)\<rbrace>
-     cap_insert cap src dest
-   \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by wpsimp
-
 crunch cap_insert
   for aobjs_of[wp]: "\<lambda>s. P (aobjs_of s)"
   (wp: crunch_wps)
@@ -642,7 +635,7 @@ lemma cap_insert_ap_invs:
   apply (simp cong: conj_cong)
   apply (rule hoare_pre)
    apply (wp cap_insert_simple_mdb cap_insert_iflive
-             cap_insert_zombies cap_insert_ifunsafe cap_insert_ioports_ap
+             cap_insert_zombies cap_insert_ifunsafe
              cap_insert_valid_global_refs cap_insert_idle
              valid_irq_node_typ cap_insert_simple_arch_caps_ap)
   apply (clarsimp simp: is_simple_cap_def cte_wp_at_caps_of_state is_cap_simps)
diff --git a/proof/invariant-abstract/AARCH64/ArchCNodeInv_AI.thy b/proof/invariant-abstract/AARCH64/ArchCNodeInv_AI.thy
index 2a9184bd13..b2677b80c6 100644
--- a/proof/invariant-abstract/AARCH64/ArchCNodeInv_AI.thy
+++ b/proof/invariant-abstract/AARCH64/ArchCNodeInv_AI.thy
@@ -427,15 +427,8 @@ lemma cap_swap_cap_refs_in_kernel_window[wp, CNodeInv_AI_assms]:
                simp: cte_wp_at_caps_of_state weak_derived_cap_range)
   done
 
-
-lemma cap_swap_ioports[wp, CNodeInv_AI_assms]:
-  "\<lbrace>valid_ioports and cte_wp_at (weak_derived c) a and cte_wp_at (weak_derived c') b\<rbrace>
-     cap_swap c a c' b
-   \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by wpsimp
-
 lemma cap_swap_vms[wp, CNodeInv_AI_assms]:
-  "\<lbrace>valid_machine_state\<rbrace>  cap_swap c a c' b \<lbrace>\<lambda>rv. valid_machine_state\<rbrace>"
+  "\<lbrace>valid_machine_state\<rbrace> cap_swap c a c' b \<lbrace>\<lambda>rv. valid_machine_state\<rbrace>"
   apply (simp add: valid_machine_state_def in_user_frame_def)
   apply (wp cap_swap_typ_at
             hoare_vcg_all_lift hoare_vcg_ex_lift hoare_vcg_disj_lift)
@@ -525,6 +518,12 @@ lemma prepare_thread_delete_thread_cap [CNodeInv_AI_assms]:
    \<lbrace>\<lambda>rv s. caps_of_state s x = Some (cap.ThreadCap p)\<rbrace>"
   by (wpsimp simp: prepare_thread_delete_def)
 
+lemma cap_swap_valid_arch_state[wp, CNodeInv_AI_assms]:
+  "\<lbrace>valid_arch_state and cte_wp_at (weak_derived c) a and cte_wp_at (weak_derived c') b\<rbrace>
+   cap_swap c a c' b
+   \<lbrace>\<lambda>_. valid_arch_state\<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps cap_swap_aobj_at)
+
 end
 
 
@@ -541,7 +540,7 @@ termination rec_del by (rule rec_del_termination)
 context Arch begin arch_global_naming
 
 lemma post_cap_delete_pre_is_final_cap':
-  "\<lbrakk>valid_ioports s; caps_of_state s slot = Some cap; is_final_cap' cap s; cap_cleanup_opt cap \<noteq> NullCap\<rbrakk>
+  "\<lbrakk> caps_of_state s slot = Some cap; is_final_cap' cap s; cap_cleanup_opt cap \<noteq> NullCap\<rbrakk>
    \<Longrightarrow> post_cap_delete_pre (cap_cleanup_opt cap) ((caps_of_state s)(slot \<mapsto> NullCap))"
   apply (clarsimp simp: cap_cleanup_opt_def cte_wp_at_def post_cap_delete_pre_def
                       split: cap.split_asm if_split_asm
@@ -932,14 +931,6 @@ global_interpretation CNodeInv_AI_4?: CNodeInv_AI_4
 
 context Arch begin arch_global_naming
 
-lemma cap_move_ioports:
-  "\<lbrace>valid_ioports and cte_wp_at ((=) cap.NullCap) ptr'
-         and cte_wp_at (weak_derived cap) ptr
-         and cte_wp_at (\<lambda>c. c \<noteq> cap.NullCap) ptr and K (ptr \<noteq> ptr')\<rbrace>
-     cap_move cap ptr ptr'
-   \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by wpsimp
-
 lemma cap_move_invs[wp, CNodeInv_AI_assms]:
   "\<lbrace>invs and valid_cap cap and cte_wp_at ((=) cap.NullCap) ptr'
          and tcb_cap_valid cap ptr'
@@ -959,7 +950,6 @@ lemma cap_move_invs[wp, CNodeInv_AI_assms]:
    apply (wpe cap_move_replies)
    apply (wpe cap_move_valid_arch_caps)
    apply (wpe cap_move_valid_ioc)
-   apply (wpe cap_move_ioports)
    apply (simp add: cap_move_def set_cdt_def)
    apply (rule hoare_pre)
     apply (wp set_cap_valid_objs set_cap_idle set_cap_typ_at
diff --git a/proof/invariant-abstract/AARCH64/ArchCSpaceInv_AI.thy b/proof/invariant-abstract/AARCH64/ArchCSpaceInv_AI.thy
index 3ad84874c7..6e45c680d2 100644
--- a/proof/invariant-abstract/AARCH64/ArchCSpaceInv_AI.thy
+++ b/proof/invariant-abstract/AARCH64/ArchCSpaceInv_AI.thy
@@ -14,20 +14,9 @@ begin
 
 context Arch begin arch_global_naming
 
-definition
-   safe_ioport_insert :: "cap \<Rightarrow> cap \<Rightarrow> 'a::state_ext state \<Rightarrow> bool"
-where
-  "safe_ioport_insert newcap oldcap \<equiv> \<lambda>_. True"
-
-lemma safe_ioport_insert_triv:
-  "\<not>is_arch_cap newcap \<Longrightarrow> safe_ioport_insert newcap oldcap s"
-  by (clarsimp simp: safe_ioport_insert_def)
-
-lemma set_cap_ioports':
- "\<lbrace>\<lambda>s. valid_ioports s \<and> cte_wp_at (\<lambda>cap'. safe_ioport_insert cap cap' s) ptr s\<rbrace>
-    set_cap cap ptr
-  \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by wpsimp
+lemma set_cap_valid_arch_state[wp]:
+  "set_cap cap ptr \<lbrace> valid_arch_state \<rbrace>"
+  by (wp valid_arch_state_lift_aobj_at_no_caps set_cap.aobj_at)
 
 lemma replace_cap_invs:
   "\<lbrace>\<lambda>s. invs s \<and> cte_wp_at (replaceable s p cap) p s
diff --git a/proof/invariant-abstract/AARCH64/ArchCSpace_AI.thy b/proof/invariant-abstract/AARCH64/ArchCSpace_AI.thy
index bc4db311ee..63f6cf92fb 100644
--- a/proof/invariant-abstract/AARCH64/ArchCSpace_AI.thy
+++ b/proof/invariant-abstract/AARCH64/ArchCSpace_AI.thy
@@ -477,15 +477,15 @@ lemma cap_insert_simple_arch_caps_no_ap:
   apply (intro conjI impI allI)
   by (auto simp:is_simple_cap_def[simplified is_simple_cap_arch_def] is_cap_simps)
 
-lemma setup_reply_master_ioports[wp, CSpace_AI_assms]:
-  "\<lbrace>valid_ioports\<rbrace> setup_reply_master c \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by wpsimp
+lemma cap_insert_derived_valid_arch_state[CSpace_AI_assms]:
+  "\<lbrace>valid_arch_state and (\<lambda>s. cte_wp_at (is_derived (cdt s) src cap) src s)\<rbrace>
+   cap_insert cap src dest
+   \<lbrace>\<lambda>rv. valid_arch_state \<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps cap_insert_aobj_at cap_insert_aobj_at)
 
-lemma cap_insert_derived_ioports[CSpace_AI_assms]:
-  "\<lbrace>valid_ioports and (\<lambda>s. cte_wp_at (is_derived (cdt s) src cap) src s)\<rbrace>
-     cap_insert cap src dest
-   \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by wpsimp
+lemma setup_reply_master_arch[CSpace_AI_assms]:
+  "setup_reply_master t \<lbrace> valid_arch_state \<rbrace>"
+  by (wpsimp simp: setup_reply_master_def wp: get_cap_wp)
 
 end
 
@@ -514,6 +514,10 @@ lemma is_cap_simps':
                             is_reply_cap_def is_master_reply_cap_def is_FrameCap_def
                      split: cap.splits arch_cap.splits)+
 
+lemma cap_insert_simple_valid_arch_state[wp]:
+  "cap_insert cap src dest \<lbrace> valid_arch_state\<rbrace>"
+  by (wp valid_arch_state_lift_aobj_at_no_caps cap_insert_aobj_at)+
+
 lemma cap_insert_simple_invs:
   "\<lbrace>invs and valid_cap cap and tcb_cap_valid cap dest and
     ex_cte_cap_wp_to (appropriate_cte_cap cap) dest and
diff --git a/proof/invariant-abstract/AARCH64/ArchDetype_AI.thy b/proof/invariant-abstract/AARCH64/ArchDetype_AI.thy
index b7a66c2305..775360f716 100644
--- a/proof/invariant-abstract/AARCH64/ArchDetype_AI.thy
+++ b/proof/invariant-abstract/AARCH64/ArchDetype_AI.thy
@@ -108,10 +108,6 @@ lemma state_hyp_refs_of_detype:
   "state_hyp_refs_of (detype S s) = (\<lambda>x. if x \<in> 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_assms]:
-  "valid_ioports s \<Longrightarrow> valid_ioports (detype (untyped_range cap) s)"
-  by simp
-
 end
 
 interpretation Detype_AI?: Detype_AI
diff --git a/proof/invariant-abstract/AARCH64/ArchFinalise_AI.thy b/proof/invariant-abstract/AARCH64/ArchFinalise_AI.thy
index 4557bb0ada..1e56245c52 100644
--- a/proof/invariant-abstract/AARCH64/ArchFinalise_AI.thy
+++ b/proof/invariant-abstract/AARCH64/ArchFinalise_AI.thy
@@ -1980,10 +1980,6 @@ lemma (* zombie_cap_two_nonidles *)[Finalise_AI_assms]:
   apply (cases ptr, auto dest: valid_idle_has_null_cap_ARCH[rotated -1])[1]
   done
 
-crunch empty_slot, finalise_cap, send_ipc, receive_ipc
-  for ioports[wp]: valid_ioports
-  (wp: crunch_wps valid_ioports_lift simp: crunch_simps ignore: set_object)
-
 lemma arch_derive_cap_notzombie[wp]:
   "\<lbrace>\<top>\<rbrace> arch_derive_cap acap \<lbrace>\<lambda>rv s. \<not> is_zombie rv\<rbrace>, -"
   by (cases acap; wpsimp simp: arch_derive_cap_def is_zombie_def o_def)
diff --git a/proof/invariant-abstract/AARCH64/ArchInvariants_AI.thy b/proof/invariant-abstract/AARCH64/ArchInvariants_AI.thy
index ee66eb7045..9923512a95 100644
--- a/proof/invariant-abstract/AARCH64/ArchInvariants_AI.thy
+++ b/proof/invariant-abstract/AARCH64/ArchInvariants_AI.thy
@@ -721,9 +721,6 @@ definition valid_asid_map :: "'z::state_ext state \<Rightarrow> bool" where
 definition valid_global_objs :: "'z::state_ext state \<Rightarrow> bool" where
   "valid_global_objs \<equiv> \<top>"
 
-definition valid_ioports :: "'z::state_ext state \<Rightarrow> bool" where
-  [simp]: "valid_ioports \<equiv> \<top>"
-
 
 (* This definition is needed as interface for other architectures only.
    In other architectures, S is a set of object references (to global tables) that
@@ -3142,10 +3139,6 @@ context Arch_p_arch_update_eq begin
 sublocale Arch_p_asid_table_update_eq
   by unfold_locales (simp add: arch)
 
-lemma valid_ioports_update[iff]:
-  "valid_ioports (f s) = valid_ioports s"
-  by simp
-
 lemma cur_vcpu_update [iff]:
   "cur_vcpu (f s) = cur_vcpu s"
   by (simp add: arch)
diff --git a/proof/invariant-abstract/AARCH64/ArchIpc_AI.thy b/proof/invariant-abstract/AARCH64/ArchIpc_AI.thy
index 0c3835fe49..eea8df7d31 100644
--- a/proof/invariant-abstract/AARCH64/ArchIpc_AI.thy
+++ b/proof/invariant-abstract/AARCH64/ArchIpc_AI.thy
@@ -11,7 +11,7 @@ begin
 
 context Arch begin arch_global_naming
 
-named_theorems Ipc_AI_assms
+named_theorems Ipc_AI_1_assms
 
 lemma cap_asid_PageCap_None[simp]:
   "cap_asid (ArchObjectCap (FrameCap r R pgsz dev None)) = None"
@@ -37,7 +37,7 @@ lemma arch_derive_cap_is_derived:
              | rule conjI)+)
   done
 
-lemma derive_cap_is_derived [Ipc_AI_assms]:
+lemma derive_cap_is_derived [Ipc_AI_1_assms]:
   "\<lbrace>\<lambda>s. c'\<noteq> cap.NullCap \<longrightarrow> cte_wp_at (\<lambda>cap. cap_master_cap cap = cap_master_cap c'
                      \<and> (cap_badge cap, cap_badge c') \<in> capBadge_ordering False
                      \<and> cap_asid cap = cap_asid c'
@@ -63,7 +63,19 @@ lemma derive_cap_is_derived [Ipc_AI_assms]:
   apply(clarsimp simp: valid_cap_def)
   done
 
-lemma is_derived_cap_rights [simp, Ipc_AI_assms]:
+end
+
+interpretation Ipc_AI?: Ipc_AI
+proof goal_cases
+  interpret Arch .
+  case 1 show ?case by (unfold_locales; (fact Ipc_AI_1_assms)?)
+qed
+
+context Arch begin arch_global_naming
+
+named_theorems Ipc_AI_2_assms
+
+lemma is_derived_cap_rights [simp, Ipc_AI_2_assms]:
   "is_derived m p (cap_rights_update R c) = is_derived m p c"
   apply (rule ext)
   apply (simp add: cap_rights_update_def is_derived_def is_cap_simps)
@@ -75,12 +87,12 @@ lemma is_derived_cap_rights [simp, Ipc_AI_assms]:
            split: arch_cap.split cap.split bool.splits)
 
 
-lemma data_to_message_info_valid [Ipc_AI_assms]:
+lemma data_to_message_info_valid [Ipc_AI_2_assms]:
   "valid_message_info (data_to_message_info w)"
   by (simp add: valid_message_info_def data_to_message_info_def  word_and_le1 msg_max_length_def
                 msg_max_extra_caps_def Let_def not_less mask_def)
 
-lemma get_extra_cptrs_length[wp, Ipc_AI_assms]:
+lemma get_extra_cptrs_length[wp, Ipc_AI_2_assms]:
   "\<lbrace>\<lambda>s . valid_message_info mi\<rbrace>
    get_extra_cptrs buf mi
    \<lbrace>\<lambda>rv s. length rv \<le> msg_max_extra_caps\<rbrace>"
@@ -95,17 +107,17 @@ lemma get_extra_cptrs_length[wp, Ipc_AI_assms]:
                  intro: length_upt)
   done
 
-lemma cap_asid_rights_update [simp, Ipc_AI_assms]:
+lemma cap_asid_rights_update [simp, Ipc_AI_2_assms]:
   "cap_asid (cap_rights_update R c) = cap_asid c"
   by (simp add: cap_rights_update_def acap_rights_update_def cap_asid_def
          split: cap.splits arch_cap.splits)
 
-lemma cap_rights_update_vs_cap_ref[simp, Ipc_AI_assms]:
+lemma cap_rights_update_vs_cap_ref[simp, Ipc_AI_2_assms]:
   "vs_cap_ref (cap_rights_update rs cap) = vs_cap_ref cap"
   by (simp add: vs_cap_ref_def vs_cap_ref_arch_def cap_rights_update_def acap_rights_update_def
          split: cap.split arch_cap.split)
 
-lemma is_derived_cap_rights2[simp, Ipc_AI_assms]:
+lemma is_derived_cap_rights2[simp, Ipc_AI_2_assms]:
   "is_derived m p c (cap_rights_update R c') = is_derived m p c c'"
   apply (case_tac c'; simp add: cap_rights_update_def)
      apply (clarsimp simp: is_derived_def is_cap_simps cap_master_cap_def vs_cap_ref_def
@@ -114,12 +126,12 @@ lemma is_derived_cap_rights2[simp, Ipc_AI_assms]:
   apply (case_tac acap1)
   by (auto simp: acap_rights_update_def)
 
-lemma cap_range_update [simp, Ipc_AI_assms]:
+lemma cap_range_update [simp, Ipc_AI_2_assms]:
   "cap_range (cap_rights_update R cap) = cap_range cap"
   by (simp add: cap_range_def cap_rights_update_def acap_rights_update_def
          split: cap.splits arch_cap.splits)
 
-lemma derive_cap_idle[wp, Ipc_AI_assms]:
+lemma derive_cap_idle[wp, Ipc_AI_2_assms]:
   "\<lbrace>\<lambda>s. global_refs s \<inter> cap_range cap = {}\<rbrace>
    derive_cap slot cap
   \<lbrace>\<lambda>c s. global_refs s \<inter> cap_range c = {}\<rbrace>, -"
@@ -131,7 +143,7 @@ lemma derive_cap_idle[wp, Ipc_AI_assms]:
   apply (case_tac arch_cap, simp_all)
   done
 
-lemma arch_derive_cap_objrefs_iszombie [Ipc_AI_assms]:
+lemma arch_derive_cap_objrefs_iszombie [Ipc_AI_2_assms]:
   "\<lbrace>\<lambda>s . P (set_option (aobj_ref cap)) False s\<rbrace>
      arch_derive_cap cap
    \<lbrace>\<lambda>rv s. rv \<noteq> NullCap \<longrightarrow> P (obj_refs rv) (is_zombie rv) s\<rbrace>,-"
@@ -139,7 +151,7 @@ lemma arch_derive_cap_objrefs_iszombie [Ipc_AI_assms]:
       apply(rule hoare_pre, wpsimp+)+
   done
 
-lemma obj_refs_remove_rights[simp, Ipc_AI_assms]:
+lemma obj_refs_remove_rights[simp, Ipc_AI_2_assms]:
   "obj_refs (remove_rights rs cap) = obj_refs cap"
   by (auto simp add: remove_rights_def cap_rights_update_def
                 acap_rights_update_def
@@ -151,7 +163,7 @@ lemma storeWord_um_inv:
    \<lbrace>\<lambda>_ s. is_aligned a 3 \<and> x \<in> {a,a+1,a+2,a+3,a+4,a+5,a+6,a+7} \<or> underlying_memory s x = um x\<rbrace>"
   by (wpsimp simp: upto.simps storeWord_def is_aligned_mask)
 
-lemma store_word_offs_vms[wp, Ipc_AI_assms]:
+lemma store_word_offs_vms[wp, Ipc_AI_2_assms]:
   "\<lbrace>valid_machine_state\<rbrace> store_word_offs ptr offs v \<lbrace>\<lambda>_. valid_machine_state\<rbrace>"
 proof -
   have aligned_offset_ignore:
@@ -190,12 +202,12 @@ proof -
     done
 qed
 
-lemma is_zombie_update_cap_data[simp, Ipc_AI_assms]:
+lemma is_zombie_update_cap_data[simp, Ipc_AI_2_assms]:
   "is_zombie (update_cap_data P data cap) = is_zombie cap"
   by (simp add: update_cap_data_closedform arch_update_cap_data_def is_zombie_def
          split: cap.splits)
 
-lemma valid_msg_length_strengthen [Ipc_AI_assms]:
+lemma valid_msg_length_strengthen [Ipc_AI_2_assms]:
   "valid_message_info mi \<longrightarrow> unat (mi_length mi) \<le> msg_max_length"
   apply (clarsimp simp: valid_message_info_def)
   apply (subgoal_tac "unat (mi_length mi) \<le> unat (of_nat msg_max_length :: machine_word)")
@@ -203,17 +215,17 @@ lemma valid_msg_length_strengthen [Ipc_AI_assms]:
   apply (clarsimp simp: un_ui_le word_le_def)
   done
 
-lemma copy_mrs_in_user_frame[wp, Ipc_AI_assms]:
+lemma copy_mrs_in_user_frame[wp, Ipc_AI_2_assms]:
   "\<lbrace>in_user_frame p\<rbrace> copy_mrs t buf t' buf' n \<lbrace>\<lambda>rv. in_user_frame p\<rbrace>"
   by (simp add: in_user_frame_def) (wp hoare_vcg_ex_lift)
 
 lemma as_user_getRestart_invs[wp]: "\<lbrace>P\<rbrace> as_user t getRestartPC \<lbrace>\<lambda>_. P\<rbrace>"
   by (simp add: getRestartPC_def, rule user_getreg_inv)
 
-lemma make_arch_fault_msg_invs[wp, Ipc_AI_assms]: "make_arch_fault_msg f t \<lbrace>invs\<rbrace>"
+lemma make_arch_fault_msg_invs[wp, Ipc_AI_2_assms]: "make_arch_fault_msg f t \<lbrace>invs\<rbrace>"
   by (cases f; wpsimp)
 
-lemma make_fault_message_inv[wp, Ipc_AI_assms]:
+lemma make_fault_message_inv[wp, Ipc_AI_2_assms]:
   "make_fault_msg ft t \<lbrace>invs\<rbrace>"
   apply (cases ft, simp_all split del: if_split)
      apply (wp as_user_inv getRestartPC_inv mapM_wp'
@@ -223,14 +235,14 @@ lemma make_fault_message_inv[wp, Ipc_AI_assms]:
 crunch make_fault_msg
   for tcb_at[wp]: "tcb_at t"
 
-lemma do_fault_transfer_invs[wp, Ipc_AI_assms]:
+lemma do_fault_transfer_invs[wp, Ipc_AI_2_assms]:
   "\<lbrace>invs and tcb_at receiver\<rbrace>
       do_fault_transfer badge sender receiver recv_buf
    \<lbrace>\<lambda>rv. invs\<rbrace>"
   by (simp add: do_fault_transfer_def split_def | wp
     | clarsimp split: option.split)+
 
-lemma lookup_ipc_buffer_in_user_frame[wp, Ipc_AI_assms]:
+lemma lookup_ipc_buffer_in_user_frame[wp, Ipc_AI_2_assms]:
   "\<lbrace>valid_objs and tcb_at t\<rbrace> lookup_ipc_buffer b t
    \<lbrace>case_option (\<lambda>_. True) in_user_frame\<rbrace>"
   apply (simp add: lookup_ipc_buffer_def)
@@ -327,9 +339,9 @@ lemma transfer_caps_non_null_cte_wp_at:
   done
 
 crunch do_fault_transfer
-  for cte_wp_at[wp,Ipc_AI_assms]: "cte_wp_at P p"
+  for cte_wp_at[wp,Ipc_AI_2_assms]: "cte_wp_at P p"
 
-lemma do_normal_transfer_non_null_cte_wp_at [Ipc_AI_assms]:
+lemma do_normal_transfer_non_null_cte_wp_at [Ipc_AI_2_assms]:
   assumes imp: "\<And>c. P c \<Longrightarrow> \<not> is_untyped_cap c"
   shows  "\<lbrace>valid_objs and cte_wp_at (P and ((\<noteq>) cap.NullCap)) ptr\<rbrace>
    do_normal_transfer st send_buffer ep b gr rt recv_buffer
@@ -340,7 +352,7 @@ lemma do_normal_transfer_non_null_cte_wp_at [Ipc_AI_assms]:
     | clarsimp simp:imp)+
   done
 
-lemma is_derived_ReplyCap [simp, Ipc_AI_assms]:
+lemma is_derived_ReplyCap [simp, Ipc_AI_2_assms]:
   "\<And>m p R. is_derived m p (cap.ReplyCap t False R) = (\<lambda>c. is_master_reply_cap c \<and> obj_ref_of c = t)"
   apply (subst fun_eq_iff)
   apply clarsimp
@@ -361,7 +373,7 @@ lemma do_normal_transfer_tcb_caps:
      | simp add:imp)+
   done
 
-lemma do_ipc_transfer_tcb_caps [Ipc_AI_assms]:
+lemma do_ipc_transfer_tcb_caps [Ipc_AI_2_assms]:
   assumes imp: "\<And>c. P c \<Longrightarrow> \<not> is_untyped_cap c"
   shows
   "\<lbrace>valid_objs and cte_wp_at P (t, ref) and tcb_at t\<rbrace>
@@ -373,7 +385,7 @@ lemma do_ipc_transfer_tcb_caps [Ipc_AI_assms]:
        | wpc | simp add:imp)+
   done
 
-lemma setup_caller_cap_valid_global_objs[wp, Ipc_AI_assms]:
+lemma setup_caller_cap_valid_global_objs[wp, Ipc_AI_2_assms]:
   "\<lbrace>valid_global_objs\<rbrace> setup_caller_cap send recv grant \<lbrace>\<lambda>rv. valid_global_objs\<rbrace>"
   apply (simp add: valid_global_objs_def)
   unfolding setup_caller_cap_def
@@ -381,9 +393,9 @@ lemma setup_caller_cap_valid_global_objs[wp, Ipc_AI_assms]:
   done
 
 crunch handle_arch_fault_reply, arch_get_sanitise_register_info
-  for inv[Ipc_AI_assms]: P
+  for inv[Ipc_AI_2_assms]: P
 
-lemma transfer_caps_loop_valid_vspace_objs[wp, Ipc_AI_assms]:
+lemma transfer_caps_loop_valid_vspace_objs[wp, Ipc_AI_2_assms]:
   "\<lbrace>valid_vspace_objs\<rbrace>
       transfer_caps_loop ep buffer n caps slots mi
     \<lbrace>\<lambda>rv. valid_vspace_objs\<rbrace>"
@@ -399,72 +411,72 @@ lemma transfer_caps_loop_valid_vspace_objs[wp, Ipc_AI_assms]:
   done
 
 crunch  make_arch_fault_msg
-  for aligned[wp, Ipc_AI_assms]: "pspace_aligned"
+  for aligned[wp, Ipc_AI_2_assms]: "pspace_aligned"
 crunch  make_arch_fault_msg
-  for distinct[wp, Ipc_AI_assms]: "pspace_distinct"
+  for distinct[wp, Ipc_AI_2_assms]: "pspace_distinct"
 crunch  make_arch_fault_msg
-  for vmdb[wp, Ipc_AI_assms]: "valid_mdb"
+  for vmdb[wp, Ipc_AI_2_assms]: "valid_mdb"
 crunch  make_arch_fault_msg
-  for ifunsafe[wp, Ipc_AI_assms]: "if_unsafe_then_cap"
+  for ifunsafe[wp, Ipc_AI_2_assms]: "if_unsafe_then_cap"
 crunch  make_arch_fault_msg
-  for iflive[wp, Ipc_AI_assms]: "if_live_then_nonz_cap"
+  for iflive[wp, Ipc_AI_2_assms]: "if_live_then_nonz_cap"
 crunch  make_arch_fault_msg
-  for state_refs_of[wp, Ipc_AI_assms]: "\<lambda>s. P (state_refs_of s)"
+  for state_refs_of[wp, Ipc_AI_2_assms]: "\<lambda>s. P (state_refs_of s)"
 crunch  make_arch_fault_msg
-  for ct[wp, Ipc_AI_assms]: "cur_tcb"
+  for ct[wp, Ipc_AI_2_assms]: "cur_tcb"
 crunch  make_arch_fault_msg
-  for zombies[wp, Ipc_AI_assms]: "zombies_final"
+  for zombies[wp, Ipc_AI_2_assms]: "zombies_final"
 crunch  make_arch_fault_msg
-  for it[wp, Ipc_AI_assms]: "\<lambda>s. P (idle_thread s)"
+  for it[wp, Ipc_AI_2_assms]: "\<lambda>s. P (idle_thread s)"
 crunch  make_arch_fault_msg
-  for valid_globals[wp, Ipc_AI_assms]: "valid_global_refs"
+  for valid_globals[wp, Ipc_AI_2_assms]: "valid_global_refs"
 crunch  make_arch_fault_msg
-  for reply_masters[wp, Ipc_AI_assms]: "valid_reply_masters"
+  for reply_masters[wp, Ipc_AI_2_assms]: "valid_reply_masters"
 crunch  make_arch_fault_msg
-  for valid_idle[wp, Ipc_AI_assms]: "valid_idle"
+  for valid_idle[wp, Ipc_AI_2_assms]: "valid_idle"
 crunch  make_arch_fault_msg
-  for arch[wp, Ipc_AI_assms]: "\<lambda>s. P (arch_state s)"
+  for arch[wp, Ipc_AI_2_assms]: "\<lambda>s. P (arch_state s)"
 crunch  make_arch_fault_msg
-  for typ_at[wp, Ipc_AI_assms]: "\<lambda>s. P (typ_at T p s)"
+  for typ_at[wp, Ipc_AI_2_assms]: "\<lambda>s. P (typ_at T p s)"
 crunch  make_arch_fault_msg
-  for irq_node[wp, Ipc_AI_assms]: "\<lambda>s. P (interrupt_irq_node s)"
+  for irq_node[wp, Ipc_AI_2_assms]: "\<lambda>s. P (interrupt_irq_node s)"
 crunch  make_arch_fault_msg
-  for valid_reply[wp, Ipc_AI_assms]: "valid_reply_caps"
+  for valid_reply[wp, Ipc_AI_2_assms]: "valid_reply_caps"
 crunch  make_arch_fault_msg
-  for irq_handlers[wp, Ipc_AI_assms]: "valid_irq_handlers"
+  for irq_handlers[wp, Ipc_AI_2_assms]: "valid_irq_handlers"
 crunch  make_arch_fault_msg
-  for vspace_objs[wp, Ipc_AI_assms]: "valid_vspace_objs"
+  for vspace_objs[wp, Ipc_AI_2_assms]: "valid_vspace_objs"
 crunch  make_arch_fault_msg
-  for global_objs[wp, Ipc_AI_assms]: "valid_global_objs"
+  for global_objs[wp, Ipc_AI_2_assms]: "valid_global_objs"
 crunch  make_arch_fault_msg
-  for global_vspace_mapping[wp, Ipc_AI_assms]: "valid_global_vspace_mappings"
+  for global_vspace_mapping[wp, Ipc_AI_2_assms]: "valid_global_vspace_mappings"
 crunch  make_arch_fault_msg
-  for arch_caps[wp, Ipc_AI_assms]: "valid_arch_caps"
+  for arch_caps[wp, Ipc_AI_2_assms]: "valid_arch_caps"
 crunch  make_arch_fault_msg
-  for eq_ker_map[wp, Ipc_AI_assms]: "equal_kernel_mappings"
+  for eq_ker_map[wp, Ipc_AI_2_assms]: "equal_kernel_mappings"
 crunch  make_arch_fault_msg
-  for asid_map[wp, Ipc_AI_assms]: "valid_asid_map"
+  for asid_map[wp, Ipc_AI_2_assms]: "valid_asid_map"
 crunch  make_arch_fault_msg
-  for only_idle[wp, Ipc_AI_assms]: "only_idle"
+  for only_idle[wp, Ipc_AI_2_assms]: "only_idle"
 crunch  make_arch_fault_msg
-  for pspace_in_kernel_window[wp, Ipc_AI_assms]: "pspace_in_kernel_window"
+  for pspace_in_kernel_window[wp, Ipc_AI_2_assms]: "pspace_in_kernel_window"
 crunch  make_arch_fault_msg
-  for cap_refs_in_kernel_window[wp, Ipc_AI_assms]: "cap_refs_in_kernel_window"
+  for cap_refs_in_kernel_window[wp, Ipc_AI_2_assms]: "cap_refs_in_kernel_window"
 crunch  make_arch_fault_msg
-  for valid_objs[wp, Ipc_AI_assms]: "valid_objs"
+  for valid_objs[wp, Ipc_AI_2_assms]: "valid_objs"
 crunch  make_arch_fault_msg
-  for valid_ioc[wp, Ipc_AI_assms]: "valid_ioc"
+  for valid_ioc[wp, Ipc_AI_2_assms]: "valid_ioc"
 crunch  make_arch_fault_msg
-  for pred_tcb[wp, Ipc_AI_assms]: "pred_tcb_at proj P t"
+  for pred_tcb[wp, Ipc_AI_2_assms]: "pred_tcb_at proj P t"
 crunch  make_arch_fault_msg
-  for cap_to[wp, Ipc_AI_assms]: "ex_nonz_cap_to p"
+  for cap_to[wp, Ipc_AI_2_assms]: "ex_nonz_cap_to p"
 
 crunch  make_arch_fault_msg
-  for v_ker_map[wp, Ipc_AI_assms]: "valid_kernel_mappings"
+  for v_ker_map[wp, Ipc_AI_2_assms]: "valid_kernel_mappings"
  (simp: valid_kernel_mappings_def)
 
 crunch  make_arch_fault_msg
-  for obj_at[wp, Ipc_AI_assms]: "\<lambda>s. P (obj_at P' pd s)"
+  for obj_at[wp, Ipc_AI_2_assms]: "\<lambda>s. P (obj_at P' pd s)"
   (wp: as_user_inv getRestartPC_inv mapM_wp'  simp: getRegister_def)
 
 lemma dmo_addressTranslateS1_valid_machine_state[wp]:
@@ -472,7 +484,7 @@ lemma dmo_addressTranslateS1_valid_machine_state[wp]:
   by (wpsimp wp: dmo_valid_machine_state)
 
 crunch make_arch_fault_msg
-  for vms[wp, Ipc_AI_assms]: valid_machine_state
+  for vms[wp, Ipc_AI_2_assms]: valid_machine_state
   (wp: as_user_inv getRestartPC_inv mapM_wp'  simp: getRegister_def ignore: do_machine_op)
 
 lemma dmo_addressTranslateS1_valid_irq_states[wp]:
@@ -480,7 +492,7 @@ lemma dmo_addressTranslateS1_valid_irq_states[wp]:
   by (wpsimp wp: dmo_valid_irq_states)
 
 crunch make_arch_fault_msg
-  for valid_irq_states[wp, Ipc_AI_assms]: "valid_irq_states"
+  for valid_irq_states[wp, Ipc_AI_2_assms]: "valid_irq_states"
   (wp: as_user_inv getRestartPC_inv mapM_wp'  simp: getRegister_def ignore: do_machine_op)
 
 lemma dmo_addressTranslateS1_cap_refs_respects_device_region[wp]:
@@ -488,20 +500,39 @@ lemma dmo_addressTranslateS1_cap_refs_respects_device_region[wp]:
   by (wpsimp wp: cap_refs_respects_device_region_dmo)
 
 crunch make_arch_fault_msg
-  for cap_refs_respects_device_region[wp, Ipc_AI_assms]: "cap_refs_respects_device_region"
+  for cap_refs_respects_device_region[wp, Ipc_AI_2_assms]: "cap_refs_respects_device_region"
   (wp: as_user_inv getRestartPC_inv mapM_wp'  simp: getRegister_def ignore: do_machine_op)
 
+lemma setup_caller_cap_aobj_at:
+  "arch_obj_pred P' \<Longrightarrow>
+  \<lbrace>\<lambda>s. P (obj_at P' pd s)\<rbrace> setup_caller_cap st rt grant \<lbrace>\<lambda>r s. P (obj_at P' pd s)\<rbrace>"
+  unfolding setup_caller_cap_def
+  by (wpsimp wp: cap_insert_aobj_at sts.aobj_at)
+
+lemma setup_caller_cap_valid_arch[Ipc_AI_2_assms, wp]:
+  "setup_caller_cap st rt grant \<lbrace>valid_arch_state\<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps[rotated -1] setup_caller_cap_aobj_at)
+
+lemma transfer_caps_loop_valid_arch[Ipc_AI_2_assms]:
+  "\<And>slots caps ep buffer n mi.
+    \<lbrace>valid_arch_state and valid_objs and valid_mdb and K (distinct slots)
+         and (\<lambda>s. \<forall>x \<in> set slots. real_cte_at x s \<and> cte_wp_at (\<lambda>cap. cap = cap.NullCap) x s)
+         and transfer_caps_srcs caps\<rbrace>
+      transfer_caps_loop ep buffer n caps slots mi
+    \<lbrace>\<lambda>_. valid_arch_state\<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps transfer_caps_loop_aobj_at)
+
 end
 
-interpretation Ipc_AI?: Ipc_AI
+interpretation Ipc_AI?: Ipc_AI_2
 proof goal_cases
   interpret Arch .
-  case 1 show ?case by (unfold_locales; (fact Ipc_AI_assms)?)
+  case 1 show ?case by (unfold_locales; (fact Ipc_AI_2_assms)?)
 qed
 
 context Arch begin arch_global_naming
 
-named_theorems Ipc_AI_cont_assms
+named_theorems Ipc_AI_3_assms
 
 lemma dmo_addressTranslateS1_pspace_respects_device_region[wp]:
   "do_machine_op (addressTranslateS1 addr) \<lbrace> pspace_respects_device_region \<rbrace>"
@@ -512,10 +543,10 @@ crunch make_fault_msg
   (wp: as_user_inv getRestartPC_inv mapM_wp'  simp: getRegister_def ignore: do_machine_op)
 
 crunch do_ipc_transfer
-  for pspace_respects_device_region[wp, Ipc_AI_cont_assms]: "pspace_respects_device_region"
+  for pspace_respects_device_region[wp, Ipc_AI_3_assms]: "pspace_respects_device_region"
   (wp: crunch_wps ignore: const_on_failure simp: crunch_simps)
 
-lemma do_ipc_transfer_respects_device_region[Ipc_AI_cont_assms]:
+lemma do_ipc_transfer_respects_device_region[Ipc_AI_3_assms]:
   "\<lbrace>cap_refs_respects_device_region and tcb_at t and  valid_objs and valid_mdb\<rbrace>
    do_ipc_transfer t ep bg grt r
    \<lbrace>\<lambda>rv. cap_refs_respects_device_region\<rbrace>"
@@ -533,7 +564,7 @@ lemma set_mrs_state_hyp_refs_of[wp]:
   by (wp set_mrs_thread_set_dmo thread_set_hyp_refs_trivial | simp)+
 
 crunch do_ipc_transfer
-  for state_hyp_refs_of[wp, Ipc_AI_cont_assms]: "\<lambda> s. P (state_hyp_refs_of s)"
+  for state_hyp_refs_of[wp, Ipc_AI_3_assms]: "\<lambda> s. P (state_hyp_refs_of s)"
   (wp: crunch_wps simp: zipWithM_x_mapM)
 
 lemma arch_derive_cap_untyped:
@@ -554,11 +585,18 @@ lemma valid_arch_mdb_cap_swap:
             ((caps_of_state s)(a \<mapsto> c', b \<mapsto> c))"
   by (auto simp: valid_arch_mdb_def)
 
+lemma do_ipc_transfer_valid_arch[Ipc_AI_3_assms]:
+  "\<lbrace>valid_arch_state and valid_objs and valid_mdb \<rbrace>
+   do_ipc_transfer s ep bg grt r
+   \<lbrace>\<lambda>rv. valid_arch_state\<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps do_ipc_transfer_aobj_at)
+
 end
 
-interpretation Ipc_AI_cont?: Ipc_AI_cont
+interpretation Ipc_AI?: Ipc_AI_3
 proof goal_cases
   interpret Arch .
-  case 1 show ?case by (unfold_locales;(fact Ipc_AI_cont_assms)?)
+  case 1 show ?case by (unfold_locales; (fact Ipc_AI_3_assms)?)
 qed
+
 end
diff --git a/proof/invariant-abstract/AARCH64/ArchKHeap_AI.thy b/proof/invariant-abstract/AARCH64/ArchKHeap_AI.thy
index bcd7840fc9..bf32081ed9 100644
--- a/proof/invariant-abstract/AARCH64/ArchKHeap_AI.thy
+++ b/proof/invariant-abstract/AARCH64/ArchKHeap_AI.thy
@@ -808,7 +808,9 @@ lemma aobjs_of_lift_aobj_at:
   apply (simp flip: aobjs_of_ako_at_Some)
   done
 
-lemma valid_arch_state_lift_aobj_at:
+(* intended for use inside Arch, as opposed to the interface lemma valid_arch_state_lift_aobj_at,
+   since this architecture does not need cap preservation for valid_arch_state *)
+lemma valid_arch_state_lift_aobj_at_no_caps:
   "f \<lbrace>valid_arch_state\<rbrace>"
   unfolding valid_arch_state_def valid_asid_table_def valid_global_arch_objs_def pt_at_eq
   apply (wp_pre, wps arch aobjs_of_lift_aobj_at)
@@ -817,6 +819,12 @@ lemma valid_arch_state_lift_aobj_at:
   apply simp
   done
 
+(* interface lemma *)
+lemma valid_arch_state_lift_aobj_at:
+  assumes caps: "\<And>P. f \<lbrace>\<lambda>s. P (caps_of_state s)\<rbrace>"
+  shows "f \<lbrace>valid_arch_state\<rbrace>"
+  by (rule valid_arch_state_lift_aobj_at_no_caps)
+
 end
 end
 
@@ -1010,14 +1018,6 @@ lemma valid_arch_tcb_same_type:
    \<Longrightarrow> valid_arch_tcb t (s\<lparr>kheap := (kheap s)(p \<mapsto> k)\<rparr>)"
   by (auto simp: valid_arch_tcb_def obj_at_def)
 
-
-(* interface lemma *)
-lemma valid_ioports_lift:
-  assumes x: "\<And>P. f \<lbrace>\<lambda>rv. P (caps_of_state s)\<rbrace>"
-  assumes y: "\<And>P. f \<lbrace>\<lambda>s. P (arch_state s)\<rbrace>"
-  shows      "f \<lbrace>valid_ioports\<rbrace>"
-  by wpsimp
-
 (* interface lemma *)
 lemma valid_arch_mdb_lift:
   assumes c: "\<And>P. f \<lbrace>\<lambda>s. P (caps_of_state s)\<rbrace>"
diff --git a/proof/invariant-abstract/AARCH64/ArchTcbAcc_AI.thy b/proof/invariant-abstract/AARCH64/ArchTcbAcc_AI.thy
index 99ad83388e..9b5811b871 100644
--- a/proof/invariant-abstract/AARCH64/ArchTcbAcc_AI.thy
+++ b/proof/invariant-abstract/AARCH64/ArchTcbAcc_AI.thy
@@ -162,6 +162,11 @@ lemma tcb_context_update_aux: "arch_tcb_context_set (P (arch_tcb_context_get atc
                                = tcb_context_update (\<lambda>ctx. P ctx) atcb"
   by (simp add: arch_tcb_context_set_def arch_tcb_context_get_def)
 
+lemma thread_set_valid_arch_state[TcbAcc_AI_assms]:
+  "(\<And>tcb. \<forall>(getF, v) \<in> ran tcb_cap_cases. getF (f tcb) = getF tcb)
+   \<Longrightarrow> thread_set f t \<lbrace> valid_arch_state \<rbrace>"
+  by (wp valid_arch_state_lift_aobj_at_no_caps thread_set.aobj_at)
+
 end
 
 global_interpretation TcbAcc_AI?: TcbAcc_AI
diff --git a/proof/invariant-abstract/AARCH64/ArchUntyped_AI.thy b/proof/invariant-abstract/AARCH64/ArchUntyped_AI.thy
index 3a60b1f14a..66a5fea4fb 100644
--- a/proof/invariant-abstract/AARCH64/ArchUntyped_AI.thy
+++ b/proof/invariant-abstract/AARCH64/ArchUntyped_AI.thy
@@ -319,10 +319,6 @@ lemma create_cap_cap_refs_in_kernel_window[wp, Untyped_AI_assms]:
   apply blast
   done
 
-lemma create_cap_ioports[wp, Untyped_AI_assms]:
-  "\<lbrace>valid_ioports and cte_wp_at (\<lambda>_. True) cref\<rbrace> create_cap tp sz p dev (cref,oref) \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by wpsimp
-
 lemma init_arch_objects_nonempty_table[Untyped_AI_assms, wp]:
   "\<lbrace>(\<lambda>s. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)
          \<and> valid_global_objs s \<and> valid_arch_state s \<and> pspace_aligned s) and
@@ -362,6 +358,18 @@ lemma obj_is_device_vui_eq[Untyped_AI_assms]:
   apply (auto simp: arch_is_frame_type_def)
   done
 
+lemma create_cap_valid_arch_state[wp, Untyped_AI_assms]:
+  "\<lbrace>valid_arch_state and cte_wp_at (\<lambda>_. True) cref\<rbrace>
+   create_cap tp sz p dev (cref,oref)
+   \<lbrace>\<lambda>rv. valid_arch_state\<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps create_cap_aobj_at)
+
+lemma set_cap_non_arch_valid_arch_state[Untyped_AI_assms]:
+ "\<lbrace>\<lambda>s. valid_arch_state s \<and> cte_wp_at (\<lambda>_. \<not>is_arch_cap cap) ptr s\<rbrace>
+  set_cap cap ptr
+  \<lbrace>\<lambda>rv. valid_arch_state \<rbrace>"
+  by wpsimp
+
 end
 
 global_interpretation Untyped_AI? : Untyped_AI
diff --git a/proof/invariant-abstract/ARM/ArchCNodeInv_AI.thy b/proof/invariant-abstract/ARM/ArchCNodeInv_AI.thy
index c582ed3a66..3cd8d619fa 100644
--- a/proof/invariant-abstract/ARM/ArchCNodeInv_AI.thy
+++ b/proof/invariant-abstract/ARM/ArchCNodeInv_AI.thy
@@ -423,7 +423,7 @@ lemma cap_swap_cap_refs_in_kernel_window[wp, CNodeInv_AI_assms]:
 
 
 lemma cap_swap_vms[wp, CNodeInv_AI_assms]:
-  "\<lbrace>valid_machine_state\<rbrace>  cap_swap c a c' b \<lbrace>\<lambda>rv. valid_machine_state\<rbrace>"
+  "\<lbrace>valid_machine_state\<rbrace> cap_swap c a c' b \<lbrace>\<lambda>rv. valid_machine_state\<rbrace>"
   apply (simp add: valid_machine_state_def in_user_frame_def)
   apply (wp cap_swap_typ_at
             hoare_vcg_all_lift hoare_vcg_ex_lift hoare_vcg_disj_lift)
@@ -518,11 +518,11 @@ lemma prepare_thread_delete_thread_cap [CNodeInv_AI_assms]:
    \<lbrace>\<lambda>rv s. caps_of_state s x = Some (cap.ThreadCap p)\<rbrace>"
   by (wpsimp simp: prepare_thread_delete_def)
 
-lemma cap_swap_ioports[wp, CNodeInv_AI_assms]:
-  "\<lbrace>valid_ioports and cte_wp_at (weak_derived c) a and cte_wp_at (weak_derived c') b\<rbrace>
-     cap_swap c a c' b
-   \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by wpsimp
+lemma cap_swap_valid_arch_state[wp, CNodeInv_AI_assms]:
+  "\<lbrace>valid_arch_state and cte_wp_at (weak_derived c) a and cte_wp_at (weak_derived c') b\<rbrace>
+   cap_swap c a c' b
+   \<lbrace>\<lambda>_. valid_arch_state\<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps cap_swap_aobj_at)
 
 end
 
@@ -541,7 +541,7 @@ context Arch begin arch_global_naming
 
 lemma post_cap_delete_pre_is_final_cap':
   "\<And>rv s'' rva s''a s.
-       \<lbrakk>valid_ioports s; caps_of_state s slot = Some cap; is_final_cap' cap s; cap_cleanup_opt cap \<noteq> NullCap\<rbrakk>
+       \<lbrakk> caps_of_state s slot = Some cap; is_final_cap' cap s; cap_cleanup_opt cap \<noteq> NullCap\<rbrakk>
        \<Longrightarrow> post_cap_delete_pre (cap_cleanup_opt cap) ((caps_of_state s)(slot \<mapsto> NullCap))"
   apply (clarsimp simp: cap_cleanup_opt_def cte_wp_at_def post_cap_delete_pre_def arch_cap_cleanup_opt_def
                       split: cap.split_asm if_split_asm
diff --git a/proof/invariant-abstract/ARM/ArchCSpaceInv_AI.thy b/proof/invariant-abstract/ARM/ArchCSpaceInv_AI.thy
index 376895e364..a673f0996e 100644
--- a/proof/invariant-abstract/ARM/ArchCSpaceInv_AI.thy
+++ b/proof/invariant-abstract/ARM/ArchCSpaceInv_AI.thy
@@ -14,24 +14,6 @@ begin
 
 context Arch begin arch_global_naming
 
-definition
-   safe_ioport_insert :: "cap \<Rightarrow> cap \<Rightarrow> 'a::state_ext state \<Rightarrow> bool"
-where
-  "safe_ioport_insert newcap oldcap s \<equiv> True"
-
-declare safe_ioport_insert_def[simp]
-
-lemma safe_ioport_insert_triv:
-  "\<not>is_arch_cap newcap \<Longrightarrow> safe_ioport_insert newcap oldcap s"
-  by clarsimp
-
-lemma set_cap_ioports':
- "\<lbrace>\<lambda>s. valid_ioports s
-      \<and> cte_wp_at (\<lambda>cap'. safe_ioport_insert cap cap' s) ptr s\<rbrace>
-    set_cap cap ptr
-  \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by wpsimp
-
 lemma unique_table_refs_no_cap_asidE:
   "\<lbrakk>caps_of_state s p = Some cap;
     unique_table_refs (caps_of_state s)\<rbrakk>
@@ -48,6 +30,10 @@ lemma unique_table_refs_no_cap_asidE:
 lemmas unique_table_refs_no_cap_asidD
      = unique_table_refs_no_cap_asidE[where S="{}"]
 
+lemma set_cap_valid_arch_state[wp]:
+  "set_cap cap ptr \<lbrace> valid_arch_state \<rbrace>"
+  by (wp valid_arch_state_lift_aobj_at_no_caps set_cap.aobj_at)
+
 lemma replace_cap_invs:
   "\<lbrace>\<lambda>s. invs s \<and> cte_wp_at (replaceable s p cap) p s
         \<and> cap \<noteq> cap.NullCap
diff --git a/proof/invariant-abstract/ARM/ArchCSpace_AI.thy b/proof/invariant-abstract/ARM/ArchCSpace_AI.thy
index 6b228b6d16..377bc8959d 100644
--- a/proof/invariant-abstract/ARM/ArchCSpace_AI.thy
+++ b/proof/invariant-abstract/ARM/ArchCSpace_AI.thy
@@ -517,15 +517,15 @@ lemma cap_insert_simple_arch_caps_no_ap:
   apply (intro conjI impI allI)
   by (auto simp:is_simple_cap_def[simplified is_simple_cap_arch_def] is_cap_simps)
 
-lemma setup_reply_master_ioports[wp, CSpace_AI_assms]:
-  "\<lbrace>valid_ioports\<rbrace> setup_reply_master c \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by wpsimp
+lemma cap_insert_derived_valid_arch_state[CSpace_AI_assms]:
+  "\<lbrace>valid_arch_state and (\<lambda>s. cte_wp_at (is_derived (cdt s) src cap) src s)\<rbrace>
+   cap_insert cap src dest
+   \<lbrace>\<lambda>rv. valid_arch_state \<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps cap_insert_aobj_at cap_insert_aobj_at)
 
-lemma cap_insert_derived_ioports[CSpace_AI_assms]:
-  "\<lbrace>valid_ioports and (\<lambda>s. cte_wp_at (is_derived (cdt s) src cap) src s)\<rbrace>
-     cap_insert cap src dest
-   \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by wpsimp
+lemma setup_reply_master_arch[CSpace_AI_assms]:
+  "setup_reply_master t \<lbrace> valid_arch_state \<rbrace>"
+  by (wpsimp simp: setup_reply_master_def wp: get_cap_wp)
 
 end
 
@@ -554,6 +554,10 @@ lemma is_cap_simps':
                               is_reply_cap_def is_master_reply_cap_def is_nondevice_page_cap_arch_def
                        split: cap.splits arch_cap.splits )+)+
 
+lemma cap_insert_simple_valid_arch_state[wp]:
+  "cap_insert cap src dest \<lbrace> valid_arch_state\<rbrace>"
+  by (wp valid_arch_state_lift_aobj_at_no_caps cap_insert_aobj_at)+
+
 lemma cap_insert_simple_invs:
   "\<lbrace>invs and valid_cap cap and tcb_cap_valid cap dest and
     ex_cte_cap_wp_to (appropriate_cte_cap cap) dest and
diff --git a/proof/invariant-abstract/ARM/ArchDetype_AI.thy b/proof/invariant-abstract/ARM/ArchDetype_AI.thy
index 8bb5ecb00d..6f98d49f50 100644
--- a/proof/invariant-abstract/ARM/ArchDetype_AI.thy
+++ b/proof/invariant-abstract/ARM/ArchDetype_AI.thy
@@ -114,10 +114,6 @@ lemma state_hyp_refs_of_detype:
   "state_hyp_refs_of (detype S s) = (\<lambda>x. if x \<in> 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_assms]:
-  "valid_ioports s \<Longrightarrow> valid_ioports (detype (untyped_range cap) s)"
-  by auto
-
 end
 
 interpretation Detype_AI?: Detype_AI
diff --git a/proof/invariant-abstract/ARM/ArchFinalise_AI.thy b/proof/invariant-abstract/ARM/ArchFinalise_AI.thy
index 3999d88f53..d402694f22 100644
--- a/proof/invariant-abstract/ARM/ArchFinalise_AI.thy
+++ b/proof/invariant-abstract/ARM/ArchFinalise_AI.thy
@@ -1678,10 +1678,6 @@ lemma (* zombie_cap_two_nonidles *)[Finalise_AI_assms]:
   apply (cases ptr, auto dest: valid_idle_has_null_cap_ARCH[rotated -1])[1]
   done
 
-crunch empty_slot, finalise_cap, send_ipc, receive_ipc
-  for ioports[wp]: valid_ioports
-  (wp: crunch_wps valid_ioports_lift simp: crunch_simps ignore: set_object)
-
 lemma arch_derive_cap_notzombie[wp]:
   "\<lbrace>\<top>\<rbrace> arch_derive_cap acap \<lbrace>\<lambda>rv s. \<not> is_zombie rv\<rbrace>, -"
   by (cases acap; wpsimp simp: arch_derive_cap_def is_zombie_def o_def)
diff --git a/proof/invariant-abstract/ARM/ArchInvariants_AI.thy b/proof/invariant-abstract/ARM/ArchInvariants_AI.thy
index 67155675fa..f2d42846c3 100644
--- a/proof/invariant-abstract/ARM/ArchInvariants_AI.thy
+++ b/proof/invariant-abstract/ARM/ArchInvariants_AI.thy
@@ -947,15 +947,10 @@ where
        (\<forall>(asid, hwasid, pd) \<in> graph_of (arm_asid_map (arch_state s)).
             vspace_at_asid asid pd s \<and> asid \<noteq> 0)"
 
-definition
-  valid_ioports :: "'z::state_ext state \<Rightarrow> bool"
-where
-  "valid_ioports \<equiv> \<lambda>s. True"
-
 definition
   "valid_arch_mdb r cs \<equiv> True"
 
-declare valid_ioports_def[simp] valid_arch_mdb_def[simp]
+declare valid_arch_mdb_def[simp]
 
 section "Lemmas"
 
diff --git a/proof/invariant-abstract/ARM/ArchIpc_AI.thy b/proof/invariant-abstract/ARM/ArchIpc_AI.thy
index 6b3aee0e7c..c0e42d9b56 100644
--- a/proof/invariant-abstract/ARM/ArchIpc_AI.thy
+++ b/proof/invariant-abstract/ARM/ArchIpc_AI.thy
@@ -10,7 +10,7 @@ begin
 
 context Arch begin arch_global_naming
 
-named_theorems Ipc_AI_assms
+named_theorems Ipc_AI_1_assms
 
 lemma cap_asid_PageCap_None [simp]:
   "cap_asid (ArchObjectCap (PageCap dev r R pgsz None)) = None"
@@ -36,7 +36,7 @@ lemma arch_derive_cap_is_derived:
              | rule conjI)+)
   done
 
-lemma derive_cap_is_derived [Ipc_AI_assms]:
+lemma derive_cap_is_derived [Ipc_AI_1_assms]:
   "\<lbrace>\<lambda>s. c'\<noteq> cap.NullCap \<longrightarrow> cte_wp_at (\<lambda>cap. cap_master_cap cap = cap_master_cap c'
                      \<and> (cap_badge cap, cap_badge c') \<in> capBadge_ordering False
                      \<and> cap_asid cap = cap_asid c'
@@ -62,7 +62,19 @@ lemma derive_cap_is_derived [Ipc_AI_assms]:
   apply(clarsimp simp: valid_cap_def)
   done
 
-lemma is_derived_cap_rights [simp, Ipc_AI_assms]:
+end
+
+interpretation Ipc_AI?: Ipc_AI
+proof goal_cases
+  interpret Arch .
+  case 1 show ?case by (unfold_locales; (fact Ipc_AI_1_assms)?)
+qed
+
+context Arch begin arch_global_naming
+
+named_theorems Ipc_AI_2_assms
+
+lemma is_derived_cap_rights [simp, Ipc_AI_2_assms]:
   "is_derived m p (cap_rights_update R c) = is_derived m p c"
   apply (rule ext)
   apply (simp add: cap_rights_update_def is_derived_def is_cap_simps)
@@ -74,12 +86,12 @@ lemma is_derived_cap_rights [simp, Ipc_AI_assms]:
            split: arch_cap.split cap.split bool.splits)
 
 
-lemma data_to_message_info_valid [Ipc_AI_assms]:
+lemma data_to_message_info_valid [Ipc_AI_2_assms]:
   "valid_message_info (data_to_message_info w)"
   by (simp add: valid_message_info_def data_to_message_info_def  word_and_le1 msg_max_length_def
                 msg_max_extra_caps_def Let_def not_less mask_def)
 
-lemma get_extra_cptrs_length[wp, Ipc_AI_assms]:
+lemma get_extra_cptrs_length[wp, Ipc_AI_2_assms]:
   "\<lbrace>\<lambda>s . valid_message_info mi\<rbrace>
    get_extra_cptrs buf mi
    \<lbrace>\<lambda>rv s. length rv \<le> msg_max_extra_caps\<rbrace>"
@@ -94,19 +106,19 @@ lemma get_extra_cptrs_length[wp, Ipc_AI_assms]:
                  intro: length_upt)
   done
 
-lemma cap_asid_rights_update [simp, Ipc_AI_assms]:
+lemma cap_asid_rights_update [simp, Ipc_AI_2_assms]:
   "cap_asid (cap_rights_update R c) = cap_asid c"
   apply (simp add: cap_rights_update_def acap_rights_update_def split: cap.splits arch_cap.splits bool.splits)
   apply (clarsimp simp: cap_asid_def)
   done
 
-lemma cap_rights_update_vs_cap_ref[simp, Ipc_AI_assms]:
+lemma cap_rights_update_vs_cap_ref[simp, Ipc_AI_2_assms]:
   "vs_cap_ref (cap_rights_update rs cap) = vs_cap_ref cap"
   by (simp add: vs_cap_ref_def cap_rights_update_def
                 acap_rights_update_def
          split: cap.split arch_cap.split bool.splits)
 
-lemma is_derived_cap_rights2[simp, Ipc_AI_assms]:
+lemma is_derived_cap_rights2[simp, Ipc_AI_2_assms]:
   "is_derived m p c (cap_rights_update R c') = is_derived m p c c'"
   apply (case_tac c')
   apply (simp_all add: cap_rights_update_def)
@@ -116,12 +128,12 @@ lemma is_derived_cap_rights2[simp, Ipc_AI_assms]:
   apply (case_tac acap1)
    by (auto simp: acap_rights_update_def)
 
-lemma cap_range_update [simp, Ipc_AI_assms]:
+lemma cap_range_update [simp, Ipc_AI_2_assms]:
   "cap_range (cap_rights_update R cap) = cap_range cap"
   by (auto simp add: cap_range_def cap_rights_update_def acap_rights_update_def
          split: cap.splits arch_cap.splits bool.splits)
 
-lemma derive_cap_idle[wp, Ipc_AI_assms]:
+lemma derive_cap_idle[wp, Ipc_AI_2_assms]:
   "\<lbrace>\<lambda>s. global_refs s \<inter> cap_range cap = {}\<rbrace>
    derive_cap slot cap
   \<lbrace>\<lambda>c s. global_refs s \<inter> cap_range c = {}\<rbrace>, -"
@@ -133,7 +145,7 @@ lemma derive_cap_idle[wp, Ipc_AI_assms]:
   apply (case_tac arch_cap, simp_all)
   done
 
-lemma arch_derive_cap_objrefs_iszombie [Ipc_AI_assms]:
+lemma arch_derive_cap_objrefs_iszombie [Ipc_AI_2_assms]:
   "\<lbrace>\<lambda>s . P (set_option (aobj_ref cap)) False s\<rbrace>
      arch_derive_cap cap
    \<lbrace>\<lambda>rv s. rv \<noteq> NullCap \<longrightarrow> P (obj_refs rv) (is_zombie rv) s\<rbrace>,-"
@@ -141,7 +153,7 @@ lemma arch_derive_cap_objrefs_iszombie [Ipc_AI_assms]:
       apply(rule hoare_pre, wpc?, wp+, simp)+
   done
 
-lemma obj_refs_remove_rights[simp, Ipc_AI_assms]:
+lemma obj_refs_remove_rights[simp, Ipc_AI_2_assms]:
   "obj_refs (remove_rights rs cap) = obj_refs cap"
   by (auto simp add: remove_rights_def cap_rights_update_def
                 acap_rights_update_def
@@ -156,7 +168,7 @@ lemma storeWord_um_inv:
   apply simp
   done
 
-lemma store_word_offs_vms[wp, Ipc_AI_assms]:
+lemma store_word_offs_vms[wp, Ipc_AI_2_assms]:
   "\<lbrace>valid_machine_state\<rbrace> store_word_offs ptr offs v \<lbrace>\<lambda>_. valid_machine_state\<rbrace>"
 proof -
   have aligned_offset_ignore:
@@ -195,12 +207,12 @@ proof -
     done
 qed
 
-lemma is_zombie_update_cap_data[simp, Ipc_AI_assms]:
+lemma is_zombie_update_cap_data[simp, Ipc_AI_2_assms]:
   "is_zombie (update_cap_data P data cap) = is_zombie cap"
   by (simp add: update_cap_data_closedform is_zombie_def arch_update_cap_data_def
          split: cap.splits)
 
-lemma valid_msg_length_strengthen [Ipc_AI_assms]:
+lemma valid_msg_length_strengthen [Ipc_AI_2_assms]:
   "valid_message_info mi \<longrightarrow> unat (mi_length mi) \<le> msg_max_length"
   apply (clarsimp simp: valid_message_info_def)
   apply (subgoal_tac "unat (mi_length mi) \<le> unat (of_nat msg_max_length :: word32)")
@@ -208,7 +220,7 @@ lemma valid_msg_length_strengthen [Ipc_AI_assms]:
   apply (clarsimp simp: un_ui_le word_le_def)
   done
 
-lemma copy_mrs_in_user_frame[wp, Ipc_AI_assms]:
+lemma copy_mrs_in_user_frame[wp, Ipc_AI_2_assms]:
   "\<lbrace>in_user_frame p\<rbrace> copy_mrs t buf t' buf' n \<lbrace>\<lambda>rv. in_user_frame p\<rbrace>"
   by (simp add: in_user_frame_def) (wp hoare_vcg_ex_lift)
 
@@ -221,21 +233,21 @@ lemma make_arch_fault_msg_inv[wp]: "\<lbrace>P\<rbrace> make_arch_fault_msg f t
   apply wp
   done
 
-lemma make_fault_message_inv[wp, Ipc_AI_assms]:
+lemma make_fault_message_inv[wp, Ipc_AI_2_assms]:
   "\<lbrace>P\<rbrace> make_fault_msg ft t \<lbrace>\<lambda>rv. P\<rbrace>"
   apply (cases ft, simp_all split del: if_split)
      apply (wp as_user_inv getRestartPC_inv mapM_wp'
               | simp add: getRegister_def)+
   done
 
-lemma do_fault_transfer_invs[wp, Ipc_AI_assms]:
+lemma do_fault_transfer_invs[wp, Ipc_AI_2_assms]:
   "\<lbrace>invs and tcb_at receiver\<rbrace>
       do_fault_transfer badge sender receiver recv_buf
    \<lbrace>\<lambda>rv. invs\<rbrace>"
   by (simp add: do_fault_transfer_def split_def | wp
     | clarsimp split: option.split)+
 
-lemma lookup_ipc_buffer_in_user_frame[wp, Ipc_AI_assms]:
+lemma lookup_ipc_buffer_in_user_frame[wp, Ipc_AI_2_assms]:
   "\<lbrace>valid_objs and tcb_at t\<rbrace> lookup_ipc_buffer b t
    \<lbrace>case_option (\<lambda>_. True) in_user_frame\<rbrace>"
   apply (simp add: lookup_ipc_buffer_def)
@@ -338,9 +350,9 @@ lemma transfer_caps_non_null_cte_wp_at:
   done
 
 crunch do_fault_transfer
-  for cte_wp_at[wp,Ipc_AI_assms]: "cte_wp_at P p"
+  for cte_wp_at[wp,Ipc_AI_2_assms]: "cte_wp_at P p"
 
-lemma do_normal_transfer_non_null_cte_wp_at [Ipc_AI_assms]:
+lemma do_normal_transfer_non_null_cte_wp_at [Ipc_AI_2_assms]:
   assumes imp: "\<And>c. P c \<Longrightarrow> \<not> is_untyped_cap c"
   shows  "\<lbrace>valid_objs and cte_wp_at (P and ((\<noteq>) cap.NullCap)) ptr\<rbrace>
    do_normal_transfer st send_buffer ep b gr rt recv_buffer
@@ -351,7 +363,7 @@ lemma do_normal_transfer_non_null_cte_wp_at [Ipc_AI_assms]:
     | clarsimp simp:imp)+
   done
 
-lemma is_derived_ReplyCap [simp, Ipc_AI_assms]:
+lemma is_derived_ReplyCap [simp, Ipc_AI_2_assms]:
   "\<And>m p R. is_derived m p (cap.ReplyCap t False R) = (\<lambda>c. is_master_reply_cap c \<and> obj_ref_of c = t)"
   apply (subst fun_eq_iff)
   apply clarsimp
@@ -372,7 +384,7 @@ lemma do_normal_transfer_tcb_caps:
      | simp add:imp)+
   done
 
-lemma do_ipc_transfer_tcb_caps [Ipc_AI_assms]:
+lemma do_ipc_transfer_tcb_caps [Ipc_AI_2_assms]:
   assumes imp: "\<And>c. P c \<Longrightarrow> \<not> is_untyped_cap c"
   shows
   "\<lbrace>valid_objs and cte_wp_at P (t, ref) and tcb_at t\<rbrace>
@@ -394,7 +406,7 @@ lemma cap_insert_valid_vso_at[wp]:
   apply (clarsimp simp: valid_vso_at_def)
   by (wpsimp wp: sts_obj_at_impossible sts_typ_ats hoare_vcg_ex_lift)
 
-lemma setup_caller_cap_valid_global_objs[wp, Ipc_AI_assms]:
+lemma setup_caller_cap_valid_global_objs[wp, Ipc_AI_2_assms]:
   "\<lbrace>valid_global_objs\<rbrace> setup_caller_cap send recv grant \<lbrace>\<lambda>rv. valid_global_objs\<rbrace>"
   apply (wp valid_global_objs_lift valid_ao_at_lift)
   unfolding setup_caller_cap_def
@@ -402,9 +414,9 @@ lemma setup_caller_cap_valid_global_objs[wp, Ipc_AI_assms]:
   done
 
 crunch handle_arch_fault_reply, arch_get_sanitise_register_info
-  for inv[Ipc_AI_assms]: P
+  for inv[Ipc_AI_2_assms]: P
 
-lemma transfer_caps_loop_valid_vspace_objs[wp, Ipc_AI_assms]:
+lemma transfer_caps_loop_valid_vspace_objs[wp, Ipc_AI_2_assms]:
   "\<lbrace>valid_vspace_objs\<rbrace>
       transfer_caps_loop ep buffer n caps slots mi
     \<lbrace>\<lambda>rv. valid_vspace_objs\<rbrace>"
@@ -419,25 +431,44 @@ lemma transfer_caps_loop_valid_vspace_objs[wp, Ipc_AI_assms]:
         | assumption | simp split del: if_split)+
   done
 
-declare make_arch_fault_msg_inv[Ipc_AI_assms]
+declare make_arch_fault_msg_inv[Ipc_AI_2_assms]
+
+lemma setup_caller_cap_aobj_at:
+  "arch_obj_pred P' \<Longrightarrow>
+  \<lbrace>\<lambda>s. P (obj_at P' pd s)\<rbrace> setup_caller_cap st rt grant \<lbrace>\<lambda>r s. P (obj_at P' pd s)\<rbrace>"
+  unfolding setup_caller_cap_def
+  by (wpsimp wp: cap_insert_aobj_at sts.aobj_at)
+
+lemma setup_caller_cap_valid_arch[Ipc_AI_2_assms, wp]:
+  "setup_caller_cap st rt grant \<lbrace>valid_arch_state\<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps[rotated -1] setup_caller_cap_aobj_at)
+
+lemma transfer_caps_loop_valid_arch[Ipc_AI_2_assms]:
+  "\<And>slots caps ep buffer n mi.
+    \<lbrace>valid_arch_state and valid_objs and valid_mdb and K (distinct slots)
+         and (\<lambda>s. \<forall>x \<in> set slots. real_cte_at x s \<and> cte_wp_at (\<lambda>cap. cap = cap.NullCap) x s)
+         and transfer_caps_srcs caps\<rbrace>
+      transfer_caps_loop ep buffer n caps slots mi
+    \<lbrace>\<lambda>_. valid_arch_state\<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps transfer_caps_loop_aobj_at)
 
 end
 
-interpretation Ipc_AI?: Ipc_AI
+interpretation Ipc_AI?: Ipc_AI_2
 proof goal_cases
   interpret Arch .
-  case 1 show ?case by (unfold_locales; (fact Ipc_AI_assms)?)
+  case 1 show ?case by (unfold_locales; (fact Ipc_AI_2_assms)?)
 qed
 
 context Arch begin arch_global_naming
 
-named_theorems Ipc_AI_cont_assms
+named_theorems Ipc_AI_3_assms
 
 crunch do_ipc_transfer
-  for pspace_respects_device_region[wp, Ipc_AI_cont_assms]: "pspace_respects_device_region"
+  for pspace_respects_device_region[wp, Ipc_AI_3_assms]: "pspace_respects_device_region"
   (wp: crunch_wps ignore: const_on_failure simp: crunch_simps)
 
-lemma do_ipc_transfer_respects_device_region[Ipc_AI_cont_assms]:
+lemma do_ipc_transfer_respects_device_region[Ipc_AI_3_assms]:
   "\<lbrace>cap_refs_respects_device_region and tcb_at t and  valid_objs and valid_mdb\<rbrace>
    do_ipc_transfer t ep bg grt r
    \<lbrace>\<lambda>rv. cap_refs_respects_device_region\<rbrace>"
@@ -455,7 +486,7 @@ lemma set_mrs_state_hyp_refs_of[wp]:
   by (wp set_mrs_thread_set_dmo thread_set_hyp_refs_trivial | simp)+
 
 crunch do_ipc_transfer
-  for state_hyp_refs_of[wp, Ipc_AI_cont_assms]: "\<lambda> s. P (state_hyp_refs_of s)"
+  for state_hyp_refs_of[wp, Ipc_AI_3_assms]: "\<lambda> s. P (state_hyp_refs_of s)"
   (wp: crunch_wps simp: zipWithM_x_mapM)
 
 lemma arch_derive_cap_untyped:
@@ -474,12 +505,18 @@ lemma valid_arch_mdb_cap_swap:
             ((caps_of_state s)(a \<mapsto> c', b \<mapsto> c))"
   by auto
 
+lemma do_ipc_transfer_valid_arch[Ipc_AI_3_assms]:
+  "\<lbrace>valid_arch_state and valid_objs and valid_mdb \<rbrace>
+   do_ipc_transfer s ep bg grt r
+   \<lbrace>\<lambda>rv. valid_arch_state\<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps do_ipc_transfer_aobj_at)
+
 end
 
-interpretation Ipc_AI?: Ipc_AI_cont
-  proof goal_cases
+interpretation Ipc_AI?: Ipc_AI_3
+proof goal_cases
   interpret Arch .
-  case 1 show ?case by (unfold_locales;(fact Ipc_AI_cont_assms)?)
-  qed
+  case 1 show ?case by (unfold_locales;(fact Ipc_AI_3_assms)?)
+qed
 
 end
diff --git a/proof/invariant-abstract/ARM/ArchKHeap_AI.thy b/proof/invariant-abstract/ARM/ArchKHeap_AI.thy
index 2b2deefdf3..f5a3c2e01f 100644
--- a/proof/invariant-abstract/ARM/ArchKHeap_AI.thy
+++ b/proof/invariant-abstract/ARM/ArchKHeap_AI.thy
@@ -553,7 +553,9 @@ lemma valid_global_pts_lift:
   apply clarsimp
   done
 
-lemma valid_arch_state_lift_aobj_at:
+(* intended for use inside Arch, as opposed to the interface lemma valid_arch_state_lift_aobj_at,
+   since this architecture does not need cap preservation for valid_arch_state *)
+lemma valid_arch_state_lift_aobj_at_no_caps:
   "\<lbrace>valid_arch_state\<rbrace> f \<lbrace>\<lambda>rv. valid_arch_state\<rbrace>"
   apply (simp add: valid_arch_state_def valid_asid_table_def)
   apply (rule hoare_lift_Pf[where f="arch_state", OF _ arch])
@@ -562,6 +564,15 @@ lemma valid_arch_state_lift_aobj_at:
   done
 
 end
+
+(* interface lemma *)
+lemma valid_arch_state_lift_aobj_at:
+  assumes aobj_at:
+    "\<And>P P' pd. arch_obj_pred P' \<Longrightarrow> \<lbrace>\<lambda>s. P (obj_at P' pd s)\<rbrace> f \<lbrace>\<lambda>r s. P (obj_at P' pd s)\<rbrace>"
+  assumes caps: "\<And>P. \<lbrace>\<lambda>s. P (caps_of_state s)\<rbrace> f \<lbrace>\<lambda>_ s. P (caps_of_state s)\<rbrace>"
+  shows "f \<lbrace>valid_arch_state\<rbrace>"
+  by (intro valid_arch_state_lift_aobj_at_no_caps aobj_at)
+
 end
 
 lemma equal_kernel_mappings_lift:
@@ -847,21 +858,11 @@ lemma valid_arch_tcb_same_type:
    \<Longrightarrow> valid_arch_tcb t (s\<lparr>kheap := (kheap s)(p \<mapsto> k)\<rparr>)"
   by (auto simp: valid_arch_tcb_def obj_at_def)
 
-lemma valid_ioports_lift:
-  assumes x: "\<And>P. \<lbrace>\<lambda>s. P (caps_of_state s)\<rbrace> f \<lbrace>\<lambda>rv s. P (caps_of_state s)\<rbrace>"
-  assumes y: "\<And>P. \<lbrace>\<lambda>s. P (arch_state s)\<rbrace> f \<lbrace>\<lambda>rv s. P (arch_state s)\<rbrace>"
-  shows      "\<lbrace>valid_ioports\<rbrace> f \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  apply simp
-  apply (rule hoare_use_eq [where f=caps_of_state, OF x y])
-  done
-
 lemma valid_arch_mdb_lift:
   assumes c: "\<And>P. \<lbrace>\<lambda>s. P (caps_of_state s)\<rbrace> f \<lbrace>\<lambda>r s. P (caps_of_state s)\<rbrace>"
   assumes r: "\<And>P. \<lbrace>\<lambda>s. P (is_original_cap s)\<rbrace> f \<lbrace>\<lambda>r s. P (is_original_cap s)\<rbrace>"
   shows "\<lbrace>\<lambda>s. valid_arch_mdb (is_original_cap s) (caps_of_state s)\<rbrace> f \<lbrace>\<lambda>r s. valid_arch_mdb (is_original_cap s) (caps_of_state s)\<rbrace>"
-  apply (clarsimp simp: valid_def)
-  done
-
+  by (clarsimp simp: valid_def valid_arch_mdb_def)
 
 end
 end
diff --git a/proof/invariant-abstract/ARM/ArchTcbAcc_AI.thy b/proof/invariant-abstract/ARM/ArchTcbAcc_AI.thy
index 971410d803..2647543b82 100644
--- a/proof/invariant-abstract/ARM/ArchTcbAcc_AI.thy
+++ b/proof/invariant-abstract/ARM/ArchTcbAcc_AI.thy
@@ -165,6 +165,11 @@ lemma tcb_context_update_aux: "arch_tcb_context_set (P (arch_tcb_context_get atc
                                = tcb_context_update (\<lambda>ctx. P ctx) atcb"
   by (simp add: arch_tcb_context_set_def arch_tcb_context_get_def)
 
+lemma thread_set_valid_arch_state[TcbAcc_AI_assms]:
+  "(\<And>tcb. \<forall>(getF, v) \<in> ran tcb_cap_cases. getF (f tcb) = getF tcb)
+   \<Longrightarrow> thread_set f t \<lbrace> valid_arch_state \<rbrace>"
+  by (wp valid_arch_state_lift_aobj_at_no_caps thread_set.aobj_at)
+
 end
 
 global_interpretation TcbAcc_AI?: TcbAcc_AI
diff --git a/proof/invariant-abstract/ARM/ArchUntyped_AI.thy b/proof/invariant-abstract/ARM/ArchUntyped_AI.thy
index 929f2e97a5..f3dd14be84 100644
--- a/proof/invariant-abstract/ARM/ArchUntyped_AI.thy
+++ b/proof/invariant-abstract/ARM/ArchUntyped_AI.thy
@@ -558,8 +558,16 @@ lemma obj_is_device_vui_eq[Untyped_AI_assms]:
   apply (auto simp: arch_is_frame_type_def)
   done
 
-lemma create_cap_ioports[wp, Untyped_AI_assms]:
-  "\<lbrace>valid_ioports and cte_wp_at (\<lambda>_. True) cref\<rbrace> create_cap tp sz p dev (cref,oref) \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
+lemma create_cap_valid_arch_state[wp, Untyped_AI_assms]:
+  "\<lbrace>valid_arch_state and cte_wp_at (\<lambda>_. True) cref\<rbrace>
+   create_cap tp sz p dev (cref,oref)
+   \<lbrace>\<lambda>rv. valid_arch_state\<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps create_cap_aobj_at)
+
+lemma set_cap_non_arch_valid_arch_state[Untyped_AI_assms]:
+ "\<lbrace>\<lambda>s. valid_arch_state s \<and> cte_wp_at (\<lambda>_. \<not>is_arch_cap cap) ptr s\<rbrace>
+  set_cap cap ptr
+  \<lbrace>\<lambda>rv. valid_arch_state \<rbrace>"
   by wpsimp
 
 end
diff --git a/proof/invariant-abstract/ARM_HYP/ArchCNodeInv_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchCNodeInv_AI.thy
index 1649a011dd..ad2a55b4e2 100644
--- a/proof/invariant-abstract/ARM_HYP/ArchCNodeInv_AI.thy
+++ b/proof/invariant-abstract/ARM_HYP/ArchCNodeInv_AI.thy
@@ -437,7 +437,7 @@ lemma cap_swap_cap_refs_in_kernel_window[wp, CNodeInv_AI_assms]:
 
 
 lemma cap_swap_vms[wp, CNodeInv_AI_assms]:
-  "\<lbrace>valid_machine_state\<rbrace>  cap_swap c a c' b \<lbrace>\<lambda>rv. valid_machine_state\<rbrace>"
+  "\<lbrace>valid_machine_state\<rbrace> cap_swap c a c' b \<lbrace>\<lambda>rv. valid_machine_state\<rbrace>"
   apply (simp add: valid_machine_state_def in_user_frame_def)
   apply (wp cap_swap_typ_at
             hoare_vcg_all_lift hoare_vcg_ex_lift hoare_vcg_disj_lift)
@@ -534,11 +534,11 @@ lemma prepare_thread_delete_thread_cap [CNodeInv_AI_assms]:
    \<lbrace>\<lambda>rv s. caps_of_state s x = Some (cap.ThreadCap p)\<rbrace>"
   by (wpsimp simp: prepare_thread_delete_def)
 
-lemma cap_swap_ioports[wp, CNodeInv_AI_assms]:
-  "\<lbrace>valid_ioports and cte_wp_at (weak_derived c) a and cte_wp_at (weak_derived c') b\<rbrace>
-     cap_swap c a c' b
-   \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by wpsimp
+lemma cap_swap_valid_arch_state[wp, CNodeInv_AI_assms]:
+  "\<lbrace>valid_arch_state and cte_wp_at (weak_derived c) a and cte_wp_at (weak_derived c') b\<rbrace>
+   cap_swap c a c' b
+   \<lbrace>\<lambda>_. valid_arch_state\<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps cap_swap_aobj_at)
 
 end
 
@@ -557,7 +557,7 @@ context Arch begin arch_global_naming
 
 lemma post_cap_delete_pre_is_final_cap':
   "\<And>rv s'' rva s''a s.
-       \<lbrakk>valid_ioports s; caps_of_state s slot = Some cap; is_final_cap' cap s; cap_cleanup_opt cap \<noteq> NullCap\<rbrakk>
+       \<lbrakk> caps_of_state s slot = Some cap; is_final_cap' cap s; cap_cleanup_opt cap \<noteq> NullCap\<rbrakk>
        \<Longrightarrow> post_cap_delete_pre (cap_cleanup_opt cap) ((caps_of_state s)(slot \<mapsto> NullCap))"
   apply (clarsimp simp: cap_cleanup_opt_def cte_wp_at_def post_cap_delete_pre_def arch_cap_cleanup_opt_def
                       split: cap.split_asm if_split_asm
diff --git a/proof/invariant-abstract/ARM_HYP/ArchCSpaceInv_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchCSpaceInv_AI.thy
index f59e602177..2ac20c4a6a 100644
--- a/proof/invariant-abstract/ARM_HYP/ArchCSpaceInv_AI.thy
+++ b/proof/invariant-abstract/ARM_HYP/ArchCSpaceInv_AI.thy
@@ -14,24 +14,6 @@ begin
 
 context Arch begin arch_global_naming
 
-definition
-   safe_ioport_insert :: "cap \<Rightarrow> cap \<Rightarrow> 'a::state_ext state \<Rightarrow> bool"
-where
-  "safe_ioport_insert newcap oldcap s \<equiv> True"
-
-declare safe_ioport_insert_def[simp]
-
-lemma safe_ioport_insert_triv:
-  "\<not>is_arch_cap newcap \<Longrightarrow> safe_ioport_insert newcap oldcap s"
-  by clarsimp
-
-lemma set_cap_ioports':
- "\<lbrace>\<lambda>s. valid_ioports s
-      \<and> cte_wp_at (\<lambda>cap'. safe_ioport_insert cap cap' s) ptr s\<rbrace>
-    set_cap cap ptr
-  \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by wpsimp
-
 lemma unique_table_refs_no_cap_asidE:
   "\<lbrakk>caps_of_state s p = Some cap;
     unique_table_refs (caps_of_state s)\<rbrakk>
@@ -48,6 +30,10 @@ lemma unique_table_refs_no_cap_asidE:
 lemmas unique_table_refs_no_cap_asidD
      = unique_table_refs_no_cap_asidE[where S="{}"]
 
+lemma set_cap_valid_arch_state[wp]:
+  "set_cap cap ptr \<lbrace> valid_arch_state \<rbrace>"
+  by (wp valid_arch_state_lift_aobj_at_no_caps set_cap.aobj_at)
+
 lemma replace_cap_invs:
   "\<lbrace>\<lambda>s. invs s \<and> cte_wp_at (replaceable s p cap) p s
         \<and> cap \<noteq> cap.NullCap
diff --git a/proof/invariant-abstract/ARM_HYP/ArchCSpace_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchCSpace_AI.thy
index 96a823b163..5cfc896b8f 100644
--- a/proof/invariant-abstract/ARM_HYP/ArchCSpace_AI.thy
+++ b/proof/invariant-abstract/ARM_HYP/ArchCSpace_AI.thy
@@ -516,15 +516,15 @@ lemma cap_insert_simple_arch_caps_no_ap:
   apply (intro conjI impI allI)
   by (auto simp:is_simple_cap_def[simplified is_simple_cap_arch_def] is_cap_simps)
 
-lemma setup_reply_master_ioports[wp, CSpace_AI_assms]:
-  "\<lbrace>valid_ioports\<rbrace> setup_reply_master c \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by wpsimp
+lemma cap_insert_derived_valid_arch_state[CSpace_AI_assms]:
+  "\<lbrace>valid_arch_state and (\<lambda>s. cte_wp_at (is_derived (cdt s) src cap) src s)\<rbrace>
+   cap_insert cap src dest
+   \<lbrace>\<lambda>rv. valid_arch_state \<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps cap_insert_aobj_at cap_insert_aobj_at)
 
-lemma cap_insert_derived_ioports[CSpace_AI_assms]:
-  "\<lbrace>valid_ioports and (\<lambda>s. cte_wp_at (is_derived (cdt s) src cap) src s)\<rbrace>
-     cap_insert cap src dest
-   \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by wpsimp
+lemma setup_reply_master_arch[CSpace_AI_assms]:
+  "setup_reply_master t \<lbrace> valid_arch_state \<rbrace>"
+  by (wpsimp simp: setup_reply_master_def wp: get_cap_wp)
 
 end
 
@@ -557,6 +557,10 @@ lemma is_cap_simps':
         apply (case_tac acap; auto simp: )
 by (cases cap; simp)+
 
+lemma cap_insert_simple_valid_arch_state[wp]:
+  "cap_insert cap src dest \<lbrace> valid_arch_state\<rbrace>"
+  by (wp valid_arch_state_lift_aobj_at_no_caps cap_insert_aobj_at)+
+
 lemma cap_insert_simple_invs:
   "\<lbrace>invs and valid_cap cap and tcb_cap_valid cap dest and
     ex_cte_cap_wp_to (appropriate_cte_cap cap) dest and
diff --git a/proof/invariant-abstract/ARM_HYP/ArchDetype_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchDetype_AI.thy
index b4394c41a3..efae1b8507 100644
--- a/proof/invariant-abstract/ARM_HYP/ArchDetype_AI.thy
+++ b/proof/invariant-abstract/ARM_HYP/ArchDetype_AI.thy
@@ -118,10 +118,6 @@ lemma state_hyp_refs_of_detype:
   "state_hyp_refs_of (detype S s) = (\<lambda>x. if x \<in> 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_assms]:
-  "valid_ioports s \<Longrightarrow> valid_ioports (detype (untyped_range cap) s)"
-  by auto
-
 end
 
 interpretation Detype_AI?: Detype_AI
diff --git a/proof/invariant-abstract/ARM_HYP/ArchFinalise_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchFinalise_AI.thy
index 44806f44df..ca59ee3f32 100644
--- a/proof/invariant-abstract/ARM_HYP/ArchFinalise_AI.thy
+++ b/proof/invariant-abstract/ARM_HYP/ArchFinalise_AI.thy
@@ -2445,10 +2445,6 @@ lemma (* zombie_cap_two_nonidles *)[Finalise_AI_assms]:
   apply (cases ptr, auto dest: valid_idle_has_null_cap_ARCH[rotated -1])[1]
   done
 
-crunch empty_slot, finalise_cap, send_ipc, receive_ipc
-  for ioports[wp]: valid_ioports
-  (wp: crunch_wps valid_ioports_lift simp: crunch_simps ignore: set_object)
-
 lemma arch_derive_cap_notzombie[wp]:
   "\<lbrace>\<top>\<rbrace> arch_derive_cap acap \<lbrace>\<lambda>rv s. \<not> is_zombie rv\<rbrace>, -"
   by (cases acap; wpsimp simp: arch_derive_cap_def is_zombie_def o_def)
diff --git a/proof/invariant-abstract/ARM_HYP/ArchInvariants_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchInvariants_AI.thy
index e44be22bd9..497160356c 100644
--- a/proof/invariant-abstract/ARM_HYP/ArchInvariants_AI.thy
+++ b/proof/invariant-abstract/ARM_HYP/ArchInvariants_AI.thy
@@ -945,15 +945,10 @@ where
        (\<forall>(asid, hwasid, pd) \<in> graph_of (arm_asid_map (arch_state s)).
             vspace_at_asid asid pd s \<and> asid \<noteq> 0)"
 
-definition
-  valid_ioports :: "'z::state_ext state \<Rightarrow> bool"
-where
-  "valid_ioports \<equiv> \<lambda>s. True"
-
 definition
   "valid_arch_mdb r cs \<equiv> True"
 
-declare valid_ioports_def[simp] valid_arch_mdb_def[simp]
+declare valid_arch_mdb_def[simp]
 
 section "Lemmas"
 
diff --git a/proof/invariant-abstract/ARM_HYP/ArchIpc_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchIpc_AI.thy
index 9030165d3a..105c74c9f0 100644
--- a/proof/invariant-abstract/ARM_HYP/ArchIpc_AI.thy
+++ b/proof/invariant-abstract/ARM_HYP/ArchIpc_AI.thy
@@ -10,7 +10,7 @@ begin
 
 context Arch begin arch_global_naming
 
-named_theorems Ipc_AI_assms
+named_theorems Ipc_AI_1_assms
 
 lemma cap_asid_PageCap_None [simp]:
   "cap_asid (ArchObjectCap (PageCap dev r R pgsz None)) = None"
@@ -36,7 +36,7 @@ lemma arch_derive_cap_is_derived:
              | rule conjI)+)
   done
 
-lemma derive_cap_is_derived [Ipc_AI_assms]:
+lemma derive_cap_is_derived [Ipc_AI_1_assms]:
   "\<lbrace>\<lambda>s. c'\<noteq> cap.NullCap \<longrightarrow> cte_wp_at (\<lambda>cap. cap_master_cap cap = cap_master_cap c'
                      \<and> (cap_badge cap, cap_badge c') \<in> capBadge_ordering False
                      \<and> cap_asid cap = cap_asid c'
@@ -62,7 +62,19 @@ lemma derive_cap_is_derived [Ipc_AI_assms]:
   apply(clarsimp simp: valid_cap_def)
   done
 
-lemma is_derived_cap_rights [simp, Ipc_AI_assms]:
+end
+
+interpretation Ipc_AI?: Ipc_AI
+proof goal_cases
+  interpret Arch .
+  case 1 show ?case by (unfold_locales; (fact Ipc_AI_1_assms)?)
+qed
+
+context Arch begin arch_global_naming
+
+named_theorems Ipc_AI_2_assms
+
+lemma is_derived_cap_rights [simp, Ipc_AI_2_assms]:
   "is_derived m p (cap_rights_update R c) = is_derived m p c"
   apply (rule ext)
   apply (simp add: cap_rights_update_def is_derived_def is_cap_simps)
@@ -74,12 +86,12 @@ lemma is_derived_cap_rights [simp, Ipc_AI_assms]:
            split: arch_cap.split cap.split bool.splits)
 
 
-lemma data_to_message_info_valid [Ipc_AI_assms]:
+lemma data_to_message_info_valid [Ipc_AI_2_assms]:
   "valid_message_info (data_to_message_info w)"
   by (simp add: valid_message_info_def data_to_message_info_def  word_and_le1 msg_max_length_def
                 msg_max_extra_caps_def Let_def not_less mask_def)
 
-lemma get_extra_cptrs_length[wp, Ipc_AI_assms]:
+lemma get_extra_cptrs_length[wp, Ipc_AI_2_assms]:
   "\<lbrace>\<lambda>s . valid_message_info mi\<rbrace>
    get_extra_cptrs buf mi
    \<lbrace>\<lambda>rv s. length rv \<le> msg_max_extra_caps\<rbrace>"
@@ -94,18 +106,18 @@ lemma get_extra_cptrs_length[wp, Ipc_AI_assms]:
                  intro: length_upt)
   done
 
-lemma cap_asid_rights_update [simp, Ipc_AI_assms]:
+lemma cap_asid_rights_update [simp, Ipc_AI_2_assms]:
   "cap_asid (cap_rights_update R c) = cap_asid c"
   apply (simp add: cap_rights_update_def acap_rights_update_def split: cap.splits arch_cap.splits)
   done
 
-lemma cap_rights_update_vs_cap_ref[simp, Ipc_AI_assms]:
+lemma cap_rights_update_vs_cap_ref[simp, Ipc_AI_2_assms]:
   "vs_cap_ref (cap_rights_update rs cap) = vs_cap_ref cap"
   by (simp add: vs_cap_ref_def cap_rights_update_def
                 acap_rights_update_def
          split: cap.split arch_cap.split)
 
-lemma is_derived_cap_rights2[simp, Ipc_AI_assms]:
+lemma is_derived_cap_rights2[simp, Ipc_AI_2_assms]:
   "is_derived m p c (cap_rights_update R c') = is_derived m p c c'"
   apply (case_tac c')
   apply (simp_all add:cap_rights_update_def)
@@ -115,12 +127,12 @@ lemma is_derived_cap_rights2[simp, Ipc_AI_assms]:
   apply (case_tac acap1)
    by (auto simp: acap_rights_update_def)
 
-lemma cap_range_update [simp, Ipc_AI_assms]:
+lemma cap_range_update [simp, Ipc_AI_2_assms]:
   "cap_range (cap_rights_update R cap) = cap_range cap"
   by (simp add: cap_range_def cap_rights_update_def acap_rights_update_def
          split: cap.splits arch_cap.splits)
 
-lemma derive_cap_idle[wp, Ipc_AI_assms]:
+lemma derive_cap_idle[wp, Ipc_AI_2_assms]:
   "\<lbrace>\<lambda>s. global_refs s \<inter> cap_range cap = {}\<rbrace>
    derive_cap slot cap
   \<lbrace>\<lambda>c s. global_refs s \<inter> cap_range c = {}\<rbrace>, -"
@@ -132,7 +144,7 @@ lemma derive_cap_idle[wp, Ipc_AI_assms]:
   apply (case_tac arch_cap, simp_all)
   done
 
-lemma arch_derive_cap_objrefs_iszombie [Ipc_AI_assms]:
+lemma arch_derive_cap_objrefs_iszombie [Ipc_AI_2_assms]:
   "\<lbrace>\<lambda>s . P (set_option (aobj_ref cap)) False s\<rbrace>
      arch_derive_cap cap
    \<lbrace>\<lambda>rv s. rv \<noteq> NullCap \<longrightarrow> P (obj_refs rv) (is_zombie rv) s\<rbrace>,-"
@@ -140,7 +152,7 @@ lemma arch_derive_cap_objrefs_iszombie [Ipc_AI_assms]:
       apply(rule hoare_pre, wpsimp+)+
   done
 
-lemma obj_refs_remove_rights[simp, Ipc_AI_assms]:
+lemma obj_refs_remove_rights[simp, Ipc_AI_2_assms]:
   "obj_refs (remove_rights rs cap) = obj_refs cap"
   by (auto simp add: remove_rights_def cap_rights_update_def
                 acap_rights_update_def
@@ -155,7 +167,7 @@ lemma storeWord_um_inv:
   apply simp
   done
 
-lemma store_word_offs_vms[wp, Ipc_AI_assms]:
+lemma store_word_offs_vms[wp, Ipc_AI_2_assms]:
   "\<lbrace>valid_machine_state\<rbrace> store_word_offs ptr offs v \<lbrace>\<lambda>_. valid_machine_state\<rbrace>"
 proof -
   have aligned_offset_ignore:
@@ -194,12 +206,12 @@ proof -
     done
 qed
 
-lemma is_zombie_update_cap_data[simp, Ipc_AI_assms]:
+lemma is_zombie_update_cap_data[simp, Ipc_AI_2_assms]:
   "is_zombie (update_cap_data P data cap) = is_zombie cap"
   by (simp add: update_cap_data_closedform arch_update_cap_data_def is_zombie_def
          split: cap.splits)
 
-lemma valid_msg_length_strengthen [Ipc_AI_assms]:
+lemma valid_msg_length_strengthen [Ipc_AI_2_assms]:
   "valid_message_info mi \<longrightarrow> unat (mi_length mi) \<le> msg_max_length"
   apply (clarsimp simp: valid_message_info_def)
   apply (subgoal_tac "unat (mi_length mi) \<le> unat (of_nat msg_max_length :: word32)")
@@ -207,20 +219,20 @@ lemma valid_msg_length_strengthen [Ipc_AI_assms]:
   apply (clarsimp simp: un_ui_le word_le_def)
   done
 
-lemma copy_mrs_in_user_frame[wp, Ipc_AI_assms]:
+lemma copy_mrs_in_user_frame[wp, Ipc_AI_2_assms]:
   "\<lbrace>in_user_frame p\<rbrace> copy_mrs t buf t' buf' n \<lbrace>\<lambda>rv. in_user_frame p\<rbrace>"
   by (simp add: in_user_frame_def) (wp hoare_vcg_ex_lift)
 
 lemma as_user_getRestart_invs[wp]: "\<lbrace>P\<rbrace> as_user t getRestartPC \<lbrace>\<lambda>_. P\<rbrace>"
   by (simp add: getRestartPC_def, rule user_getreg_inv)
 
-lemma make_arch_fault_msg_invs[wp, Ipc_AI_assms]: "make_arch_fault_msg f t \<lbrace>invs\<rbrace>"
+lemma make_arch_fault_msg_invs[wp, Ipc_AI_2_assms]: "make_arch_fault_msg f t \<lbrace>invs\<rbrace>"
   apply (cases f)
   apply simp_all
   apply (wpsimp simp: do_machine_op_bind addressTranslateS1_def)
   done
 
-lemma make_fault_message_inv[wp, Ipc_AI_assms]:
+lemma make_fault_message_inv[wp, Ipc_AI_2_assms]:
   "make_fault_msg ft t \<lbrace>invs\<rbrace>"
   apply (cases ft, simp_all split del: if_split)
      apply (wp as_user_inv getRestartPC_inv mapM_wp'
@@ -230,14 +242,14 @@ lemma make_fault_message_inv[wp, Ipc_AI_assms]:
 crunch make_fault_msg
   for tcb_at[wp]: "tcb_at t"
 
-lemma do_fault_transfer_invs[wp, Ipc_AI_assms]:
+lemma do_fault_transfer_invs[wp, Ipc_AI_2_assms]:
   "\<lbrace>invs and tcb_at receiver\<rbrace>
       do_fault_transfer badge sender receiver recv_buf
    \<lbrace>\<lambda>rv. invs\<rbrace>"
   by (simp add: do_fault_transfer_def split_def | wp
     | clarsimp split: option.split)+
 
-lemma lookup_ipc_buffer_in_user_frame[wp, Ipc_AI_assms]:
+lemma lookup_ipc_buffer_in_user_frame[wp, Ipc_AI_2_assms]:
   "\<lbrace>valid_objs and tcb_at t\<rbrace> lookup_ipc_buffer b t
    \<lbrace>case_option (\<lambda>_. True) in_user_frame\<rbrace>"
   apply (simp add: lookup_ipc_buffer_def)
@@ -340,9 +352,9 @@ lemma transfer_caps_non_null_cte_wp_at:
   done
 
 crunch do_fault_transfer
-  for cte_wp_at[wp,Ipc_AI_assms]: "cte_wp_at P p"
+  for cte_wp_at[wp,Ipc_AI_2_assms]: "cte_wp_at P p"
 
-lemma do_normal_transfer_non_null_cte_wp_at [Ipc_AI_assms]:
+lemma do_normal_transfer_non_null_cte_wp_at [Ipc_AI_2_assms]:
   assumes imp: "\<And>c. P c \<Longrightarrow> \<not> is_untyped_cap c"
   shows  "\<lbrace>valid_objs and cte_wp_at (P and ((\<noteq>) cap.NullCap)) ptr\<rbrace>
    do_normal_transfer st send_buffer ep b gr rt recv_buffer
@@ -353,7 +365,7 @@ lemma do_normal_transfer_non_null_cte_wp_at [Ipc_AI_assms]:
     | clarsimp simp:imp)+
   done
 
-lemma is_derived_ReplyCap [simp, Ipc_AI_assms]:
+lemma is_derived_ReplyCap [simp, Ipc_AI_2_assms]:
   "\<And>m p R. is_derived m p (cap.ReplyCap t False R) = (\<lambda>c. is_master_reply_cap c \<and> obj_ref_of c = t)"
   apply (subst fun_eq_iff)
   apply clarsimp
@@ -374,7 +386,7 @@ lemma do_normal_transfer_tcb_caps:
      | simp add:imp)+
   done
 
-lemma do_ipc_transfer_tcb_caps [Ipc_AI_assms]:
+lemma do_ipc_transfer_tcb_caps [Ipc_AI_2_assms]:
   assumes imp: "\<And>c. P c \<Longrightarrow> \<not> is_untyped_cap c"
   shows
   "\<lbrace>valid_objs and cte_wp_at P (t, ref) and tcb_at t\<rbrace>
@@ -386,7 +398,7 @@ lemma do_ipc_transfer_tcb_caps [Ipc_AI_assms]:
        | wpc | simp add:imp)+
   done
 
-lemma setup_caller_cap_valid_global_objs[wp, Ipc_AI_assms]:
+lemma setup_caller_cap_valid_global_objs[wp, Ipc_AI_2_assms]:
   "\<lbrace>valid_global_objs\<rbrace> setup_caller_cap send recv grant \<lbrace>\<lambda>rv. valid_global_objs\<rbrace>"
   apply (simp add: valid_global_objs_def)
   unfolding setup_caller_cap_def
@@ -394,9 +406,9 @@ lemma setup_caller_cap_valid_global_objs[wp, Ipc_AI_assms]:
   done
 
 crunch handle_arch_fault_reply, arch_get_sanitise_register_info
-  for typ_at[Ipc_AI_assms]: "P (typ_at T p s)"
+  for typ_at[Ipc_AI_2_assms]: "P (typ_at T p s)"
 
-lemma transfer_caps_loop_valid_vspace_objs[wp, Ipc_AI_assms]:
+lemma transfer_caps_loop_valid_vspace_objs[wp, Ipc_AI_2_assms]:
   "\<lbrace>valid_vspace_objs\<rbrace>
       transfer_caps_loop ep buffer n caps slots mi
     \<lbrace>\<lambda>rv. valid_vspace_objs\<rbrace>"
@@ -425,95 +437,114 @@ lemma dmo_addressTranslateS1_cap_refs_respects_device_region[wp]:
   by (wpsimp  wp: cap_refs_respects_device_region_dmo)
 
 crunch  make_arch_fault_msg
-  for aligned[wp, Ipc_AI_assms]: "pspace_aligned"
+  for aligned[wp, Ipc_AI_2_assms]: "pspace_aligned"
 crunch  make_arch_fault_msg
-  for distinct[wp, Ipc_AI_assms]: "pspace_distinct"
+  for distinct[wp, Ipc_AI_2_assms]: "pspace_distinct"
 crunch  make_arch_fault_msg
-  for vmdb[wp, Ipc_AI_assms]: "valid_mdb"
+  for vmdb[wp, Ipc_AI_2_assms]: "valid_mdb"
 crunch  make_arch_fault_msg
-  for ifunsafe[wp, Ipc_AI_assms]: "if_unsafe_then_cap"
+  for ifunsafe[wp, Ipc_AI_2_assms]: "if_unsafe_then_cap"
 crunch  make_arch_fault_msg
-  for iflive[wp, Ipc_AI_assms]: "if_live_then_nonz_cap"
+  for iflive[wp, Ipc_AI_2_assms]: "if_live_then_nonz_cap"
 crunch  make_arch_fault_msg
-  for state_refs_of[wp, Ipc_AI_assms]: "\<lambda>s. P (state_refs_of s)"
+  for state_refs_of[wp, Ipc_AI_2_assms]: "\<lambda>s. P (state_refs_of s)"
 crunch  make_arch_fault_msg
-  for ct[wp, Ipc_AI_assms]: "cur_tcb"
+  for ct[wp, Ipc_AI_2_assms]: "cur_tcb"
 crunch  make_arch_fault_msg
-  for zombies[wp, Ipc_AI_assms]: "zombies_final"
+  for zombies[wp, Ipc_AI_2_assms]: "zombies_final"
 crunch  make_arch_fault_msg
-  for it[wp, Ipc_AI_assms]: "\<lambda>s. P (idle_thread s)"
+  for it[wp, Ipc_AI_2_assms]: "\<lambda>s. P (idle_thread s)"
 crunch  make_arch_fault_msg
-  for valid_globals[wp, Ipc_AI_assms]: "valid_global_refs"
+  for valid_globals[wp, Ipc_AI_2_assms]: "valid_global_refs"
 crunch  make_arch_fault_msg
-  for reply_masters[wp, Ipc_AI_assms]: "valid_reply_masters"
+  for reply_masters[wp, Ipc_AI_2_assms]: "valid_reply_masters"
 crunch  make_arch_fault_msg
-  for valid_idle[wp, Ipc_AI_assms]: "valid_idle"
+  for valid_idle[wp, Ipc_AI_2_assms]: "valid_idle"
 crunch  make_arch_fault_msg
-  for arch[wp, Ipc_AI_assms]: "\<lambda>s. P (arch_state s)"
+  for arch[wp, Ipc_AI_2_assms]: "\<lambda>s. P (arch_state s)"
 crunch  make_arch_fault_msg
-  for typ_at[wp, Ipc_AI_assms]: "\<lambda>s. P (typ_at T p s)"
+  for typ_at[wp, Ipc_AI_2_assms]: "\<lambda>s. P (typ_at T p s)"
 crunch  make_arch_fault_msg
-  for irq_node[wp, Ipc_AI_assms]: "\<lambda>s. P (interrupt_irq_node s)"
+  for irq_node[wp, Ipc_AI_2_assms]: "\<lambda>s. P (interrupt_irq_node s)"
 crunch  make_arch_fault_msg
-  for valid_reply[wp, Ipc_AI_assms]: "valid_reply_caps"
+  for valid_reply[wp, Ipc_AI_2_assms]: "valid_reply_caps"
 crunch  make_arch_fault_msg
-  for irq_handlers[wp, Ipc_AI_assms]: "valid_irq_handlers"
+  for irq_handlers[wp, Ipc_AI_2_assms]: "valid_irq_handlers"
 crunch  make_arch_fault_msg
-  for vspace_objs[wp, Ipc_AI_assms]: "valid_vspace_objs"
+  for vspace_objs[wp, Ipc_AI_2_assms]: "valid_vspace_objs"
 crunch  make_arch_fault_msg
-  for global_objs[wp, Ipc_AI_assms]: "valid_global_objs"
+  for global_objs[wp, Ipc_AI_2_assms]: "valid_global_objs"
 crunch  make_arch_fault_msg
-  for global_vspace_mapping[wp, Ipc_AI_assms]: "valid_global_vspace_mappings"
+  for global_vspace_mapping[wp, Ipc_AI_2_assms]: "valid_global_vspace_mappings"
 crunch  make_arch_fault_msg
-  for arch_caps[wp, Ipc_AI_assms]: "valid_arch_caps"
+  for arch_caps[wp, Ipc_AI_2_assms]: "valid_arch_caps"
 crunch  make_arch_fault_msg
-  for v_ker_map[wp, Ipc_AI_assms]: "valid_kernel_mappings"
+  for v_ker_map[wp, Ipc_AI_2_assms]: "valid_kernel_mappings"
 crunch  make_arch_fault_msg
-  for eq_ker_map[wp, Ipc_AI_assms]: "equal_kernel_mappings"
+  for eq_ker_map[wp, Ipc_AI_2_assms]: "equal_kernel_mappings"
 crunch  make_arch_fault_msg
-  for asid_map[wp, Ipc_AI_assms]: "valid_asid_map"
+  for asid_map[wp, Ipc_AI_2_assms]: "valid_asid_map"
 crunch  make_arch_fault_msg
-  for only_idle[wp, Ipc_AI_assms]: "only_idle"
+  for only_idle[wp, Ipc_AI_2_assms]: "only_idle"
 crunch  make_arch_fault_msg
-  for pspace_in_kernel_window[wp, Ipc_AI_assms]: "pspace_in_kernel_window"
+  for pspace_in_kernel_window[wp, Ipc_AI_2_assms]: "pspace_in_kernel_window"
 crunch  make_arch_fault_msg
-  for cap_refs_in_kernel_window[wp, Ipc_AI_assms]: "cap_refs_in_kernel_window"
+  for cap_refs_in_kernel_window[wp, Ipc_AI_2_assms]: "cap_refs_in_kernel_window"
 crunch  make_arch_fault_msg
-  for valid_objs[wp, Ipc_AI_assms]: "valid_objs"
+  for valid_objs[wp, Ipc_AI_2_assms]: "valid_objs"
 crunch  make_arch_fault_msg
-  for valid_ioc[wp, Ipc_AI_assms]: "valid_ioc"
+  for valid_ioc[wp, Ipc_AI_2_assms]: "valid_ioc"
 crunch  make_arch_fault_msg
-  for pred_tcb[wp, Ipc_AI_assms]: "pred_tcb_at proj P t"
+  for pred_tcb[wp, Ipc_AI_2_assms]: "pred_tcb_at proj P t"
 crunch  make_arch_fault_msg
-  for cap_to[wp, Ipc_AI_assms]: "ex_nonz_cap_to p"
+  for cap_to[wp, Ipc_AI_2_assms]: "ex_nonz_cap_to p"
 
 crunch  make_arch_fault_msg
-  for obj_at[wp, Ipc_AI_assms]: "\<lambda>s. P (obj_at P' pd s)"
+  for obj_at[wp, Ipc_AI_2_assms]: "\<lambda>s. P (obj_at P' pd s)"
   (wp: as_user_inv getRestartPC_inv mapM_wp'  simp: getRegister_def)
 
 crunch make_arch_fault_msg
-  for vms[wp, Ipc_AI_assms]: valid_machine_state
+  for vms[wp, Ipc_AI_2_assms]: valid_machine_state
   (wp: as_user_inv getRestartPC_inv mapM_wp'  simp: getRegister_def ignore: do_machine_op)
 
 crunch make_arch_fault_msg
-  for valid_irq_states[wp, Ipc_AI_assms]: "valid_irq_states"
+  for valid_irq_states[wp, Ipc_AI_2_assms]: "valid_irq_states"
   (wp: as_user_inv getRestartPC_inv mapM_wp'  simp: getRegister_def ignore: do_machine_op)
 
 crunch make_arch_fault_msg
-  for cap_refs_respects_device_region[wp, Ipc_AI_assms]: "cap_refs_respects_device_region"
+  for cap_refs_respects_device_region[wp, Ipc_AI_2_assms]: "cap_refs_respects_device_region"
   (wp: as_user_inv getRestartPC_inv mapM_wp'  simp: getRegister_def ignore: do_machine_op)
 
+lemma setup_caller_cap_aobj_at:
+  "arch_obj_pred P' \<Longrightarrow>
+  \<lbrace>\<lambda>s. P (obj_at P' pd s)\<rbrace> setup_caller_cap st rt grant \<lbrace>\<lambda>r s. P (obj_at P' pd s)\<rbrace>"
+  unfolding setup_caller_cap_def
+  by (wpsimp wp: cap_insert_aobj_at sts.aobj_at)
+
+lemma setup_caller_cap_valid_arch[Ipc_AI_2_assms, wp]:
+  "setup_caller_cap st rt grant \<lbrace>valid_arch_state\<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps[rotated -1] setup_caller_cap_aobj_at)
+
+lemma transfer_caps_loop_valid_arch[Ipc_AI_2_assms]:
+  "\<And>slots caps ep buffer n mi.
+    \<lbrace>valid_arch_state and valid_objs and valid_mdb and K (distinct slots)
+         and (\<lambda>s. \<forall>x \<in> set slots. real_cte_at x s \<and> cte_wp_at (\<lambda>cap. cap = cap.NullCap) x s)
+         and transfer_caps_srcs caps\<rbrace>
+      transfer_caps_loop ep buffer n caps slots mi
+    \<lbrace>\<lambda>_. valid_arch_state\<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps transfer_caps_loop_aobj_at)
+
 end
 
-interpretation Ipc_AI?: Ipc_AI
+interpretation Ipc_AI?: Ipc_AI_2
 proof goal_cases
   interpret Arch .
-  case 1 show ?case by (unfold_locales; (fact Ipc_AI_assms)?)
+  case 1 show ?case by (unfold_locales; (fact Ipc_AI_2_assms)?)
 qed
 
 context Arch begin arch_global_naming
 
-named_theorems Ipc_AI_cont_assms
+named_theorems Ipc_AI_3_assms
 
 lemma dmo_addressTranslateS1_pspace_respects_device_region[wp]:
   "do_machine_op (addressTranslateS1 pc) \<lbrace>pspace_respects_device_region\<rbrace>"
@@ -524,10 +555,10 @@ crunch make_fault_msg
   (wp: as_user_inv getRestartPC_inv mapM_wp'  simp: getRegister_def ignore: do_machine_op)
 
 crunch do_ipc_transfer
-  for pspace_respects_device_region[wp, Ipc_AI_cont_assms]: "pspace_respects_device_region"
+  for pspace_respects_device_region[wp, Ipc_AI_3_assms]: "pspace_respects_device_region"
   (wp: crunch_wps ignore: const_on_failure simp: crunch_simps)
 
-lemma do_ipc_transfer_respects_device_region[Ipc_AI_cont_assms]:
+lemma do_ipc_transfer_respects_device_region[Ipc_AI_3_assms]:
   "\<lbrace>cap_refs_respects_device_region and tcb_at t and  valid_objs and valid_mdb\<rbrace>
    do_ipc_transfer t ep bg grt r
    \<lbrace>\<lambda>rv. cap_refs_respects_device_region\<rbrace>"
@@ -545,7 +576,7 @@ lemma set_mrs_state_hyp_refs_of[wp]:
   by (wp set_mrs_thread_set_dmo thread_set_hyp_refs_trivial | simp)+
 
 crunch do_ipc_transfer
-  for state_hyp_refs_of[wp, Ipc_AI_cont_assms]: "\<lambda> s. P (state_hyp_refs_of s)"
+  for state_hyp_refs_of[wp, Ipc_AI_3_assms]: "\<lambda> s. P (state_hyp_refs_of s)"
   (wp: crunch_wps simp: zipWithM_x_mapM)
 
 lemma arch_derive_cap_untyped:
@@ -564,11 +595,18 @@ lemma valid_arch_mdb_cap_swap:
             ((caps_of_state s)(a \<mapsto> c', b \<mapsto> c))"
   by auto
 
+lemma do_ipc_transfer_valid_arch[Ipc_AI_3_assms]:
+  "\<lbrace>valid_arch_state and valid_objs and valid_mdb \<rbrace>
+   do_ipc_transfer s ep bg grt r
+   \<lbrace>\<lambda>rv. valid_arch_state\<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps do_ipc_transfer_aobj_at)
+
 end
 
-interpretation Ipc_AI_cont?: Ipc_AI_cont
-  proof goal_cases
+interpretation Ipc_AI?: Ipc_AI_3
+proof goal_cases
   interpret Arch .
-  case 1 show ?case by (unfold_locales;(fact Ipc_AI_cont_assms)?)
-  qed
+  case 1 show ?case by (unfold_locales;(fact Ipc_AI_3_assms)?)
+qed
+
 end
diff --git a/proof/invariant-abstract/ARM_HYP/ArchKHeap_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchKHeap_AI.thy
index d42f40b02f..839a785abc 100644
--- a/proof/invariant-abstract/ARM_HYP/ArchKHeap_AI.thy
+++ b/proof/invariant-abstract/ARM_HYP/ArchKHeap_AI.thy
@@ -464,7 +464,9 @@ lemma valid_kernel_mappings_lift:
 
 end
 
-lemma valid_arch_state_lift_aobj_at:
+(* intended for use inside Arch, as opposed to the interface lemma valid_arch_state_lift_aobj_at,
+   since this architecture does not need cap preservation for valid_arch_state *)
+lemma valid_arch_state_lift_aobj_at_no_caps:
   assumes aobj_at:
     "\<And>P P' pd. arch_obj_pred P' \<Longrightarrow> \<lbrace>\<lambda>s. P (obj_at P' pd s)\<rbrace> f \<lbrace>\<lambda>r s. P (obj_at P' pd s)\<rbrace>"
   shows "\<lbrace>valid_arch_state\<rbrace> f \<lbrace>\<lambda>rv. valid_arch_state\<rbrace>"
@@ -478,6 +480,14 @@ lemma valid_arch_state_lift_aobj_at:
   apply wp
   done
 
+(* interface lemma *)
+lemma valid_arch_state_lift_aobj_at:
+  assumes aobj_at:
+    "\<And>P P' pd. arch_obj_pred P' \<Longrightarrow> \<lbrace>\<lambda>s. P (obj_at P' pd s)\<rbrace> f \<lbrace>\<lambda>r s. P (obj_at P' pd s)\<rbrace>"
+  assumes caps: "\<And>P. \<lbrace>\<lambda>s. P (caps_of_state s)\<rbrace> f \<lbrace>\<lambda>_ s. P (caps_of_state s)\<rbrace>"
+  shows "f \<lbrace>valid_arch_state\<rbrace>"
+  by (intro valid_arch_state_lift_aobj_at_no_caps aobj_at)
+
 end
 
 lemma equal_kernel_mappings_lift:
@@ -742,21 +752,11 @@ lemma valid_arch_tcb_same_type:
    \<Longrightarrow> valid_arch_tcb t (s\<lparr>kheap := (kheap s)(p \<mapsto> k)\<rparr>)"
   by (auto simp: valid_arch_tcb_def obj_at_def)
 
-lemma valid_ioports_lift:
-  assumes x: "\<And>P. \<lbrace>\<lambda>s. P (caps_of_state s)\<rbrace> f \<lbrace>\<lambda>rv s. P (caps_of_state s)\<rbrace>"
-  assumes y: "\<And>P. \<lbrace>\<lambda>s. P (arch_state s)\<rbrace> f \<lbrace>\<lambda>rv s. P (arch_state s)\<rbrace>"
-  shows      "\<lbrace>valid_ioports\<rbrace> f \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  apply simp
-  apply (rule hoare_use_eq [where f=caps_of_state, OF x y])
-  done
-
 lemma valid_arch_mdb_lift:
   assumes c: "\<And>P. \<lbrace>\<lambda>s. P (caps_of_state s)\<rbrace> f \<lbrace>\<lambda>r s. P (caps_of_state s)\<rbrace>"
   assumes r: "\<And>P. \<lbrace>\<lambda>s. P (is_original_cap s)\<rbrace> f \<lbrace>\<lambda>r s. P (is_original_cap s)\<rbrace>"
   shows "\<lbrace>\<lambda>s. valid_arch_mdb (is_original_cap s) (caps_of_state s)\<rbrace> f \<lbrace>\<lambda>r s. valid_arch_mdb (is_original_cap s) (caps_of_state s)\<rbrace>"
-  apply (clarsimp simp: valid_def)
-  done
-
+  by (clarsimp simp: valid_def valid_arch_mdb_def)
 
 end
 end
diff --git a/proof/invariant-abstract/ARM_HYP/ArchTcbAcc_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchTcbAcc_AI.thy
index 91f66dda4b..b648343a77 100644
--- a/proof/invariant-abstract/ARM_HYP/ArchTcbAcc_AI.thy
+++ b/proof/invariant-abstract/ARM_HYP/ArchTcbAcc_AI.thy
@@ -167,7 +167,10 @@ lemma tcb_context_update_aux: "arch_tcb_context_set (P (arch_tcb_context_get atc
                                = tcb_context_update (\<lambda>ctx. P ctx) atcb"
   by (simp add: arch_tcb_context_set_def arch_tcb_context_get_def)
 
-
+lemma thread_set_valid_arch_state[TcbAcc_AI_assms]:
+  "(\<And>tcb. \<forall>(getF, v) \<in> ran tcb_cap_cases. getF (f tcb) = getF tcb)
+   \<Longrightarrow> thread_set f t \<lbrace> valid_arch_state \<rbrace>"
+  by (wp valid_arch_state_lift_aobj_at_no_caps thread_set.aobj_at)
 
 end
 
diff --git a/proof/invariant-abstract/ARM_HYP/ArchUntyped_AI.thy b/proof/invariant-abstract/ARM_HYP/ArchUntyped_AI.thy
index 900d27e25a..f0f8a8e4d1 100644
--- a/proof/invariant-abstract/ARM_HYP/ArchUntyped_AI.thy
+++ b/proof/invariant-abstract/ARM_HYP/ArchUntyped_AI.thy
@@ -443,8 +443,16 @@ lemma obj_is_device_vui_eq[Untyped_AI_assms]:
   apply (auto simp: arch_is_frame_type_def)
   done
 
-lemma create_cap_ioports[wp, Untyped_AI_assms]:
-  "\<lbrace>valid_ioports and cte_wp_at (\<lambda>_. True) cref\<rbrace> create_cap tp sz p dev (cref,oref) \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
+lemma create_cap_valid_arch_state[wp, Untyped_AI_assms]:
+  "\<lbrace>valid_arch_state and cte_wp_at (\<lambda>_. True) cref\<rbrace>
+   create_cap tp sz p dev (cref,oref)
+   \<lbrace>\<lambda>rv. valid_arch_state\<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps create_cap_aobj_at)
+
+lemma set_cap_non_arch_valid_arch_state[Untyped_AI_assms]:
+ "\<lbrace>\<lambda>s. valid_arch_state s \<and> cte_wp_at (\<lambda>_. \<not>is_arch_cap cap) ptr s\<rbrace>
+  set_cap cap ptr
+  \<lbrace>\<lambda>rv. valid_arch_state \<rbrace>"
   by wpsimp
 
 end
diff --git a/proof/invariant-abstract/RISCV64/ArchArch_AI.thy b/proof/invariant-abstract/RISCV64/ArchArch_AI.thy
index 302db1c015..195495b331 100644
--- a/proof/invariant-abstract/RISCV64/ArchArch_AI.thy
+++ b/proof/invariant-abstract/RISCV64/ArchArch_AI.thy
@@ -628,13 +628,6 @@ lemma safe_parent_cap_is_device:
   "safe_parent_for m p cap pcap \<Longrightarrow> cap_is_device cap = cap_is_device pcap"
   by (simp add: safe_parent_for_def)
 
-lemma cap_insert_ioports_ap:
-  "\<lbrace>valid_ioports and (\<lambda>s. cte_wp_at (\<lambda>cap'. safe_ioport_insert cap cap' s) dest s) and
-        K (is_ap_cap cap)\<rbrace>
-     cap_insert cap src dest
-   \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by wpsimp
-
 crunch cap_insert
   for aobjs_of[wp]: "\<lambda>s. P (aobjs_of s)"
   (wp: crunch_wps)
@@ -660,7 +653,7 @@ lemma cap_insert_ap_invs:
   apply (simp cong: conj_cong)
   apply (rule hoare_pre)
    apply (wp cap_insert_simple_mdb cap_insert_iflive
-             cap_insert_zombies cap_insert_ifunsafe cap_insert_ioports_ap
+             cap_insert_zombies cap_insert_ifunsafe
              cap_insert_valid_global_refs cap_insert_idle
              valid_irq_node_typ cap_insert_simple_arch_caps_ap)
   apply (clarsimp simp: is_simple_cap_def cte_wp_at_caps_of_state is_cap_simps)
diff --git a/proof/invariant-abstract/RISCV64/ArchCNodeInv_AI.thy b/proof/invariant-abstract/RISCV64/ArchCNodeInv_AI.thy
index 80422354f9..d2eed1c993 100644
--- a/proof/invariant-abstract/RISCV64/ArchCNodeInv_AI.thy
+++ b/proof/invariant-abstract/RISCV64/ArchCNodeInv_AI.thy
@@ -427,15 +427,8 @@ lemma cap_swap_cap_refs_in_kernel_window[wp, CNodeInv_AI_assms]:
                simp: cte_wp_at_caps_of_state weak_derived_cap_range)
   done
 
-
-lemma cap_swap_ioports[wp, CNodeInv_AI_assms]:
-  "\<lbrace>valid_ioports and cte_wp_at (weak_derived c) a and cte_wp_at (weak_derived c') b\<rbrace>
-     cap_swap c a c' b
-   \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by wpsimp
-
 lemma cap_swap_vms[wp, CNodeInv_AI_assms]:
-  "\<lbrace>valid_machine_state\<rbrace>  cap_swap c a c' b \<lbrace>\<lambda>rv. valid_machine_state\<rbrace>"
+  "\<lbrace>valid_machine_state\<rbrace> cap_swap c a c' b \<lbrace>\<lambda>rv. valid_machine_state\<rbrace>"
   apply (simp add: valid_machine_state_def in_user_frame_def)
   apply (wp cap_swap_typ_at
             hoare_vcg_all_lift hoare_vcg_ex_lift hoare_vcg_disj_lift)
@@ -529,6 +522,12 @@ lemma prepare_thread_delete_thread_cap [CNodeInv_AI_assms]:
    \<lbrace>\<lambda>rv s. caps_of_state s x = Some (cap.ThreadCap p)\<rbrace>"
   by (wpsimp simp: prepare_thread_delete_def)
 
+lemma cap_swap_valid_arch_state[wp, CNodeInv_AI_assms]:
+  "\<lbrace>valid_arch_state and cte_wp_at (weak_derived c) a and cte_wp_at (weak_derived c') b\<rbrace>
+   cap_swap c a c' b
+   \<lbrace>\<lambda>_. valid_arch_state\<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps cap_swap_aobj_at)
+
 end
 
 
@@ -546,7 +545,7 @@ context Arch begin arch_global_naming
 
 lemma post_cap_delete_pre_is_final_cap':
   "\<And>s.
-       \<lbrakk>valid_ioports s; caps_of_state s slot = Some cap; is_final_cap' cap s; cap_cleanup_opt cap \<noteq> NullCap\<rbrakk>
+       \<lbrakk> caps_of_state s slot = Some cap; is_final_cap' cap s; cap_cleanup_opt cap \<noteq> NullCap\<rbrakk>
        \<Longrightarrow> post_cap_delete_pre (cap_cleanup_opt cap) ((caps_of_state s)(slot \<mapsto> NullCap))"
   apply (clarsimp simp: cap_cleanup_opt_def cte_wp_at_def post_cap_delete_pre_def
                       split: cap.split_asm if_split_asm
@@ -943,14 +942,6 @@ global_interpretation CNodeInv_AI_4?: CNodeInv_AI_4
 
 context Arch begin arch_global_naming
 
-lemma cap_move_ioports:
-  "\<lbrace>valid_ioports and cte_wp_at ((=) cap.NullCap) ptr'
-         and cte_wp_at (weak_derived cap) ptr
-         and cte_wp_at (\<lambda>c. c \<noteq> cap.NullCap) ptr and K (ptr \<noteq> ptr')\<rbrace>
-     cap_move cap ptr ptr'
-   \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by wpsimp
-
 lemma cap_move_invs[wp, CNodeInv_AI_assms]:
   "\<lbrace>invs and valid_cap cap and cte_wp_at ((=) cap.NullCap) ptr'
          and tcb_cap_valid cap ptr'
@@ -970,7 +961,6 @@ lemma cap_move_invs[wp, CNodeInv_AI_assms]:
    apply (wpe cap_move_replies)
    apply (wpe cap_move_valid_arch_caps)
    apply (wpe cap_move_valid_ioc)
-   apply (wpe cap_move_ioports)
    apply (simp add: cap_move_def set_cdt_def)
    apply (rule hoare_pre)
     apply (wp set_cap_valid_objs set_cap_idle set_cap_typ_at
diff --git a/proof/invariant-abstract/RISCV64/ArchCSpaceInv_AI.thy b/proof/invariant-abstract/RISCV64/ArchCSpaceInv_AI.thy
index f0dbf7d8d8..91aaaf377c 100644
--- a/proof/invariant-abstract/RISCV64/ArchCSpaceInv_AI.thy
+++ b/proof/invariant-abstract/RISCV64/ArchCSpaceInv_AI.thy
@@ -14,20 +14,9 @@ begin
 
 context Arch begin arch_global_naming
 
-definition
-   safe_ioport_insert :: "cap \<Rightarrow> cap \<Rightarrow> 'a::state_ext state \<Rightarrow> bool"
-where
-  "safe_ioport_insert newcap oldcap \<equiv> \<lambda>_. True"
-
-lemma safe_ioport_insert_triv:
-  "\<not>is_arch_cap newcap \<Longrightarrow> safe_ioport_insert newcap oldcap s"
-  by (clarsimp simp: safe_ioport_insert_def)
-
-lemma set_cap_ioports':
- "\<lbrace>\<lambda>s. valid_ioports s \<and> cte_wp_at (\<lambda>cap'. safe_ioport_insert cap cap' s) ptr s\<rbrace>
-    set_cap cap ptr
-  \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by wpsimp
+lemma set_cap_valid_arch_state[wp]:
+  "set_cap cap ptr \<lbrace> valid_arch_state \<rbrace>"
+  by (wp valid_arch_state_lift_aobj_at_no_caps set_cap.aobj_at)
 
 lemma replace_cap_invs:
   "\<lbrace>\<lambda>s. invs s \<and> cte_wp_at (replaceable s p cap) p s
diff --git a/proof/invariant-abstract/RISCV64/ArchCSpace_AI.thy b/proof/invariant-abstract/RISCV64/ArchCSpace_AI.thy
index 544080c317..f6fb1c97d6 100644
--- a/proof/invariant-abstract/RISCV64/ArchCSpace_AI.thy
+++ b/proof/invariant-abstract/RISCV64/ArchCSpace_AI.thy
@@ -477,15 +477,15 @@ lemma cap_insert_simple_arch_caps_no_ap:
   apply (intro conjI impI allI)
   by (auto simp:is_simple_cap_def[simplified is_simple_cap_arch_def] is_cap_simps)
 
-lemma setup_reply_master_ioports[wp, CSpace_AI_assms]:
-  "\<lbrace>valid_ioports\<rbrace> setup_reply_master c \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by wpsimp
+lemma cap_insert_derived_valid_arch_state[CSpace_AI_assms]:
+  "\<lbrace>valid_arch_state and (\<lambda>s. cte_wp_at (is_derived (cdt s) src cap) src s)\<rbrace>
+   cap_insert cap src dest
+   \<lbrace>\<lambda>rv. valid_arch_state \<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps cap_insert_aobj_at cap_insert_aobj_at)
 
-lemma cap_insert_derived_ioports[CSpace_AI_assms]:
-  "\<lbrace>valid_ioports and (\<lambda>s. cte_wp_at (is_derived (cdt s) src cap) src s)\<rbrace>
-     cap_insert cap src dest
-   \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by wpsimp
+lemma setup_reply_master_arch[CSpace_AI_assms]:
+  "setup_reply_master t \<lbrace> valid_arch_state \<rbrace>"
+  by (wpsimp simp: setup_reply_master_def wp: get_cap_wp)
 
 end
 
@@ -514,6 +514,10 @@ lemma is_cap_simps':
                             is_reply_cap_def is_master_reply_cap_def is_FrameCap_def
                      split: cap.splits arch_cap.splits)+
 
+lemma cap_insert_simple_valid_arch_state[wp]:
+  "cap_insert cap src dest \<lbrace> valid_arch_state\<rbrace>"
+  by (wp valid_arch_state_lift_aobj_at_no_caps cap_insert_aobj_at)+
+
 lemma cap_insert_simple_invs:
   "\<lbrace>invs and valid_cap cap and tcb_cap_valid cap dest and
     ex_cte_cap_wp_to (appropriate_cte_cap cap) dest and
diff --git a/proof/invariant-abstract/RISCV64/ArchDetype_AI.thy b/proof/invariant-abstract/RISCV64/ArchDetype_AI.thy
index 6a8ea14122..6944211c47 100644
--- a/proof/invariant-abstract/RISCV64/ArchDetype_AI.thy
+++ b/proof/invariant-abstract/RISCV64/ArchDetype_AI.thy
@@ -107,10 +107,6 @@ lemma state_hyp_refs_of_detype:
   "state_hyp_refs_of (detype S s) = (\<lambda>x. if x \<in> 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_assms]:
-  "valid_ioports s \<Longrightarrow> valid_ioports (detype (untyped_range cap) s)"
-  by simp
-
 end
 
 interpretation Detype_AI?: Detype_AI
diff --git a/proof/invariant-abstract/RISCV64/ArchFinalise_AI.thy b/proof/invariant-abstract/RISCV64/ArchFinalise_AI.thy
index d9fe10ca35..e615482aad 100644
--- a/proof/invariant-abstract/RISCV64/ArchFinalise_AI.thy
+++ b/proof/invariant-abstract/RISCV64/ArchFinalise_AI.thy
@@ -1363,10 +1363,6 @@ lemma (* zombie_cap_two_nonidles *)[Finalise_AI_assms]:
   apply (cases ptr, auto dest: valid_idle_has_null_cap_ARCH[rotated -1])[1]
   done
 
-crunch empty_slot, finalise_cap, send_ipc, receive_ipc
-  for ioports[wp]: valid_ioports
-  (wp: crunch_wps valid_ioports_lift simp: crunch_simps ignore: set_object)
-
 lemma arch_derive_cap_notzombie[wp]:
   "\<lbrace>\<top>\<rbrace> arch_derive_cap acap \<lbrace>\<lambda>rv s. \<not> is_zombie rv\<rbrace>, -"
   by (cases acap; wpsimp simp: arch_derive_cap_def is_zombie_def o_def)
diff --git a/proof/invariant-abstract/RISCV64/ArchInvariants_AI.thy b/proof/invariant-abstract/RISCV64/ArchInvariants_AI.thy
index cac9af2e9c..3c163230d6 100644
--- a/proof/invariant-abstract/RISCV64/ArchInvariants_AI.thy
+++ b/proof/invariant-abstract/RISCV64/ArchInvariants_AI.thy
@@ -629,9 +629,6 @@ definition valid_asid_map :: "'z::state_ext state \<Rightarrow> bool" where
 definition valid_global_objs :: "'z::state_ext state \<Rightarrow> bool" where
   "valid_global_objs \<equiv> \<top>"
 
-definition valid_ioports :: "'z::state_ext state \<Rightarrow> bool" where
-  [simp]: "valid_ioports \<equiv> \<top>"
-
 
 (* This definition is needed as interface for other architectures only.
    In other architectures, S is a set of object references (to global tables) that
@@ -2779,10 +2776,6 @@ lemma valid_table_caps_update [iff]:
   "valid_table_caps (f s) = valid_table_caps s"
   by (simp add: valid_table_caps_def arch pspace)
 
-lemma valid_ioports_update[iff]:
-  "valid_ioports (f s) = valid_ioports s"
-  by simp
-
 lemma valid_asid_table_update [iff]:
   "valid_asid_table (f s) = valid_asid_table s"
   by (simp add: valid_asid_table_def arch pspace)
diff --git a/proof/invariant-abstract/RISCV64/ArchIpc_AI.thy b/proof/invariant-abstract/RISCV64/ArchIpc_AI.thy
index d8cefceb96..379ee331ac 100644
--- a/proof/invariant-abstract/RISCV64/ArchIpc_AI.thy
+++ b/proof/invariant-abstract/RISCV64/ArchIpc_AI.thy
@@ -10,7 +10,7 @@ begin
 
 context Arch begin arch_global_naming
 
-named_theorems Ipc_AI_assms
+named_theorems Ipc_AI_1_assms
 
 lemma cap_asid_PageCap_None[simp]:
   "cap_asid (ArchObjectCap (FrameCap r R pgsz dev None)) = None"
@@ -36,7 +36,7 @@ lemma arch_derive_cap_is_derived:
              | rule conjI)+)
   done
 
-lemma derive_cap_is_derived [Ipc_AI_assms]:
+lemma derive_cap_is_derived [Ipc_AI_1_assms]:
   "\<lbrace>\<lambda>s. c'\<noteq> cap.NullCap \<longrightarrow> cte_wp_at (\<lambda>cap. cap_master_cap cap = cap_master_cap c'
                      \<and> (cap_badge cap, cap_badge c') \<in> capBadge_ordering False
                      \<and> cap_asid cap = cap_asid c'
@@ -62,7 +62,19 @@ lemma derive_cap_is_derived [Ipc_AI_assms]:
   apply(clarsimp simp: valid_cap_def)
   done
 
-lemma is_derived_cap_rights [simp, Ipc_AI_assms]:
+end
+
+interpretation Ipc_AI?: Ipc_AI
+proof goal_cases
+  interpret Arch .
+  case 1 show ?case by (unfold_locales; (fact Ipc_AI_1_assms)?)
+qed
+
+context Arch begin arch_global_naming
+
+named_theorems Ipc_AI_2_assms
+
+lemma is_derived_cap_rights [simp, Ipc_AI_2_assms]:
   "is_derived m p (cap_rights_update R c) = is_derived m p c"
   apply (rule ext)
   apply (simp add: cap_rights_update_def is_derived_def is_cap_simps)
@@ -74,12 +86,12 @@ lemma is_derived_cap_rights [simp, Ipc_AI_assms]:
            split: arch_cap.split cap.split bool.splits)
 
 
-lemma data_to_message_info_valid [Ipc_AI_assms]:
+lemma data_to_message_info_valid [Ipc_AI_2_assms]:
   "valid_message_info (data_to_message_info w)"
   by (simp add: valid_message_info_def data_to_message_info_def  word_and_le1 msg_max_length_def
                 msg_max_extra_caps_def Let_def not_less mask_def)
 
-lemma get_extra_cptrs_length[wp, Ipc_AI_assms]:
+lemma get_extra_cptrs_length[wp, Ipc_AI_2_assms]:
   "\<lbrace>\<lambda>s . valid_message_info mi\<rbrace>
    get_extra_cptrs buf mi
    \<lbrace>\<lambda>rv s. length rv \<le> msg_max_extra_caps\<rbrace>"
@@ -94,17 +106,17 @@ lemma get_extra_cptrs_length[wp, Ipc_AI_assms]:
                  intro: length_upt)
   done
 
-lemma cap_asid_rights_update [simp, Ipc_AI_assms]:
+lemma cap_asid_rights_update [simp, Ipc_AI_2_assms]:
   "cap_asid (cap_rights_update R c) = cap_asid c"
   by (simp add: cap_rights_update_def acap_rights_update_def cap_asid_def
          split: cap.splits arch_cap.splits)
 
-lemma cap_rights_update_vs_cap_ref[simp, Ipc_AI_assms]:
+lemma cap_rights_update_vs_cap_ref[simp, Ipc_AI_2_assms]:
   "vs_cap_ref (cap_rights_update rs cap) = vs_cap_ref cap"
   by (simp add: vs_cap_ref_def vs_cap_ref_arch_def cap_rights_update_def acap_rights_update_def
          split: cap.split arch_cap.split)
 
-lemma is_derived_cap_rights2[simp, Ipc_AI_assms]:
+lemma is_derived_cap_rights2[simp, Ipc_AI_2_assms]:
   "is_derived m p c (cap_rights_update R c') = is_derived m p c c'"
   apply (case_tac c'; simp add: cap_rights_update_def)
      apply (clarsimp simp: is_derived_def is_cap_simps cap_master_cap_def vs_cap_ref_def
@@ -113,12 +125,12 @@ lemma is_derived_cap_rights2[simp, Ipc_AI_assms]:
   apply (case_tac acap1)
   by (auto simp: acap_rights_update_def)
 
-lemma cap_range_update [simp, Ipc_AI_assms]:
+lemma cap_range_update [simp, Ipc_AI_2_assms]:
   "cap_range (cap_rights_update R cap) = cap_range cap"
   by (simp add: cap_range_def cap_rights_update_def acap_rights_update_def
          split: cap.splits arch_cap.splits)
 
-lemma derive_cap_idle[wp, Ipc_AI_assms]:
+lemma derive_cap_idle[wp, Ipc_AI_2_assms]:
   "\<lbrace>\<lambda>s. global_refs s \<inter> cap_range cap = {}\<rbrace>
    derive_cap slot cap
   \<lbrace>\<lambda>c s. global_refs s \<inter> cap_range c = {}\<rbrace>, -"
@@ -130,7 +142,7 @@ lemma derive_cap_idle[wp, Ipc_AI_assms]:
   apply (case_tac arch_cap, simp_all)
   done
 
-lemma arch_derive_cap_objrefs_iszombie [Ipc_AI_assms]:
+lemma arch_derive_cap_objrefs_iszombie [Ipc_AI_2_assms]:
   "\<lbrace>\<lambda>s . P (set_option (aobj_ref cap)) False s\<rbrace>
      arch_derive_cap cap
    \<lbrace>\<lambda>rv s. rv \<noteq> NullCap \<longrightarrow> P (obj_refs rv) (is_zombie rv) s\<rbrace>,-"
@@ -138,7 +150,7 @@ lemma arch_derive_cap_objrefs_iszombie [Ipc_AI_assms]:
       apply(rule hoare_pre, wpsimp+)+
   done
 
-lemma obj_refs_remove_rights[simp, Ipc_AI_assms]:
+lemma obj_refs_remove_rights[simp, Ipc_AI_2_assms]:
   "obj_refs (remove_rights rs cap) = obj_refs cap"
   by (auto simp add: remove_rights_def cap_rights_update_def
                 acap_rights_update_def
@@ -150,7 +162,7 @@ lemma storeWord_um_inv:
    \<lbrace>\<lambda>_ s. is_aligned a 3 \<and> x \<in> {a,a+1,a+2,a+3,a+4,a+5,a+6,a+7} \<or> underlying_memory s x = um x\<rbrace>"
   by (wpsimp simp: upto.simps storeWord_def is_aligned_mask)
 
-lemma store_word_offs_vms[wp, Ipc_AI_assms]:
+lemma store_word_offs_vms[wp, Ipc_AI_2_assms]:
   "\<lbrace>valid_machine_state\<rbrace> store_word_offs ptr offs v \<lbrace>\<lambda>_. valid_machine_state\<rbrace>"
 proof -
   have aligned_offset_ignore:
@@ -189,12 +201,12 @@ proof -
     done
 qed
 
-lemma is_zombie_update_cap_data[simp, Ipc_AI_assms]:
+lemma is_zombie_update_cap_data[simp, Ipc_AI_2_assms]:
   "is_zombie (update_cap_data P data cap) = is_zombie cap"
   by (simp add: update_cap_data_closedform arch_update_cap_data_def is_zombie_def
          split: cap.splits)
 
-lemma valid_msg_length_strengthen [Ipc_AI_assms]:
+lemma valid_msg_length_strengthen [Ipc_AI_2_assms]:
   "valid_message_info mi \<longrightarrow> unat (mi_length mi) \<le> msg_max_length"
   apply (clarsimp simp: valid_message_info_def)
   apply (subgoal_tac "unat (mi_length mi) \<le> unat (of_nat msg_max_length :: machine_word)")
@@ -202,17 +214,17 @@ lemma valid_msg_length_strengthen [Ipc_AI_assms]:
   apply (clarsimp simp: un_ui_le word_le_def)
   done
 
-lemma copy_mrs_in_user_frame[wp, Ipc_AI_assms]:
+lemma copy_mrs_in_user_frame[wp, Ipc_AI_2_assms]:
   "\<lbrace>in_user_frame p\<rbrace> copy_mrs t buf t' buf' n \<lbrace>\<lambda>rv. in_user_frame p\<rbrace>"
   by (simp add: in_user_frame_def) (wp hoare_vcg_ex_lift)
 
 lemma as_user_getRestart_invs[wp]: "\<lbrace>P\<rbrace> as_user t getRestartPC \<lbrace>\<lambda>_. P\<rbrace>"
   by (simp add: getRestartPC_def, rule user_getreg_inv)
 
-lemma make_arch_fault_msg_invs[wp, Ipc_AI_assms]: "make_arch_fault_msg f t \<lbrace>invs\<rbrace>"
+lemma make_arch_fault_msg_invs[wp, Ipc_AI_2_assms]: "make_arch_fault_msg f t \<lbrace>invs\<rbrace>"
   by (cases f; wpsimp)
 
-lemma make_fault_message_inv[wp, Ipc_AI_assms]:
+lemma make_fault_message_inv[wp, Ipc_AI_2_assms]:
   "make_fault_msg ft t \<lbrace>invs\<rbrace>"
   apply (cases ft, simp_all split del: if_split)
      apply (wp as_user_inv getRestartPC_inv mapM_wp'
@@ -222,14 +234,14 @@ lemma make_fault_message_inv[wp, Ipc_AI_assms]:
 crunch make_fault_msg
   for tcb_at[wp]: "tcb_at t"
 
-lemma do_fault_transfer_invs[wp, Ipc_AI_assms]:
+lemma do_fault_transfer_invs[wp, Ipc_AI_2_assms]:
   "\<lbrace>invs and tcb_at receiver\<rbrace>
       do_fault_transfer badge sender receiver recv_buf
    \<lbrace>\<lambda>rv. invs\<rbrace>"
   by (simp add: do_fault_transfer_def split_def | wp
     | clarsimp split: option.split)+
 
-lemma lookup_ipc_buffer_in_user_frame[wp, Ipc_AI_assms]:
+lemma lookup_ipc_buffer_in_user_frame[wp, Ipc_AI_2_assms]:
   "\<lbrace>valid_objs and tcb_at t\<rbrace> lookup_ipc_buffer b t
    \<lbrace>case_option (\<lambda>_. True) in_user_frame\<rbrace>"
   apply (simp add: lookup_ipc_buffer_def)
@@ -326,9 +338,9 @@ lemma transfer_caps_non_null_cte_wp_at:
   done
 
 crunch do_fault_transfer
-  for cte_wp_at[wp,Ipc_AI_assms]: "cte_wp_at P p"
+  for cte_wp_at[wp,Ipc_AI_2_assms]: "cte_wp_at P p"
 
-lemma do_normal_transfer_non_null_cte_wp_at [Ipc_AI_assms]:
+lemma do_normal_transfer_non_null_cte_wp_at [Ipc_AI_2_assms]:
   assumes imp: "\<And>c. P c \<Longrightarrow> \<not> is_untyped_cap c"
   shows  "\<lbrace>valid_objs and cte_wp_at (P and ((\<noteq>) cap.NullCap)) ptr\<rbrace>
    do_normal_transfer st send_buffer ep b gr rt recv_buffer
@@ -339,7 +351,7 @@ lemma do_normal_transfer_non_null_cte_wp_at [Ipc_AI_assms]:
     | clarsimp simp:imp)+
   done
 
-lemma is_derived_ReplyCap [simp, Ipc_AI_assms]:
+lemma is_derived_ReplyCap [simp, Ipc_AI_2_assms]:
   "\<And>m p R. is_derived m p (cap.ReplyCap t False R) = (\<lambda>c. is_master_reply_cap c \<and> obj_ref_of c = t)"
   apply (subst fun_eq_iff)
   apply clarsimp
@@ -360,7 +372,7 @@ lemma do_normal_transfer_tcb_caps:
      | simp add:imp)+
   done
 
-lemma do_ipc_transfer_tcb_caps [Ipc_AI_assms]:
+lemma do_ipc_transfer_tcb_caps [Ipc_AI_2_assms]:
   assumes imp: "\<And>c. P c \<Longrightarrow> \<not> is_untyped_cap c"
   shows
   "\<lbrace>valid_objs and cte_wp_at P (t, ref) and tcb_at t\<rbrace>
@@ -372,7 +384,7 @@ lemma do_ipc_transfer_tcb_caps [Ipc_AI_assms]:
        | wpc | simp add:imp)+
   done
 
-lemma setup_caller_cap_valid_global_objs[wp, Ipc_AI_assms]:
+lemma setup_caller_cap_valid_global_objs[wp, Ipc_AI_2_assms]:
   "\<lbrace>valid_global_objs\<rbrace> setup_caller_cap send recv grant \<lbrace>\<lambda>rv. valid_global_objs\<rbrace>"
   apply (simp add: valid_global_objs_def)
   unfolding setup_caller_cap_def
@@ -380,9 +392,9 @@ lemma setup_caller_cap_valid_global_objs[wp, Ipc_AI_assms]:
   done
 
 crunch handle_arch_fault_reply, arch_get_sanitise_register_info
-  for inv[Ipc_AI_assms]: P
+  for inv[Ipc_AI_2_assms]: P
 
-lemma transfer_caps_loop_valid_vspace_objs[wp, Ipc_AI_assms]:
+lemma transfer_caps_loop_valid_vspace_objs[wp, Ipc_AI_2_assms]:
   "\<lbrace>valid_vspace_objs\<rbrace>
       transfer_caps_loop ep buffer n caps slots mi
     \<lbrace>\<lambda>rv. valid_vspace_objs\<rbrace>"
@@ -398,105 +410,124 @@ lemma transfer_caps_loop_valid_vspace_objs[wp, Ipc_AI_assms]:
   done
 
 crunch  make_arch_fault_msg
-  for aligned[wp, Ipc_AI_assms]: "pspace_aligned"
+  for aligned[wp, Ipc_AI_2_assms]: "pspace_aligned"
 crunch  make_arch_fault_msg
-  for distinct[wp, Ipc_AI_assms]: "pspace_distinct"
+  for distinct[wp, Ipc_AI_2_assms]: "pspace_distinct"
 crunch  make_arch_fault_msg
-  for vmdb[wp, Ipc_AI_assms]: "valid_mdb"
+  for vmdb[wp, Ipc_AI_2_assms]: "valid_mdb"
 crunch  make_arch_fault_msg
-  for ifunsafe[wp, Ipc_AI_assms]: "if_unsafe_then_cap"
+  for ifunsafe[wp, Ipc_AI_2_assms]: "if_unsafe_then_cap"
 crunch  make_arch_fault_msg
-  for iflive[wp, Ipc_AI_assms]: "if_live_then_nonz_cap"
+  for iflive[wp, Ipc_AI_2_assms]: "if_live_then_nonz_cap"
 crunch  make_arch_fault_msg
-  for state_refs_of[wp, Ipc_AI_assms]: "\<lambda>s. P (state_refs_of s)"
+  for state_refs_of[wp, Ipc_AI_2_assms]: "\<lambda>s. P (state_refs_of s)"
 crunch  make_arch_fault_msg
-  for ct[wp, Ipc_AI_assms]: "cur_tcb"
+  for ct[wp, Ipc_AI_2_assms]: "cur_tcb"
 crunch  make_arch_fault_msg
-  for zombies[wp, Ipc_AI_assms]: "zombies_final"
+  for zombies[wp, Ipc_AI_2_assms]: "zombies_final"
 crunch  make_arch_fault_msg
-  for it[wp, Ipc_AI_assms]: "\<lambda>s. P (idle_thread s)"
+  for it[wp, Ipc_AI_2_assms]: "\<lambda>s. P (idle_thread s)"
 crunch  make_arch_fault_msg
-  for valid_globals[wp, Ipc_AI_assms]: "valid_global_refs"
+  for valid_globals[wp, Ipc_AI_2_assms]: "valid_global_refs"
 crunch  make_arch_fault_msg
-  for reply_masters[wp, Ipc_AI_assms]: "valid_reply_masters"
+  for reply_masters[wp, Ipc_AI_2_assms]: "valid_reply_masters"
 crunch  make_arch_fault_msg
-  for valid_idle[wp, Ipc_AI_assms]: "valid_idle"
+  for valid_idle[wp, Ipc_AI_2_assms]: "valid_idle"
 crunch  make_arch_fault_msg
-  for arch[wp, Ipc_AI_assms]: "\<lambda>s. P (arch_state s)"
+  for arch[wp, Ipc_AI_2_assms]: "\<lambda>s. P (arch_state s)"
 crunch  make_arch_fault_msg
-  for typ_at[wp, Ipc_AI_assms]: "\<lambda>s. P (typ_at T p s)"
+  for typ_at[wp, Ipc_AI_2_assms]: "\<lambda>s. P (typ_at T p s)"
 crunch  make_arch_fault_msg
-  for irq_node[wp, Ipc_AI_assms]: "\<lambda>s. P (interrupt_irq_node s)"
+  for irq_node[wp, Ipc_AI_2_assms]: "\<lambda>s. P (interrupt_irq_node s)"
 crunch  make_arch_fault_msg
-  for valid_reply[wp, Ipc_AI_assms]: "valid_reply_caps"
+  for valid_reply[wp, Ipc_AI_2_assms]: "valid_reply_caps"
 crunch  make_arch_fault_msg
-  for irq_handlers[wp, Ipc_AI_assms]: "valid_irq_handlers"
+  for irq_handlers[wp, Ipc_AI_2_assms]: "valid_irq_handlers"
 crunch  make_arch_fault_msg
-  for vspace_objs[wp, Ipc_AI_assms]: "valid_vspace_objs"
+  for vspace_objs[wp, Ipc_AI_2_assms]: "valid_vspace_objs"
 crunch  make_arch_fault_msg
-  for global_objs[wp, Ipc_AI_assms]: "valid_global_objs"
+  for global_objs[wp, Ipc_AI_2_assms]: "valid_global_objs"
 crunch  make_arch_fault_msg
-  for global_vspace_mapping[wp, Ipc_AI_assms]: "valid_global_vspace_mappings"
+  for global_vspace_mapping[wp, Ipc_AI_2_assms]: "valid_global_vspace_mappings"
 crunch  make_arch_fault_msg
-  for arch_caps[wp, Ipc_AI_assms]: "valid_arch_caps"
+  for arch_caps[wp, Ipc_AI_2_assms]: "valid_arch_caps"
 crunch  make_arch_fault_msg
-  for v_ker_map[wp, Ipc_AI_assms]: "valid_kernel_mappings"
+  for v_ker_map[wp, Ipc_AI_2_assms]: "valid_kernel_mappings"
 crunch  make_arch_fault_msg
-  for eq_ker_map[wp, Ipc_AI_assms]: "equal_kernel_mappings"
+  for eq_ker_map[wp, Ipc_AI_2_assms]: "equal_kernel_mappings"
 crunch  make_arch_fault_msg
-  for asid_map[wp, Ipc_AI_assms]: "valid_asid_map"
+  for asid_map[wp, Ipc_AI_2_assms]: "valid_asid_map"
 crunch  make_arch_fault_msg
-  for only_idle[wp, Ipc_AI_assms]: "only_idle"
+  for only_idle[wp, Ipc_AI_2_assms]: "only_idle"
 crunch  make_arch_fault_msg
-  for pspace_in_kernel_window[wp, Ipc_AI_assms]: "pspace_in_kernel_window"
+  for pspace_in_kernel_window[wp, Ipc_AI_2_assms]: "pspace_in_kernel_window"
 crunch  make_arch_fault_msg
-  for cap_refs_in_kernel_window[wp, Ipc_AI_assms]: "cap_refs_in_kernel_window"
+  for cap_refs_in_kernel_window[wp, Ipc_AI_2_assms]: "cap_refs_in_kernel_window"
 crunch  make_arch_fault_msg
-  for valid_objs[wp, Ipc_AI_assms]: "valid_objs"
+  for valid_objs[wp, Ipc_AI_2_assms]: "valid_objs"
 crunch  make_arch_fault_msg
-  for valid_ioc[wp, Ipc_AI_assms]: "valid_ioc"
+  for valid_ioc[wp, Ipc_AI_2_assms]: "valid_ioc"
 crunch  make_arch_fault_msg
-  for pred_tcb[wp, Ipc_AI_assms]: "pred_tcb_at proj P t"
+  for pred_tcb[wp, Ipc_AI_2_assms]: "pred_tcb_at proj P t"
 crunch  make_arch_fault_msg
-  for cap_to[wp, Ipc_AI_assms]: "ex_nonz_cap_to p"
+  for cap_to[wp, Ipc_AI_2_assms]: "ex_nonz_cap_to p"
 
 crunch  make_arch_fault_msg
-  for obj_at[wp, Ipc_AI_assms]: "\<lambda>s. P (obj_at P' pd s)"
+  for obj_at[wp, Ipc_AI_2_assms]: "\<lambda>s. P (obj_at P' pd s)"
   (wp: as_user_inv getRestartPC_inv mapM_wp'  simp: getRegister_def)
 
 crunch make_arch_fault_msg
-  for vms[wp, Ipc_AI_assms]: valid_machine_state
+  for vms[wp, Ipc_AI_2_assms]: valid_machine_state
   (wp: as_user_inv getRestartPC_inv mapM_wp'  simp: getRegister_def ignore: do_machine_op)
 
 crunch make_arch_fault_msg
-  for valid_irq_states[wp, Ipc_AI_assms]: "valid_irq_states"
+  for valid_irq_states[wp, Ipc_AI_2_assms]: "valid_irq_states"
   (wp: as_user_inv getRestartPC_inv mapM_wp'  simp: getRegister_def ignore: do_machine_op)
 
 crunch make_arch_fault_msg
-  for cap_refs_respects_device_region[wp, Ipc_AI_assms]: "cap_refs_respects_device_region"
+  for cap_refs_respects_device_region[wp, Ipc_AI_2_assms]: "cap_refs_respects_device_region"
   (wp: as_user_inv getRestartPC_inv mapM_wp'  simp: getRegister_def ignore: do_machine_op)
 
+lemma setup_caller_cap_aobj_at:
+  "arch_obj_pred P' \<Longrightarrow>
+  \<lbrace>\<lambda>s. P (obj_at P' pd s)\<rbrace> setup_caller_cap st rt grant \<lbrace>\<lambda>r s. P (obj_at P' pd s)\<rbrace>"
+  unfolding setup_caller_cap_def
+  by (wpsimp wp: cap_insert_aobj_at sts.aobj_at)
+
+lemma setup_caller_cap_valid_arch[Ipc_AI_2_assms, wp]:
+  "setup_caller_cap st rt grant \<lbrace>valid_arch_state\<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps[rotated -1] setup_caller_cap_aobj_at)
+
+lemma transfer_caps_loop_valid_arch[Ipc_AI_2_assms]:
+  "\<And>slots caps ep buffer n mi.
+    \<lbrace>valid_arch_state and valid_objs and valid_mdb and K (distinct slots)
+         and (\<lambda>s. \<forall>x \<in> set slots. real_cte_at x s \<and> cte_wp_at (\<lambda>cap. cap = cap.NullCap) x s)
+         and transfer_caps_srcs caps\<rbrace>
+      transfer_caps_loop ep buffer n caps slots mi
+    \<lbrace>\<lambda>_. valid_arch_state\<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps transfer_caps_loop_aobj_at)
+
 end
 
-interpretation Ipc_AI?: Ipc_AI
+interpretation Ipc_AI?: Ipc_AI_2
 proof goal_cases
   interpret Arch .
-  case 1 show ?case by (unfold_locales; (fact Ipc_AI_assms)?)
+  case 1 show ?case by (unfold_locales; (fact Ipc_AI_2_assms)?)
 qed
 
 context Arch begin arch_global_naming
 
-named_theorems Ipc_AI_cont_assms
+named_theorems Ipc_AI_3_assms
 
 crunch make_fault_msg
   for pspace_respects_device_region[wp]: "pspace_respects_device_region"
   (wp: as_user_inv getRestartPC_inv mapM_wp'  simp: getRegister_def ignore: do_machine_op)
 
 crunch do_ipc_transfer
-  for pspace_respects_device_region[wp, Ipc_AI_cont_assms]: "pspace_respects_device_region"
+  for pspace_respects_device_region[wp, Ipc_AI_3_assms]: "pspace_respects_device_region"
   (wp: crunch_wps ignore: const_on_failure simp: crunch_simps)
 
-lemma do_ipc_transfer_respects_device_region[Ipc_AI_cont_assms]:
+lemma do_ipc_transfer_respects_device_region[Ipc_AI_3_assms]:
   "\<lbrace>cap_refs_respects_device_region and tcb_at t and  valid_objs and valid_mdb\<rbrace>
    do_ipc_transfer t ep bg grt r
    \<lbrace>\<lambda>rv. cap_refs_respects_device_region\<rbrace>"
@@ -514,7 +545,7 @@ lemma set_mrs_state_hyp_refs_of[wp]:
   by (wp set_mrs_thread_set_dmo thread_set_hyp_refs_trivial | simp)+
 
 crunch do_ipc_transfer
-  for state_hyp_refs_of[wp, Ipc_AI_cont_assms]: "\<lambda> s. P (state_hyp_refs_of s)"
+  for state_hyp_refs_of[wp, Ipc_AI_3_assms]: "\<lambda> s. P (state_hyp_refs_of s)"
   (wp: crunch_wps simp: zipWithM_x_mapM)
 
 lemma arch_derive_cap_untyped:
@@ -535,11 +566,18 @@ lemma valid_arch_mdb_cap_swap:
             ((caps_of_state s)(a \<mapsto> c', b \<mapsto> c))"
   by (auto simp: valid_arch_mdb_def)
 
+lemma do_ipc_transfer_valid_arch[Ipc_AI_3_assms]:
+  "\<lbrace>valid_arch_state and valid_objs and valid_mdb \<rbrace>
+   do_ipc_transfer s ep bg grt r
+   \<lbrace>\<lambda>rv. valid_arch_state\<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps do_ipc_transfer_aobj_at)
+
 end
 
-interpretation Ipc_AI_cont?: Ipc_AI_cont
-  proof goal_cases
+interpretation Ipc_AI?: Ipc_AI_3
+proof goal_cases
   interpret Arch .
-  case 1 show ?case by (unfold_locales;(fact Ipc_AI_cont_assms)?)
-  qed
+  case 1 show ?case by (unfold_locales;(fact Ipc_AI_3_assms)?)
+qed
+
 end
diff --git a/proof/invariant-abstract/RISCV64/ArchKHeap_AI.thy b/proof/invariant-abstract/RISCV64/ArchKHeap_AI.thy
index 447f2e639c..40ae14b731 100644
--- a/proof/invariant-abstract/RISCV64/ArchKHeap_AI.thy
+++ b/proof/invariant-abstract/RISCV64/ArchKHeap_AI.thy
@@ -584,7 +584,9 @@ lemma aobjs_of_lift_aobj_at:
   apply (simp flip: aobjs_of_ako_at_Some)
   done
 
-lemma valid_arch_state_lift_aobj_at:
+(* intended for use inside Arch, as opposed to the interface lemma valid_arch_state_lift_aobj_at,
+   since this architecture does not need cap preservation for valid_arch_state *)
+lemma valid_arch_state_lift_aobj_at_no_caps:
   "f \<lbrace>valid_arch_state\<rbrace>"
   unfolding valid_arch_state_def valid_asid_table_def valid_global_arch_objs_def pt_at_eq
   apply (wp_pre, wps arch aobjs_of_lift_aobj_at)
@@ -592,6 +594,12 @@ lemma valid_arch_state_lift_aobj_at:
   apply simp
   done
 
+(* interface lemma *)
+lemma valid_arch_state_lift_aobj_at:
+  assumes caps: "\<And>P. f \<lbrace>\<lambda>s. P (caps_of_state s)\<rbrace>"
+  shows "f \<lbrace>valid_arch_state\<rbrace>"
+  by (rule valid_arch_state_lift_aobj_at_no_caps)
+
 end
 end
 
@@ -765,14 +773,6 @@ lemma valid_arch_tcb_same_type:
    \<Longrightarrow> valid_arch_tcb t (s\<lparr>kheap := (kheap s)(p \<mapsto> k)\<rparr>)"
   by (auto simp: valid_arch_tcb_def obj_at_def)
 
-
-(* interface lemma *)
-lemma valid_ioports_lift:
-  assumes x: "\<And>P. f \<lbrace>\<lambda>rv. P (caps_of_state s)\<rbrace>"
-  assumes y: "\<And>P. f \<lbrace>\<lambda>s. P (arch_state s)\<rbrace>"
-  shows      "f \<lbrace>valid_ioports\<rbrace>"
-  by wpsimp
-
 (* interface lemma *)
 lemma valid_arch_mdb_lift:
   assumes c: "\<And>P. f \<lbrace>\<lambda>s. P (caps_of_state s)\<rbrace>"
diff --git a/proof/invariant-abstract/RISCV64/ArchTcbAcc_AI.thy b/proof/invariant-abstract/RISCV64/ArchTcbAcc_AI.thy
index 6b5a76b972..075eb5d8ce 100644
--- a/proof/invariant-abstract/RISCV64/ArchTcbAcc_AI.thy
+++ b/proof/invariant-abstract/RISCV64/ArchTcbAcc_AI.thy
@@ -162,6 +162,11 @@ lemma tcb_context_update_aux: "arch_tcb_context_set (P (arch_tcb_context_get atc
                                = tcb_context_update (\<lambda>ctx. P ctx) atcb"
   by (simp add: arch_tcb_context_set_def arch_tcb_context_get_def)
 
+lemma thread_set_valid_arch_state[TcbAcc_AI_assms]:
+  "(\<And>tcb. \<forall>(getF, v) \<in> ran tcb_cap_cases. getF (f tcb) = getF tcb)
+   \<Longrightarrow> thread_set f t \<lbrace> valid_arch_state \<rbrace>"
+  by (wp valid_arch_state_lift_aobj_at_no_caps thread_set.aobj_at)
+
 end
 
 global_interpretation TcbAcc_AI?: TcbAcc_AI
diff --git a/proof/invariant-abstract/RISCV64/ArchUntyped_AI.thy b/proof/invariant-abstract/RISCV64/ArchUntyped_AI.thy
index db56478145..2778695512 100644
--- a/proof/invariant-abstract/RISCV64/ArchUntyped_AI.thy
+++ b/proof/invariant-abstract/RISCV64/ArchUntyped_AI.thy
@@ -319,10 +319,6 @@ lemma create_cap_cap_refs_in_kernel_window[wp, Untyped_AI_assms]:
   apply blast
   done
 
-lemma create_cap_ioports[wp, Untyped_AI_assms]:
-  "\<lbrace>valid_ioports and cte_wp_at (\<lambda>_. True) cref\<rbrace> create_cap tp sz p dev (cref,oref) \<lbrace>\<lambda>rv. valid_ioports\<rbrace>"
-  by wpsimp
-
 lemma init_arch_objects_nonempty_table[Untyped_AI_assms, wp]:
   "\<lbrace>(\<lambda>s. \<not> (obj_at (nonempty_table (set (second_level_tables (arch_state s)))) r s)
          \<and> valid_global_objs s \<and> valid_arch_state s \<and> pspace_aligned s) and
@@ -361,6 +357,18 @@ lemma obj_is_device_vui_eq[Untyped_AI_assms]:
   apply (auto simp: arch_is_frame_type_def)
   done
 
+lemma create_cap_valid_arch_state[wp, Untyped_AI_assms]:
+  "\<lbrace>valid_arch_state and cte_wp_at (\<lambda>_. True) cref\<rbrace>
+   create_cap tp sz p dev (cref,oref)
+   \<lbrace>\<lambda>rv. valid_arch_state\<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps create_cap_aobj_at)
+
+lemma set_cap_non_arch_valid_arch_state[Untyped_AI_assms]:
+ "\<lbrace>\<lambda>s. valid_arch_state s \<and> cte_wp_at (\<lambda>_. \<not>is_arch_cap cap) ptr s\<rbrace>
+  set_cap cap ptr
+  \<lbrace>\<lambda>rv. valid_arch_state \<rbrace>"
+  by wpsimp
+
 end
 
 global_interpretation Untyped_AI? : Untyped_AI

From dc3647ab94ca10b87da2e1492d1404c56bcdde89 Mon Sep 17 00:00:00 2001
From: Rafal Kolanski <rafal.kolanski@proofcraft.systems>
Date: Thu, 21 Nov 2024 00:29:09 +1100
Subject: [PATCH 26/31] aarch64+riscv refine: remove mentions of IO ports

Signed-off-by: Rafal Kolanski <rafal.kolanski@proofcraft.systems>
---
 proof/refine/AARCH64/Finalise_R.thy | 2 +-
 proof/refine/RISCV64/Finalise_R.thy | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/proof/refine/AARCH64/Finalise_R.thy b/proof/refine/AARCH64/Finalise_R.thy
index 282c581fc2..ed95bad7bb 100644
--- a/proof/refine/AARCH64/Finalise_R.thy
+++ b/proof/refine/AARCH64/Finalise_R.thy
@@ -1859,7 +1859,7 @@ lemma final_matters_sameRegion_sameObject:
   done
 
 lemma final_matters_sameRegion_sameObject2:
-  "\<lbrakk> final_matters' cap'; \<not> isUntypedCap cap; \<not> isIRQHandlerCap cap'; \<not> isArchIOPortCap cap' \<rbrakk>
+  "\<lbrakk> final_matters' cap'; \<not> isUntypedCap cap; \<not> isIRQHandlerCap cap' \<rbrakk>
      \<Longrightarrow> sameRegionAs cap cap' = sameObjectAs cap cap'"
   apply (rule iffI)
    apply (erule sameRegionAsE)
diff --git a/proof/refine/RISCV64/Finalise_R.thy b/proof/refine/RISCV64/Finalise_R.thy
index 7fa4008e26..cebc9aa322 100644
--- a/proof/refine/RISCV64/Finalise_R.thy
+++ b/proof/refine/RISCV64/Finalise_R.thy
@@ -1868,7 +1868,7 @@ lemma final_matters_sameRegion_sameObject:
   done
 
 lemma final_matters_sameRegion_sameObject2:
-  "\<lbrakk> final_matters' cap'; \<not> isUntypedCap cap; \<not> isIRQHandlerCap cap'; \<not> isArchIOPortCap cap' \<rbrakk>
+  "\<lbrakk> final_matters' cap'; \<not> isUntypedCap cap; \<not> isIRQHandlerCap cap' \<rbrakk>
      \<Longrightarrow> sameRegionAs cap cap' = sameObjectAs cap cap'"
   apply (rule iffI)
    apply (erule sameRegionAsE)

From fbec9c761356e18e22cd646cb6d9b75600b88f14 Mon Sep 17 00:00:00 2001
From: Rafal Kolanski <rafal.kolanski@proofcraft.systems>
Date: Thu, 21 Nov 2024 17:42:11 +1100
Subject: [PATCH 27/31] access+infoflow: minimal update for ioport hiding for
 current arches

Currently this means ARM and RISCV64. Already, these two architectures
did not consider IO ports, so were not compatible with X64, and neither
was an X64 integrity proof planned. This change leans on that by
requalifying/assuming some extra lemmas which pretend that
valid_arch_state not relying on caps is a generic concept.

Signed-off-by: Rafal Kolanski <rafal.kolanski@proofcraft.systems>
---
 proof/access-control/ARM/ArchIpc_AC.thy     |  4 ++++
 proof/access-control/CNode_AC.thy           | 16 +++++++++++++---
 proof/access-control/Finalise_AC.thy        |  2 +-
 proof/access-control/Ipc_AC.thy             | 13 +++++++++----
 proof/access-control/RISCV64/ArchIpc_AC.thy |  4 ++++
 proof/infoflow/ARM/ArchRetype_IF.thy        |  9 +++++++++
 proof/infoflow/ARM/ArchTcb_IF.thy           |  2 ++
 proof/infoflow/Arch_IF.thy                  |  8 ++++++++
 proof/infoflow/Finalise_IF.thy              |  3 ++-
 proof/infoflow/Ipc_IF.thy                   | 18 +++++++++++-------
 proof/infoflow/RISCV64/ArchRetype_IF.thy    |  9 +++++++++
 proof/infoflow/RISCV64/ArchTcb_IF.thy       |  3 +++
 proof/infoflow/Tcb_IF.thy                   |  2 +-
 13 files changed, 76 insertions(+), 17 deletions(-)

diff --git a/proof/access-control/ARM/ArchIpc_AC.thy b/proof/access-control/ARM/ArchIpc_AC.thy
index 4f2b49cd9d..b7d2687f13 100644
--- a/proof/access-control/ARM/ArchIpc_AC.thy
+++ b/proof/access-control/ARM/ArchIpc_AC.thy
@@ -63,6 +63,10 @@ lemma tcb_context_no_change[Ipc_AC_assms]:
   apply (auto simp: arch_tcb_context_set_def)
   done
 
+lemma transfer_caps_loop_valid_arch[Ipc_AC_assms]:
+  "transfer_caps_loop ep buffer n caps slots mi \<lbrace>valid_arch_state :: det_ext state \<Rightarrow> _\<rbrace>"
+  by (wp valid_arch_state_lift_aobj_at_no_caps transfer_caps_loop_aobj_at)
+
 end
 
 
diff --git a/proof/access-control/CNode_AC.thy b/proof/access-control/CNode_AC.thy
index 383935f0bf..b79309883c 100644
--- a/proof/access-control/CNode_AC.thy
+++ b/proof/access-control/CNode_AC.thy
@@ -8,6 +8,19 @@ theory CNode_AC
 imports ArchAccess_AC
 begin
 
+(* Note: exporting the following diverges from AInvs interfaces where valid_arch_state is
+   permitted to depend on caps (due to supporting x64). If x64 access control is to go ahead,
+   these will need more careful management. *)
+arch_requalify_facts
+  set_cap_valid_arch_state
+  cap_insert_simple_valid_arch_state
+
+lemmas [wp] = set_cap_valid_arch_state cap_insert_simple_valid_arch_state
+
+crunch set_untyped_cap_as_full
+  for valid_arch_state[wp]: valid_arch_state
+
+
 section\<open>CNode-specific AC.\<close>
 
 
@@ -33,7 +46,6 @@ crunch cap_swap_ext,cap_move_ext,empty_slot_ext
 crunch set_untyped_cap_as_full
   for integrity_autarch: "integrity aag X st"
 
-
 locale CNode_AC_1 =
   fixes aag :: "'a PAS"
   and val_t :: "'b"
@@ -1010,8 +1022,6 @@ locale CNode_AC_3 = CNode_AC_2 +
     "arch_post_cap_deletion irqopt \<lbrace>pas_refined aag\<rbrace>"
   and aobj_ref'_same_aobject:
     "same_aobject_as ao' ao \<Longrightarrow> aobj_ref' ao = aobj_ref' ao'"
-  and set_untyped_cap_as_full_valid_arch_state[wp]:
-    "set_untyped_cap_as_full src_cap new_cap src_slot \<lbrace>\<lambda>s :: det_ext state. valid_arch_state s\<rbrace>"
 begin
 
 lemma cap_insert_pas_refined:
diff --git a/proof/access-control/Finalise_AC.thy b/proof/access-control/Finalise_AC.thy
index 465471bb1f..36f064cfa3 100644
--- a/proof/access-control/Finalise_AC.thy
+++ b/proof/access-control/Finalise_AC.thy
@@ -372,7 +372,7 @@ crunch suspend
   for pspace_aligned[wp]: "\<lambda>s :: det_ext state. pspace_aligned s"
   and valid_vspace_objs[wp]: "\<lambda>s :: det_ext state. valid_vspace_objs s"
   and valid_arch_state[wp]: "\<lambda>s :: det_ext state. valid_arch_state s"
-  (wp: dxo_wp_weak hoare_drop_imps simp: crunch_simps)
+  (wp: dxo_wp_weak hoare_drop_imps simp: crunch_simps simp: tcb_cap_cases_def)
 
 crunch suspend
   for pas_refined[wp]: "pas_refined aag"
diff --git a/proof/access-control/Ipc_AC.thy b/proof/access-control/Ipc_AC.thy
index aec0b47790..eb7a8cc056 100644
--- a/proof/access-control/Ipc_AC.thy
+++ b/proof/access-control/Ipc_AC.thy
@@ -172,6 +172,9 @@ locale Ipc_AC_1 =
     "\<And>P. make_fault_msg ft t \<lbrace>\<lambda>s :: det_ext state. P s\<rbrace>"
   and tcb_context_no_change:
     "\<exists>ctxt. (tcb :: tcb) = tcb\<lparr>tcb_arch := arch_tcb_context_set ctxt (tcb_arch tcb)\<rparr>"
+  (* This assumption excludes x64 (its valid_arch_state includes caps) *)
+  and transfer_caps_loop_valid_arch[wp]:
+    "transfer_caps_loop ep buffer n caps slots mi \<lbrace>valid_arch_state :: det_ext state \<Rightarrow> _\<rbrace>"
 begin
 
 lemma send_upd_ctxintegrity:
@@ -914,7 +917,7 @@ crunch do_fault_transfer
   for pas_refined[wp]: "\<lambda>s :: det_ext state. pas_refined aag s"
 
 crunch transfer_caps, copy_mrs
-  for valid_arch_state[wp]: valid_arch_state
+  for valid_arch_state[wp]: "valid_arch_state :: det_ext state \<Rightarrow> _"
   (wp: crunch_wps)
 
 lemma do_normal_transfer_pas_refined:
@@ -1067,6 +1070,7 @@ lemma send_ipc_pas_refined:
                     in hoare_strengthen_post[rotated])
         apply simp
        apply (wp set_thread_state_pas_refined do_ipc_transfer_pas_refined hoare_weak_lift_imp gts_wp
+                 do_ipc_transfer_valid_arch
               | wpc
               | simp add: hoare_if_r_and)+
    apply (wp hoare_vcg_all_lift hoare_imp_lift_something | simp add: st_tcb_at_tcb_states_of_state_eq)+
@@ -1214,6 +1218,7 @@ lemma receive_ipc_base_pas_refined:
         apply (wp hoare_weak_lift_imp do_ipc_transfer_pas_refined set_simple_ko_pas_refined
                   set_thread_state_pas_refined get_simple_ko_wp hoare_vcg_all_lift
                   hoare_vcg_imp_lift [OF set_simple_ko_get_tcb, unfolded disj_not1]
+                  do_ipc_transfer_valid_arch
                | wpc
                | simp add: thread_get_def  get_thread_state_def do_nbrecv_failed_transfer_def)+
   apply (clarsimp simp: tcb_at_def [symmetric] tcb_at_st_tcb_at)
@@ -2541,9 +2546,9 @@ lemma do_reply_transfer_pas_refined:
    \<lbrace>\<lambda>_. pas_refined aag\<rbrace>"
   apply (simp add: do_reply_transfer_def)
   apply (rule hoare_pre)
-  apply (wp set_thread_state_pas_refined do_ipc_transfer_pas_refined
-            thread_set_pas_refined K_valid
-         | wpc | simp add: thread_get_def split del: if_split)+
+  apply (wp set_thread_state_pas_refined do_ipc_transfer_pas_refined do_ipc_transfer_valid_arch
+            thread_set_pas_refined K_valid thread_set_valid_arch_state
+         | wpc | simp add: thread_get_def tcb_cap_cases_def split del: if_split)+
   (* otherwise simp does too much *)
   apply (rule hoare_strengthen_post, rule gts_inv)
    apply (rule impI)
diff --git a/proof/access-control/RISCV64/ArchIpc_AC.thy b/proof/access-control/RISCV64/ArchIpc_AC.thy
index 7be518e246..211262fde4 100644
--- a/proof/access-control/RISCV64/ArchIpc_AC.thy
+++ b/proof/access-control/RISCV64/ArchIpc_AC.thy
@@ -66,6 +66,10 @@ lemma tcb_context_no_change[Ipc_AC_assms]:
   apply (auto simp: arch_tcb_context_set_def)
   done
 
+lemma transfer_caps_loop_valid_arch[Ipc_AC_assms]:
+  "transfer_caps_loop ep buffer n caps slots mi \<lbrace>valid_arch_state :: det_ext state \<Rightarrow> _\<rbrace>"
+  by (wp valid_arch_state_lift_aobj_at_no_caps transfer_caps_loop_aobj_at)
+
 end
 
 
diff --git a/proof/infoflow/ARM/ArchRetype_IF.thy b/proof/infoflow/ARM/ArchRetype_IF.thy
index 8a8060dc9d..d30122f709 100644
--- a/proof/infoflow/ARM/ArchRetype_IF.thy
+++ b/proof/infoflow/ARM/ArchRetype_IF.thy
@@ -12,6 +12,15 @@ context Arch begin global_naming ARM
 
 named_theorems Retype_IF_assms
 
+lemma do_ipc_transfer_valid_arch_no_caps[wp]:
+  "do_ipc_transfer s ep bg grt r \<lbrace>valid_arch_state\<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps do_ipc_transfer_aobj_at)
+
+lemma create_cap_valid_arch_state_no_caps[wp]:
+  "\<lbrace>valid_arch_state \<rbrace> create_cap tp sz p dev ref
+   \<lbrace>\<lambda>rv. valid_arch_state\<rbrace>"
+  by (wp valid_arch_state_lift_aobj_at_no_caps create_cap_aobj_at)
+
 lemma cacheRangeOp_ev[wp]:
   "(\<And>a b. equiv_valid_inv I A \<top> (oper a b))
    \<Longrightarrow> equiv_valid_inv I A \<top> (cacheRangeOp oper x y z)"
diff --git a/proof/infoflow/ARM/ArchTcb_IF.thy b/proof/infoflow/ARM/ArchTcb_IF.thy
index 44dd1df9c1..c84b03c1fd 100644
--- a/proof/infoflow/ARM/ArchTcb_IF.thy
+++ b/proof/infoflow/ARM/ArchTcb_IF.thy
@@ -185,6 +185,7 @@ lemma tc_reads_respects_f[Tcb_IF_assms]:
                            cap_delete_pas_refined' itr_wps(12) itr_wps(14) cap_insert_cte_at
                            checked_insert_no_cap_to hoare_vcg_const_imp_liftE_R hoare_vcg_conj_lift
                            as_user_reads_respects_f thread_set_mdb cap_delete_invs
+                           thread_set_valid_arch_state
                       | wpc
                       | simp add: emptyable_def tcb_cap_cases_def tcb_cap_valid_def
                                   tcb_at_st_tcb_at when_def
@@ -231,6 +232,7 @@ lemma tc_reads_respects_f[Tcb_IF_assms]:
              thread_set_pas_refined thread_set_emptyable thread_set_valid_cap
              thread_set_cte_at thread_set_no_cap_to_trivial
              thread_set_tcb_fault_handler_update_only_timer_irq_inv
+             thread_set_valid_arch_state
           | simp add: tcb_cap_cases_def | wpc | wp (once) hoare_drop_imp)+
   apply (clarsimp simp: authorised_tcb_inv_def  authorised_tcb_inv_extra_def emptyable_def)
   by (clarsimp simp: is_cap_simps is_cnode_or_valid_arch_def is_valid_vtable_root_def det_setRegister
diff --git a/proof/infoflow/Arch_IF.thy b/proof/infoflow/Arch_IF.thy
index 98d64ca9d7..ea1c2388a8 100644
--- a/proof/infoflow/Arch_IF.thy
+++ b/proof/infoflow/Arch_IF.thy
@@ -8,6 +8,14 @@ theory Arch_IF
 imports ArchRetype_IF
 begin
 
+(* Note: exporting the following diverges from AInvs interfaces where valid_arch_state is
+   permitted to depend on caps (due to supporting x64). If x64 confidentiality is to go ahead,
+   this will need more careful management. *)
+arch_requalify_facts
+  do_ipc_transfer_valid_arch_no_caps
+
+lemmas [wp] = do_ipc_transfer_valid_arch_no_caps
+
 abbreviation irq_state_of_state :: "det_state \<Rightarrow> nat" where
   "irq_state_of_state s \<equiv> irq_state (machine_state s)"
 
diff --git a/proof/infoflow/Finalise_IF.thy b/proof/infoflow/Finalise_IF.thy
index 476a7a8062..259a182e72 100644
--- a/proof/infoflow/Finalise_IF.thy
+++ b/proof/infoflow/Finalise_IF.thy
@@ -1489,7 +1489,8 @@ crunch deleting_irq_handler
 
 crunch cancel_ipc
   for globals_equiv[wp]: "globals_equiv st"
-  (wp: mapM_x_wp select_inv hoare_drop_imps hoare_vcg_if_lift2 simp: unless_def)
+  (wp: mapM_x_wp select_inv hoare_drop_imps hoare_vcg_if_lift2 thread_set_valid_arch_state
+   simp: unless_def tcb_cap_cases_def)
 
 lemma suspend_globals_equiv[ wp]:
   "\<lbrace>globals_equiv st and (\<lambda>s. t \<noteq> idle_thread s) and valid_arch_state\<rbrace>
diff --git a/proof/infoflow/Ipc_IF.thy b/proof/infoflow/Ipc_IF.thy
index 11865a8ea3..049644dedb 100644
--- a/proof/infoflow/Ipc_IF.thy
+++ b/proof/infoflow/Ipc_IF.thy
@@ -1600,9 +1600,9 @@ lemma do_reply_transfer_reads_respects_f:
             cap_delete_one_silc_inv do_ipc_transfer_silc_inv
             set_thread_state_pas_refined thread_set_fault_pas_refined'
             possible_switch_to_reads_respects[THEN reads_respects_f[where aag=aag and st=st and Q=\<top>]]
-            when_ev
+            when_ev thread_set_valid_arch_state
          | wpc
-         | simp split del: if_split
+         | simp split del: if_split add: tcb_cap_cases_def
          | wp (once) reads_respects_f[where aag=aag and st=st]
          | elim conjE
          | wp (once) hoare_drop_imps)+
@@ -1987,8 +1987,10 @@ lemma send_fault_ipc_globals_equiv:
   apply (wp)
      apply (simp add: Let_def)
      apply (wp send_ipc_globals_equiv thread_set_globals_equiv thread_set_valid_objs''
-               thread_set_fault_valid_global_refs thread_set_valid_idle_trivial thread_set_refs_trivial
-            | wpc | simp)+
+               thread_set_fault_valid_global_refs thread_set_valid_idle_trivial
+               thread_set_refs_trivial thread_set_valid_arch_state
+               thread_set_tcb_fault_update_valid_mdb
+            | wpc | simp add: tcb_cap_cases_def)+
     apply (rule_tac Q'="\<lambda>_. globals_equiv st and valid_objs and valid_arch_state and
                             valid_global_refs and pspace_distinct and pspace_aligned and
                             valid_global_objs and K (valid_fault fault) and valid_idle and
@@ -2000,8 +2002,9 @@ lemma send_fault_ipc_globals_equiv:
   done
 
 crunch send_fault_ipc
-  for valid_arch_state[wp]: valid_arch_state
-  (wp: dxo_wp_weak hoare_drop_imps simp: crunch_simps)
+  for valid_arch_statex[wp]: valid_arch_state
+  (wp: dxo_wp_weak hoare_drop_imps thread_set_valid_arch_state crunch_wps
+   simp: crunch_simps tcb_cap_cases_def)
 
 lemma handle_fault_globals_equiv:
   "\<lbrace>globals_equiv st and valid_objs and valid_arch_state and valid_global_refs
@@ -2033,7 +2036,8 @@ lemma do_reply_transfer_globals_equiv:
   unfolding do_reply_transfer_def
   apply (wp set_thread_state_globals_equiv cap_delete_one_globals_equiv do_ipc_transfer_globals_equiv
             thread_set_globals_equiv handle_fault_reply_globals_equiv dxo_wp_weak
-         | wpc | simp split del: if_split)+
+            thread_set_valid_arch_state
+         | wpc | simp split del: if_split add: tcb_cap_cases_def)+
      apply (rule_tac Q'="\<lambda>_. globals_equiv st and valid_arch_state and valid_objs and valid_arch_state
                                              and valid_global_refs and pspace_distinct
                                              and pspace_aligned and valid_global_objs
diff --git a/proof/infoflow/RISCV64/ArchRetype_IF.thy b/proof/infoflow/RISCV64/ArchRetype_IF.thy
index 194bdbbf0d..3f23f73912 100644
--- a/proof/infoflow/RISCV64/ArchRetype_IF.thy
+++ b/proof/infoflow/RISCV64/ArchRetype_IF.thy
@@ -12,6 +12,15 @@ context Arch begin global_naming RISCV64
 
 named_theorems Retype_IF_assms
 
+lemma do_ipc_transfer_valid_arch_no_caps[wp]:
+  "do_ipc_transfer s ep bg grt r \<lbrace>valid_arch_state\<rbrace>"
+  by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps do_ipc_transfer_aobj_at)
+
+lemma create_cap_valid_arch_state_no_caps[wp]:
+  "\<lbrace>valid_arch_state \<rbrace> create_cap tp sz p dev ref
+   \<lbrace>\<lambda>rv. valid_arch_state\<rbrace>"
+  by (wp valid_arch_state_lift_aobj_at_no_caps create_cap_aobj_at)
+
 lemma modify_underlying_memory_update_0_ev:
   "equiv_valid_inv (equiv_machine_state P) (equiv_machine_state Q) \<top>
                    (modify (underlying_memory_update (\<lambda>m. m(x := word_rsplit 0 ! 7,
diff --git a/proof/infoflow/RISCV64/ArchTcb_IF.thy b/proof/infoflow/RISCV64/ArchTcb_IF.thy
index 56830a0004..999bc04b2c 100644
--- a/proof/infoflow/RISCV64/ArchTcb_IF.thy
+++ b/proof/infoflow/RISCV64/ArchTcb_IF.thy
@@ -181,6 +181,7 @@ lemma tc_reads_respects_f[Tcb_IF_assms]:
                            cap_delete_pas_refined' itr_wps(12) itr_wps(14) cap_insert_cte_at
                            checked_insert_no_cap_to hoare_vcg_const_imp_liftE_R hoare_vcg_conj_lift
                            as_user_reads_respects_f thread_set_mdb cap_delete_invs
+                           thread_set_valid_arch_state
                       | wpc
                       | simp add: emptyable_def tcb_cap_cases_def tcb_cap_valid_def
                                   tcb_at_st_tcb_at when_def
@@ -220,6 +221,7 @@ lemma tc_reads_respects_f[Tcb_IF_assms]:
     apply (simp add: option_update_thread_def tcb_cap_cases_def
            | wp hoare_weak_lift_imp hoare_weak_lift_imp_conj thread_set_pas_refined
                 reads_respects_f[OF thread_set_reads_respects, where st=st and Q="\<top>"]
+                thread_set_valid_arch_state
            | wpc)+
    apply (wp hoare_vcg_all_lift thread_set_tcb_fault_handler_update_invs
              thread_set_tcb_fault_handler_update_silc_inv
@@ -227,6 +229,7 @@ lemma tc_reads_respects_f[Tcb_IF_assms]:
              thread_set_pas_refined thread_set_emptyable thread_set_valid_cap
              thread_set_cte_at thread_set_no_cap_to_trivial
              thread_set_tcb_fault_handler_update_only_timer_irq_inv
+             thread_set_valid_arch_state
           | simp add: tcb_cap_cases_def | wpc | wp (once) hoare_drop_imp)+
   apply (clarsimp simp: authorised_tcb_inv_def authorised_tcb_inv_extra_def emptyable_def)
   apply (clarsimp simp: invs_psp_aligned invs_vspace_objs invs_arch_state)
diff --git a/proof/infoflow/Tcb_IF.thy b/proof/infoflow/Tcb_IF.thy
index 16cfd1f855..fcdcb12975 100644
--- a/proof/infoflow/Tcb_IF.thy
+++ b/proof/infoflow/Tcb_IF.thy
@@ -196,7 +196,7 @@ begin
 
 crunch cap_swap_for_delete
   for valid_arch_state[wp]: valid_arch_state
-  (wp: dxo_wp_weak)
+  (wp: dxo_wp_weak simp: crunch_simps)
 
 lemma rec_del_globals_equiv:
   "\<lbrace>\<lambda>s. invs s \<and> globals_equiv st s \<and> emptyable (slot_rdcall call) s \<and> valid_rec_del_call call s\<rbrace>

From 5cb634210b476e803fda7803cd44b357694a9465 Mon Sep 17 00:00:00 2001
From: Gerwin Klein <gerwin.klein@proofcraft.systems>
Date: Fri, 6 Dec 2024 16:15:30 +1100
Subject: [PATCH 28/31] github: fix concurrency group syntax

- fix concurrency group syntax (needs a group entry)
- cancel started runs

Signed-off-by: Gerwin Klein <gerwin.klein@proofcraft.systems>
---
 .github/workflows/proof-deploy.yml | 8 ++++++--
 .github/workflows/proof.yml        | 4 +++-
 2 files changed, 9 insertions(+), 3 deletions(-)

diff --git a/.github/workflows/proof-deploy.yml b/.github/workflows/proof-deploy.yml
index 66ab7d2f44..20d51cb371 100644
--- a/.github/workflows/proof-deploy.yml
+++ b/.github/workflows/proof-deploy.yml
@@ -62,7 +62,9 @@ jobs:
           - arch: AARCH64
             plat: bcm2711
     # test only most recent push:
-    concurrency: l4v-regression-${{ github.ref }}-${{ strategy.job-index }}
+    concurrency:
+      group: l4v-regression-${{ github.ref }}-${{ strategy.job-index }}
+      cancel-in-progress: true
     steps:
     - name: Proofs
       uses: seL4/ci-actions/aws-proofs@master
@@ -98,7 +100,9 @@ jobs:
         num_domains: ['1', '']
         plat: [""]
     # test only most recent push:
-    concurrency: l4v-mcs-regression-${{ github.ref }}-${{ strategy.job-index }}
+    concurrency:
+      group: l4v-mcs-regression-${{ github.ref }}-${{ strategy.job-index }}
+      cancel-in-progress: true
     steps:
     - name: Proofs
       uses: seL4/ci-actions/aws-proofs@master
diff --git a/.github/workflows/proof.yml b/.github/workflows/proof.yml
index 02bb6ce83a..7eac5186da 100644
--- a/.github/workflows/proof.yml
+++ b/.github/workflows/proof.yml
@@ -33,7 +33,9 @@ jobs:
       matrix:
         arch: [ARM, ARM_HYP, AARCH64, RISCV64, X64]
     # test only most recent push to PR:
-    concurrency: l4v-pr-${{ github.event.number }}-idx-${{ strategy.job-index }}
+    concurrency:
+      group: l4v-${{ github.workflow }}-${{ github.event.number }}-idx-${{ strategy.job-index }}
+      cancel-in-progress: true
     steps:
     - name: Proofs
       uses: seL4/ci-actions/aws-proofs@master

From 0b2d165582328155c4d581a9843ee57cfe7fdf58 Mon Sep 17 00:00:00 2001
From: Rafal Kolanski <rafal.kolanski@proofcraft.systems>
Date: Fri, 6 Dec 2024 14:33:31 +1100
Subject: [PATCH 29/31] docs: style: extra emphasis on 2 indent, add section
 lines

We generally tend to do two newlines before a section, and the style
guide was inconsistent about it.

Add extra subcoal-count indent example (in words).

Signed-off-by: Rafal Kolanski <rafal.kolanski@proofcraft.systems>
---
 docs/Style.thy | 14 ++++++++++++--
 1 file changed, 12 insertions(+), 2 deletions(-)

diff --git a/docs/Style.thy b/docs/Style.thy
index 0dfcde2b12..d394a9d8ce 100644
--- a/docs/Style.thy
+++ b/docs/Style.thy
@@ -66,6 +66,7 @@ text \<open>
 
     * Don't mix object and meta logic in a lemma statement.\<close>
 
+
 section \<open>Text and comments\<close>
 
 text \<open>
@@ -87,11 +88,18 @@ text \<open>
   the closing bracket on the same line as the ending text to not waste too much vertical space.
   Indent text by 2 inside the @{command text} area. This achieves visual separation.\<close>
 
+
 section \<open>Indentation\<close>
 
 text \<open>
-  Isabelle code is much easier to maintain when indented consistently. In apply style proofs we
-  indent by 2 spaces, and add an additional space for every additional subgoal.
+  Isabelle code is much easier to maintain when indented consistently.
+  When in doubt and not constrained by vertically aligning items or subgoal-count offsets, use
+  2 spaces when indenting something with respect to its container (see ``General layout`` in
+  ``Other`` section).
+
+  In apply style proofs we indent by 2 spaces, and add an additional space for every additional
+  subgoal. For instance, a command which applies when there are 3 subgoals should be indented by
+  4 spaces.
 
   In the following example, the rules iffI and conjI add a new subgoal, and fast removes a subgoal.
   The idea is that, when something breaks, the indentation tells you whether a tactic used to solve
@@ -351,6 +359,7 @@ term "
     B \<or>
   A" \<comment> \<open>NOT OK: implies this parses as @{text "((A \<and> B) \<longrightarrow> B) \<or> A"}\<close>
 
+
 section \<open>Other\<close>
 
 text \<open>
@@ -365,6 +374,7 @@ text \<open>
     * Avoid commands that produce "legacy" warnings. Add an issue with tag cleanup if you see them
       after an Isabelle update.\<close>
 
+
 section \<open>Comments\<close>
 
 text \<open>

From 86cab463a327fdc56fa436fac6dcd17b38e235fa Mon Sep 17 00:00:00 2001
From: Rafal Kolanski <rafal.kolanski@proofcraft.systems>
Date: Fri, 6 Dec 2024 14:34:51 +1100
Subject: [PATCH 30/31] docs: style: wrapping complex rule instantiations

Signed-off-by: Rafal Kolanski <rafal.kolanski@proofcraft.systems>
---
 docs/Style.thy | 65 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 65 insertions(+)

diff --git a/docs/Style.thy b/docs/Style.thy
index d394a9d8ce..86ac86afa0 100644
--- a/docs/Style.thy
+++ b/docs/Style.thy
@@ -360,6 +360,71 @@ term "
   A" \<comment> \<open>NOT OK: implies this parses as @{text "((A \<and> B) \<longrightarrow> B) \<or> A"}\<close>
 
 
+section \<open>Wrapping/indenting complex rule instantiations, usually as part of @{text "_tac"} methods\<close>
+
+text \<open>
+  This section concerns @{text "_tac"} methods, which are generally used when the instantiations
+  contain bound variables. When bound variables do no occur, prefer instantiations via attribute
+  (@{text "fact[where ...]"}) as they are more general.\<close>
+
+text \<open>
+  For simple instantiations which can fit on one line, style them as follows.
+  Notes:
+    * for single-variable instantiations, do not use quotes
+    * no space between @{text "="} and the instantiation or start of quote\<close>
+
+lemma
+  "\<lbrakk>a; b\<rbrakk> \<Longrightarrow> a \<and> b"
+  apply (frule_tac P=a and Q="id b" in conjI) \<comment> \<open>GOOD\<close>
+  apply (frule_tac P="a" and Q = "id b" in conjI) \<comment> \<open>BAD: unnecessary quotes, unnecessary spacing\<close>
+  oops
+
+text \<open>
+  However, when the instantiation is complex, the instantiations, @{text "and"} and @{text "in"}
+  need to be distributed over multiple lines.\<close>
+
+lemma conjI3:
+  "\<lbrakk>a; b; c\<rbrakk> \<Longrightarrow> a \<and> b \<and> c"
+  by simp
+
+text \<open>
+  For left operator-wrapping style, use this version. It was chosen based on being space-optimising
+  and nice-looking (variable instantiations and rule all left-align, while operators right-align):\<close>
+
+lemma \<comment> \<open>left operator-wrapping pretty version - preferred\<close>
+  "\<lbrakk> x; y; z \<rbrakk> \<Longrightarrow> x \<and> y \<and> z"
+  apply (drule_tac a=x
+               and b=y
+               and c=z
+                in conjI3)
+  oops
+
+text \<open>
+  For right-operator wrapping style, use this version. It still provides the alignment of variable
+  instantiations, but provides less horizontal space for the instantiation bodies themselves:\<close>
+
+lemma \<comment> \<open>right operator-wrapping pretty version - preferred\<close>
+  "\<lbrakk> x; y; z \<rbrakk> \<Longrightarrow> x \<and> y \<and> z"
+  apply (drule_tac a=x and
+                   b=y and
+                   c=z
+                   in conjI3) \<comment> \<open>this must not go on previous line in multi-line instantiations\<close>
+  oops
+
+text \<open>
+  There is one more left-operator wrappings style we permit, but only due to legacy proofs and the
+  possibility of being understandable/generatable by tools. Please do not use it on new
+  hand-written lemmas:\<close>
+
+lemma \<comment> \<open>left operator-wrapping pretty version for tools/legacy - permitted\<close>
+  "\<lbrakk> x; y; z \<rbrakk> \<Longrightarrow> x \<and> y \<and> z"
+  apply (drule_tac a=x
+                   and b=y
+                   and c=z
+                   in conjI3)
+  oops
+
+
 section \<open>Other\<close>
 
 text \<open>

From 3d8703e7f8b1ef3cd6c68f2efd6490da02cbdff2 Mon Sep 17 00:00:00 2001
From: Rafal Kolanski <rafal.kolanski@proofcraft.systems>
Date: Fri, 6 Dec 2024 14:35:29 +1100
Subject: [PATCH 31/31] docs: style: fact transformers and attributes

Signed-off-by: Rafal Kolanski <rafal.kolanski@proofcraft.systems>
---
 docs/Style.thy | 37 +++++++++++++++++++++++++++++++++++++
 1 file changed, 37 insertions(+)

diff --git a/docs/Style.thy b/docs/Style.thy
index 86ac86afa0..48ec6b1366 100644
--- a/docs/Style.thy
+++ b/docs/Style.thy
@@ -227,6 +227,43 @@ lemma test_lemma3:
          case_tac h; simp)
   done
 
+
+section \<open>Fact transformers and attributes\<close>
+
+text \<open>
+  For simple cases, standard approach applies: comma-separated list with one space after commas:\<close>
+
+lemmas attr1 = conj_absorb[THEN iffD2, OF conj_absorb, simplified] \<comment> \<open>basic case\<close>
+
+text \<open>
+  When the transform is more complex or runs out of horizontal room, wrapping is needed.
+  In most cases, reconfiguring the attributes into a vertical list should suffice:\<close>
+
+lemmas attr2 = conj_absorb[THEN iffD2,
+                           OF conj_absorb[where A="A \<and> B \<and> C \<and> D \<and> E \<and> F \<and> G" for A B C D E F G,
+                                          simplified],
+                           simplified] \<comment> \<open>simple wrapping case\<close>
+
+text \<open>
+  When terms get even larger, the transforms more complicated, or we start running into the column
+  limit, more wrapping is needed. We can gain extra space by indenting from the fact name:\<close>
+
+lemmas attr3 = conj_absorb[ \<comment> \<open>note the @{text "["} to indicate transform\<close>
+                 THEN iffD2,
+                 OF conj_absorb[where A="A \<and> B \<and> C \<and> D \<and> E \<and> F \<and> G" for A B C D E F G,
+                                simplified],
+                 simplified] \<comment> \<open>extreme wrapping case\<close>
+
+text \<open>
+  There is an important principle here: telling apart transformed/attributed facts from unaltered
+  facts at a glance. In other words avoid:\<close>
+
+lemmas attrb = conj_absorb \<comment> \<open>BAD: at first glance looks to be an unmodified fact\<close>
+                 [THEN iffD2 (*...*)]
+
+lemmas attrb2 = conj_absorb [THEN iffD2 (*...*)] \<comment> \<open>avoid: still needs some mental processing\<close>
+
+
 section \<open>Right vs left operator-wrapping\<close>
 
 text \<open>