diff --git a/thys/ConcurrentGC/Handshakes.thy b/thys/ConcurrentGC/Handshakes.thy
--- a/thys/ConcurrentGC/Handshakes.thy
+++ b/thys/ConcurrentGC/Handshakes.thy
@@ -1,585 +1,587 @@
 (*<*)
 (*
  * Copyright 2015, NICTA
  *
  * This software may be distributed and modified according to the terms of
  * the BSD 2-Clause license. Note that NO WARRANTY is provided.
  * See "LICENSE_BSD2.txt" for details.
  *
  * @TAG(NICTA_BSD)
  *)
 
 theory Handshakes
 imports
   TSO
 begin
 
+declare subst_all [simp del] [[simproc del: defined_all]]
+
 (*>*)
 subsection\<open>Handshake phases\<close>
 
 text\<open>
 
 The mutators can be at most one step behind the garbage collector (and
 system). If any mutator is behind then the GC is stalled on a pending
 handshake. Unfortunately this is a complicated by needing to consider
 the handshake type due to \<open>get_work\<close>. This relation is very
 precise.
 
 \<close>
 
 definition hp_step_rel :: "(bool \<times> handshake_type \<times> handshake_phase \<times> handshake_phase) set" where
   "hp_step_rel \<equiv>
   { True }  \<times> ({ (ht_NOOP, hp, hp) |hp. hp \<in> {hp_Idle, hp_IdleInit, hp_InitMark, hp_Mark} }
             \<union> { (ht_GetRoots, hp_IdleMarkSweep, hp_IdleMarkSweep)
               , (ht_GetWork,  hp_IdleMarkSweep, hp_IdleMarkSweep) })
 \<union> { False } \<times> { (ht_NOOP,     hp_Idle,          hp_IdleMarkSweep)
               , (ht_NOOP,     hp_IdleInit,      hp_Idle)
               , (ht_NOOP,     hp_InitMark,      hp_IdleInit)
               , (ht_NOOP,     hp_Mark,          hp_InitMark)
               , (ht_GetRoots, hp_IdleMarkSweep, hp_Mark)
               , (ht_GetWork,  hp_IdleMarkSweep, hp_IdleMarkSweep) }"
 
 definition handshake_phase_inv :: "('field, 'mut, 'ref) lsts_pred" where
   "handshake_phase_inv = (\<^bold>\<forall>m.
       (sys_ghost_handshake_in_sync m \<^bold>\<otimes> sys_handshake_type
         \<^bold>\<otimes> sys_ghost_handshake_phase \<^bold>\<otimes> mut_m.mut_ghost_handshake_phase m) \<^bold>\<in> \<langle>hp_step_rel\<rangle>
   \<^bold>\<and> (sys_handshake_pending m \<^bold>\<longrightarrow> \<^bold>\<not>(sys_ghost_handshake_in_sync m)))"
 (*<*)
 
 (* Sanity *)
 lemma handshake_step_inv:
   "hp' = handshake_step hp \<Longrightarrow> \<exists>in' ht. (in', ht, hp', hp) \<in> hp_step_rel"
 by (cases hp) (auto simp: hp_step_rel_def)
 
 (* Sanity *)
 lemma handshake_step_invD:
   "(False, ht, hp', hp) \<in> hp_step_rel \<Longrightarrow> hp' = hp_step ht hp"
 by (cases ht) (auto simp: hp_step_rel_def)
 
 lemma (in mut_m) handshake_phase_invD:
   "handshake_phase_inv s \<Longrightarrow> (sys_ghost_handshake_in_sync m s, sys_handshake_type s, sys_ghost_handshake_phase s, mut_ghost_handshake_phase s) \<in> hp_step_rel
                           \<and> (sys_handshake_pending m s \<longrightarrow> \<not>sys_ghost_handshake_in_sync m s)"
 by (simp add: handshake_phase_inv_def)
 
 lemma handshake_in_syncD:
   "\<lbrakk> All (ghost_handshake_in_sync (s sys)); handshake_phase_inv s \<rbrakk>
      \<Longrightarrow> \<forall>m'. mut_m.mut_ghost_handshake_phase m' s = sys_ghost_handshake_phase s"
 by clarsimp (auto simp: hp_step_rel_def dest!: mut_m.handshake_phase_invD)
 
 lemma (in sys) handshake_phase_inv[intro]:
   "\<lbrace> LSTP handshake_phase_inv \<rbrace> sys"
 by (vcg_jackhammer simp: handshake_phase_inv_def)
 
 (*>*)
 text\<open>
 
 Connect @{const "sys_ghost_handshake_phase"} with locations in the GC.
 
 \<close>
 
 locset_definition "hp_Idle_locs =
   (prefixed ''idle_noop'' - { ''idle_noop_mfence'', ''idle_noop_init_type'' })
 \<union> { ''idle_read_fM'', ''idle_invert_fM'', ''idle_write_fM'', ''idle_flip_noop_mfence'', ''idle_flip_noop_init_type'' }"
 
 locset_definition "hp_IdleInit_locs =
     (prefixed ''idle_flip_noop'' - { ''idle_flip_noop_mfence'', ''idle_flip_noop_init_type'' })
   \<union> { ''idle_phase_init'', ''init_noop_mfence'', ''init_noop_init_type'' }"
 
 locset_definition "hp_InitMark_locs =
   (prefixed ''init_noop'' - { ''init_noop_mfence'', ''init_noop_init_type'' })
 \<union> { ''init_phase_mark'', ''mark_read_fM'', ''mark_write_fA'', ''mark_noop_mfence'', ''mark_noop_init_type'' }"
 
 locset_definition "hp_IdleMarkSweep_locs =
      { ''idle_noop_mfence'', ''idle_noop_init_type'', ''mark_end'' }
   \<union>  sweep_locs
   \<union> (mark_loop_locs - { ''mark_loop_get_roots_init_type'' })"
 
 locset_definition "hp_Mark_locs =
     (prefixed ''mark_noop'' - { ''mark_noop_mfence'', ''mark_noop_init_type'' })
   \<union> { ''mark_loop_get_roots_init_type'' }"
 
 abbreviation
   "hs_noop_prefixes \<equiv> {''idle_noop'', ''idle_flip_noop'', ''init_noop'', ''mark_noop'' }"
 
 locset_definition "hs_noop_locs =
   (\<Union>l \<in> hs_noop_prefixes. prefixed l - (suffixed ''_noop_mfence'' \<union> suffixed ''_noop_init_type''))"
 
 locset_definition "hs_get_roots_locs =
   prefixed ''mark_loop_get_roots'' - {''mark_loop_get_roots_init_type''}"
 
 locset_definition "hs_get_work_locs =
   prefixed ''mark_loop_get_work'' - {''mark_loop_get_work_init_type''}"
 
 abbreviation "hs_prefixes \<equiv>
   hs_noop_prefixes \<union> { ''mark_loop_get_roots'', ''mark_loop_get_work'' }"
 
 locset_definition "hs_init_loop_locs = (\<Union>l \<in> hs_prefixes. prefixed (l @ ''_init_loop''))"
 
 locset_definition "hs_done_loop_locs = (\<Union>l \<in> hs_prefixes. prefixed (l @ ''_done_loop''))"
 
 locset_definition "hs_done_locs = (\<Union>l \<in> hs_prefixes. prefixed (l @ ''_done''))"
 
 locset_definition "hs_none_pending_locs = - (hs_init_loop_locs \<union> hs_done_locs)"
 
 locset_definition "hs_in_sync_locs =
   (- ( (\<Union>l \<in> hs_prefixes. prefixed (l @ ''_init'')) \<union> hs_done_locs ))
   \<union> (\<Union>l \<in> hs_prefixes. {l @ ''_init_type''})"
 
 locset_definition "hs_out_of_sync_locs =
   (\<Union>l \<in> hs_prefixes. {l @ ''_init_muts''})"
 
 locset_definition "hs_mut_in_muts_locs =
   (\<Union>l \<in> hs_prefixes. {l @ ''_init_loop_set_pending'', l @ ''_init_loop_done''})"
 
 locset_definition "hs_init_loop_done_locs =
   (\<Union>l \<in> hs_prefixes. {l @ ''_init_loop_done''})"
 
 locset_definition "hs_init_loop_not_done_locs =
   (hs_init_loop_locs - (\<Union>l \<in> hs_prefixes. {l @ ''_init_loop_done''}))"
 
 inv_definition (in gc) handshake_invL :: "('field, 'mut, 'ref) gc_pred" where
   "handshake_invL =
      (atS_gc hs_noop_locs         (sys_handshake_type \<^bold>= \<langle>ht_NOOP\<rangle>)
     \<^bold>\<and> atS_gc hs_get_roots_locs    (sys_handshake_type \<^bold>= \<langle>ht_GetRoots\<rangle>)
     \<^bold>\<and> atS_gc hs_get_work_locs     (sys_handshake_type \<^bold>= \<langle>ht_GetWork\<rangle>)
 
     \<^bold>\<and> atS_gc hs_mut_in_muts_locs      (gc_mut \<^bold>\<in> gc_muts)
     \<^bold>\<and> atS_gc hs_init_loop_locs        (\<^bold>\<forall>m. \<^bold>\<not>(\<langle>m\<rangle> \<^bold>\<in> gc_muts) \<^bold>\<longrightarrow> sys_handshake_pending m
                                                                   \<^bold>\<or> sys_ghost_handshake_in_sync m)
     \<^bold>\<and> atS_gc hs_init_loop_not_done_locs (\<^bold>\<forall>m.   \<langle>m\<rangle> \<^bold>\<in> gc_muts \<^bold>\<longrightarrow> \<^bold>\<not>(sys_handshake_pending m)
                                                                  \<^bold>\<and> \<^bold>\<not>(sys_ghost_handshake_in_sync m))
     \<^bold>\<and> atS_gc hs_init_loop_done_locs     ( (sys_handshake_pending \<^bold>$ gc_mut
                                         \<^bold>\<or> sys_ghost_handshake_in_sync \<^bold>$ gc_mut)
                                       \<^bold>\<and> (\<^bold>\<forall>m. \<langle>m\<rangle> \<^bold>\<in> gc_muts \<^bold>\<and> \<langle>m\<rangle> \<^bold>\<noteq> gc_mut
                                                                  \<^bold>\<longrightarrow> \<^bold>\<not>(sys_handshake_pending m)
                                                                    \<^bold>\<and> \<^bold>\<not>(sys_ghost_handshake_in_sync m)) )
     \<^bold>\<and> atS_gc hs_done_locs       (\<^bold>\<forall>m. sys_handshake_pending m \<^bold>\<or> sys_ghost_handshake_in_sync m)
     \<^bold>\<and> atS_gc hs_done_loop_locs  (\<^bold>\<forall>m. \<^bold>\<not>(\<langle>m\<rangle> \<^bold>\<in> gc_muts) \<^bold>\<longrightarrow> \<^bold>\<not>(sys_handshake_pending m))
     \<^bold>\<and> atS_gc hs_none_pending_locs (\<^bold>\<forall>m. \<^bold>\<not>(sys_handshake_pending m))
     \<^bold>\<and> atS_gc hs_in_sync_locs      (\<^bold>\<forall>m. sys_ghost_handshake_in_sync m)
     \<^bold>\<and> atS_gc hs_out_of_sync_locs  (\<^bold>\<forall>m. \<^bold>\<not>(sys_handshake_pending m)
                                          \<^bold>\<and> \<^bold>\<not>(sys_ghost_handshake_in_sync m))
 
     \<^bold>\<and> atS_gc hp_Idle_locs          (sys_ghost_handshake_phase \<^bold>= \<langle>hp_Idle\<rangle>)
     \<^bold>\<and> atS_gc hp_IdleInit_locs      (sys_ghost_handshake_phase \<^bold>= \<langle>hp_IdleInit\<rangle>)
     \<^bold>\<and> atS_gc hp_InitMark_locs      (sys_ghost_handshake_phase \<^bold>= \<langle>hp_InitMark\<rangle>)
     \<^bold>\<and> atS_gc hp_IdleMarkSweep_locs (sys_ghost_handshake_phase \<^bold>= \<langle>hp_IdleMarkSweep\<rangle>)
     \<^bold>\<and> atS_gc hp_Mark_locs          (sys_ghost_handshake_phase \<^bold>= \<langle>hp_Mark\<rangle>))"
 (*<*)
 
 lemma hs_get_roots_locs_subseteq_hp_IdleMarkSweep_locs:
   "hs_get_roots_locs \<subseteq> hp_IdleMarkSweep_locs"
 by (auto simp: hs_get_roots_locs_def hp_IdleMarkSweep_locs_def mark_loop_locs_def
         intro: append_prefixD)
 
 lemma hs_get_work_locs_subseteq_hp_IdleMarkSweep_locs:
   "hs_get_work_locs \<subseteq> hp_IdleMarkSweep_locs"
 apply (simp add: hs_get_work_locs_def hp_IdleMarkSweep_locs_def mark_loop_locs_def)
 apply clarsimp
 apply (drule mp)
  apply (auto intro: append_prefixD)[1]
 apply auto
 done
 
 lemma gc_handshake_invL_eq_imp:
   "eq_imp (\<lambda>(_::unit) s. (AT s gc, s\<down> gc, sys_ghost_handshake_phase s\<down>, handshake_pending (s\<down> sys), ghost_handshake_in_sync (s\<down> sys), sys_handshake_type s\<down>))
           gc.handshake_invL"
 by (simp add: gc.handshake_invL_def eq_imp_def)
 
 lemmas gc_handshake_invL_niE[nie] =
   iffD1[OF gc_handshake_invL_eq_imp[simplified eq_imp_simps, rule_format, unfolded conj_explode], rotated -1]
 
 lemma (in gc) handshake_invL[intro]:
   "\<lbrace> handshake_invL \<rbrace> gc"
 by vcg_jackhammer_ff
 
 lemma (in sys) gc_handshake_invL[intro]:
   notes gc.handshake_invL_def[inv]
   shows "\<lbrace> gc.handshake_invL \<rbrace> sys"
 by vcg_ni
 
 lemma (in gc) handshake_phase_inv[intro]:
   "\<lbrace> handshake_invL \<^bold>\<and> LSTP handshake_phase_inv \<rbrace> gc \<lbrace> LSTP handshake_phase_inv \<rbrace>"
 by (vcg_jackhammer_ff simp: handshake_phase_inv_def hp_step_rel_def)
 
 (*>*)
 text\<open>
 
 Local handshake phase invariant for the mutators.
 
 \<close>
 
 locset_definition "mut_no_pending_mutates_locs =
     (prefixed ''hs_noop'' - { ''hs_noop'', ''hs_noop_mfence'' })
   \<union> (prefixed ''hs_get_roots'' - { ''hs_get_roots'', ''hs_get_roots_mfence'' })
   \<union> (prefixed ''hs_get_work'' - { ''hs_get_work'', ''hs_get_work_mfence'' })"
 
 inv_definition (in mut_m) handshake_invL :: "('field, 'mut, 'ref) gc_pred" where
   "handshake_invL =
    (atS_mut (prefixed ''hs_noop_'')     (sys_handshake_type \<^bold>= \<langle>ht_NOOP\<rangle> \<^bold>\<and> sys_handshake_pending m)
  \<^bold>\<and> atS_mut (prefixed ''hs_get_roots_'') (sys_handshake_type \<^bold>= \<langle>ht_GetRoots\<rangle> \<^bold>\<and> sys_handshake_pending m)
  \<^bold>\<and> atS_mut (prefixed ''hs_get_work_'')  (sys_handshake_type \<^bold>= \<langle>ht_GetWork\<rangle> \<^bold>\<and> sys_handshake_pending m)
  \<^bold>\<and> atS_mut mut_no_pending_mutates_locs  (LIST_NULL (tso_pending_mutate (mutator m))))"
 (*<*)
 
 lemma (in mut_m) handshake_invL_eq_imp:
   "eq_imp (\<lambda>(_::unit) s. (AT s (mutator m), s\<down> (mutator m), sys_handshake_type s\<down>, handshake_pending (s\<down> sys), mem_write_buffers (s\<down> sys) (mutator m)))
           handshake_invL"
 by (simp add: eq_imp_def handshake_invL_def)
 
 lemmas mut_m_handshake_invL_niE[nie] =
   iffD1[OF mut_m.handshake_invL_eq_imp[simplified eq_imp_simps, rule_format, unfolded conj_explode], rotated -1]
 
 lemma (in mut_m) handshake_invL[intro]:
   "\<lbrace> handshake_invL \<rbrace> mutator m"
 by vcg_jackhammer
 
 lemma (in mut_m') handshake_invL[intro]:
   "\<lbrace> handshake_invL \<rbrace> mutator m'"
 by vcg_nihe vcg_ni+
 
 lemma (in gc) mut_handshake_invL[intro]:
   notes mut_m.handshake_invL_def[inv]
   shows "\<lbrace> handshake_invL \<^bold>\<and> mut_m.handshake_invL m \<rbrace> gc \<lbrace> mut_m.handshake_invL m \<rbrace>"
 by vcg_nihe vcg_ni+
 
 lemma (in sys) mut_handshake_invL[intro]:
   notes mut_m.handshake_invL_def[inv]
   shows "\<lbrace> mut_m.handshake_invL m \<rbrace> sys"
 by (vcg_ni split: if_splits)
 
 lemma (in mut_m) gc_handshake_invL[intro]:
   notes gc.handshake_invL_def[inv]
   shows "\<lbrace> handshake_invL \<^bold>\<and> gc.handshake_invL \<rbrace> mutator m \<lbrace> gc.handshake_invL \<rbrace>"
 by vcg_nihe vcg_ni+
 
 lemma (in mut_m) handshake_phase_inv[intro]:
   "\<lbrace> handshake_invL \<^bold>\<and> LSTP handshake_phase_inv \<rbrace> mutator m \<lbrace> LSTP handshake_phase_inv \<rbrace>"
 by (vcg_jackhammer simp: handshake_phase_inv_def) (auto simp: hp_step_rel_def)
 
 (*>*)
 text\<open>
 
 Relate @{const "sys_ghost_handshake_phase"}, @{const "gc_phase"},
 @{const "sys_phase"} and writes to the phase in the GC's TSO buffer.
 
 The first relation treats the case when the GC's TSO buffer does not
 contain any writes to the phase.
 
 The second relation exhibits the data race on the phase variable: we
 need to precisely track the possible states of the GC's TSO buffer.
 
 \<close>
 
 definition handshake_phase_rel :: "handshake_phase \<Rightarrow> bool \<Rightarrow> gc_phase \<Rightarrow> bool" where
   "handshake_phase_rel hp in_sync ph \<equiv>
      case hp of
        hp_Idle          \<Rightarrow> ph = ph_Idle
      | hp_IdleInit      \<Rightarrow> ph = ph_Idle \<or> (in_sync \<and> ph = ph_Init)
      | hp_InitMark      \<Rightarrow> ph = ph_Init \<or> (in_sync \<and> ph = ph_Mark)
      | hp_Mark          \<Rightarrow> ph = ph_Mark
      | hp_IdleMarkSweep \<Rightarrow> ph = ph_Mark \<or> (in_sync \<and> ph \<in> { ph_Idle, ph_Sweep })"
 
 definition phase_rel :: "(bool \<times> handshake_phase \<times> gc_phase \<times> gc_phase \<times> ('field, 'ref) mem_write_action list) set" where
   "phase_rel \<equiv>
       { (in_sync, hp, ph, ph, []) |in_sync hp ph. handshake_phase_rel hp in_sync ph }
     \<union> ({True} \<times> { (hp_IdleInit, ph_Init, ph_Idle, [mw_Phase ph_Init]),
                   (hp_InitMark, ph_Mark, ph_Init, [mw_Phase ph_Mark]),
                   (hp_IdleMarkSweep, ph_Sweep, ph_Mark, [mw_Phase ph_Sweep]),
                   (hp_IdleMarkSweep, ph_Idle, ph_Mark, [mw_Phase ph_Sweep, mw_Phase ph_Idle]),
                   (hp_IdleMarkSweep, ph_Idle, ph_Sweep, [mw_Phase ph_Idle]) })"
 
 definition phase_rel_inv :: "('field, 'mut, 'ref) lsts_pred" where
   "phase_rel_inv = ((\<^bold>\<forall>m. sys_ghost_handshake_in_sync m) \<^bold>\<otimes> sys_ghost_handshake_phase \<^bold>\<otimes> gc_phase \<^bold>\<otimes> sys_phase \<^bold>\<otimes> tso_pending_phase gc \<^bold>\<in> \<langle>phase_rel\<rangle>)"
 (*<*)
 
 simps_of_case handshake_phase_rel_simps[simp]: handshake_phase_rel_def (splits: handshake_phase.split)
 
 lemma phase_rel_invD:
   "phase_rel_inv s \<Longrightarrow> (\<forall>m. sys_ghost_handshake_in_sync m s, sys_ghost_handshake_phase s, gc_phase s, sys_phase s, tso_pending_phase gc s) \<in> phase_rel"
 by (simp add: phase_rel_inv_def)
 
 lemma phases_rel_Id[iff]:
   "(\<forall>m. sys_ghost_handshake_in_sync m s, sys_ghost_handshake_phase s, gc_phase s, sys_phase s, tso_pending_phase gc s) \<in> phase_rel
      \<Longrightarrow> (\<forall>ph. mw_Phase ph \<notin> set (sys_mem_write_buffers gc s)) \<longleftrightarrow> sys_phase s = gc_phase s"
 by (auto simp: phase_rel_def filter_empty_conv filter_eq_Cons_iff)
 
 (*>*)
 text\<open>
 
 Tie the garbage collector's control location to the value of @{const
 "gc_phase"}.
 
 \<close>
 
 locset_definition no_pending_phase_locs :: "location set" where
   "no_pending_phase_locs \<equiv>
        (idle_locs - { ''idle_noop_mfence'' })
      \<union> (init_locs - { ''init_noop_mfence'' })
      \<union> (mark_locs - { ''mark_read_fM'', ''mark_write_fA'', ''mark_noop_mfence'' })"
 
 inv_definition (in gc) phase_invL :: "('field, 'mut, 'ref) gc_pred" where
   "phase_invL =
      (atS_gc idle_locs             (gc_phase \<^bold>= \<langle>ph_Idle\<rangle>)
   \<^bold>\<and> atS_gc init_locs             (gc_phase \<^bold>= \<langle>ph_Init\<rangle>)
   \<^bold>\<and> atS_gc mark_locs             (gc_phase \<^bold>= \<langle>ph_Mark\<rangle>)
   \<^bold>\<and> atS_gc sweep_locs            (gc_phase \<^bold>= \<langle>ph_Sweep\<rangle>)
   \<^bold>\<and> atS_gc no_pending_phase_locs (LIST_NULL (tso_pending_phase gc)))"
 (*<*)
 
 lemma (in gc) phase_invL_eq_imp:
   "eq_imp (\<lambda>r (s :: ('field, 'mut, 'ref) gc_pred_state). (AT s gc, s\<down> gc, tso_pending_phase gc s\<down>))
           phase_invL"
 by (clarsimp simp: eq_imp_def inv)
 
 lemmas gc_phase_invL_niE[nie] =
   iffD1[OF gc.phase_invL_eq_imp[simplified eq_imp_simps, rule_format, unfolded conj_explode], rotated -1]
 
 lemma (in gc) phase_invL[intro]:
   "\<lbrace> phase_invL \<^bold>\<and> LSTP phase_rel_inv \<rbrace> gc \<lbrace> phase_invL \<rbrace>"
 by (vcg_jackhammer dest!: phase_rel_invD simp: phase_rel_def)
 
 lemma (in sys) gc_phase_invL[intro]:
   notes gc.phase_invL_def[inv]
   shows "\<lbrace> gc.phase_invL \<^bold>\<and> LSTP tso_writes_inv \<rbrace> sys \<lbrace> gc.phase_invL \<rbrace>"
 by (vcg_ni split: if_splits)
 
 lemma (in mut_m) gc_phase_invL[intro]:
   notes gc.phase_invL_def[inv]
   shows "\<lbrace> gc.phase_invL \<rbrace> mutator m"
 by vcg_nihe
 
 lemma (in gc) phase_rel_inv[intro]:
   notes phase_rel_inv_def[inv]
   shows "\<lbrace> handshake_invL \<^bold>\<and> phase_invL \<^bold>\<and> LSTP phase_rel_inv \<rbrace> gc \<lbrace> LSTP phase_rel_inv \<rbrace>"
 by (vcg_jackhammer_ff dest!: phase_rel_invD simp: phase_rel_def)
 
 lemma (in sys) phase_rel_inv[intro]:
   notes gc.phase_invL_def[inv] phase_rel_inv_def[inv]
   shows "\<lbrace> LSTP (phase_rel_inv \<^bold>\<and> tso_writes_inv) \<rbrace> sys \<lbrace> LSTP phase_rel_inv \<rbrace>"
 apply vcg_jackhammer
 apply (simp add: phase_rel_def p_not_sys split: if_splits)
 apply (elim disjE; auto split: if_splits)
 done
 
 lemma (in mut_m) phase_rel_inv[intro]:
   "\<lbrace> handshake_invL \<^bold>\<and> LSTP (handshake_phase_inv \<^bold>\<and> phase_rel_inv) \<rbrace>
      mutator m
    \<lbrace> LSTP phase_rel_inv \<rbrace>"
 apply (vcg_jackhammer simp: phase_rel_inv_def)
 subgoal by (auto dest!: handshake_phase_invD
              simp: handshake_phase_rel_def phase_rel_def hp_step_rel_def
             split: handshake_phase.splits)
 subgoal by (auto dest!: handshake_phase_invD
              simp: handshake_phase_rel_def phase_rel_def hp_step_rel_def
             split: handshake_phase.splits)
 subgoal by (auto dest!: handshake_phase_invD
              simp: handshake_phase_rel_def phase_rel_def hp_step_rel_def
             split: handshake_phase.splits)
 done
 
 (*>*)
 text\<open>
 
 Validity of @{const "sys_fM"} wrt @{const "gc_fM"} and the handshake
 phase. Effectively we use @{const "gc_fM"} as ghost state. We also
 include the TSO lock to rule out the GC having any pending marks
 during the @{const "hp_Idle"} handshake phase.
 
 \<close>
 
 definition fM_rel :: "(bool \<times> handshake_phase \<times> gc_mark \<times> gc_mark \<times> ('field, 'ref) mem_write_action list \<times> bool) set" where
   "fM_rel =
       { (in_sync, hp, fM, fM, [], l) |fM hp in_sync l. hp = hp_Idle \<longrightarrow> \<not>in_sync }
     \<union> { (in_sync, hp_Idle, fM, fM', [], l) |fM fM' in_sync l. in_sync }
     \<union> { (in_sync, hp_Idle, \<not>fM, fM, [mw_fM (\<not>fM)], False) |fM in_sync. in_sync }"
 
 definition fM_rel_inv :: "('field, 'mut, 'ref) lsts_pred" where
   "fM_rel_inv = ((\<^bold>\<forall>m. sys_ghost_handshake_in_sync m) \<^bold>\<otimes> sys_ghost_handshake_phase \<^bold>\<otimes> gc_fM \<^bold>\<otimes> sys_fM \<^bold>\<otimes> tso_pending_fM gc \<^bold>\<otimes> (sys_mem_lock \<^bold>= \<langle>Some gc\<rangle>) \<^bold>\<in> \<langle>fM_rel\<rangle>)"
 
 definition fA_rel :: "(bool \<times> handshake_phase \<times> gc_mark \<times> gc_mark \<times> ('field, 'ref) mem_write_action list) set" where
   "fA_rel =
       { (in_sync, hp_Idle,          fA,  fM, []) |fA fM in_sync. \<not>in_sync \<longrightarrow> fA = fM }
     \<union> { (in_sync, hp_IdleInit,      fA, \<not>fA, []) |fA in_sync. True }
     \<union> { (in_sync, hp_InitMark,      fA, \<not>fA, [mw_fA (\<not>fA)]) |fA in_sync. in_sync }
     \<union> { (in_sync, hp_InitMark,      fA,  fM, []) |fA fM in_sync. \<not>in_sync \<longrightarrow> fA \<noteq> fM }
     \<union> { (in_sync, hp_Mark,          fA,  fA, []) |fA in_sync. True }
     \<union> { (in_sync, hp_IdleMarkSweep, fA,  fA, []) |fA in_sync. True }"
 
 definition fA_rel_inv :: "('field, 'mut, 'ref) lsts_pred" where
   "fA_rel_inv = ((\<^bold>\<forall>m. sys_ghost_handshake_in_sync m) \<^bold>\<otimes> sys_ghost_handshake_phase \<^bold>\<otimes> sys_fA \<^bold>\<otimes> gc_fM \<^bold>\<otimes> tso_pending_fA gc \<^bold>\<in> \<langle>fA_rel\<rangle>)"
 
 locset_definition "fM_eq_locs = (- { ''idle_write_fM'', ''idle_flip_noop_mfence'' })"
 locset_definition "fM_tso_empty_locs = (- { ''idle_flip_noop_mfence'' })"
 locset_definition "fA_tso_empty_locs = (- { ''mark_noop_mfence'' })"
 
 locset_definition
   "fA_eq_locs \<equiv> { ''idle_read_fM'', ''idle_invert_fM'' }
               \<union> prefixed ''idle_noop''
               \<union> (mark_locs - { ''mark_read_fM'', ''mark_write_fA'', ''mark_noop_mfence'' })
               \<union> sweep_locs"
 
 locset_definition
   "fA_neq_locs \<equiv> { ''idle_phase_init'', ''idle_write_fM'', ''mark_read_fM'', ''mark_write_fA'' }
                \<union> prefixed ''idle_flip_noop''
                \<union> init_locs"
 
 inv_definition (in gc) fM_fA_invL :: "('field, 'mut, 'ref) gc_pred" where
   "fM_fA_invL =
    (atS_gc fM_eq_locs                    (sys_fM  \<^bold>= gc_fM)
   \<^bold>\<and> at_gc ''idle_write_fM''              (sys_fM \<^bold>\<noteq> gc_fM)
   \<^bold>\<and> at_gc ''idle_flip_noop_mfence''      (sys_fM \<^bold>\<noteq> gc_fM \<^bold>\<longrightarrow> (\<^bold>\<not>(LIST_NULL (tso_pending_fM gc))))
   \<^bold>\<and> atS_gc fM_tso_empty_locs             (LIST_NULL (tso_pending_fM gc))
 
   \<^bold>\<and> atS_gc fA_eq_locs                    (sys_fA  \<^bold>= gc_fM)
   \<^bold>\<and> atS_gc fA_neq_locs                   (sys_fA \<^bold>\<noteq> gc_fM)
   \<^bold>\<and> at_gc ''mark_noop_mfence''           (sys_fA \<^bold>\<noteq> gc_fM \<^bold>\<longrightarrow> (\<^bold>\<not>(LIST_NULL (tso_pending_fA gc))))
   \<^bold>\<and> atS_gc fA_tso_empty_locs             (LIST_NULL (tso_pending_fA gc)))"
 (*<*)
 
 lemmas fM_rel_invD = iffD1[OF fun_cong[OF fM_rel_inv_def[simplified atomize_eq]]]
 
 lemma do_write_action_fM[simp]:
   "\<lbrakk> sys_mem_write_buffers p s = w # ws; tso_writes_inv s; handshake_phase_inv s; fM_rel_inv s;
      ghost_handshake_phase (s (mutator m)) \<noteq> hp_Idle \<or> (sys_ghost_handshake_phase s = hp_IdleMarkSweep \<and> All (ghost_handshake_in_sync (s sys)));
      p \<noteq> sys \<rbrakk>
      \<Longrightarrow> fM (do_write_action w (s sys)) = fM (s sys)"
 apply (drule mut_m.handshake_phase_invD[where m=m])
 apply (clarsimp simp: do_write_action_def p_not_sys
                split: mem_write_action.splits)
 apply (simp add: hp_step_rel_def)
 apply (elim disjE, auto simp: fM_rel_inv_def fM_rel_def)
 done
 
 lemmas fA_rel_invD = iffD1[OF fun_cong[OF fA_rel_inv_def[simplified atomize_eq]]]
 
 lemma gc_fM_fA_invL_eq_imp:
   "eq_imp (\<lambda>(_::unit) s. (AT s gc, s\<down> gc, sys_fA s\<down>, sys_fM s\<down>, sys_mem_write_buffers gc s\<down>))
           gc.fM_fA_invL"
 by (simp add: gc.fM_fA_invL_def eq_imp_def)
 
 lemmas gc_fM_fA_invL_niE[nie] =
   iffD1[OF gc_fM_fA_invL_eq_imp[simplified eq_imp_simps, rule_format, unfolded conj_explode], rotated -1]
 
 lemma (in gc) fM_fA_invL[intro]:
   "\<lbrace> fM_fA_invL \<rbrace> gc"
 by vcg_jackhammer
 
 lemma (in gc) fM_rel_inv[intro]:
   "\<lbrace> fM_fA_invL \<^bold>\<and> handshake_invL \<^bold>\<and> tso_lock_invL \<^bold>\<and> LSTP fM_rel_inv \<rbrace>
      gc
    \<lbrace> LSTP fM_rel_inv \<rbrace>"
 by (vcg_jackhammer simp: fM_rel_inv_def fM_rel_def)
 
 lemma (in gc) fA_rel_inv[intro]:
   "\<lbrace> fM_fA_invL \<^bold>\<and> handshake_invL \<^bold>\<and> LSTP fA_rel_inv \<rbrace>
      gc
    \<lbrace> LSTP fA_rel_inv \<rbrace>"
 by (vcg_jackhammer simp: fA_rel_inv_def; auto simp: fA_rel_def)
 
 lemma (in mut_m) gc_fM_fA_invL[intro]:
   notes gc.fM_fA_invL_def[inv]
   shows "\<lbrace> gc.fM_fA_invL \<rbrace> mutator m"
 by vcg_nihe
 
 lemma (in mut_m) fM_rel_inv[intro]:
   "\<lbrace> LSTP fM_rel_inv \<rbrace> mutator m"
 by (vcg_jackhammer simp: fM_rel_inv_def fM_rel_def; elim disjE; auto split: if_splits)
 (* FIXME trivial but eta reduction plays merry hell *)
 
 lemma (in mut_m) fA_rel_inv[intro]:
   "\<lbrace> LSTP fA_rel_inv \<rbrace> mutator m"
 by (vcg_jackhammer simp: fA_rel_inv_def; simp add: fA_rel_def; elim disjE; auto split: if_splits)
 
 lemma fA_neq_locs_diff_fA_tso_empty_locs[simp]:
   "fA_neq_locs - fA_tso_empty_locs = {}"
 by (simp add: fA_neq_locs_def fA_tso_empty_locs_def loc)
 
 lemma (in sys) gc_fM_fA_invL[intro]:
   notes gc.fM_fA_invL_def[inv]
   shows
   "\<lbrace> gc.fM_fA_invL \<^bold>\<and> LSTP (fA_rel_inv \<^bold>\<and> fM_rel_inv \<^bold>\<and> tso_writes_inv) \<rbrace>
      sys
    \<lbrace> gc.fM_fA_invL \<rbrace>"
 apply (vcg_ni simp: p_not_sys)
 
 apply (erule disjE)
  apply (clarsimp simp: fM_rel_inv_def fM_rel_def split: if_splits)
 apply (clarsimp simp: fM_rel_inv_def fM_rel_def filter_empty_conv)
 
 apply (erule disjE; clarsimp)
 
 apply (rule conjI; clarsimp simp: fM_rel_inv_def fM_rel_def split: if_splits)
 
 apply (clarsimp split: if_splits)
 
 apply (erule disjE)
  apply (clarsimp simp: fA_rel_inv_def fA_rel_def)
 apply clarsimp
 
 apply (erule disjE)
  apply (clarsimp simp: fA_rel_inv_def fA_rel_def fM_rel_inv_def fM_rel_def)
  apply (drule (1) atS_dests(3), fastforce simp: atS_simps)
 apply clarsimp
 
 apply (rule conjI)
  apply (clarsimp simp: fA_rel_inv_def fA_rel_def split: if_splits)
 apply clarsimp
 
 apply (clarsimp split: if_splits)
 done
 
 lemma (in sys) fM_rel_inv[intro]:
   "\<lbrace> LSTP (fM_rel_inv \<^bold>\<and> tso_writes_inv) \<rbrace> sys \<lbrace> LSTP fM_rel_inv \<rbrace>"
 apply (vcg_ni simp: p_not_sys)
 apply (fastforce simp: do_write_action_def fM_rel_inv_def fM_rel_def
                 split: mem_write_action.splits)
 done
 
 lemma (in sys) fA_rel_inv[intro]:
   "\<lbrace> LSTP (fA_rel_inv \<^bold>\<and> tso_writes_inv) \<rbrace> sys \<lbrace> LSTP fA_rel_inv \<rbrace>"
 apply (vcg_ni simp: p_not_sys)
 apply (fastforce simp: do_write_action_def fA_rel_inv_def fA_rel_def
                 split: mem_write_action.splits)
 done
 
 lemma mut_m_get_roots_no_fM_write:
   "\<lbrakk> atS (mutator m) (prefixed ''hs_get_roots_'') s; mut_m.handshake_invL m s; handshake_phase_inv s\<down>; fM_rel_inv s\<down>; tso_writes_inv s\<down>; p \<noteq> sys \<rbrakk>
      \<Longrightarrow> \<not>sys_mem_write_buffers p s\<down> = mw_fM fl # ws"
 unfolding mut_m.handshake_invL_def
 apply (elim conjE)
 apply (drule mut_m.handshake_phase_invD[where m=m])
 apply (drule fM_rel_invD)
 apply (fastforce simp: hp_step_rel_def fM_rel_def loc filter_empty_conv p_not_sys)
 done
 
 lemma mut_m_get_roots_no_phase_write:
   "\<lbrakk> atS (mutator m) (prefixed ''hs_get_roots_'') s; mut_m.handshake_invL m s; handshake_phase_inv s\<down>; phase_rel_inv s\<down>; tso_writes_inv s\<down>; p \<noteq> sys \<rbrakk>
      \<Longrightarrow> \<not>sys_mem_write_buffers p s\<down> = mw_Phase ph # ws"
 unfolding mut_m.handshake_invL_def
 apply (elim conjE)
 apply (drule mut_m.handshake_phase_invD[where m=m])
 apply (drule phase_rel_invD)
 apply (fastforce simp: hp_step_rel_def phase_rel_def loc filter_empty_conv p_not_sys)
 done
 
 lemma mut_m_not_idle_no_fM_write:
   "\<lbrakk> ghost_handshake_phase (s (mutator m)) \<noteq> hp_Idle; fM_rel_inv s; handshake_phase_inv s; tso_writes_inv s; p \<noteq> sys \<rbrakk>
      \<Longrightarrow> \<not>sys_mem_write_buffers p s = mw_fM fl # ws"
 apply (drule mut_m.handshake_phase_invD[where m=m])
 apply (drule fM_rel_invD)
 apply (fastforce simp: hp_step_rel_def fM_rel_def filter_empty_conv p_not_sys)
 done
 
 lemma (in mut_m) mut_ghost_handshake_phase_idle:
   "\<lbrakk> mut_ghost_handshake_phase s = hp_Idle; handshake_phase_inv s; phase_rel_inv s \<rbrakk>
      \<Longrightarrow> sys_phase s = ph_Idle"
   apply (drule phase_rel_invD)
   apply (drule handshake_phase_invD)
   apply (auto simp: phase_rel_def hp_step_rel_def)
   done
 (*>*)
 (*<*)
 
 end
 (*>*)
diff --git a/thys/ConcurrentGC/MarkObject.thy b/thys/ConcurrentGC/MarkObject.thy
--- a/thys/ConcurrentGC/MarkObject.thy
+++ b/thys/ConcurrentGC/MarkObject.thy
@@ -1,1102 +1,1104 @@
 (*<*)
 (*
  * Copyright 2015, NICTA
  *
  * This software may be distributed and modified according to the terms of
  * the BSD 2-Clause license. Note that NO WARRANTY is provided.
  * See "LICENSE_BSD2.txt" for details.
  *
  * @TAG(NICTA_BSD)
  *)
 
 theory MarkObject
 imports
   Handshakes
 begin
 
+declare subst_all [simp del] [[simproc del: defined_all]]
+
 (*>*)
 subsection\<open>Object colours, reference validity, worklist validity\<close>
 
 text\<open>
 
 We adopt the classical tricolour scheme for object colours due to
 @{cite [cite_macro=citet] "DBLP:journals/cacm/DijkstraLMSS78"}, but
 tweak it somewhat in the presence of worklists and TSO. Intuitively:
 \begin{description}
 \item[White] potential garbage, not yet reached
 \item[Grey] reached, presumed live, a source of possible new references (work)
 \item[Black] reached, presumed live, not a source of new references
 \end{description}
 
 In this particular setting we use the following interpretation:
 \begin{description}
 \item[White:] not marked
 \item[Grey:] on a worklist
 \item[Black:] marked and not on a worklist
 \end{description}
 
 Note that this allows the colours to overlap: an object being marked
 may be white (on the heap) and in @{const "ghost_honorary_grey"} for
 some process, i.e. grey.
 
 \<close>
 
 abbreviation marked :: "'ref \<Rightarrow> ('field, 'mut, 'ref) lsts_pred" where
   "marked r s \<equiv> obj_at (\<lambda>obj. obj_mark obj = sys_fM s) r s"
 
 abbreviation white :: "'ref \<Rightarrow> ('field, 'mut, 'ref) lsts_pred" where
   "white r s \<equiv> obj_at (\<lambda>obj. obj_mark obj = (\<not>sys_fM s)) r s"
 
 definition WL :: "'mut process_name \<Rightarrow> ('field, 'mut, 'ref) lsts \<Rightarrow> 'ref set" where
   "WL p \<equiv> \<lambda>s. W (s p) \<union> ghost_honorary_grey (s p)"
 
 definition grey :: "'ref \<Rightarrow> ('field, 'mut, 'ref) lsts_pred" where
   "grey r \<equiv> \<^bold>\<exists>p. \<langle>r\<rangle> \<^bold>\<in> WL p"
 
 definition black :: "'ref \<Rightarrow> ('field, 'mut, 'ref) lsts_pred" where
   "black r \<equiv> marked r \<^bold>\<and> \<^bold>\<not>(grey r)"
 
 text\<open>
 
 We show that if a mutator can load a reference into its roots (its
 working set of references), then there is an object in the heap at
 that reference.
 
 In this particular collector, we can think of grey references and
 pending TSO heap mutations as extra mutator roots; in particular the
 GC holds no roots itself but marks everything reachable from its
 worklist, and so we need to know these objects exist. By the strong
 tricolour invariant (\S\ref{sec:strong-tricolour-invariant}), black
 objects point to black or grey objects, and so we do not need to treat
 these specially.
 
 \<close>
 
 abbreviation write_refs :: "('field, 'ref) mem_write_action \<Rightarrow> 'ref set" where
   "write_refs w \<equiv> case w of mw_Mutate r f r' \<Rightarrow> {r} \<union> Option.set_option r' | _ \<Rightarrow> {}"
 
 definition (in mut_m) tso_write_refs :: "('field, 'mut, 'ref) lsts \<Rightarrow> 'ref set" where
   "tso_write_refs = (\<lambda>s. \<Union>w \<in> set (sys_mem_write_buffers (mutator m) s). write_refs w)"
 
 definition (in mut_m) reachable :: "'ref \<Rightarrow> ('field, 'mut, 'ref) lsts_pred" where
   "reachable y = (\<^bold>\<exists>x. \<langle>x\<rangle> \<^bold>\<in> mut_roots \<^bold>\<union> mut_ghost_honorary_root \<^bold>\<union> tso_write_refs
                     \<^bold>\<and> x reaches y)"
 
 definition grey_reachable :: "'ref \<Rightarrow> ('field, 'mut, 'ref) lsts_pred" where
   "grey_reachable y = (\<^bold>\<exists>g. grey g \<^bold>\<and> g reaches y)"
 
 definition valid_refs_inv :: "('field, 'mut, 'ref) lsts_pred" where
  "valid_refs_inv = (\<^bold>\<forall>x. ((\<^bold>\<exists>m. mut_m.reachable m x) \<^bold>\<or> grey_reachable x) \<^bold>\<longrightarrow> valid_ref x)"
 
 text\<open>
 
 \label{def:valid_W_inv}
 
 The worklists track the grey objects. The following invariant asserts
 that grey objects are marked on the heap except for a few steps near
 the end of @{const "mark_object_fn"}, the processes' worklists and
 @{const "ghost_honorary_grey"}s are disjoint, and that pending marks
 are sensible.
 
 The safety of the collector does not to depend on disjointness; we
 include it as proof that the single-threading of grey objects in the
 implementation is sound.
 
 \<close>
 
 definition valid_W_inv :: "('field, 'mut, 'ref) lsts_pred" where
   "valid_W_inv = (\<^bold>\<forall>p q r fl.
     (r in_W p \<^bold>\<or> (sys_mem_lock \<^bold>\<noteq> \<langle>Some p\<rangle> \<^bold>\<and> r in_ghost_honorary_grey p) \<^bold>\<longrightarrow> marked r)
   \<^bold>\<and> (\<langle>p \<noteq> q\<rangle> \<^bold>\<longrightarrow> \<^bold>\<not>(\<langle>r\<rangle> \<^bold>\<in> WL p \<^bold>\<and> \<langle>r\<rangle> \<^bold>\<in> WL q))
   \<^bold>\<and> (\<^bold>\<not>(r in_ghost_honorary_grey p \<^bold>\<and> r in_W q))
   \<^bold>\<and> (EMPTY sys_ghost_honorary_grey)
   \<^bold>\<and> (tso_pending_write p (mw_Mark r fl)
        \<^bold>\<longrightarrow> ( \<langle>fl\<rangle> \<^bold>= sys_fM
              \<^bold>\<and> r in_ghost_honorary_grey p
              \<^bold>\<and> tso_locked_by p
              \<^bold>\<and> white r
              \<^bold>\<and> tso_pending_mark p \<^bold>= \<langle>[mw_Mark r fl]\<rangle> )))"
 
 (*<*)
 
 lemma obj_at_mark_dequeue[simp]:
   "obj_at P r (s(sys := s sys\<lparr> heap := (sys_heap s)(r' := Option.map_option (obj_mark_update (\<lambda>_. fl)) (sys_heap s r')), mem_write_buffers := wb' \<rparr>))
 \<longleftrightarrow> (r = r' \<longrightarrow> obj_at (\<lambda>obj. (P (obj\<lparr> obj_mark := fl \<rparr>))) r s) \<and> (r \<noteq> r' \<longrightarrow> obj_at P r s)"
 by (clarsimp split: obj_at_splits)
 
 lemma marked_not_white:
   "white r s \<Longrightarrow> \<not>marked r s"
 by (clarsimp split: obj_at_splits)
 
 lemma valid_ref_valid_null_ref_simps[simp]:
   "valid_ref r (s(sys := do_write_action w (s sys)\<lparr>mem_write_buffers := (mem_write_buffers (s sys))(p := ws)\<rparr>)) \<longleftrightarrow> valid_ref r s"
   "valid_null_ref r' (s(sys := do_write_action w (s sys)\<lparr>mem_write_buffers := (mem_write_buffers (s sys))(p := ws)\<rparr>)) \<longleftrightarrow> valid_null_ref r' s"
   "valid_null_ref r' (s(mutator m := mut_s', sys := (s sys)\<lparr> heap := (heap (s sys))(r'' \<mapsto> obj) \<rparr>)) \<longleftrightarrow> valid_null_ref r' s \<or> r' = Some r''"
 by (auto simp: do_write_action_def valid_null_ref_def
         split: mem_write_action.splits obj_at_splits option.splits)
 
 text\<open>points to, reaches, reachable mut, reachable grey\<close>
 
 lemma reaches_fields:
   assumes "(x reaches y) s'"
   assumes "\<forall>r. (Option.set_option (sys_heap s' r) \<bind> ran \<circ> obj_fields) = (Option.set_option (sys_heap s r) \<bind> ran \<circ> obj_fields)"
   shows "(x reaches y) s"
 using assms
 proof induct
   case (step y z)
   then have "(y points_to z) s"
     by (cases "sys_heap s y")
        (auto simp: ran_def obj_at_def split: option.splits dest!: spec[where x=y])
   with step show ?case by (blast intro: rtranclp.intros(2))
 qed simp
 
 lemma reaches_eq_imp:
   "eq_imp (\<lambda>r s. Option.set_option (sys_heap s r) \<bind> ran \<circ> obj_fields)
           (x reaches y)"
 by (auto simp: eq_imp_def elim: reaches_fields)
 
 lemmas reaches_fun_upd[simp] = eq_imp_fun_upd[OF reaches_eq_imp, simplified eq_imp_simps, rule_format]
 
 lemma (in mut_m) reachable_eq_imp:
   "eq_imp (\<lambda>r'. mut_roots \<^bold>\<otimes> mut_ghost_honorary_root \<^bold>\<otimes> (\<lambda>s. Option.set_option (sys_heap s r') \<bind> ran \<circ> obj_fields) \<^bold>\<otimes> tso_pending_mutate (mutator m))
           (reachable r)"
 apply (clarsimp simp: eq_imp_def reachable_def tso_write_refs_def ex_disj_distrib)
 apply (rename_tac s s')
 apply (subgoal_tac "\<forall>r'. (\<exists>w\<in>set (sys_mem_write_buffers (mutator m) s). r' \<in> write_refs w) \<longleftrightarrow> (\<exists>w\<in>set (sys_mem_write_buffers (mutator m) s'). r' \<in> write_refs w)")
  apply (subgoal_tac "\<forall>x. (x reaches r) s \<longleftrightarrow> (x reaches r) s'")
   apply clarsimp
  apply (auto simp: reaches_fields)[1]
 apply (drule arg_cong[where f=set])
 apply (clarsimp simp: set_eq_iff)
 apply (rule iffI)
  apply clarsimp
  apply (rename_tac s s' r' w)
  apply (drule_tac x=w in spec)
  apply (rule_tac x=w in bexI)
   apply clarsimp
  apply (case_tac w, simp_all)
 apply clarsimp
 apply (rename_tac s s' r' w)
 apply (drule_tac x=w in spec)
 apply (rule_tac x=w in bexI)
  apply clarsimp
 apply (case_tac w, simp_all)
 done
 
 lemmas reachable_fun_upd[simp] = eq_imp_fun_upd[OF mut_m.reachable_eq_imp, simplified eq_imp_simps, rule_format]
 
 lemma reachableI[intro]:
   "x \<in> mut_m.mut_roots m s \<Longrightarrow> mut_m.reachable m x s"
   "x \<in> mut_m.tso_write_refs m s \<Longrightarrow> mut_m.reachable m x s"
 by (auto simp: mut_m.reachable_def)
 
 lemma reachableE:
   "\<lbrakk> (x points_to y) s; mut_m.reachable m x s \<rbrakk> \<Longrightarrow> mut_m.reachable m y s"
 by (auto simp: mut_m.reachable_def
          elim: rtranclp.intros(2))
 
 lemma (in mut_m) reachable_induct[consumes 1, case_names root ghost_honorary_root tso_root reaches]:
   assumes r: "reachable y s"
   assumes root: "\<And>x. \<lbrakk> x \<in> mut_roots s \<rbrakk> \<Longrightarrow> P x"
   assumes ghost_honorary_root: "\<And>x. \<lbrakk> x \<in> mut_ghost_honorary_root s \<rbrakk> \<Longrightarrow> P x"
   assumes tso_root: "\<And>x. \<lbrakk> x \<in> tso_write_refs s \<rbrakk> \<Longrightarrow> P x"
   assumes reaches: "\<And>x y. \<lbrakk> reachable x s; (x points_to y) s; P x \<rbrakk> \<Longrightarrow> P y"
   shows "P y"
 using r unfolding reachable_def
 proof(clarify)
   fix x
   assume xy: "(x reaches y) s" and xr: "x \<in> mut_roots s \<union> mut_ghost_honorary_root s \<union> tso_write_refs s"
   then show "P y"
   proof induct
     case base with root ghost_honorary_root tso_root show ?case by blast
   next
     case (step y z) with reaches show ?case
       unfolding reachable_def by blast
   qed
 qed
 
 lemmas reachable_induct = mut_m.reachable_induct[consumes 1, case_names root ghost_honorary_root tso_root reaches]
 
 lemma (in mut_m) mut_reachableE[consumes 1, case_names mut_root tso_write_refs]:
   "\<lbrakk> reachable y s;
      \<And>x. \<lbrakk> (x reaches y) s; x \<in> mut_roots s \<rbrakk> \<Longrightarrow> Q;
      \<And>x. \<lbrakk> (x reaches y) s; x \<in> mut_ghost_honorary_root s \<rbrakk> \<Longrightarrow> Q;
      \<And>x. \<lbrakk> (x reaches y) s; x \<in> tso_write_refs s \<rbrakk> \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
 by (auto simp: reachable_def)
 
 lemma grey_reachable_eq_imp:
   "eq_imp (\<lambda>r'. (\<lambda>s. \<Union>p. WL p s) \<^bold>\<otimes> (\<lambda>s. Option.set_option (sys_heap s r') \<bind> ran \<circ> obj_fields))
           (grey_reachable r)"
 by (auto simp: eq_imp_def grey_reachable_def grey_def set_eq_iff reaches_fields)
 
 lemmas grey_reachable_fun_upd[simp] = eq_imp_fun_upd[OF grey_reachable_eq_imp, simplified eq_imp_simps, rule_format]
 
 lemma grey_reachableI[intro]:
   "grey g s \<Longrightarrow> grey_reachable g s"
 by (auto simp: grey_reachable_def)
 
 lemma grey_reachableE:
   "\<lbrakk> (g points_to y) s; grey_reachable g s \<rbrakk> \<Longrightarrow> grey_reachable y s"
 by (auto simp: grey_reachable_def
          elim: rtranclp.intros(2))
 
 text\<open>colours and work lists\<close>
 
 lemma black_eq_imp:
   "eq_imp (\<lambda>_::unit. (\<lambda>s. r \<in> (\<Union>p. WL p s)) \<^bold>\<otimes> sys_fM \<^bold>\<otimes> (\<lambda>s. Option.map_option obj_mark (sys_heap s r)))
           (black r)"
 by (auto simp add: eq_imp_def black_def grey_def obj_at_def split: option.splits)
 
 lemma white_eq_imp:
   "eq_imp (\<lambda>_::unit. sys_fM \<^bold>\<otimes> (\<lambda>s. Option.map_option obj_mark (sys_heap s r)))
           (white r)"
 by (auto simp add: eq_imp_def obj_at_def split: option.splits)
 
 lemma grey_eq_imp:
   "eq_imp (\<lambda>_::unit. (\<lambda>s. r \<in> (\<Union>p. WL p s)))
           (grey r)"
 by (auto simp add: eq_imp_def grey_def)
 
 lemmas black_fun_upd[simp] = eq_imp_fun_upd[OF black_eq_imp, simplified eq_imp_simps, rule_format]
 lemmas grey_fun_upd[simp] = eq_imp_fun_upd[OF grey_eq_imp, simplified eq_imp_simps, rule_format]
 lemmas white_fun_upd[simp] = eq_imp_fun_upd[OF white_eq_imp, simplified eq_imp_simps, rule_format]
 
 text\<open> These demonstrate the overlap in colours. \<close>
 
 lemma colours_distinct[dest]:
   "black r s \<Longrightarrow> \<not>grey r s"
   "black r s \<Longrightarrow> \<not>white r s"
   "grey r s  \<Longrightarrow> \<not>black r s"
   "white r s \<Longrightarrow> \<not>black r s"
 by (auto simp: black_def split: obj_at_splits)
 
 lemma marked_imp_black_or_grey:
   "marked r s \<Longrightarrow> black r s \<or> grey r s"
   "\<not> white r s \<Longrightarrow> \<not> valid_ref r s \<or> black r s \<or> grey r s"
 by (auto simp: black_def grey_def split: obj_at_splits)
 
 lemma blackD[dest]:
   "black r s \<Longrightarrow> marked r s"
   "black r s \<Longrightarrow> r \<notin> WL p s"
 by (simp_all add: black_def grey_def)
 
 text\<open>valid refs inv\<close>
 
 lemma valid_refs_inv_eq_imp:
   "eq_imp (\<lambda>(m', r'). (\<lambda>s. roots (s (mutator m'))) \<^bold>\<otimes> (\<lambda>s. ghost_honorary_root (s (mutator m'))) \<^bold>\<otimes> (\<lambda>s. Option.map_option obj_fields (sys_heap s r')) \<^bold>\<otimes> tso_pending_mutate (mutator m') \<^bold>\<otimes> (\<lambda>s. \<Union>p. WL p s))
           valid_refs_inv"
 apply (clarsimp simp: eq_imp_def valid_refs_inv_def grey_reachable_def all_conj_distrib)
 apply (rename_tac s s')
 apply (subgoal_tac "\<forall>r. valid_ref r s \<longleftrightarrow> valid_ref r s'")
  apply (subgoal_tac "\<forall>x. Option.set_option (sys_heap s x) \<bind> ran \<circ> obj_fields = Option.set_option (sys_heap s' x) \<bind> ran \<circ> obj_fields")
   apply (subst eq_impD[OF mut_m.reachable_eq_imp])
    defer
    apply (subst eq_impD[OF grey_eq_imp])
     defer
     apply (subst eq_impD[OF reaches_eq_imp])
      defer
      apply force
     apply clarsimp
     apply (rename_tac x)
     apply (drule_tac x=x in spec)
     apply (clarsimp simp: set_eq_iff ran_def)
     apply (case_tac "sys_heap s x", simp_all)[1]
     apply (metis (hide_lams, no_types) elem_set not_Some_eq option.inject map_option_eq_Some)
    apply (clarsimp split: obj_at_splits)
    apply (rule conjI)
     apply (metis map_option_is_None)
    apply (metis map_option_eq_Some)
   apply clarsimp
  apply clarsimp
 apply clarsimp
 done
 
 lemmas valid_refs_inv_fun_upd[simp] = eq_imp_fun_upd[OF valid_refs_inv_eq_imp, simplified eq_imp_simps, rule_format]
 
 lemma valid_refs_invD[elim]:
   "\<lbrakk> x \<in> mut_m.mut_roots m s; (x reaches y) s; valid_refs_inv s \<rbrakk> \<Longrightarrow> valid_ref y s"
   "\<lbrakk> x \<in> mut_m.mut_roots m s; (x reaches y) s; valid_refs_inv s \<rbrakk> \<Longrightarrow> \<exists>obj. sys_heap s y = Some obj"
   "\<lbrakk> x \<in> mut_m.tso_write_refs m s; (x reaches y) s; valid_refs_inv s \<rbrakk> \<Longrightarrow> valid_ref y s"
   "\<lbrakk> x \<in> mut_m.tso_write_refs m s; (x reaches y) s; valid_refs_inv s \<rbrakk> \<Longrightarrow> \<exists>obj. sys_heap s y = Some obj"
   "\<lbrakk> w \<in> set (sys_mem_write_buffers (mutator m) s); x \<in> write_refs w; (x reaches y) s; valid_refs_inv s \<rbrakk> \<Longrightarrow> valid_ref y s"
   "\<lbrakk> w \<in> set (sys_mem_write_buffers (mutator m) s); x \<in> write_refs w; (x reaches y) s; valid_refs_inv s \<rbrakk> \<Longrightarrow> \<exists>obj. sys_heap s y = Some obj"
   "\<lbrakk> grey x s; (x reaches y) s; valid_refs_inv s \<rbrakk> \<Longrightarrow> valid_ref y s"
   "\<lbrakk> mut_m.reachable m x s; valid_refs_inv s \<rbrakk> \<Longrightarrow> valid_ref x s"
   "\<lbrakk> mut_m.reachable m x s; valid_refs_inv s \<rbrakk> \<Longrightarrow> \<exists>obj. sys_heap s x = Some obj"
   "\<lbrakk> x \<in> mut_m.mut_ghost_honorary_root m s; (x reaches y) s; valid_refs_inv s \<rbrakk> \<Longrightarrow> valid_ref y s"
   "\<lbrakk> x \<in> mut_m.mut_ghost_honorary_root m s; (x reaches y) s; valid_refs_inv s \<rbrakk> \<Longrightarrow> \<exists>obj. sys_heap s y = Some obj"
 by (fastforce simp: valid_refs_inv_def grey_reachable_def mut_m.reachable_def mut_m.tso_write_refs_def
              split: obj_at_splits)+
 
 lemma valid_refs_invD2[elim]:
   "\<lbrakk> mut_m.reachable m x s;  valid_refs_inv s; (x reaches y) s \<rbrakk> \<Longrightarrow> valid_ref y s"
 apply (clarsimp simp: valid_refs_inv_def mut_m.reachable_def)
 apply (frule (1) rtranclp_trans)
 apply auto
 done
 
 lemma valid_refs_invD3:
   "\<lbrakk> sys_mem_write_buffers (mutator m) s = mw_Mutate r f opt_r' # ws; (r reaches y) s; valid_refs_inv s \<rbrakk> \<Longrightarrow> valid_ref y s"
 apply (clarsimp simp: valid_refs_inv_def mut_m.reachable_def mut_m.tso_write_refs_def)
 apply (fastforce dest: spec[where x=y] spec[where x=m])
 done
 
 text\<open>WL\<close>
 
 lemma WLI[intro]:
   "r \<in> W (s p) \<Longrightarrow> r \<in> WL p s"
   "r \<in> ghost_honorary_grey (s p) \<Longrightarrow> r \<in> WL p s"
 by (simp_all add: WL_def)
 
 lemma WL_eq_imp:
   "eq_imp (\<lambda>(_::unit) s. (ghost_honorary_grey (s p), W (s p)))
           (WL p)"
 by (clarsimp simp: eq_imp_def WL_def)
 
 lemmas WL_fun_upd[simp] = eq_imp_fun_upd[OF WL_eq_imp, simplified eq_imp_simps, rule_format]
 
 lemma greyI[intro]:
   "r \<in> ghost_honorary_grey (s p) \<Longrightarrow> grey r s"
   "r \<in> W (s p) \<Longrightarrow> grey r s"
   "r \<in> WL p s \<Longrightarrow> grey r s"
 by (case_tac [!] p) (auto simp: grey_def WL_def)
 
 text\<open>@{const "valid_W_inv"}\<close>
 
 lemma valid_W_inv_eq_imp:
   "eq_imp (\<lambda>(p, r). (\<lambda>s. W (s p)) \<^bold>\<otimes> (\<lambda>s. ghost_honorary_grey (s p)) \<^bold>\<otimes> sys_fM \<^bold>\<otimes> (\<lambda>s. Option.map_option obj_mark (sys_heap s r)) \<^bold>\<otimes> sys_mem_lock \<^bold>\<otimes> tso_pending_mark p)
           valid_W_inv"
 apply (clarsimp simp: eq_imp_def valid_W_inv_def fun_eq_iff all_conj_distrib)
 apply (rename_tac s s')
 apply (subgoal_tac "\<forall>p. WL p s = WL p s'")
  apply (subgoal_tac "\<forall>x. obj_at (\<lambda>obj. obj_mark obj = sys_fM s') x s \<longleftrightarrow> obj_at (\<lambda>obj. obj_mark obj = sys_fM s') x s'")
   apply (subgoal_tac "\<forall>x. obj_at (\<lambda>obj. obj_mark obj = (\<not>sys_fM s')) x s \<longleftrightarrow> obj_at (\<lambda>obj. obj_mark obj = (\<not>sys_fM s')) x s'")
    apply (subgoal_tac "\<forall>x xa xb. mw_Mark xa xb \<in> set (sys_mem_write_buffers x s) \<longleftrightarrow> mw_Mark xa xb \<in> set (sys_mem_write_buffers x s')")
     apply simp
    apply clarsimp
    apply (rename_tac x xa xb)
    apply (drule_tac x=x in spec, drule arg_cong[where f=set], fastforce)
   apply (clarsimp split: obj_at_splits)
   apply (rename_tac x)
   apply ( (drule_tac x=x in spec)+ )[1]
   apply (case_tac "sys_heap s x", simp_all)
    apply (case_tac "sys_heap s' x", auto)[1]
  apply (clarsimp split: obj_at_splits)
  apply (rename_tac x)
  apply (drule_tac x=x in spec)
  apply (case_tac "sys_heap s x", simp_all)
  apply (case_tac "sys_heap s' x", simp_all)
 apply (simp add: WL_def)
 done
 
 lemmas valid_W_inv_fun_upd[simp] = eq_imp_fun_upd[OF valid_W_inv_eq_imp, simplified eq_imp_simps, rule_format]
 
 lemma valid_W_invD[dest]:
   "\<lbrakk> r \<in> W (s p); valid_W_inv s \<rbrakk> \<Longrightarrow> marked r s"
   "\<lbrakk> r \<in> W (s p); valid_W_inv s \<rbrakk> \<Longrightarrow> valid_ref r s"
   "\<lbrakk> r \<in> WL p s;  valid_W_inv s; p \<noteq> q \<rbrakk> \<Longrightarrow> r \<notin> WL q s"
   "\<lbrakk> r \<in> W (s p); valid_W_inv s; p \<noteq> q \<rbrakk> \<Longrightarrow> r \<notin> WL q s"
   "\<lbrakk> r \<in> W (s p); valid_W_inv s \<rbrakk> \<Longrightarrow> r \<notin> ghost_honorary_grey (s q)"
   "\<lbrakk> r \<in> ghost_honorary_grey (s p); valid_W_inv s \<rbrakk> \<Longrightarrow> r \<notin> W (s q)"
   "\<lbrakk> r \<in> ghost_honorary_grey (s p); valid_W_inv s; p \<noteq> q \<rbrakk> \<Longrightarrow> r \<notin> WL q s"
 by (auto simp: valid_W_inv_def WL_def split: obj_at_splits)
 
 (* FIXME horrible but effective (?) *)
 lemma valid_W_invD2[dest]:
   "\<lbrakk> sys_mem_write_buffers p s = mw_Mark r fl # ws; valid_W_inv s \<rbrakk>
      \<Longrightarrow> fl = sys_fM s \<and> r \<in> ghost_honorary_grey (s p) \<and> tso_locked_by p s \<and> white r s \<and> filter is_mw_Mark ws = []"
   "\<lbrakk> mw_Mark r fl \<in> set (sys_mem_write_buffers p s); valid_W_inv s \<rbrakk>
      \<Longrightarrow> fl = sys_fM s \<and> r \<in> ghost_honorary_grey (s p) \<and> tso_locked_by p s \<and> white r s \<and> filter is_mw_Mark (sys_mem_write_buffers p s) = [mw_Mark r fl]"
 by (clarsimp simp: valid_W_inv_def dest!: spec[where x=p], blast)+
 
 lemma valid_W_invD3[elim]:
   "\<lbrakk> mw_Mark r fl \<in> set (sys_mem_write_buffers p s); valid_W_inv s \<rbrakk> \<Longrightarrow> r \<in> ghost_honorary_grey (s p)"
   "\<lbrakk> r \<in> ghost_honorary_grey (s p); sys_mem_lock s \<noteq> Some p; valid_W_inv s \<rbrakk> \<Longrightarrow> marked r s"
   "\<lbrakk> r \<in> ghost_honorary_grey (s p); sys_mem_lock s \<noteq> Some p; valid_W_inv s \<rbrakk> \<Longrightarrow> valid_ref r s"
 apply (simp_all add: valid_W_inv_def)
 apply (clarsimp split: obj_at_splits)
 apply blast
 done
 
 lemma valid_W_invD4:
   "\<lbrakk> sys_mem_write_buffers p s = mw_Mutate r' f r'' # ws; mw_Mark r fl \<in> set ws; valid_W_inv s \<rbrakk>
      \<Longrightarrow> fl = sys_fM s \<and> r \<in> ghost_honorary_grey (s p) \<and> tso_locked_by p s \<and> white r s \<and> filter is_mw_Mark ws = [mw_Mark r fl]"
   "\<lbrakk> sys_mem_write_buffers p s = mw_fA fl' # ws; mw_Mark r fl \<in> set ws; valid_W_inv s \<rbrakk>
      \<Longrightarrow> fl = sys_fM s \<and> r \<in> ghost_honorary_grey (s p) \<and> tso_locked_by p s \<and> white r s \<and> filter is_mw_Mark ws = [mw_Mark r fl]"
   "\<lbrakk> sys_mem_write_buffers p s = mw_fM fl' # ws; mw_Mark r fl \<in> set ws; valid_W_inv s \<rbrakk>
      \<Longrightarrow> fl = sys_fM s \<and> r \<in> ghost_honorary_grey (s p) \<and> tso_locked_by p s \<and> white r s \<and> filter is_mw_Mark ws = [mw_Mark r fl]"
   "\<lbrakk> sys_mem_write_buffers p s = mw_Phase ph # ws; mw_Mark r fl \<in> set ws; valid_W_inv s \<rbrakk>
      \<Longrightarrow> fl = sys_fM s \<and> r \<in> ghost_honorary_grey (s p) \<and> tso_locked_by p s \<and> white r s \<and> filter is_mw_Mark ws = [mw_Mark r fl]"
 by (clarsimp simp: valid_W_inv_def dest!: spec[where x=p], blast)+
 
 lemma valid_W_iff[iff]:
   "valid_W_inv s \<Longrightarrow> sys_ghost_honorary_grey s = {}"
 by (simp add: valid_W_inv_def)
 
 lemma valid_W_inv_no_mark_writes_invD:
   "\<lbrakk> sys_mem_lock s \<noteq> Some p; valid_W_inv s \<rbrakk>
      \<Longrightarrow> tso_pending p is_mw_Mark s = []"
 by (auto intro!: filter_False)
 
 lemma valid_W_inv_sys_read[simp]:
   "\<lbrakk> sys_mem_lock s \<noteq> Some p; valid_W_inv s \<rbrakk>
      \<Longrightarrow> sys_read p (mr_Mark r) (s sys) = mv_Mark (Option.map_option obj_mark (sys_heap s r))"
 apply (clarsimp simp: sys_read_def fold_writes_def)
 apply (rule fold_invariant[where P="\<lambda>fr. Option.map_option obj_mark (heap (fr (s sys)) r) = Option.map_option obj_mark (sys_heap s r)"
                              and Q="\<lambda>w. \<forall>r fl. w \<noteq> mw_Mark r fl"])
   apply (auto simp: Option.map_option_case do_write_action_def filter_empty_conv
              split: mem_write_action.splits option.splits)
 done
 
 (*>*)
 subsection\<open>Mark Object\<close>
 
 text\<open>
 
 Local invariants for @{const "mark_object_fn"}. Invoking this code in
 phases where @{const "sys_fM"} is constant marks the reference in
 @{const "ref"}. When @{const "sys_fM"} could vary this code is not
 called. The two cases are distinguished by @{term "p_ph_enabled"}.
 
 Each use needs to provide extra facts to justify validity of
 references, etc.  We do not include a post-condition for @{const
 "mark_object_fn"} here as it is different at each call site.
 
 \<close>
 
 locale mark_object =
   fixes p :: "'mut process_name"
   fixes l :: "location"
   fixes p_ph_enabled :: "('field, 'mut, 'ref) lsts_pred"
   assumes p_ph_enabled_eq_imp: "eq_imp (\<lambda>(_::unit) s. s p) p_ph_enabled"
 begin
 
 abbreviation (input) "p_cas_mark s \<equiv> cas_mark (s p)"
 abbreviation (input) "p_mark s \<equiv> mark (s p)"
 abbreviation (input) "p_fM s \<equiv> fM (s p)"
 abbreviation (input) "p_ghost_handshake_phase s \<equiv> ghost_handshake_phase (s p)"
 abbreviation (input) "p_ghost_honorary_grey s \<equiv> ghost_honorary_grey (s p)"
 abbreviation (input) "p_ghost_handshake_in_sync s \<equiv> ghost_handshake_in_sync (s p)"
 abbreviation (input) "p_phase s \<equiv> phase (s p)"
 abbreviation (input) "p_ref s \<equiv> ref (s p)"
 abbreviation (input) "p_the_ref \<equiv> the \<circ> p_ref"
 abbreviation (input) "p_W s \<equiv> W (s p)"
 
 abbreviation at_p :: "location \<Rightarrow> ('field, 'mut, 'ref) lsts_pred \<Rightarrow> ('field, 'mut, 'ref) gc_pred" where
   "at_p l' P \<equiv> at p (l @ l') \<^bold>\<longrightarrow> LSTP P"
 
 abbreviation (input) "p_en_cond P \<equiv> p_ph_enabled \<^bold>\<longrightarrow> P"
 
 abbreviation (input) "p_valid_ref \<equiv> \<^bold>\<not>(NULL p_ref) \<^bold>\<and> valid_ref \<^bold>$ p_the_ref"
 abbreviation (input) "p_tso_no_pending_mark \<equiv> LIST_NULL (tso_pending_mark p)"
 abbreviation (input) "p_tso_no_pending_mutate \<equiv> LIST_NULL (tso_pending_mutate p)"
 
 abbreviation (input)
   "p_valid_W_inv \<equiv> ((p_cas_mark \<^bold>\<noteq> p_mark \<^bold>\<or> p_tso_no_pending_mark) \<^bold>\<longrightarrow> marked \<^bold>$ p_the_ref)
                 \<^bold>\<and> (tso_pending_mark p \<^bold>\<in> (\<lambda>s. {[], [mw_Mark (p_the_ref s) (p_fM s)]}) )"
 
 abbreviation (input)
   "p_mark_inv \<equiv> \<^bold>\<not>(NULL p_mark)
             \<^bold>\<and> ((\<lambda>s. obj_at (\<lambda>obj. Some (obj_mark obj) = p_mark s) (p_the_ref s) s)
               \<^bold>\<or> marked \<^bold>$ p_the_ref)"
 
 abbreviation (input)
   "p_cas_mark_inv \<equiv> (\<lambda>s. obj_at (\<lambda>obj. Some (obj_mark obj) = p_cas_mark s) (p_the_ref s) s)"
 
 abbreviation (input) "p_valid_fM \<equiv> p_fM \<^bold>= sys_fM"
 
 abbreviation (input)
   "p_ghg_eq_ref \<equiv> p_ghost_honorary_grey \<^bold>= pred_singleton (the \<circ> p_ref)"
 abbreviation (input)
   "p_ghg_inv \<equiv> If p_cas_mark \<^bold>= p_mark Then p_ghg_eq_ref Else EMPTY p_ghost_honorary_grey"
 
 definition mark_object_invL :: "('field, 'mut, 'ref) gc_pred" where
   "mark_object_invL =
    (at_p ''_mo_null''        \<langle>True\<rangle>
   \<^bold>\<and> at_p ''_mo_mark''        (p_valid_ref)
   \<^bold>\<and> at_p ''_mo_fM''          (p_valid_ref \<^bold>\<and> p_en_cond (p_mark_inv))
   \<^bold>\<and> at_p ''_mo_mtest''       (p_valid_ref \<^bold>\<and> p_en_cond (p_mark_inv \<^bold>\<and> p_valid_fM))
   \<^bold>\<and> at_p ''_mo_phase''       (p_valid_ref \<^bold>\<and> p_mark \<^bold>\<noteq> Some \<circ> p_fM \<^bold>\<and> p_en_cond (p_mark_inv \<^bold>\<and> p_valid_fM))
   \<^bold>\<and> at_p ''_mo_ptest''       (p_valid_ref \<^bold>\<and> p_mark \<^bold>\<noteq> Some \<circ> p_fM \<^bold>\<and> p_en_cond (p_mark_inv \<^bold>\<and> p_valid_fM))
   \<^bold>\<and> at_p ''_mo_co_lock''     (p_valid_ref \<^bold>\<and> p_mark_inv \<^bold>\<and> p_valid_fM \<^bold>\<and> p_mark \<^bold>\<noteq> Some \<circ> p_fM \<^bold>\<and> p_tso_no_pending_mark)
   \<^bold>\<and> at_p ''_mo_co_cmark''    (p_valid_ref \<^bold>\<and> p_mark_inv \<^bold>\<and> p_valid_fM \<^bold>\<and> p_mark \<^bold>\<noteq> Some \<circ> p_fM \<^bold>\<and> p_tso_no_pending_mark)
   \<^bold>\<and> at_p ''_mo_co_ctest''    (p_valid_ref \<^bold>\<and> p_mark_inv \<^bold>\<and> p_valid_fM \<^bold>\<and> p_mark \<^bold>\<noteq> Some \<circ> p_fM \<^bold>\<and> p_cas_mark_inv \<^bold>\<and> p_tso_no_pending_mark)
   \<^bold>\<and> at_p ''_mo_co_mark''     (p_cas_mark \<^bold>= p_mark \<^bold>\<and> p_valid_ref \<^bold>\<and> p_valid_fM \<^bold>\<and> white \<^bold>$ p_the_ref \<^bold>\<and> p_tso_no_pending_mark)
   \<^bold>\<and> at_p ''_mo_co_unlock''   (p_ghg_inv \<^bold>\<and> p_valid_ref \<^bold>\<and> p_valid_fM \<^bold>\<and> p_valid_W_inv)
   \<^bold>\<and> at_p ''_mo_co_won''      (p_ghg_inv \<^bold>\<and> p_valid_ref \<^bold>\<and> p_valid_fM \<^bold>\<and> marked \<^bold>$ p_the_ref \<^bold>\<and> p_tso_no_pending_mutate)
   \<^bold>\<and> at_p ''_mo_co_W''        (p_ghg_eq_ref \<^bold>\<and> p_valid_ref \<^bold>\<and> p_valid_fM \<^bold>\<and> marked \<^bold>$ p_the_ref \<^bold>\<and> p_tso_no_pending_mutate))"
 (*<*)
 
 lemma mark_object_invL_eq_imp:
   "eq_imp (\<lambda>(_::unit) s. (AT s p, s\<down> p, sys_heap s\<down>, sys_fM s\<down>, sys_mem_write_buffers p s\<down>))
           mark_object_invL"
 apply (clarsimp simp: eq_imp_def)
 apply (rename_tac s s')
 apply (cut_tac s="s\<down>" and s'="s'\<down>" in eq_impD[OF p_ph_enabled_eq_imp], simp)
 apply (clarsimp simp: mark_object_invL_def obj_at_def
                 cong: option.case_cong)
 done
 
 lemmas mark_object_invL_niE[nie] =
   iffD1[OF mark_object_invL_eq_imp[simplified eq_imp_simps, rule_format, unfolded conj_explode], rotated -1]
 (*>*)
 
 end
 
 text\<open>
 
 The uses of @{const "mark_object_fn"} in the GC and during the root
 marking are straightforward.
 
 \<close>
 (* FIXME we'd like:
 
 sublocale mut < get_roots: mark_object "mutator mut" "''hs_get_roots_loop''" .
 
 but this doesn't seem to get promoted to the top-level, so we can't
 use it in the other process locales.
 
 This interpretation promotes the [inv] attribute to the top-level.
 
 *)
 interpretation gc_mark: mark_object "gc" "''mark_loop''" "\<langle>True\<rangle>"
   by standard (simp add: eq_imp_def)
 
 lemmas gc_mark_mark_object_invL_def2[inv] = gc_mark.mark_object_invL_def[simplified]
 
 interpretation mut_get_roots: mark_object "mutator m" "''hs_get_roots_loop''" "\<langle>True\<rangle>" for m
   by standard (simp add: eq_imp_def)
 
 lemmas mut_get_roots_mark_object_invL_def2[inv] = mut_get_roots.mark_object_invL_def[simplified]
 
 text\<open>
 
 The most interesting cases are the two asynchronous uses of @{const
 "mark_object_fn"} in the mutators: we need something that holds even
 before we read the phase. In particular we need to avoid interference
 by an @{const "fM"} flip.
 
 \<close>
 
 interpretation mut_store_del: mark_object "mutator m" "''store_del''" "mut_m.mut_ghost_handshake_phase m \<^bold>\<noteq> \<langle>hp_Idle\<rangle>" for m
   by standard (simp add: eq_imp_def)
 
 lemmas mut_store_del_mark_object_invL_def2[inv] = mut_store_del.mark_object_invL_def[simplified]
 
 interpretation mut_store_ins: mark_object "mutator m" "''store_ins''"  "mut_m.mut_ghost_handshake_phase m \<^bold>\<noteq> \<langle>hp_Idle\<rangle>" for m
   by standard (simp add: eq_imp_def)
 
 lemmas mut_store_ins_mark_object_invL_def2[inv] = mut_store_ins.mark_object_invL_def[simplified]
 
 text\<open>
 
 Local invariant for the mutator's uses of @{term "mark_object"}.
 
 \<close>
 
 locset_definition "mut_hs_get_roots_loop_locs = prefixed ''hs_get_roots_loop''"
 locset_definition "mut_hs_get_roots_loop_mo_locs =
   prefixed ''hs_get_roots_loop_mo'' \<union> {''hs_get_roots_loop_done''}"
 
 abbreviation "mut_async_mark_object_prefixes \<equiv> { ''store_del'', ''store_ins'' }"
 
 locset_definition "mut_hs_not_hp_Idle_locs =
   (\<Union>pref\<in>mut_async_mark_object_prefixes.
      \<Union>l\<in>{''mo_co_lock'', ''mo_co_cmark'', ''mo_co_ctest'', ''mo_co_mark'', ''mo_co_unlock'', ''mo_co_won'', ''mo_co_W''}. {pref @ ''_'' @ l})"
 
 locset_definition "mut_async_mo_ptest_locs =
   (\<Union>pref\<in>mut_async_mark_object_prefixes. {pref @ ''_mo_ptest''})"
 
 locset_definition "mut_mo_ptest_locs =
   (\<Union>pref\<in>mut_async_mark_object_prefixes. {pref @ ''_mo_ptest''})"
 
 locset_definition "mut_mo_valid_ref_locs =
   (prefixed ''store_del'' \<union> prefixed ''store_ins'' \<union> { ''deref_del'', ''lop_store_ins''})"
 (*<*)
 
 lemma mut_hs_get_roots_loop_locs_subseteq_hs_get_roots:
   "mut_hs_get_roots_loop_locs \<subseteq> prefixed ''hs_get_roots_''"
 by (auto simp: mut_hs_get_roots_loop_locs_def intro: append_prefixD)
 
 lemma mut_m_ghost_handshake_phase_not_hp_Idle:
   "\<lbrakk> atS (mutator m) mut_hs_get_roots_loop_locs s; mut_m.handshake_invL m s; handshake_phase_inv s\<down> \<rbrakk>
      \<Longrightarrow> ghost_handshake_phase (s\<down> (mutator m)) \<noteq> hp_Idle"
 unfolding mut_m.handshake_invL_def
 apply (elim conjE)
 apply (drule mut_m.handshake_phase_invD[where m=m])
 apply (drule mp, erule atS_mono[OF _ mut_hs_get_roots_loop_locs_subseteq_hs_get_roots])
 apply (clarsimp simp: hp_step_rel_def)
 done
 
 (*>*)
 text\<open>
 
 This local invariant for the mutators illustrates the handshake
 structure: we can rely on the insertion barrier earlier than on the
 deletion barrier. Both need to be installed before \<open>get_roots\<close>
 to ensure we preserve the strong tricolour invariant. All black
 objects at that point are allocated: we need to know that the
 insertion barrier is installed to preserve it. This limits when \<open>fA\<close> can be set.
 
 It is interesting to contrast the two barriers. Intuitively a mutator
 can locally guarantee that it, in the relevant phases, will insert
 only marked references. Less often can it be sure that the reference
 it is overwriting is marked. We also need to consider writes pending
 in TSO buffers: it is key that after the \<open>''init_noop''\<close>
 handshake there are no pending white insertions
 (mutations that insert unmarked references). This ensures the deletion barrier
 does its job.
 
 \<close>
 
 locset_definition
   "ghost_honorary_grey_empty_locs \<equiv>
      - (\<Union>pref\<in>{ ''mark_loop'', ''hs_get_roots_loop'', ''store_del'', ''store_ins'' }.
         \<Union>l\<in>{ ''mo_co_unlock'', ''mo_co_won'', ''mo_co_W'' }. {pref @ ''_'' @ l})"
 
 locset_definition
   "ghost_honorary_root_empty_locs \<equiv>
      - (prefixed ''store_del'' \<union> {''lop_store_ins''} \<union> prefixed ''store_ins'')"
 
 inv_definition (in mut_m) mark_object_invL :: "('field, 'mut, 'ref) gc_pred" where
   "mark_object_invL =
    (atS_mut mut_hs_get_roots_loop_locs    (mut_refs \<^bold>\<subseteq> mut_roots \<^bold>\<and> (\<^bold>\<forall>r. \<langle>r\<rangle> \<^bold>\<in> mut_roots \<^bold>- mut_refs \<^bold>\<longrightarrow> marked r))
   \<^bold>\<and> atS_mut mut_hs_get_roots_loop_mo_locs (\<^bold>\<not>(NULL mut_ref) \<^bold>\<and> mut_the_ref \<^bold>\<in> mut_roots)
   \<^bold>\<and> at_mut ''hs_get_roots_loop_done''     (marked \<^bold>$ mut_the_ref)
   \<^bold>\<and> at_mut ''hs_get_roots_loop_mo_ptest'' (mut_phase \<^bold>\<noteq> \<langle>ph_Idle\<rangle>)
   \<^bold>\<and> at_mut ''hs_get_roots_done''          (\<^bold>\<forall>r. \<langle>r\<rangle> \<^bold>\<in> mut_roots \<^bold>\<longrightarrow> marked r)
 
   \<^bold>\<and> atS_mut mut_mo_valid_ref_locs         ( (\<^bold>\<not>(NULL mut_new_ref) \<^bold>\<longrightarrow> mut_the_new_ref \<^bold>\<in> mut_roots)
                                           \<^bold>\<and> (mut_tmp_ref \<^bold>\<in> mut_roots) )
   \<^bold>\<and> at_mut ''store_del_mo_null''          (\<^bold>\<not>(NULL mut_ref) \<^bold>\<longrightarrow> mut_the_ref \<^bold>\<in> mut_ghost_honorary_root)
   \<^bold>\<and> atS_mut (prefixed ''store_del'' - {''store_del_mo_null''}) (mut_the_ref \<^bold>\<in> mut_ghost_honorary_root)
   \<^bold>\<and> atS_mut (prefixed ''store_ins'')      (mut_ref \<^bold>= mut_new_ref)
 
   \<^bold>\<and> atS_mut (suffixed ''_mo_ptest'')      (mut_phase \<^bold>\<noteq> \<langle>ph_Idle\<rangle> \<^bold>\<longrightarrow> mut_ghost_handshake_phase \<^bold>\<noteq> \<langle>hp_Idle\<rangle>)
   \<^bold>\<and> atS_mut mut_hs_not_hp_Idle_locs       (mut_ghost_handshake_phase \<^bold>\<noteq> \<langle>hp_Idle\<rangle>)
 
   \<^bold>\<and> atS_mut mut_mo_ptest_locs             (mut_phase \<^bold>= \<langle>ph_Idle\<rangle> \<^bold>\<longrightarrow> (mut_ghost_handshake_phase \<^bold>\<in> \<langle>{hp_Idle, hp_IdleInit}\<rangle>
                                                                           \<^bold>\<or> (mut_ghost_handshake_phase \<^bold>= \<langle>hp_IdleMarkSweep\<rangle>
                                                                                 \<^bold>\<and> sys_phase \<^bold>= \<langle>ph_Idle\<rangle>)))
   \<^bold>\<and> atS_mut ghost_honorary_grey_empty_locs (EMPTY mut_ghost_honorary_grey)
 \<comment> \<open>insertion barrier\<close>
   \<^bold>\<and> at_mut ''store_ins''                  ( (mut_ghost_handshake_phase \<^bold>\<in> \<langle>{hp_InitMark, hp_Mark}\<rangle>
                                             \<^bold>\<or> (mut_ghost_handshake_phase \<^bold>= \<langle>hp_IdleMarkSweep\<rangle> \<^bold>\<and> sys_phase \<^bold>\<noteq> \<langle>ph_Idle\<rangle>))
                                            \<^bold>\<and> \<^bold>\<not>(NULL mut_new_ref)
                                            \<^bold>\<longrightarrow> marked \<^bold>$ mut_the_new_ref )
 \<comment> \<open>deletion barrier\<close>
   \<^bold>\<and> atS_mut (prefixed ''store_del_mo'' \<union> {''lop_store_ins''})
                                           ( (mut_ghost_handshake_phase \<^bold>= \<langle>hp_Mark\<rangle>
                                             \<^bold>\<or> (mut_ghost_handshake_phase \<^bold>= \<langle>hp_IdleMarkSweep\<rangle> \<^bold>\<and> sys_phase \<^bold>\<noteq> \<langle>ph_Idle\<rangle>))
                                            \<^bold>\<and> (\<lambda>s. \<forall>opt_r'. \<not>tso_pending_write (mutator m) (mw_Mutate (mut_tmp_ref s) (mut_field s) opt_r') s)
                                           \<^bold>\<longrightarrow> (\<lambda>s. obj_at_field_on_heap (\<lambda>r. mut_ref s = Some r \<or> marked r s) (mut_tmp_ref s) (mut_field s) s))
   \<^bold>\<and> at_mut ''lop_store_ins''              ( (mut_ghost_handshake_phase \<^bold>= \<langle>hp_Mark\<rangle>
                                              \<^bold>\<or> (mut_ghost_handshake_phase \<^bold>= \<langle>hp_IdleMarkSweep\<rangle> \<^bold>\<and> sys_phase \<^bold>\<noteq> \<langle>ph_Idle\<rangle>))
                                            \<^bold>\<and> \<^bold>\<not>(NULL mut_ref)
                                           \<^bold>\<longrightarrow> marked \<^bold>$ mut_the_ref )
   \<^bold>\<and> atS_mut (prefixed ''store_ins'')
                                             ( (mut_ghost_handshake_phase \<^bold>= \<langle>hp_Mark\<rangle>
                                              \<^bold>\<or> (mut_ghost_handshake_phase \<^bold>= \<langle>hp_IdleMarkSweep\<rangle> \<^bold>\<and> sys_phase \<^bold>\<noteq> \<langle>ph_Idle\<rangle>))
                                           \<^bold>\<and> (\<lambda>s. \<forall>opt_r'. \<not>tso_pending_write (mutator m) (mw_Mutate (mut_tmp_ref s) (mut_field s) opt_r') s)
                                           \<^bold>\<longrightarrow> (\<lambda>s. obj_at_field_on_heap (\<lambda>r'. marked r' s) (mut_tmp_ref s) (mut_field s) s) )
 \<comment>\<open>after \<open>''init_noop''\<close>\<close>
   \<^bold>\<and> at_mut ''load''         (mut_tmp_ref \<^bold>\<in> mut_roots)
   \<^bold>\<and> at_mut ''hs_noop_done'' (LIST_NULL (tso_pending_mutate (mutator m))) \<comment>\<open> key: no pending white insertions \<close>
   \<^bold>\<and> atS_mut ghost_honorary_root_empty_locs (EMPTY mut_ghost_honorary_root) )"
 (*<*)
 
 lemma get_roots_get_work_subseteq_ghost_honorary_grey_empty_locs:
   "hs_get_roots_locs \<union> hs_get_work_locs \<subseteq> ghost_honorary_grey_empty_locs"
 unfolding ghost_honorary_grey_empty_locs_def hs_get_roots_locs_def hs_get_work_locs_def
 apply (clarsimp simp: subset_eq)
 apply (intro conjI conjI; force)
 done
 
 lemma (in mut_m) mark_object_invL_eq_imp:
   "eq_imp (\<lambda>r s. (AT s (mutator m), s\<down> (mutator m), sys_heap s\<down> r, sys_fM s\<down>, sys_phase s\<down>, tso_pending_mutate (mutator m) s\<down>))
           mark_object_invL"
 apply (clarsimp simp: eq_imp_def mark_object_invL_def fun_eq_iff[symmetric] obj_at_field_on_heap_def
                 cong: option.case_cong)
 apply (rename_tac s s')
 apply (subgoal_tac "\<forall>r. marked r s\<down> \<longleftrightarrow> marked r s'\<down>")
  apply (subgoal_tac "\<forall>r. valid_null_ref r s\<down> \<longleftrightarrow> valid_null_ref r s'\<down>")
   apply (subgoal_tac "\<forall>r f opt_r'. mw_Mutate r f opt_r' \<notin> set (sys_mem_write_buffers (mutator m) s\<down>) \<longleftrightarrow> mw_Mutate r f opt_r' \<notin> set (sys_mem_write_buffers (mutator m) s'\<down>)")
    apply (clarsimp cong: option.case_cong)
   apply (drule arg_cong[where f=set])
   apply auto[1]
  apply (clarsimp simp: obj_at_def valid_null_ref_def split: option.splits)
 apply (clarsimp simp: obj_at_def valid_null_ref_def split: option.splits)
 done
 
 lemmas mut_m_mark_object_invL_niE[nie] =
   iffD1[OF mut_m.mark_object_invL_eq_imp[simplified eq_imp_simps, rule_format, unfolded conj_explode], rotated -1]
 
 lemma (in mut_m) mark_object_invL[intro]:
   "\<lbrace> handshake_invL \<^bold>\<and> mark_object_invL
       \<^bold>\<and> mut_get_roots.mark_object_invL m
       \<^bold>\<and> mut_store_del.mark_object_invL m
       \<^bold>\<and> mut_store_ins.mark_object_invL m
       \<^bold>\<and> LSTP (phase_rel_inv \<^bold>\<and> handshake_phase_inv \<^bold>\<and> phase_rel_inv \<^bold>\<and> tso_writes_inv \<^bold>\<and> valid_refs_inv) \<rbrace>
      mutator m
    \<lbrace> mark_object_invL \<rbrace>"
 apply vcg_jackhammer
 
 (* store_ins_mo_ptest *)
 subgoal by (elim disjE; fastforce)
 
 (* store_ins_mo_ptest *)
 subgoal for s s' y
  apply (drule handshake_phase_invD)
  apply (drule phase_rel_invD)
  apply (clarsimp simp: phase_rel_def)
  apply (case_tac "sys_ghost_handshake_phase s\<down>"; simp add: hp_step_rel_def; elim disjE; simp; force)
  done
 
 subgoal by fastforce
 subgoal by fastforce
 subgoal by fastforce
 
 subgoal for s s' y
  apply (drule handshake_phase_invD)
  apply (drule phase_rel_invD)
  apply (clarsimp simp: phase_rel_def)
  apply (case_tac "sys_ghost_handshake_phase s\<down>"; simp add: hp_step_rel_def; elim disjE; simp; force)
  done
 
 subgoal by fastforce
 
 subgoal by (auto dest: obj_at_field_on_heap_no_pending_writes)
 
 (* hs get roots loop done *)
 subgoal by force
 
 (* hs get roots loop mo phase *)
 subgoal
  apply (drule handshake_phase_invD)
  apply (drule phase_rel_invD)
  apply (clarsimp simp: phase_rel_def hp_step_rel_def)
  done
 
 (* hs get roots loop choose ref *)
 subgoal by blast
 
 done
 
 lemma (in mut_m') mut_mark_object_invL[intro]:
   "\<lbrace> mark_object_invL \<rbrace> mutator m'"
 apply vcg_nihe
 apply vcg_ni
  apply (clarsimp simp: obj_at_field_on_heap_def split: option.splits)
  apply (clarsimp simp: obj_at_field_on_heap_def split: option.splits)
 done
 
 lemma (in mut_m) mut_store_ins_mark_object_invL[intro]:
   "\<lbrace> mut_store_ins.mark_object_invL m \<^bold>\<and> mark_object_invL \<^bold>\<and> handshake_invL \<^bold>\<and> tso_lock_invL
        \<^bold>\<and> LSTP (handshake_phase_inv \<^bold>\<and> valid_W_inv \<^bold>\<and> tso_writes_inv \<^bold>\<and> valid_refs_inv) \<rbrace>
      mutator m
    \<lbrace> mut_store_ins.mark_object_invL m \<rbrace>"
 apply vcg_jackhammer
 apply (auto dest: valid_refs_invD valid_W_inv_no_mark_writes_invD
            split: obj_at_splits)
 done
 
 lemma mut_m_not_idle_no_fM_writeD:
   "\<lbrakk> sys_mem_write_buffers p s = mw_fM fl # ws; ghost_handshake_phase (s (mutator m)) \<noteq> hp_Idle; fM_rel_inv s; handshake_phase_inv s; tso_writes_inv s; p \<noteq> sys \<rbrakk>
      \<Longrightarrow> False"
 apply (drule mut_m.handshake_phase_invD[where m=m])
 apply (drule fM_rel_invD)
 apply (fastforce simp: hp_step_rel_def fM_rel_def filter_empty_conv p_not_sys)
 done
 
 lemma (in sys) mut_store_ins_mark_object_invL[intro]:
   notes mut_m.mark_object_invL_def[inv]
   notes mut_m.tso_lock_invL_def[inv]
   notes mut_m_not_idle_no_fM_writeD[where m=m, dest!]
   notes map_option.compositionality[simp] o_def[simp]
   shows
   "\<lbrace> mut_m.tso_lock_invL m \<^bold>\<and> mut_m.mark_object_invL m \<^bold>\<and> mut_store_ins.mark_object_invL m
        \<^bold>\<and> LSTP (fM_rel_inv \<^bold>\<and> handshake_phase_inv \<^bold>\<and> valid_W_inv \<^bold>\<and> tso_writes_inv) \<rbrace>
      sys
    \<lbrace> mut_store_ins.mark_object_invL m \<rbrace>"
 apply (vcg_ni simp: not_blocked_def)
 
 subgoal by (auto simp: do_write_action_def split: mem_write_action.splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def split: mem_write_action.splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def split: mem_write_action.splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def split: mem_write_action.splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def split: mem_write_action.splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def split: mem_write_action.splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def split: mem_write_action.splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def split: mem_write_action.splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def split: mem_write_action.splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def split: mem_write_action.splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def split: mem_write_action.splits obj_at_splits)
 done
 
 lemma (in sys) mut_get_roots_mark_object_invL[intro]:
   notes mut_m.handshake_invL_def[inv]
   notes mut_m.tso_lock_invL_def[inv]
   notes map_option.compositionality[simp] o_def[simp]
   shows
   "\<lbrace> mut_m.tso_lock_invL m \<^bold>\<and> mut_m.handshake_invL m \<^bold>\<and> mut_get_roots.mark_object_invL m
        \<^bold>\<and> LSTP (fM_rel_inv \<^bold>\<and> handshake_phase_inv \<^bold>\<and> valid_W_inv \<^bold>\<and> tso_writes_inv) \<rbrace>
      sys
    \<lbrace> mut_get_roots.mark_object_invL m \<rbrace>"
 apply (vcg_ni simp: not_blocked_def p_not_sys
              dest!: mut_m.handshake_phase_invD[where m=m])
 
 subgoal by (auto simp: do_write_action_def fM_rel_inv_def fM_rel_def hp_step_rel_def filter_empty_conv
                 split: mem_write_action.splits if_splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def fM_rel_inv_def fM_rel_def hp_step_rel_def filter_empty_conv
                 split: mem_write_action.splits if_splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def fM_rel_inv_def fM_rel_def hp_step_rel_def filter_empty_conv
                 split: mem_write_action.splits if_splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def fM_rel_inv_def fM_rel_def hp_step_rel_def filter_empty_conv
                 split: mem_write_action.splits if_splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def fM_rel_inv_def fM_rel_def hp_step_rel_def filter_empty_conv
                 split: mem_write_action.splits if_splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def fM_rel_inv_def fM_rel_def hp_step_rel_def filter_empty_conv
                 split: mem_write_action.splits if_splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def fM_rel_inv_def fM_rel_def hp_step_rel_def filter_empty_conv
                 split: mem_write_action.splits if_splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def fM_rel_inv_def fM_rel_def hp_step_rel_def filter_empty_conv
                 split: mem_write_action.splits if_splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def fM_rel_inv_def fM_rel_def hp_step_rel_def filter_empty_conv
                 split: mem_write_action.splits if_splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def fM_rel_inv_def fM_rel_def hp_step_rel_def filter_empty_conv
                 split: mem_write_action.splits if_splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def fM_rel_inv_def fM_rel_def hp_step_rel_def filter_empty_conv
                 split: mem_write_action.splits if_splits obj_at_splits)
 done
 
 lemma (in sys) mut_store_del_mark_object_invL[intro]:
   notes mut_m.mark_object_invL_def[inv]
   notes mut_m.tso_lock_invL_def[inv]
   notes mut_m_not_idle_no_fM_writeD[where m=m, dest!]
   notes map_option.compositionality[simp] o_def[simp]
   shows
   "\<lbrace> mut_m.tso_lock_invL m \<^bold>\<and> mut_m.mark_object_invL m \<^bold>\<and> mut_store_del.mark_object_invL m
        \<^bold>\<and> LSTP (fM_rel_inv \<^bold>\<and> handshake_phase_inv \<^bold>\<and> valid_W_inv \<^bold>\<and> tso_writes_inv) \<rbrace>
      sys
    \<lbrace> mut_store_del.mark_object_invL m \<rbrace>"
 apply (vcg_ni simp: not_blocked_def)
 
 subgoal by (auto simp: do_write_action_def split: mem_write_action.splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def split: mem_write_action.splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def split: mem_write_action.splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def split: mem_write_action.splits obj_at_splits)
 subgoal by (fastforce simp: do_write_action_def split: mem_write_action.splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def split: mem_write_action.splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def split: mem_write_action.splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def split: mem_write_action.splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def split: mem_write_action.splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def split: mem_write_action.splits obj_at_splits)
 subgoal by (auto simp: do_write_action_def split: mem_write_action.splits obj_at_splits)
 done
 
 lemma (in mut_m) mut_store_del_mark_object_invL[intro]:
   "\<lbrace> mut_store_del.mark_object_invL m \<^bold>\<and> mark_object_invL \<^bold>\<and> handshake_invL \<^bold>\<and> tso_lock_invL
        \<^bold>\<and> LSTP (handshake_phase_inv \<^bold>\<and> valid_W_inv \<^bold>\<and> tso_writes_inv \<^bold>\<and> valid_refs_inv) \<rbrace>
      mutator m
    \<lbrace> mut_store_del.mark_object_invL m \<rbrace>"
 by vcg_jackhammer (auto dest: valid_refs_invD valid_W_inv_no_mark_writes_invD split: obj_at_splits)
 
 lemma (in mut_m) mut_get_roots_mark_object_invL[intro]:
   "\<lbrace> mut_get_roots.mark_object_invL m \<^bold>\<and> mark_object_invL \<^bold>\<and> handshake_invL \<^bold>\<and> tso_lock_invL
        \<^bold>\<and> LSTP (handshake_phase_inv \<^bold>\<and> valid_W_inv \<^bold>\<and> tso_writes_inv \<^bold>\<and> valid_refs_inv) \<rbrace>
      mutator m
    \<lbrace> mut_get_roots.mark_object_invL m \<rbrace>"
 by vcg_jackhammer (auto dest: valid_W_inv_no_mark_writes_invD split: obj_at_splits)
 
 lemma (in mut_m') mut_get_roots_mark_object_invL[intro]:
   "\<lbrace> mut_get_roots.mark_object_invL m \<rbrace> mutator m'"
 by vcg_nihe vcg_ni
 
 lemma (in mut_m') mut_store_ins_mark_object_invL[intro]:
   "\<lbrace> mut_store_ins.mark_object_invL m \<rbrace> mutator m'"
 by vcg_nihe vcg_ni
 
 lemma (in mut_m') mut_store_del_mark_object_invL[intro]:
   "\<lbrace> mut_store_del.mark_object_invL m \<rbrace> mutator m'"
 by vcg_nihe vcg_ni
 
 lemma (in gc) mut_get_roots_mark_object_invL[intro]:
   notes mut_m.handshake_invL_def[inv]
   shows "\<lbrace> handshake_invL \<^bold>\<and> mut_m.handshake_invL m \<^bold>\<and> mut_get_roots.mark_object_invL m \<rbrace> gc \<lbrace> mut_get_roots.mark_object_invL m \<rbrace>"
 by vcg_nihe vcg_ni
 
 (*>*)
 text\<open>
 
 We now show that the GC's use of @{const "mark_object_fn"} is correct.
 
 When we take grey @{const "tmp_ref"} to black, all of the objects it
 points to are marked, ergo the new black does not point to white, and
 so we preserve the strong tricolour invariant.
 
 \<close>
 
 definition (in gc) obj_fields_marked_inv :: "('field, 'mut, 'ref) lsts_pred" where
   "obj_fields_marked_inv =
      (\<^bold>\<forall>f. \<langle>f\<rangle> \<^bold>\<in> (- gc_field_set) \<^bold>\<longrightarrow> (\<lambda>s. obj_at_field_on_heap (\<lambda>r. marked r s) (gc_tmp_ref s) f s))"
 (*<*)
 
 lemma (in gc) obj_fields_marked_inv_eq_imp:
   "eq_imp (\<lambda>_::unit. gc_field_set \<^bold>\<otimes> gc_tmp_ref \<^bold>\<otimes> sys_heap \<^bold>\<otimes> sys_fM \<^bold>\<otimes> tso_pending_mutate gc)
           obj_fields_marked_inv"
 by (clarsimp simp: eq_imp_def obj_fields_marked_inv_def obj_at_field_on_heap_def obj_at_def
              cong: option.case_cong)
 
 lemmas gc_obj_fields_marked_inv_fun_upd[simp] = eq_imp_fun_upd[OF gc.obj_fields_marked_inv_eq_imp, simplified eq_imp_simps, rule_format]
 
 lemma (in gc) obj_fields_marked_inv_UNIV[iff]:
   "obj_fields_marked_inv (s(gc := (s gc)\<lparr> field_set := UNIV \<rparr>))"
 by (simp_all add: obj_fields_marked_inv_def)
 
 lemma (in gc) obj_fields_marked_inv_mark_field_done[iff]:
   "\<lbrakk> obj_at_field_on_heap (\<lambda>r. marked r s) (gc_tmp_ref s) (gc_field s) s; obj_fields_marked_inv s \<rbrakk>
      \<Longrightarrow> obj_fields_marked_inv (s(gc := (s gc)\<lparr>field_set := gc_field_set s - {gc_field s}\<rparr>))"
 by (force simp: obj_fields_marked_inv_def obj_at_field_on_heap_def split: option.splits obj_at_splits)
 (*>*)
 text\<open>\<close>
 
 locset_definition
   "obj_fields_marked_locs \<equiv>
      { ''mark_loop_mark_object_loop'', ''mark_loop_mark_choose_field'', ''mark_loop_mark_deref'', ''mark_loop_mark_field_done'', ''mark_loop_blacken'' }
    \<union> prefixed ''mark_loop_mo''"
 
 inv_definition (in gc) obj_fields_marked_invL :: "('field, 'mut, 'ref) gc_pred" where
   "obj_fields_marked_invL \<equiv>
     (atS_gc obj_fields_marked_locs       (obj_fields_marked_inv \<^bold>\<and> gc_tmp_ref \<^bold>\<in> gc_W)
   \<^bold>\<and> atS_gc (prefixed ''mark_loop_mo'' \<union> { ''mark_loop_mark_field_done'' })
                                           (\<lambda>s. obj_at_field_on_heap (\<lambda>r. gc_ref s = Some r \<or> marked r s) (gc_tmp_ref s) (gc_field s) s)
   \<^bold>\<and> atS_gc (prefixed ''mark_loop_mo'')  (\<^bold>\<forall>y. \<^bold>\<not>(NULL gc_ref) \<^bold>\<and> (\<lambda>s. ((gc_the_ref s) reaches y) s) \<^bold>\<longrightarrow> valid_ref y)
   \<^bold>\<and> at_gc ''mark_loop_fields''          (gc_tmp_ref \<^bold>\<in> gc_W)
   \<^bold>\<and> at_gc ''mark_loop_mark_field_done'' (\<^bold>\<not>(NULL gc_ref) \<^bold>\<longrightarrow> marked \<^bold>$ gc_the_ref)
   \<^bold>\<and> at_gc ''mark_loop_blacken''         (EMPTY gc_field_set)
   \<^bold>\<and> atS_gc ghost_honorary_grey_empty_locs (EMPTY gc_ghost_honorary_grey))"
 (*<*)
 
 lemma (in gc) obj_fields_marked_invL_eq_imp:
   "eq_imp (\<lambda>(_::unit) (s :: ('field, 'mut, 'ref) gc_pred_state). (AT s gc, s\<down> gc, sys_heap s\<down>, sys_fM s\<down>, sys_W s\<down>, tso_pending_mutate gc s\<down>))
           obj_fields_marked_invL"
 by (clarsimp simp: eq_imp_def inv obj_at_def obj_fields_marked_inv_def obj_at_field_on_heap_def
              cong: option.case_cong)
 
 lemmas gc_obj_fields_marked_invL_niE[nie] =
   iffD1[OF gc.obj_fields_marked_invL_eq_imp[simplified eq_imp_simps, rule_format, unfolded conj_explode], rotated -1]
 
 lemma (in gc) gc_mark_mark_object_invL[intro]:
   "\<lbrace> fM_fA_invL \<^bold>\<and> gc_mark.mark_object_invL \<^bold>\<and> obj_fields_marked_invL \<^bold>\<and> tso_lock_invL
         \<^bold>\<and> LSTP valid_W_inv \<rbrace>
      gc
    \<lbrace> gc_mark.mark_object_invL \<rbrace>"
 by vcg_jackhammer (auto dest: valid_W_inv_no_mark_writes_invD split: obj_at_splits)
 
 lemma (in gc) obj_fields_marked_invL[intro]:
   "\<lbrace> fM_fA_invL \<^bold>\<and> phase_invL \<^bold>\<and> obj_fields_marked_invL \<^bold>\<and> gc_mark.mark_object_invL
        \<^bold>\<and> LSTP (tso_writes_inv \<^bold>\<and> valid_W_inv \<^bold>\<and> valid_refs_inv) \<rbrace>
      gc
    \<lbrace> obj_fields_marked_invL \<rbrace>"
 apply vcg_jackhammer
 
 (* mark_loop_mark_field_done *)
 apply (rule obj_fields_marked_inv_mark_field_done, auto)[1]
 
 (* mark_loop_mark_deref *)
 apply (rename_tac s s')
 apply (subgoal_tac "grey (gc_tmp_ref s\<down>) s\<down>") (* FIXME rule *)
  apply (clarsimp simp: obj_at_field_on_heap_def split: option.splits)
  apply (frule valid_refs_invD, fastforce, fastforce)
  apply (rule conjI)
   apply (clarsimp split: obj_at_splits)
  apply clarsimp
  apply (rename_tac x)
  apply (subgoal_tac "(gc_tmp_ref s\<down> reaches x) s\<down>")
   apply (erule valid_refs_invD, fastforce, fastforce)
  apply (fastforce elim: converse_rtranclp_into_rtranclp[rotated]
                   simp: ran_def split: obj_at_splits)
 apply blast
 done
 
 lemma (in mut_m) gc_obj_fields_marked_invL[intro]:
   notes gc.obj_fields_marked_invL_def[inv]
   notes gc.handshake_invL_def[inv]
   shows "\<lbrace> handshake_invL \<^bold>\<and> gc.handshake_invL \<^bold>\<and> gc.obj_fields_marked_invL
              \<^bold>\<and> LSTP (tso_writes_inv \<^bold>\<and> valid_refs_inv) \<rbrace>
            mutator m
          \<lbrace> gc.obj_fields_marked_invL \<rbrace>"
 apply vcg_nihe
 apply vcg_ni
 (* FIXME rules *)
  apply (clarsimp simp: gc.obj_fields_marked_inv_def)
  apply (rename_tac s s' ra x)
  apply (drule_tac x=x in spec)
  apply clarsimp
  apply (erule obj_at_field_on_heapE)
   apply (subgoal_tac "grey (gc_tmp_ref s\<down>) s\<down>")
    apply (drule_tac y="gc_tmp_ref s\<down>" in valid_refs_invD(7), simp+)
    apply (clarsimp split: obj_at_splits)
   apply (erule greyI)
  apply (clarsimp split: obj_at_splits)
 apply (clarsimp simp: obj_at_field_on_heap_def split: option.splits)
 apply vcg_ni+
 done
 
 lemma (in mut_m) gc_mark_mark_object_invL[intro]:
   "\<lbrace> gc_mark.mark_object_invL \<rbrace> mutator m"
 by vcg_nihe vcg_ni
 
 lemma (in sys) gc_mark_mark_object_invL[intro]:
   notes gc.tso_lock_invL_def[inv]
   notes gc.phase_invL_def[inv]
   notes gc.fM_fA_invL_def[inv]
   notes gc.handshake_invL_def[inv]
   notes map_option.compositionality[simp] o_def[simp]
   shows
   "\<lbrace> gc.fM_fA_invL \<^bold>\<and> gc.handshake_invL \<^bold>\<and> gc.phase_invL \<^bold>\<and> gc_mark.mark_object_invL \<^bold>\<and> gc.tso_lock_invL
        \<^bold>\<and> LSTP (handshake_phase_inv \<^bold>\<and> phase_rel_inv \<^bold>\<and> valid_W_inv \<^bold>\<and> tso_writes_inv) \<rbrace>
      sys
    \<lbrace> gc_mark.mark_object_invL \<rbrace>"
 apply vcg_ni
 
 subgoal by (auto dest!: valid_W_invD2
                   simp: do_write_action_def not_blocked_def fM_rel_def filter_empty_conv p_not_sys
                  split: mem_write_action.split if_splits)
 subgoal by (auto dest!: valid_W_invD2
                   simp: do_write_action_def not_blocked_def fM_rel_def filter_empty_conv p_not_sys
                  split: mem_write_action.split if_splits)
 subgoal by (auto dest!: valid_W_invD2
                   simp: do_write_action_def not_blocked_def fM_rel_def filter_empty_conv p_not_sys
                  split: mem_write_action.split if_splits)
 subgoal by (auto dest!: valid_W_invD2
                   simp: do_write_action_def not_blocked_def fM_rel_def filter_empty_conv p_not_sys
                  split: mem_write_action.split if_splits)
 subgoal by (auto dest!: valid_W_invD2
                   simp: do_write_action_def not_blocked_def fM_rel_def filter_empty_conv p_not_sys
                  split: mem_write_action.split if_splits)
 subgoal by (auto dest!: valid_W_invD2
                   simp: do_write_action_def not_blocked_def fM_rel_def filter_empty_conv p_not_sys
                  split: mem_write_action.split if_splits)
 subgoal by (auto dest!: valid_W_invD2
                   simp: do_write_action_def not_blocked_def fM_rel_def filter_empty_conv p_not_sys
                  split: mem_write_action.split if_splits)
 subgoal by (auto dest!: valid_W_invD2
                   simp: do_write_action_def not_blocked_def fM_rel_def filter_empty_conv p_not_sys
                  split: mem_write_action.split if_splits)
 subgoal by (auto dest!: valid_W_invD2
                   simp: do_write_action_def not_blocked_def fM_rel_def filter_empty_conv p_not_sys
                  split: mem_write_action.split if_splits)
 subgoal by (auto dest!: valid_W_invD2
                   simp: do_write_action_def not_blocked_def fM_rel_def filter_empty_conv p_not_sys
                  split: mem_write_action.split if_splits)
 subgoal by (auto dest!: valid_W_invD2
                   simp: do_write_action_def not_blocked_def fM_rel_def filter_empty_conv p_not_sys
                  split: mem_write_action.split if_splits)
 done
 
 (*>*)
 (*<*)
 
 end
 (*>*)
diff --git a/thys/ConcurrentGC/Model.thy b/thys/ConcurrentGC/Model.thy
--- a/thys/ConcurrentGC/Model.thy
+++ b/thys/ConcurrentGC/Model.thy
@@ -1,1006 +1,1008 @@
 (*<*)
 (*
  * Copyright 2015, NICTA
  *
  * This software may be distributed and modified according to the terms of
  * the BSD 2-Clause license. Note that NO WARRANTY is provided.
  * See "LICENSE_BSD2.txt" for details.
  *
  * @TAG(NICTA_BSD)
  *)
 
 theory Model
 imports
   ConcurrentIMP.CIMP
   "HOL-Library.Monad_Syntax"
 begin
 
+declare subst_all [simp del] [[simproc del: defined_all]]
+
 (*>*)
 section\<open>The Schism garbage collector \label{sec:gc-model}\<close>
 
 text \<open>
 
 The following formalises Figures~2.8 (\<open>mark_object_fn\<close>),
 2.9 (load and store but not alloc), and 2.15 (garbage collector) of
 @{cite [cite_macro=citet] "Pizlo201xPhd"}; see also @{cite
 [cite_macro=citet] "Pizlo+2010PLDI"}.
 
 We additionally need to model TSO memory, the handshakes and
 compare-and-swap (\texttt{CAS}).  We closely model things where
 interference is possible and abstract everything else.
 
 \textbf{\emph{NOTE}: this model is for TSO \emph{only}. We elide any details
 irrelevant for that memory model.}
 
 We begin by defining the types of the various parts. Our program
 locations are labelled with strings for readability. We enumerate the
 names of the processes in our system. The safety proof treats an
 arbitary (unbounded) number of mutators.
 
 \<close>
 
 type_synonym location = "char list"
 
 datatype 'mut process_name = mutator 'mut | gc | sys
 
 text \<open>
 
 The garbage collection process can be in one of the following phases.
 
 \<close>
 
 datatype gc_phase
   = ph_Idle
   | ph_Init
   | ph_Mark
   | ph_Sweep
 
 text \<open>
 
 The garbage collector instructs mutators to perform certain actions,
 and blocks until the mutators signal these actions are done. The
 mutators always respond with their work list (a set of
 references). The handshake can be of one of the specified types.
 
 \<close>
 
 datatype handshake_type
   = ht_NOOP
   | ht_GetRoots
   | ht_GetWork
 
 text\<open>
 
 We track how many \texttt{noop} and \texttt{get\_roots} handshakes
 each process has participated in as ghost state. See
 \S\ref{sec:gc_ragged_safepoints}.
 
 \<close>
 
 datatype handshake_phase
   = hp_Idle \<comment>\<open> done 1 noop \<close>
   | hp_IdleInit
   | hp_InitMark
   | hp_Mark \<comment>\<open> done 4 noops \<close>
   | hp_IdleMarkSweep \<comment>\<open> done get roots \<close>
 
 definition handshake_step :: "handshake_phase \<Rightarrow> handshake_phase" where
   "handshake_step ph \<equiv> case ph of
        hp_Idle          \<Rightarrow> hp_IdleInit
      | hp_IdleInit      \<Rightarrow> hp_InitMark
      | hp_InitMark      \<Rightarrow> hp_Mark
      | hp_Mark          \<Rightarrow> hp_IdleMarkSweep
      | hp_IdleMarkSweep \<Rightarrow> hp_Idle"
 
 text \<open>
 
 An object consists of a garbage collection mark and a function that maps
 its fields to values. A value is either a reference or \texttt{NULL}.
 
   @{typ "'field"} is the abstract type of fields.
   @{typ "'ref"} is the abstract type of object references.
   @{typ "'mut"} is the abstract type of the mutators' names.
 
 For simplicity we assume all objects define all fields and ignore all
 non-reference payload in objects.
 
 \<close>
 
 type_synonym gc_mark = bool
 
 record ('field, 'ref) object =
   obj_mark :: "gc_mark"
   obj_fields :: "'field \<Rightarrow> 'ref option"
 
 text\<open>
 
 The TSO store buffers track write actions, represented by \<open>('field, 'ref) mem_write_action\<close>.
 
 \<close>
 
 datatype ('field, 'ref) mem_write_action
   = mw_Mark 'ref gc_mark
   | mw_Mutate 'ref 'field "'ref option"
   | mw_fA gc_mark
   | mw_fM gc_mark
   | mw_Phase gc_phase
 
 text\<open>
 
 The following record is the type of all processes's local states. For
 the mutators and the garbage collector, consider these to be local
 variables or registers.
 
 The system's \<open>fA\<close>, \<open>fM\<close>, \<open>phase\<close> and \<open>heap\<close> variables are subject to the TSO memory model, as are all heap
 operations.
 
 \<close>
 
 record ('field, 'mut, 'ref) local_state =
   \<comment> \<open>System-specific fields\<close>
   heap :: "'ref \<Rightarrow> ('field, 'ref) object option"
   \<comment> \<open>TSO memory state\<close>
   mem_write_buffers :: "'mut process_name \<Rightarrow> ('field, 'ref) mem_write_action list"
   mem_lock :: "'mut process_name option"
   \<comment> \<open>The state of the handshakes\<close>
   handshake_type :: "handshake_type"
   handshake_pending :: "'mut \<Rightarrow> bool"
   \<comment> \<open>Ghost state\<close>
   ghost_handshake_in_sync :: "'mut \<Rightarrow> bool"
   ghost_handshake_phase :: "handshake_phase"
 
   \<comment> \<open>Mutator-specific temporaries\<close>
   new_ref :: "'ref option"
   roots :: "'ref set"
   ghost_honorary_root :: "'ref set"
 
   \<comment> \<open>Garbage collector-specific temporaries\<close>
   field_set :: "'field set"
   mut :: "'mut"
   muts :: "'mut set"
 
   \<comment> \<open>Local variables used by multiple processes\<close>
   fA :: "gc_mark"
   fM :: "gc_mark"
   cas_mark :: "gc_mark option"
   field :: "'field"
   mark :: "gc_mark option"
   phase :: "gc_phase"
   tmp_ref :: "'ref"
   ref :: "'ref option"
   refs :: "'ref set"
   W :: "'ref set"
   \<comment> \<open>Ghost state\<close>
   ghost_honorary_grey :: "'ref set"
 
 text\<open>
 
 An action is a request by a mutator or the garbage collector to the
 system.
 
 \<close>
 
 datatype ('field, 'ref) mem_read_action
   = mr_Ref 'ref 'field
   | mr_Mark 'ref
   | mr_Phase
   | mr_fM
   | mr_fA
 
 datatype ('field, 'mut, 'ref) request_op
   = ro_MFENCE
   | ro_Read "('field, 'ref) mem_read_action"
   | ro_Write "('field, 'ref) mem_write_action"
   | ro_Lock
   | ro_Unlock
   | ro_Alloc
   | ro_Free 'ref
   | ro_hs_gc_set_type handshake_type
   | ro_hs_gc_set_pending 'mut
   | ro_hs_gc_read_pending 'mut
   | ro_hs_gc_load_W
   | ro_hs_mut_read_type handshake_type
   | ro_hs_mut_done "'ref set"
 
 abbreviation "ReadfM \<equiv> ro_Read mr_fM"
 abbreviation "ReadMark r \<equiv> ro_Read (mr_Mark r)"
 abbreviation "ReadPhase \<equiv> ro_Read mr_Phase"
 abbreviation "ReadRef r f \<equiv> ro_Read (mr_Ref r f)"
 
 abbreviation "WritefA m \<equiv> ro_Write (mw_fA m)"
 abbreviation "WritefM m \<equiv> ro_Write (mw_fM m)"
 abbreviation "WriteMark r m \<equiv> ro_Write (mw_Mark r m)"
 abbreviation "WritePhase ph \<equiv> ro_Write (mw_Phase ph)"
 abbreviation "WriteRef r f r' \<equiv> ro_Write (mw_Mutate r f r')"
 
 type_synonym ('field, 'mut, 'ref) request
   = "'mut process_name \<times> ('field, 'mut, 'ref) request_op"
 
 datatype ('field, 'ref) response
   = mv_Bool "bool"
   | mv_Mark "gc_mark option"
   | mv_Phase "gc_phase"
   | mv_Ref "'ref option"
   | mv_Refs "'ref set"
   | mv_Void
 
 text\<open>We instantiate CIMP's types as follows:\<close>
 
 type_synonym ('field, 'mut, 'ref) gc_com
   = "(('field, 'ref) response, location, ('field, 'mut, 'ref) request, ('field, 'mut, 'ref) local_state) com"
 type_synonym ('field, 'mut, 'ref) gc_loc_comp
   = "(('field, 'ref) response, location, ('field, 'mut, 'ref) request, ('field, 'mut, 'ref) local_state) loc_comp"
 type_synonym ('field, 'mut, 'ref) gc_pred_state
   = "(('field, 'ref) response, location, 'mut process_name, ('field, 'mut, 'ref) request, ('field, 'mut, 'ref) local_state) pred_state"
 type_synonym ('field, 'mut, 'ref) gc_pred
   = "(('field, 'ref) response, location, 'mut process_name, ('field, 'mut, 'ref) request, ('field, 'mut, 'ref) local_state) pred"
 type_synonym ('field, 'mut, 'ref) gc_system
   = "(('field, 'ref) response, location, 'mut process_name, ('field, 'mut, 'ref) request, ('field, 'mut, 'ref) local_state) system"
 
 type_synonym ('field, 'mut, 'ref) gc_event
   = "('field, 'mut, 'ref) request \<times> ('field, 'ref) response"
 type_synonym ('field, 'mut, 'ref) gc_history
   = "('field, 'mut, 'ref) gc_event list"
 
 type_synonym ('field, 'mut, 'ref) lst_pred
   = "('field, 'mut, 'ref) local_state \<Rightarrow> bool"
 
 type_synonym ('field, 'mut, 'ref) lsts
   = "'mut process_name \<Rightarrow> ('field, 'mut, 'ref) local_state"
 
 type_synonym ('field, 'mut, 'ref) lsts_pred
   = "('field, 'mut, 'ref) lsts \<Rightarrow> bool"
 
 text\<open>
 
 We use one locale per process to define a namespace for definitions
 local to these processes. Mutator definitions are parametrised by the
 mutator's identifier \<open>m\<close>. We never interpret these locales; we
 use their contents typically by prefixing their names the locale
 name. This might be considered an abuse. The attributes depend on
 locale scoping somewhat, which is a mixed blessing.
 
 If we have more than one mutator then we need to show that mutators do
 not mutually interfere. To that end we define an extra locale that
 contains these proofs.
 
 \<close>
 
 locale mut_m = fixes m :: "'mut"
 locale mut_m' = mut_m + fixes m' :: "'mut" assumes mm'[iff]: "m \<noteq> m'"
 locale gc
 locale sys
 
 
 subsection\<open>Object marking \label{sec:gc-marking}\<close>
 
 text\<open>
 
 Both the mutators and the garbage collector mark references, which
 indicates that a reference is live in the current round of
 collection. This operation is defined in @{cite [cite_macro=citet]
 \<open>Figure~2.8\<close> "Pizlo201xPhd"}. These definitions are
 parameterised by the name of the process.
 
 \<close>
 
 context
   fixes p :: "'mut process_name"
 begin
 
 abbreviation lock :: "location \<Rightarrow> ('field, 'mut, 'ref) gc_com" where
   "lock l \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (p, ro_Lock)) (\<lambda>_ s. {s})"
 notation lock ("\<lbrace>_\<rbrace> lock")
 
 abbreviation unlock :: "location \<Rightarrow> ('field, 'mut, 'ref) gc_com" where
   "unlock l \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (p, ro_Unlock)) (\<lambda>_ s. {s})"
 notation unlock ("\<lbrace>_\<rbrace> unlock")
 
 abbreviation
   read_mark :: "location \<Rightarrow> (('field, 'mut, 'ref) local_state \<Rightarrow> 'ref)
               \<Rightarrow> ((gc_mark option \<Rightarrow> gc_mark option)
                  \<Rightarrow> ('field, 'mut, 'ref) local_state
                  \<Rightarrow> ('field, 'mut, 'ref) local_state) \<Rightarrow> ('field, 'mut, 'ref) gc_com"
 where
   "read_mark l r upd \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (p, ReadMark (r s))) (\<lambda>mv s. { upd \<langle>m\<rangle> s |m. mv = mv_Mark m })"
 notation read_mark ("\<lbrace>_\<rbrace> read'_mark")
 
 abbreviation read_fM :: "location \<Rightarrow> ('field, 'mut, 'ref) gc_com" where
   "read_fM l \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (p, ro_Read mr_fM)) (\<lambda>mv s. { s\<lparr>fM := m\<rparr> |m. mv = mv_Mark (Some m) })"
 notation read_fM ("\<lbrace>_\<rbrace> read'_fM")
 
 abbreviation
   read_phase :: "location \<Rightarrow> ('field, 'mut, 'ref) gc_com"
 where
   "read_phase l \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (p, ReadPhase)) (\<lambda>mv s. { s\<lparr>phase := ph\<rparr> |ph. mv = mv_Phase ph })"
 notation read_phase ("\<lbrace>_\<rbrace> read'_phase")
 
 abbreviation write_mark :: "location \<Rightarrow> (('field, 'mut, 'ref) local_state \<Rightarrow> 'ref) \<Rightarrow> (('field, 'mut, 'ref) local_state \<Rightarrow> bool) \<Rightarrow> ('field, 'mut, 'ref) gc_com" where
   "write_mark l r fl \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (p, WriteMark (r s) (fl s))) (\<lambda>_ s. { s\<lparr> ghost_honorary_grey := {r s} \<rparr> })"
 notation write_mark ("\<lbrace>_\<rbrace> write'_mark")
 
 abbreviation add_to_W :: "location \<Rightarrow> (('field, 'mut, 'ref) local_state \<Rightarrow> 'ref) \<Rightarrow> ('field, 'mut, 'ref) gc_com" where
   "add_to_W l r \<equiv> \<lbrace>l\<rbrace> \<lfloor>\<lambda>s. s\<lparr> W := W s \<union> {r s}, ghost_honorary_grey := {} \<rparr>\<rfloor>"
 notation add_to_W ("\<lbrace>_\<rbrace> add'_to'_W")
 
 text\<open>
 
 The reference we're marking is given in @{const "ref"}. If the current
 process wins the \texttt{CAS} race then the reference is marked and
 added to the local work list @{const "W"}.
 
 TSO means we cannot avoid having the mark write pending in a store
 buffer; in other words, we cannot have objects atomically transition
 from white to grey. The following scheme blackens a white object, and
 then reverts it to grey. The @{const "ghost_honorary_grey"} variable
 is used to track objects undergoing this transition.
 
 As CIMP provides no support for function calls, we prefix each
 statement's label with a string from its callsite.
 
 \<close>
 
 definition mark_object_fn :: "location \<Rightarrow> ('field, 'mut, 'ref) gc_com" where
   "mark_object_fn l \<equiv>
      \<lbrace>l @ ''_mo_null''\<rbrace> IF \<^bold>\<not> (NULL ref) THEN
        \<lbrace>l @ ''_mo_mark''\<rbrace> read_mark (the \<circ> ref) mark_update ;;
        \<lbrace>l @ ''_mo_fM''\<rbrace> read_fM ;;
        \<lbrace>l @ ''_mo_mtest''\<rbrace> IF mark \<^bold>\<noteq> Some \<circ> fM THEN
          \<lbrace>l @ ''_mo_phase''\<rbrace> read_phase ;;
          \<lbrace>l @ ''_mo_ptest''\<rbrace> IF phase \<^bold>\<noteq> \<langle>ph_Idle\<rangle> THEN
            \<comment> \<open>CAS: claim object\<close>
            \<lbrace>l @ ''_mo_co_lock''\<rbrace> lock ;;
            \<lbrace>l @ ''_mo_co_cmark''\<rbrace> read_mark (the \<circ> ref) cas_mark_update ;;
            \<lbrace>l @ ''_mo_co_ctest''\<rbrace> IF cas_mark \<^bold>= mark THEN
              \<lbrace>l @ ''_mo_co_mark''\<rbrace> write_mark (the \<circ> ref) fM
            FI ;;
            \<lbrace>l @ ''_mo_co_unlock''\<rbrace> unlock ;;
            \<lbrace>l @ ''_mo_co_won''\<rbrace> IF cas_mark \<^bold>= mark THEN
              \<lbrace>l @ ''_mo_co_W''\<rbrace> add_to_W (the \<circ> ref)
            FI
          FI
        FI
      FI"
 
 end
 
 text\<open>
 
 The worklists (field @{term "W"}) are not subject to TSO. As we later
 show (\S\ref{def:valid_W_inv}), these are disjoint and hence
 operations on these are private to each process, with the sole
 exception of when the GC requests them from the mutators. We describe
 that mechanism next.
 
 \<close>
 
 subsection\<open>Handshakes \label{sec:gc_ragged_safepoints}\<close>
 
 text\<open>
 
 The garbage collector needs to synchronise with the mutators. In
 practice this is implemented with some thread synchronisation
 primitives that include memory fences. The scheme we adopt here has
 the GC busy waiting. It sets a \<open>pending\<close> flag for each mutator
 and then waits for each to respond.
 
 The system side of the interface collects the responses from the
 mutators into a single worklist, which acts as a proxy for the garbage
 collector's local worklist during \<open>get_roots\<close> and \<open>get_work\<close> handshakes. In practise this involves a \texttt{CAS}
 operation. We carefully model the effect these handshakes have on the
 process's TSO buffers.
 
 The system and mutators track handshake phases using ghost state.
 
 \<close>
 
 abbreviation hp_step :: "handshake_type \<Rightarrow> handshake_phase \<Rightarrow> handshake_phase" where
   "hp_step ht \<equiv>
      case ht of
          ht_NOOP \<Rightarrow> handshake_step
        | ht_GetRoots \<Rightarrow> handshake_step
        | ht_GetWork \<Rightarrow> id"
 
 context sys
 begin
 
 definition handshake :: "('field, 'mut, 'ref) gc_com" where
   "handshake \<equiv>
      \<lbrace>''sys_hs_gc_set_type''\<rbrace> Response
         (\<lambda>req s. { (s\<lparr> handshake_type := ht,
                        ghost_handshake_in_sync := \<langle>False\<rangle>,
                        ghost_handshake_phase := hp_step ht (ghost_handshake_phase s) \<rparr>,
                     mv_Void)
                  |ht. req = (gc, ro_hs_gc_set_type ht) })
    \<squnion> \<lbrace>''sys_hs_gc_mut_reqs''\<rbrace> Response
         (\<lambda>req s. { (s\<lparr> handshake_pending := (handshake_pending s)(m := True) \<rparr>, mv_Void)
                  |m. req = (gc, ro_hs_gc_set_pending m) })
    \<squnion> \<lbrace>''sys_hs_gc_done''\<rbrace> Response
         (\<lambda>req s. { (s, mv_Bool (\<not>handshake_pending s m))
                  |m. req = (gc, ro_hs_gc_read_pending m) })
    \<squnion> \<lbrace>''sys_hs_gc_load_W''\<rbrace> Response
         (\<lambda>req s. { (s\<lparr> W := {} \<rparr>, mv_Refs (W s))
                  |_::unit. req = (gc, ro_hs_gc_load_W) })
    \<squnion> \<lbrace>''sys_hs_mut''\<rbrace> Response
         (\<lambda>req s. { (s, mv_Void)
                  |m. req = (mutator m, ro_hs_mut_read_type (handshake_type s))
                      \<and> handshake_pending s m })
    \<squnion> \<lbrace>''sys_hs_mut_done''\<rbrace> Response
         (\<lambda>req s. { (s\<lparr> handshake_pending := (handshake_pending s)(m := False),
                        W := W s \<union> W',
                        ghost_handshake_in_sync := (ghost_handshake_in_sync s)(m := True) \<rparr>,
                     mv_Void)
                  |m W'. req = (mutator m, ro_hs_mut_done W') })"
 
 end
 
 text\<open>
 
 The mutator's side of the interface. Also updates the ghost state
 tracking the handshake state for @{const "ht_NOOP"} and @{const
 "ht_GetRoots"} but not @{const "ht_GetWork"}.
 
 \<close>
 
 context mut_m
 begin
 
 abbreviation mark_object :: "location \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> mark'_object") where
   "\<lbrace>l\<rbrace> mark_object \<equiv> mark_object_fn (mutator m) l"
 
 abbreviation mfence :: "location \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> MFENCE")  where
   "\<lbrace>l\<rbrace> MFENCE \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (mutator m, ro_MFENCE)) (\<lambda>_ s. {s})"
 
 abbreviation hs_read_type :: "location \<Rightarrow> handshake_type \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> hs'_read'_type")  where
   "\<lbrace>l\<rbrace> hs_read_type ht \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (mutator m, ro_hs_mut_read_type ht)) (\<lambda>_ s. {s})"
 
 abbreviation hs_noop_done :: "location \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> hs'_noop'_done")  where
   "\<lbrace>l\<rbrace> hs_noop_done \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (mutator m, ro_hs_mut_done {}))
                                   (\<lambda>_ s. {s\<lparr> ghost_handshake_phase := handshake_step (ghost_handshake_phase s) \<rparr>})"
 
 abbreviation hs_get_roots_done :: "location \<Rightarrow> (('field, 'mut, 'ref) local_state \<Rightarrow> 'ref set) \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> hs'_get'_roots'_done")  where
   "\<lbrace>l\<rbrace> hs_get_roots_done wl \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (mutator m, ro_hs_mut_done (wl s)))
                                           (\<lambda>_ s. {s\<lparr> W := {}, ghost_handshake_phase := handshake_step (ghost_handshake_phase s) \<rparr>})"
 
 abbreviation hs_get_work_done :: "location \<Rightarrow> (('field, 'mut, 'ref) local_state \<Rightarrow> 'ref set) \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> hs'_get'_work'_done")  where
   "\<lbrace>l\<rbrace> hs_get_work_done wl \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (mutator m, ro_hs_mut_done (wl s)))
                                          (\<lambda>_ s. {s\<lparr> W := {} \<rparr>})"
 
 definition handshake :: "('field, 'mut, 'ref) gc_com" where
   "handshake \<equiv>
       \<lbrace>''hs_noop''\<rbrace> hs_read_type ht_NOOP ;;
       \<lbrace>''hs_noop_mfence''\<rbrace> MFENCE ;;
       \<lbrace>''hs_noop_done''\<rbrace> hs_noop_done
    \<squnion>
       \<lbrace>''hs_get_roots''\<rbrace> hs_read_type ht_GetRoots ;;
       \<lbrace>''hs_get_roots_mfence''\<rbrace> MFENCE ;;
       \<lbrace>''hs_get_roots_refs''\<rbrace> \<acute>refs := \<acute>roots ;;
       \<lbrace>''hs_get_roots_loop''\<rbrace> WHILE \<^bold>\<not>(EMPTY refs) DO
          \<lbrace>''hs_get_roots_loop_choose_ref''\<rbrace> \<acute>ref :\<in> Some ` \<acute>refs ;;
          \<lbrace>''hs_get_roots_loop''\<rbrace> mark_object ;;
          \<lbrace>''hs_get_roots_loop_done''\<rbrace> \<acute>refs := (\<acute>refs - {the \<acute>ref})
       OD ;;
       \<lbrace>''hs_get_roots_done''\<rbrace> hs_get_roots_done W
    \<squnion>
       \<lbrace>''hs_get_work''\<rbrace> hs_read_type ht_GetWork ;;
       \<lbrace>''hs_get_work_mfence''\<rbrace> MFENCE ;;
       \<lbrace>''hs_get_work_done''\<rbrace> hs_get_work_done W"
 
 end
 
 text\<open>
 
 The garbage collector's side of the interface.
 
 \<close>
 
 context gc
 begin
 
 abbreviation set_hs_type :: "location \<Rightarrow> handshake_type \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> set'_hs'_type")  where
   "\<lbrace>l\<rbrace> set_hs_type ht \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (gc, ro_hs_gc_set_type ht)) (\<lambda>_ s. {s})"
 
 abbreviation set_hs_pending :: "location \<Rightarrow> (('field, 'mut, 'ref) local_state \<Rightarrow> 'mut) \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> set'_hs'_pending")  where
   "\<lbrace>l\<rbrace> set_hs_pending m \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (gc, ro_hs_gc_set_pending (m s))) (\<lambda>_ s. {s})"
 
 definition
   handshake_init :: "location \<Rightarrow> handshake_type \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> handshake'_init")
 where
   "\<lbrace>l\<rbrace> handshake_init req \<equiv>
      \<lbrace>l @ ''_init_type''\<rbrace> set_hs_type req ;;
      \<lbrace>l @ ''_init_muts''\<rbrace> \<acute>muts := UNIV ;;
      \<lbrace>l @ ''_init_loop''\<rbrace> WHILE \<^bold>\<not> (EMPTY muts) DO
        \<lbrace>l @ ''_init_loop_choose_mut''\<rbrace> \<acute>mut :\<in> \<acute>muts ;;
        \<lbrace>l @ ''_init_loop_set_pending''\<rbrace> set_hs_pending mut ;;
        \<lbrace>l @ ''_init_loop_done''\<rbrace> \<acute>muts := (\<acute>muts - {\<acute>mut})
      OD"
 
 definition
   handshake_done :: "location \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> handshake'_done")
 where
   "\<lbrace>l\<rbrace> handshake_done \<equiv>
      \<lbrace>l @ ''_done_muts''\<rbrace> \<acute>muts := UNIV ;;
      \<lbrace>l @ ''_done_loop''\<rbrace> WHILE \<^bold>\<not>(EMPTY muts) DO
        \<lbrace>l @ ''_done_loop_choose_mut''\<rbrace> \<acute>mut :\<in> \<acute>muts ;;
        \<lbrace>l @ ''_done_loop_rendezvous''\<rbrace> Request
                (\<lambda>s. (gc, ro_hs_gc_read_pending (mut s)))
                (\<lambda>mv s. { s\<lparr> muts := muts s - { mut s |done. mv = mv_Bool done \<and> done } \<rparr>})
      OD"
 
 abbreviation load_W :: "location \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> load'_W") where
   "\<lbrace>l\<rbrace> load_W \<equiv> \<lbrace>l @ ''_load_W''\<rbrace> Request (\<lambda>s. (gc, ro_hs_gc_load_W))
                                           (\<lambda>resp s. {s\<lparr>W := W'\<rparr> |W'. resp = mv_Refs W'})"
 
 abbreviation mfence :: "location \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> MFENCE")  where
   "\<lbrace>l\<rbrace> MFENCE \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (gc, ro_MFENCE)) (\<lambda>_ s. {s})"
 
 definition
   handshake_noop :: "location \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> handshake'_noop")
 where
   "\<lbrace>l\<rbrace> handshake_noop \<equiv>
          \<lbrace>l @ ''_mfence''\<rbrace> MFENCE ;;
          \<lbrace>l\<rbrace> handshake_init ht_NOOP ;;
          \<lbrace>l\<rbrace> handshake_done"
 
 definition
   handshake_get_roots :: "location \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> handshake'_get'_roots")
 where
   "\<lbrace>l\<rbrace> handshake_get_roots \<equiv>
          \<lbrace>l\<rbrace> handshake_init ht_GetRoots ;;
          \<lbrace>l\<rbrace> handshake_done ;;
          \<lbrace>l\<rbrace> load_W"
 
 definition
   handshake_get_work :: "location \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> handshake'_get'_work")
 where
   "\<lbrace>l\<rbrace> handshake_get_work \<equiv>
          \<lbrace>l\<rbrace> handshake_init ht_GetWork ;;
          \<lbrace>l\<rbrace> handshake_done ;;
          \<lbrace>l\<rbrace> load_W"
 
 end
 
 
 subsection\<open>The system process\<close>
 
 text \<open>
 
 The system process models the environment in which the garbage
 collector and mutators execute.  We translate the x86-TSO memory model
 due to @{cite [cite_macro=citet] "DBLP:journals/cacm/SewellSONM10"}
 into a CIMP process. It is a reactive system: it receives requests and
 returns values, but initiates no communication itself. It can,
 however, autonomously commit a write pending in a TSO store buffer.
 
 The memory bus can be locked by atomic compare-and-swap (\texttt{CAS})
 instructions (and others in general). A processor is not blocked
 (i.e., it can read from memory) when it holds the lock, or no-one
 does.
 
 \<close>
 
 definition
   not_blocked :: "('field, 'mut, 'ref) local_state \<Rightarrow> 'mut process_name \<Rightarrow> bool"
 where
   "not_blocked s p \<equiv> case mem_lock s of None \<Rightarrow> True | Some p' \<Rightarrow> p = p'"
 
 text\<open>
 
 We compute the view a processor has of memory by applying all its
 pending writes.
 
 \<close>
 
 definition do_write_action :: "('field, 'ref) mem_write_action \<Rightarrow> ('field, 'mut, 'ref) local_state \<Rightarrow> ('field, 'mut, 'ref) local_state" where
   "do_write_action wact \<equiv> \<lambda>s.
      case wact of
        mw_Mark r gc_mark    \<Rightarrow> s\<lparr>heap := (heap s)(r := map_option (\<lambda>obj. obj\<lparr>obj_mark := gc_mark\<rparr>) (heap s r))\<rparr>
      | mw_Mutate r f new_r  \<Rightarrow> s\<lparr>heap := (heap s)(r := map_option (\<lambda>obj. obj\<lparr>obj_fields := (obj_fields obj)(f := new_r) \<rparr>) (heap s r))\<rparr>
      | mw_fM gc_mark        \<Rightarrow> s\<lparr>fM := gc_mark\<rparr>
      | mw_fA gc_mark        \<Rightarrow> s\<lparr>fA := gc_mark\<rparr>
      | mw_Phase gc_phase    \<Rightarrow> s\<lparr>phase := gc_phase\<rparr>"
 
 definition
   fold_writes :: "('field, 'ref) mem_write_action list \<Rightarrow> ('field, 'mut, 'ref) local_state \<Rightarrow> ('field, 'mut, 'ref) local_state"
 where
   "fold_writes ws \<equiv> fold (\<lambda>w. (\<circ>) (do_write_action w)) ws id"
 
 abbreviation
   processors_view_of_memory :: "'mut process_name \<Rightarrow> ('field, 'mut, 'ref) local_state \<Rightarrow> ('field, 'mut, 'ref) local_state"
 where
   "processors_view_of_memory p s \<equiv> fold_writes (mem_write_buffers s p) s"
 
 definition
   do_read_action :: "('field, 'ref) mem_read_action
                    \<Rightarrow> ('field, 'mut, 'ref) local_state
                    \<Rightarrow> ('field, 'ref) response"
 where
   "do_read_action ract \<equiv> \<lambda>s.
      case ract of
        mr_Ref r f \<Rightarrow> mv_Ref (heap s r \<bind> (\<lambda>obj. obj_fields obj f))
      | mr_Mark r  \<Rightarrow> mv_Mark (map_option obj_mark (heap s r))
      | mr_Phase   \<Rightarrow> mv_Phase (phase s)
      | mr_fM      \<Rightarrow> mv_Mark (Some (fM s))
      | mr_fA      \<Rightarrow> mv_Mark (Some (fA s))"
 
 definition
   sys_read :: "'mut process_name
               \<Rightarrow> ('field, 'ref) mem_read_action
               \<Rightarrow> ('field, 'mut, 'ref) local_state
               \<Rightarrow> ('field, 'ref) response"
 where
   "sys_read p ract \<equiv> do_read_action ract \<circ> processors_view_of_memory p"
 
 context sys
 begin
 
 text\<open>
 
 The semantics of TSO memory following @{cite [cite_macro=citet]
 \<open>\S3\<close> "DBLP:journals/cacm/SewellSONM10"}. This differs
 from the earlier @{cite [cite_macro=citet]
 "DBLP:conf/tphol/OwensSS09"} by allowing the TSO lock to be taken by a
 process with a non-empty write buffer. We omit their treatment of
 registers; these are handled by the local states of the other
 processes. The system can autonomously take the oldest write in the
 write buffer for processor \<open>p\<close> and commit it to memory,
 provided \<open>p\<close> either holds the lock or no processor does.
 
 \<close>
 
 definition
   mem_TSO :: "('field, 'mut, 'ref) gc_com"
 where
   "mem_TSO \<equiv>
         \<lbrace>''sys_read''\<rbrace> Response (\<lambda>req s. { (s, sys_read p mr s)
                                          |p mr. req = (p, ro_Read mr) \<and> not_blocked s p })
       \<squnion> \<lbrace>''sys_write''\<rbrace> Response (\<lambda>req s. { (s\<lparr> mem_write_buffers := (mem_write_buffers s)(p := mem_write_buffers s p @ [w]) \<rparr>, mv_Void)
                                           |p w. req = (p, ro_Write w) })
       \<squnion> \<lbrace>''sys_mfence''\<rbrace> Response (\<lambda>req s. { (s, mv_Void)
                                            |p. req = (p, ro_MFENCE) \<and> mem_write_buffers s p = [] })
       \<squnion> \<lbrace>''sys_lock''\<rbrace> Response (\<lambda>req s. { (s\<lparr> mem_lock := Some p \<rparr>, mv_Void)
                                          |p. req = (p, ro_Lock) \<and> mem_lock s = None })
       \<squnion> \<lbrace>''sys_unlock''\<rbrace> Response (\<lambda>req s. { (s\<lparr> mem_lock := None \<rparr>, mv_Void)
                                          |p. req = (p, ro_Unlock) \<and> mem_lock s = Some p \<and> mem_write_buffers s p = [] })
       \<squnion> \<lbrace>''sys_dequeue_write_buffer''\<rbrace> LocalOp (\<lambda>s. { (do_write_action w s)\<lparr> mem_write_buffers := (mem_write_buffers s)(p := ws) \<rparr>
                                                     | p w ws. mem_write_buffers s p = w # ws \<and> not_blocked s p \<and> p \<noteq> sys })"
 
 text\<open>
 
 We track which references are allocated using the domain of @{const
 "heap"}.
 
 \label{sec:sys_alloc}
 
 For now we assume that the system process magically allocates and
 deallocates references. To model this more closely we would need to
 take care of the underlying machine addresses. We should be able to
 separate out those issues from GC correctness: the latter should imply
 that only alloc and free can interfere with each other.
 
 We also arrange for the object to be marked atomically (see
 \S\ref{sec:mut_alloc}) which morally should be done by the mutator. In
 practice allocation pools enable this kind of atomicity (wrt the sweep
 loop in the GC described in \S\ref{sec:gc-model-gc}).
 
 Note that the \texttt{abort} in @{cite [cite_macro=citet]
 \<open>Figure~2.9: Alloc\<close> "Pizlo201xPhd"} means the atomic
 fails and the mutator can revert to activity outside of
 \texttt{Alloc}, avoiding deadlock.
 
 \<close>
 
 definition
   alloc :: "('field, 'mut, 'ref) gc_com"
 where
   "alloc \<equiv> \<lbrace>''sys_alloc''\<rbrace> Response (\<lambda>req s.
       { ( s\<lparr> heap := (heap s)(r := Some \<lparr> obj_mark = fA s, obj_fields = \<langle>None\<rangle> \<rparr>) \<rparr>, mv_Ref (Some r) )
       |r. r \<notin> dom (heap s) \<and> snd req = ro_Alloc })"
 
 text\<open>
 
 References are freed by removing them from @{const "heap"}.
 
 \<close>
 
 definition
   free :: "('field, 'mut, 'ref) gc_com"
 where
   "free \<equiv> \<lbrace>''sys_free''\<rbrace> Response (\<lambda>req s.
       { (s\<lparr>heap := (heap s)(r := None)\<rparr>, mv_Void) |r. snd req = ro_Free r })"
 
 text\<open>
 
 The top-level system process.
 
 \<close>
 
 definition
   com :: "('field, 'mut, 'ref) gc_com"
 where
   "com \<equiv>
     LOOP DO
         mem_TSO
       \<squnion> alloc
       \<squnion> free
       \<squnion> handshake
     OD"
 
 end
 
 
 subsection\<open>Mutators\<close>
 
 text\<open>
 
 The mutators need to cooperate with the garbage collector. In
 particular, when the garbage collector is not idle the mutators use a
 \emph{write barrier} (see \S\ref{sec:gc-marking}).
 
 The local state for each mutator tracks a working set of references,
 which abstracts from how the process's registers and stack are
 traversed to discover roots.
 
 \<close>
 
 context mut_m
 begin
 
 text\<open>
 
 \label{sec:mut_alloc}
 
 Allocation is defined in @{cite [cite_macro=citet]
 \<open>Figure~2.9\<close> "Pizlo201xPhd"}. See \S\ref{sec:sys_alloc}
 for how we abstract it.
 
 \<close>
 
 abbreviation (in -) mut_alloc :: "'mut \<Rightarrow> ('field, 'mut, 'ref) gc_com" where
   "mut_alloc m \<equiv>
     \<lbrace>''alloc''\<rbrace> Request (\<lambda>s. (mutator m, ro_Alloc))
                         (\<lambda>mv s. { s\<lparr> roots := roots s \<union> {r} \<rparr> |r. mv = mv_Ref (Some r) })"
 
 abbreviation alloc :: "('field, 'mut, 'ref) gc_com" where
   "alloc \<equiv> mut_alloc m"
 
 text\<open>
 
 The mutator can always discard any references it holds.
 
 \<close>
 
 abbreviation discard :: "('field, 'mut, 'ref) gc_com" where
   "discard \<equiv>
     \<lbrace>''discard_refs''\<rbrace> LocalOp (\<lambda>s. { s\<lparr> roots := roots' \<rparr> |roots'. roots' \<subseteq> roots s })"
 
 text\<open>
 
 Load and store are defined in @{cite [cite_macro=citet]
 \<open>Figure~2.9\<close> "Pizlo201xPhd"}.
 
 Dereferencing a reference can increase the set of mutator roots.
 
 \<close>
 
 abbreviation load :: "('field, 'mut, 'ref) gc_com" where
   "load \<equiv>
     \<lbrace>''load_choose''\<rbrace> LocalOp (\<lambda>s. { s\<lparr> tmp_ref := r, field := f \<rparr> |r f. r \<in> roots s }) ;;
     \<lbrace>''load''\<rbrace> Request (\<lambda>s. (mutator m, ReadRef (tmp_ref s) (field s)))
                        (\<lambda>mv s. { s\<lparr> roots := roots s \<union> set_option r \<rparr>
                                |r. mv = mv_Ref r })"
 
 text\<open>
 
 \label{sec:write-barriers}
 
 Storing a reference involves marking both the old and new references,
 i.e., both \emph{insertion} and \emph{deletion} barriers are
 installed. The deletion barrier preserves the \emph{weak tricolour
 invariant}, and the insertion barrier preserves the \emph{strong
 tricolour invariant}; see \S\ref{sec:strong-tricolour-invariant} for
 further discussion.
 
 Note that the the mutator reads the overwritten reference but does not
 store it in its roots.
 
 \<close>
 
 abbreviation
   mut_deref :: "location
           \<Rightarrow> (('field, 'mut, 'ref) local_state \<Rightarrow> 'ref)
           \<Rightarrow> (('field, 'mut, 'ref) local_state \<Rightarrow> 'field)
           \<Rightarrow> (('ref option \<Rightarrow> 'ref option) \<Rightarrow> ('field, 'mut, 'ref) local_state \<Rightarrow> ('field, 'mut, 'ref) local_state) \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> deref")
 where
   "\<lbrace>l\<rbrace> deref r f upd \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (mutator m, ReadRef (r s) (f s)))
                                    (\<lambda>mv s. { upd \<langle>opt_r'\<rangle> (s\<lparr>ghost_honorary_root := set_option opt_r'\<rparr>) |opt_r'. mv = mv_Ref opt_r' })"
 
 (*
 Does not work in local theory mode:
 
 syntax
   "_mut_fassign" :: "location \<Rightarrow> idt \<Rightarrow> 'ref \<Rightarrow> 'field \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> \<acute>_ := \<acute>_ \<rightarrow> _" [0, 0, 70] 71)
 translations
   "\<lbrace>l\<rbrace> \<acute>q := \<acute>r\<rightarrow>f"    => "CONST mut_deref l r \<guillemotleft>f\<guillemotright> (_update_name q)"
 
  \<acute>ref := \<acute>tmp_ref\<rightarrow>\<acute>field ;;
 *)
 
 abbreviation
   write_ref :: "location
               \<Rightarrow> (('field, 'mut, 'ref) local_state \<Rightarrow> 'ref)
               \<Rightarrow> (('field, 'mut, 'ref) local_state \<Rightarrow> 'field)
               \<Rightarrow> (('field, 'mut, 'ref) local_state \<Rightarrow> 'ref option)
               \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> write'_ref")
 where
   "\<lbrace>l\<rbrace> write_ref r f r' \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (mutator m, WriteRef (r s) (f s) (r' s))) (\<lambda>_ s. {s\<lparr>ghost_honorary_root := {}\<rparr>})"
 
 definition
   store :: "('field, 'mut, 'ref) gc_com"
 where
   "store \<equiv>
      \<comment> \<open>Choose vars for: \<open>ref\<rightarrow>field := new_ref\<close>\<close>
      \<lbrace>''store_choose''\<rbrace> LocalOp (\<lambda>s. { s\<lparr> tmp_ref := r, field := f, new_ref := r' \<rparr>
                                      |r f r'. r \<in> roots s \<and> r' \<in> Some ` roots s \<union> {None} }) ;;
      \<comment> \<open>Mark the reference we're about to overwrite. Does not update roots.\<close>
      \<lbrace>''deref_del''\<rbrace> deref tmp_ref field ref_update ;;
      \<lbrace>''store_del''\<rbrace> mark_object ;;
      \<comment> \<open>Mark the reference we're about to insert.\<close>
      \<lbrace>''lop_store_ins''\<rbrace> \<acute>ref := \<acute>new_ref ;;
      \<lbrace>''store_ins''\<rbrace> mark_object ;;
      \<lbrace>''store_ins''\<rbrace> write_ref tmp_ref field new_ref"
 
 text\<open>
 
 A mutator makes a non-deterministic choice amongst its possible
 actions. For completeness we allow mutators to issue \texttt{MFENCE}
 instructions. We leave \texttt{CAS} (etc) to future work. Neither has
 a significant impact on the rest of the development.
 
 \<close>
 
 definition
   com :: "('field, 'mut, 'ref) gc_com"
 where
   "com \<equiv>
     LOOP DO
         \<lbrace>''mut local computation''\<rbrace> SKIP
       \<squnion> alloc
       \<squnion> discard
       \<squnion> load
       \<squnion> store
       \<squnion> \<lbrace>''mut mfence''\<rbrace> MFENCE
       \<squnion> handshake
     OD"
 
 end
 
 
 subsection \<open>Garbage collector \label{sec:gc-model-gc}\<close>
 
 text\<open>
 
 We abstract the primitive actions of the garbage collector thread.
 
 \<close>
 
 abbreviation
   gc_deref :: "location
              \<Rightarrow> (('field, 'mut, 'ref) local_state \<Rightarrow> 'ref)
              \<Rightarrow> (('field, 'mut, 'ref) local_state \<Rightarrow> 'field)
              \<Rightarrow> (('ref option \<Rightarrow> 'ref option) \<Rightarrow> ('field, 'mut, 'ref) local_state \<Rightarrow> ('field, 'mut, 'ref) local_state) \<Rightarrow> ('field, 'mut, 'ref) gc_com"
 where
   "gc_deref l r f upd \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (gc, ReadRef (r s) (f s)))
                                     (\<lambda>mv s. { upd \<langle>r'\<rangle> s |r'. mv = mv_Ref r' })"
 
 abbreviation
   gc_read_mark :: "location
                 \<Rightarrow> (('field, 'mut, 'ref) local_state \<Rightarrow> 'ref)
                 \<Rightarrow> ((gc_mark option \<Rightarrow> gc_mark option) \<Rightarrow> ('field, 'mut, 'ref) local_state \<Rightarrow> ('field, 'mut, 'ref) local_state)
                 \<Rightarrow> ('field, 'mut, 'ref) gc_com"
 where
   "gc_read_mark l r upd \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (gc, ReadMark (r s))) (\<lambda>mv s. { upd \<langle>m\<rangle> s |m. mv = mv_Mark m })"
 
 syntax
   "_gc_fassign" :: "location \<Rightarrow> idt \<Rightarrow> 'ref \<Rightarrow> 'field \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> \<acute>_ := \<acute>_ \<rightarrow> _" [0, 0, 70] 71)
   "_gc_massign" :: "location \<Rightarrow> idt \<Rightarrow> 'ref \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> \<acute>_ := \<acute>_ \<rightarrow> flag" [0, 0] 71)
 translations
   "\<lbrace>l\<rbrace> \<acute>q := \<acute>r\<rightarrow>f"    => "CONST gc_deref l r \<guillemotleft>f\<guillemotright> (_update_name q)"
   "\<lbrace>l\<rbrace> \<acute>m := \<acute>r\<rightarrow>flag" => "CONST gc_read_mark l r (_update_name m)"
 
 context gc
 begin
 
 abbreviation write_fA :: "location \<Rightarrow> (('field, 'mut, 'ref) local_state \<Rightarrow> gc_mark) \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> write'_fA") where
   "\<lbrace>l\<rbrace> write_fA f \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (gc, WritefA (f s))) (\<lambda>_ s. {s})"
 
 abbreviation read_fM :: "location \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> read'_fM") where
   "\<lbrace>l\<rbrace> read_fM \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (gc, ReadfM)) (\<lambda>mv s. { s\<lparr>fM := m\<rparr> |m. mv = mv_Mark (Some m) })"
 
 abbreviation write_fM :: "location \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> write'_fM") where
   "\<lbrace>l\<rbrace> write_fM \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (gc, WritefM (fM s))) (\<lambda>_ s. {s})"
 
 abbreviation write_phase :: "location \<Rightarrow> gc_phase \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> write'_phase") where
   "\<lbrace>l\<rbrace> write_phase ph \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (gc, WritePhase ph)) (\<lambda>_ s. {s\<lparr> phase := ph \<rparr>})"
 
 abbreviation mark_object :: "location \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> mark'_object") where
   "\<lbrace>l\<rbrace> mark_object \<equiv> mark_object_fn gc l"
 
 abbreviation free :: "location \<Rightarrow> (('field, 'mut, 'ref) local_state \<Rightarrow> 'ref) \<Rightarrow> ('field, 'mut, 'ref) gc_com" ("\<lbrace>_\<rbrace> free") where
   "\<lbrace>l\<rbrace> free r \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (gc, ro_Free (r s))) (\<lambda>_ s. {s})"
 
 text\<open>
 
 The following CIMP program encodes the garbage collector algorithm
 proposed in Figure~2.15 of @{cite [cite_macro=citet] "Pizlo201xPhd"}.
 
 \<close>
 
 definition (in gc)
   com :: "('field, 'mut, 'ref) gc_com"
 where
   "com \<equiv>
      LOOP DO
        \<lbrace>''idle_noop''\<rbrace> handshake_noop ;; \<comment> \<open>\<open>hp_Idle\<close>\<close>
 
        \<lbrace>''idle_read_fM''\<rbrace> read_fM ;;
        \<lbrace>''idle_invert_fM''\<rbrace> \<acute>fM := (\<not> \<acute>fM) ;;
        \<lbrace>''idle_write_fM''\<rbrace> write_fM ;;
 
        \<lbrace>''idle_flip_noop''\<rbrace> handshake_noop ;; \<comment> \<open>\<open>hp_IdleInit\<close>\<close>
 
        \<lbrace>''idle_phase_init''\<rbrace> write_phase ph_Init ;;
 
        \<lbrace>''init_noop''\<rbrace> handshake_noop ;; \<comment> \<open>\<open>hp_InitMark\<close>\<close>
 
        \<lbrace>''init_phase_mark''\<rbrace> write_phase ph_Mark ;;
        \<lbrace>''mark_read_fM''\<rbrace> read_fM ;;
        \<lbrace>''mark_write_fA''\<rbrace> write_fA fM ;;
 
        \<lbrace>''mark_noop''\<rbrace> handshake_noop ;; \<comment> \<open>\<open>hp_Mark\<close>\<close>
 
        \<lbrace>''mark_loop_get_roots''\<rbrace> handshake_get_roots ;; \<comment> \<open>\<open>hp_IdleMarkSweep\<close>\<close>
 
        \<lbrace>''mark_loop''\<rbrace> WHILE \<^bold>\<not>(EMPTY W) DO
          \<lbrace>''mark_loop_inner''\<rbrace> WHILE \<^bold>\<not>(EMPTY W) DO
            \<lbrace>''mark_loop_choose_ref''\<rbrace> \<acute>tmp_ref :\<in> \<acute>W ;;
            \<lbrace>''mark_loop_fields''\<rbrace> \<acute>field_set := UNIV ;;
            \<lbrace>''mark_loop_mark_object_loop''\<rbrace> WHILE \<^bold>\<not>(EMPTY field_set) DO
              \<lbrace>''mark_loop_mark_choose_field''\<rbrace> \<acute>field :\<in> \<acute>field_set ;;
              \<lbrace>''mark_loop_mark_deref''\<rbrace> \<acute>ref := \<acute>tmp_ref\<rightarrow>\<acute>field ;;
              \<lbrace>''mark_loop''\<rbrace> mark_object ;;
              \<lbrace>''mark_loop_mark_field_done''\<rbrace> \<acute>field_set := (\<acute>field_set - {\<acute>field})
            OD ;;
            \<lbrace>''mark_loop_blacken''\<rbrace> \<acute>W := (\<acute>W - {\<acute>tmp_ref})
          OD ;;
          \<lbrace>''mark_loop_get_work''\<rbrace> handshake_get_work
        OD ;;
 
        \<comment> \<open>sweep\<close>
 
        \<lbrace>''mark_end''\<rbrace> write_phase ph_Sweep ;;
        \<lbrace>''sweep_read_fM''\<rbrace> read_fM ;;
        \<lbrace>''sweep_refs''\<rbrace> \<acute>refs := UNIV ;;
        \<lbrace>''sweep_loop''\<rbrace> WHILE \<^bold>\<not>(EMPTY refs) DO
          \<lbrace>''sweep_loop_choose_ref''\<rbrace> \<acute>tmp_ref :\<in> \<acute>refs ;;
          \<lbrace>''sweep_loop_read_mark''\<rbrace> \<acute>mark := \<acute>tmp_ref\<rightarrow>flag ;;
          \<lbrace>''sweep_loop_check''\<rbrace> IF \<^bold>\<not>(NULL mark) \<^bold>\<and> the \<circ> mark \<^bold>\<noteq> fM THEN
            \<lbrace>''sweep_loop_free''\<rbrace> free tmp_ref
          FI ;;
          \<lbrace>''sweep_loop_ref_done''\<rbrace> \<acute>refs := (\<acute>refs - {\<acute>tmp_ref})
        OD ;;
        \<lbrace>''sweep_idle''\<rbrace> write_phase ph_Idle
      OD"
 
 end
 
 primrec
   gc_pgms :: "'mut process_name \<Rightarrow> ('field, 'mut, 'ref) gc_com"
 where
   "gc_pgms (mutator m) = mut_m.com m"
 | "gc_pgms gc = gc.com"
 | "gc_pgms sys = sys.com"
 (*<*)
 
 end
 (*>*)
diff --git a/thys/ConcurrentGC/Proofs.thy b/thys/ConcurrentGC/Proofs.thy
--- a/thys/ConcurrentGC/Proofs.thy
+++ b/thys/ConcurrentGC/Proofs.thy
@@ -1,331 +1,333 @@
 (*<*)
 (*
  * Copyright 2015, NICTA
  *
  * This software may be distributed and modified according to the terms of
  * the BSD 2-Clause license. Note that NO WARRANTY is provided.
  * See "LICENSE_BSD2.txt" for details.
  *
  * @TAG(NICTA_BSD)
  *)
 
 theory Proofs
 imports
   StrongTricolour
 begin
 
+declare subst_all [simp del] [[simproc del: defined_all]]
+
 (*>*)
 section\<open>Top-level safety \label{sec:top-level-correctness}\<close>
 
 subsection\<open>Invariants\<close>
 
 definition (in gc) invsL :: "('field, 'mut, 'ref) gc_pred" where
   "invsL \<equiv>
     fM_fA_invL
   \<^bold>\<and> gc_mark.mark_object_invL
   \<^bold>\<and> gc_W_empty_invL
   \<^bold>\<and> handshake_invL
   \<^bold>\<and> obj_fields_marked_invL
   \<^bold>\<and> phase_invL
   \<^bold>\<and> sweep_loop_invL
   \<^bold>\<and> tso_lock_invL
   \<^bold>\<and> LSTP (fA_rel_inv \<^bold>\<and> fM_rel_inv)"
 
 definition (in mut_m) invsL :: "('field, 'mut, 'ref) gc_pred" where
   "invsL \<equiv>
     mark_object_invL
   \<^bold>\<and> mut_get_roots.mark_object_invL m
   \<^bold>\<and> mut_store_ins.mark_object_invL m
   \<^bold>\<and> mut_store_del.mark_object_invL m
   \<^bold>\<and> handshake_invL
   \<^bold>\<and> tso_lock_invL
   \<^bold>\<and> LSTP mutator_phase_inv"
 
 definition invs :: "('field, 'mut, 'ref) lsts_pred" where
   "invs \<equiv>
     handshake_phase_inv
   \<^bold>\<and> phase_rel_inv
   \<^bold>\<and> strong_tricolour_inv
   \<^bold>\<and> sys_phase_inv
   \<^bold>\<and> tso_writes_inv
   \<^bold>\<and> valid_refs_inv
   \<^bold>\<and> valid_W_inv"
 
 definition I :: "('field, 'mut, 'ref) gc_pred" where
   "I \<equiv>
      gc.invsL
   \<^bold>\<and> (\<^bold>\<forall>m. mut_m.invsL m)
   \<^bold>\<and> LSTP invs"
 (*<*)
 
 lemmas I_defs = gc.invsL_def mut_m.invsL_def invs_def I_def
 
 lemma (in gc) I:
   "\<lbrace> I \<rbrace> gc"
 apply (simp add: I_defs)
 apply (rule valid_pre)
 apply ( rule valid_conj_lift valid_all_lift | fastforce )+
 done
 
 lemma (in sys) I:
   "\<lbrace> I \<rbrace> sys"
 apply (simp add: I_defs)
 apply (rule valid_pre)
 apply ( rule valid_conj_lift valid_all_lift | fastforce )+
 done
 
 text\<open>
 
 We need to separately treat the two cases of a single mutator and
 multiple mutators. In the latter case we have the additional
 obligation of showing mutual non-interference amongst mutators.
 
 \<close>
 
 lemma mut_invsL[intro]:
   "\<lbrace>I\<rbrace> mutator m \<lbrace>mut_m.invsL m'\<rbrace>"
 proof(cases "m = m'")
   case True
   interpret mut_m m' by unfold_locales
   from True show ?thesis
     apply (simp add: I_defs)
     apply (rule valid_pre)
     apply ( rule valid_conj_lift valid_all_lift | fastforce )+
     done
 next
   case False
   then interpret mut_m' m' m by unfold_locales blast
   from False show ?thesis
     apply (simp add: I_defs)
     apply (rule valid_pre)
     apply ( rule valid_conj_lift valid_all_lift | fastforce )+
     done
 qed
 
 lemma (in mut_m) I:
   "\<lbrace> I \<rbrace> mutator m"
 apply (simp add: I_def gc.invsL_def invs_def)
 apply (rule valid_pre)
 apply ( rule valid_conj_lift valid_all_lift | fastforce )+
 apply (simp add: I_defs)
 done
 
 (*>*)
 
 subsection\<open>Initial conditions\<close>
 
 text\<open>
 
 We ask that the GC and system initially agree on some things:
 \begin{itemize}
 
 \item All objects on the heap are marked (have their flags equal to
   @{const "sys_fM"}, and there are no grey references, i.e. the heap
   is uniformly black.
 
 \item The GC and system have the same values for @{term "fA"}, @{term
   "fM"}, etc. and the phase is @{term "Idle"}.
 
 \item No process holds the TSO lock and all write buffers are empty.
 
 \item All root-reachable references are backed by objects.
 
 \end{itemize}
 Note that these are merely sufficient initial conditions and can be
 weakened.
 
 \<close>
 
 locale gc_system =
   fixes initial_mark :: gc_mark
 begin
 
 definition gc_initial_state :: "('field, 'mut, 'ref) lst_pred" where
   "gc_initial_state s \<equiv>
      fM s = initial_mark
    \<and> phase s = ph_Idle
    \<and> ghost_honorary_grey s = {}
    \<and> W s = {}"
 
 definition mut_initial_state :: "('field, 'mut, 'ref) lst_pred" where
   "mut_initial_state s \<equiv>
      ghost_handshake_phase s = hp_IdleMarkSweep
    \<and> ghost_honorary_grey s = {}
    \<and> ghost_honorary_root s = {}
    \<and> W s = {}"
 
 definition sys_initial_state :: "('field, 'mut, 'ref) lst_pred" where
   "sys_initial_state s \<equiv>
      (\<forall>m. \<not>handshake_pending s m \<and> ghost_handshake_in_sync s m)
    \<and> ghost_handshake_phase s = hp_IdleMarkSweep \<and> handshake_type s = ht_GetRoots
    \<and> obj_mark ` ran (heap s) \<subseteq> {initial_mark}
    \<and> fA s = initial_mark
    \<and> fM s = initial_mark
    \<and> phase s = ph_Idle
    \<and> ghost_honorary_grey s = {}
    \<and> W s = {}
    \<and> (\<forall>p. mem_write_buffers s p = [])
    \<and> mem_lock s = None"
 
 abbreviation
   "root_reachable y \<equiv> \<^bold>\<exists>m x. \<langle>x\<rangle> \<^bold>\<in> mut_m.mut_roots m \<^bold>\<and> x reaches y"
 
 definition valid_refs :: "('field, 'mut, 'ref) lsts_pred" where
   "valid_refs \<equiv> \<^bold>\<forall>y. root_reachable y \<^bold>\<longrightarrow> valid_ref y"
 
 definition gc_system_init :: "('field, 'mut, 'ref) lsts_pred" where
   "gc_system_init \<equiv>
        (\<lambda>s. gc_initial_state (s gc))
      \<^bold>\<and> (\<lambda>s. \<forall>m. mut_initial_state (s (mutator m)))
      \<^bold>\<and> (\<lambda>s. sys_initial_state (s sys))
      \<^bold>\<and> valid_refs"
 
 text\<open>
 
 The system consists of the programs and these constraints on the initial state.
 
 \<close>
 
 abbreviation gc_system :: "('field, 'mut, 'ref) gc_system" where
   "gc_system \<equiv> (gc_pgms, gc_system_init)"
 (*<*)
 
 lemma init_strong_tricolour_inv:
   "\<lbrakk> obj_mark ` ran (sys_heap (mkP (s, []))\<down>) \<subseteq> {gc_fM (mkP (s, []))\<down>};
      sys_fM (mkP (s, []))\<down> = gc_fM (mkP (s, []))\<down> \<rbrakk>
      \<Longrightarrow> strong_tricolour_inv (mkP (s, []))\<down>"
 by (auto simp: strong_tricolour_inv_def ran_def
         split: obj_at_splits)
 
 lemma init_no_grey_refs:
   "\<lbrakk> gc_W (mkP (s, []))\<down> = {}; \<forall>m. W ((mkP (s, []))\<down> (mutator m)) = {}; sys_W (mkP (s, []))\<down> = {};
      gc_ghost_honorary_grey (mkP (s, []))\<down> = {}; \<forall>m. ghost_honorary_grey ((mkP (s, []))\<down> (mutator m)) = {}; sys_ghost_honorary_grey (mkP (s, []))\<down> = {} \<rbrakk>
      \<Longrightarrow> no_grey_refs (mkP (s, []))\<down>"
 apply (clarsimp simp: no_grey_refs_def grey_def)
 apply (rename_tac x xa)
 apply (case_tac xa)
 apply (auto simp: WL_def)
 done
 
 lemma valid_refs_imp_valid_refs_inv:
   "\<lbrakk> valid_refs s; no_grey_refs s; \<forall>p. sys_mem_write_buffers p s = []; \<forall>m. ghost_honorary_root (s (mutator m)) = {} \<rbrakk>
      \<Longrightarrow> valid_refs_inv s"
 by (auto simp: valid_refs_def valid_refs_inv_def mut_m.reachable_def mut_m.tso_write_refs_def
          dest: no_grey_refs_not_grey_reachableD)
 
 lemma no_grey_refs_imp_valid_W_inv:
   "\<lbrakk> no_grey_refs s; \<forall>p. sys_mem_write_buffers p s = [] \<rbrakk>
      \<Longrightarrow> valid_W_inv s"
 unfolding valid_W_inv_def
 by (auto simp: no_grey_refs_def grey_def WL_def)
 
 lemma init_inv_sys: "\<forall>s\<in>initial_states gc_system. invs (mkP (s, []))\<down>"
 apply (clarsimp dest!: initial_statesD
               simp: gc_system_init_def invs_def gc_initial_state_def mut_initial_state_def sys_initial_state_def
                     inv
                     handshake_phase_rel_def handshake_phase_inv_def hp_step_rel_def phase_rel_inv_def phase_rel_def
                     tso_writes_inv_def
                     init_no_grey_refs init_strong_tricolour_inv no_grey_refs_imp_valid_W_inv
                     valid_refs_imp_valid_refs_inv
                     all_conj_distrib)
 done
 
 lemma init_inv_gc: "\<forall>s\<in>initial_states gc_system. gc.invsL (mkP (s, []))"
 apply (clarsimp dest!: initial_statesD)
 apply (drule fun_cong[where x=gc]) (* hacky *)
 apply (simp add: com)
 apply (clarsimp simp: gc_system_init_def gc_initial_state_def mut_initial_state_def sys_initial_state_def
                       gc.invsL_def inv
                       gc.fM_fA_invL_def fA_rel_inv_def fA_rel_def fM_rel_inv_def fM_rel_def gc.handshake_invL_def
                       gc.obj_fields_marked_invL_def gc.phase_invL_def gc.sweep_loop_invL_def
                       gc.tso_lock_invL_def gc.gc_W_empty_invL_def
                       init_no_grey_refs
                       loc atS_simps
                       all_conj_distrib)
 apply (auto simp: ran_def image_subset_iff split: obj_at_splits)
 done
 
 lemma valid_refs_imp_reachable_snapshot_inv:
   "\<lbrakk> valid_refs s; obj_mark ` ran (sys_heap s) \<subseteq> {sys_fM s}; \<forall>p. sys_mem_write_buffers p s = []; \<forall>m. ghost_honorary_root (s (mutator m)) = {} \<rbrakk>
      \<Longrightarrow> mut_m.reachable_snapshot_inv m s"
 apply (clarsimp simp: mut_m.reachable_snapshot_inv_def in_snapshot_def valid_refs_def)
 apply (auto simp: image_subset_iff ran_def black_def mut_m.reachable_def mut_m.tso_write_refs_def
            split: obj_at_splits)
 done
 
 lemma init_inv_mut: "\<forall>s\<in>initial_states gc_system. mut_m.invsL m (mkP (s, []))"
 apply (clarsimp dest!: initial_statesD)
 apply (drule fun_cong[where x="mutator m"]) (* hacky *)
 apply (simp add: com)
 apply (clarsimp simp: gc_system_init_def mut_initial_state_def sys_initial_state_def
                       valid_refs_imp_reachable_snapshot_inv
                       mut_m.invsL_def inv
                       mut_m.mark_object_invL_def
                       mut_m.handshake_invL_def mut_m.tso_lock_invL_def
                       mut_m.marked_deletions_def mut_m.marked_insertions_def
                       loc atS_simps)
 done
 
 lemma init_inv: "\<forall>s\<in>initial_states gc_system. I (mkP (s, []))"
 by (simp add: I_def init_inv_sys init_inv_gc init_inv_mut)
 
 (*>*)
 text\<open>\<close>
 
 theorem inv: "s \<in> reachable_states gc_system \<Longrightarrow> I (mkP s)"
 (*<*)
 apply (erule VCG)
  apply (rule init_inv)
 apply (rename_tac p)
 apply (case_tac p, simp_all)
   apply (rule mut_m.I[unfolded valid_proc_def, simplified])
  apply (rule gc.I[unfolded valid_proc_def, simplified])
 apply (rule sys.I[unfolded valid_proc_def, simplified])
 done
 
 (*>*)
 text\<open>
 
 Our headline safety result follows directly.
 
 \<close>
 
 corollary safety:
   "s \<in> reachable_states gc_system \<Longrightarrow> valid_refs (mkP s)\<down>"
 (*<*)
 apply (drule inv)
 apply (clarsimp simp: I_def invs_def valid_refs_inv_def valid_refs_def)
 apply (rename_tac x xa xb)
 apply (drule_tac x=x in spec)
 apply clarsimp
 apply (drule_tac x=xa in spec, fastforce simp: mut_m.reachable_def)
 done
 
 (*>*)
 text\<open>\<close>
 
 end
 
 text\<open>
 
 The GC is correct for the remaining fixed-but-arbitrary initial
 conditions.
 
 \<close>
 
 interpretation gc_system_interpretation: gc_system undefined .
 
 
 subsection\<open>A concrete system state\<close>
 
 text\<open>
 
 We demonstrate that our definitions are not vacuous by exhibiting a
 concrete initial state that satisfies the initial conditions. We use
 Isabelle's notation for types of a given size.
 
 \<close>
 (*<*)
 
 end
 (*>*)
diff --git a/thys/ConcurrentGC/Proofs_basis.thy b/thys/ConcurrentGC/Proofs_basis.thy
--- a/thys/ConcurrentGC/Proofs_basis.thy
+++ b/thys/ConcurrentGC/Proofs_basis.thy
@@ -1,349 +1,351 @@
 (*<*)
 (*
  * Copyright 2015, NICTA
  *
  * This software may be distributed and modified according to the terms of
  * the BSD 2-Clause license. Note that NO WARRANTY is provided.
  * See "LICENSE_BSD2.txt" for details.
  *
  * @TAG(NICTA_BSD)
  *)
 
 theory Proofs_basis
 imports
   Tactics
   "HOL-Library.Simps_Case_Conv"
 begin
 
+declare subst_all [simp del] [[simproc del: defined_all]]
+
 (*>*)
 subsection\<open>Functions and predicates\<close>
 
 text\<open>
 
 We define a pile of predicates and accessor functions for the
 process's local states. One might hope that a more sophisticated
 approach would automate all of this (cf @{cite [cite_macro=citet]
 "DBLP:journals/entcs/SchirmerW09"}).
 
 \<close>
 
 abbreviation "is_mw_Mark w \<equiv> \<exists>r fl. w = mw_Mark r fl"
 abbreviation "is_mw_Mutate w \<equiv> \<exists>r f r'. w = mw_Mutate r f r'"
 abbreviation "is_mw_fA w \<equiv> \<exists>fl. w = mw_fA fl"
 abbreviation "is_mw_fM w \<equiv> \<exists>fl. w = mw_fM fl"
 abbreviation "is_mw_Phase w \<equiv> \<exists>ph. w = mw_Phase ph"
 
 abbreviation (input) pred_in_W :: "'ref \<Rightarrow> 'mut process_name \<Rightarrow> ('field, 'mut, 'ref) lsts_pred" (infix "in'_W" 50) where
   "r in_W p \<equiv> \<lambda>s. r \<in> W (s p)"
 
 abbreviation (input) pred_in_ghost_honorary_grey :: "'ref \<Rightarrow> 'mut process_name \<Rightarrow> ('field, 'mut, 'ref) lsts_pred" (infix "in'_ghost'_honorary'_grey" 50) where
   "r in_ghost_honorary_grey p \<equiv> \<lambda>s. r \<in> ghost_honorary_grey (s p)"
 
 context gc
 begin
 
 abbreviation
   valid_gc_syn :: "('field, 'mut, 'ref) gc_loc_comp \<Rightarrow> ('field, 'mut, 'ref) gc_pred \<Rightarrow> ('field, 'mut, 'ref) gc_com \<Rightarrow> ('field, 'mut, 'ref) gc_pred \<Rightarrow> bool"
                        ("_ \<Turnstile> \<lbrace>_\<rbrace>/ _/ \<lbrace>_\<rbrace>")
 where
   "afts \<Turnstile> \<lbrace>P\<rbrace> c \<lbrace>Q\<rbrace> \<equiv> gc_pgms, gc, afts \<Turnstile> \<lbrace>P\<rbrace> c \<lbrace>Q\<rbrace>"
 
 abbreviation valid_gc_inv_syn :: "('field, 'mut, 'ref) gc_loc_comp \<Rightarrow> ('field, 'mut, 'ref) gc_pred \<Rightarrow> ('field, 'mut, 'ref) gc_com \<Rightarrow> bool" ("_ \<Turnstile> \<lbrace>_\<rbrace>/ _") where
   "afts \<Turnstile> \<lbrace>P\<rbrace> c \<equiv> afts \<Turnstile> \<lbrace>P\<rbrace> c \<lbrace>P\<rbrace>"
 
 end
 
 abbreviation "gc_cas_mark s \<equiv> cas_mark (s gc)"
 abbreviation "gc_fM s \<equiv> fM (s gc)"
 abbreviation "gc_field s \<equiv> field (s gc)"
 abbreviation "gc_field_set s \<equiv> field_set (s gc)"
 abbreviation "gc_mark s \<equiv> mark (s gc)"
 abbreviation "gc_mut s \<equiv> mut (s gc)"
 abbreviation "gc_muts s \<equiv> muts (s gc)"
 abbreviation "gc_phase s \<equiv> phase (s gc)"
 abbreviation "gc_tmp_ref s \<equiv> tmp_ref (s gc)"
 abbreviation "gc_ghost_honorary_grey s \<equiv> ghost_honorary_grey (s gc)"
 abbreviation "gc_ref s \<equiv> ref (s gc)"
 abbreviation "gc_refs s \<equiv> refs (s gc)"
 abbreviation "gc_the_ref \<equiv> the \<circ> gc_ref"
 abbreviation "gc_W s \<equiv> W (s gc)"
 
 abbreviation at_gc :: "location \<Rightarrow> ('field, 'mut, 'ref) lsts_pred \<Rightarrow> ('field, 'mut, 'ref) gc_pred" where
   "at_gc l P \<equiv> at gc l \<^bold>\<longrightarrow> LSTP P"
 
 abbreviation atS_gc :: "location set \<Rightarrow> ('field, 'mut, 'ref) lsts_pred \<Rightarrow> ('field, 'mut, 'ref) gc_pred" where
   "atS_gc ls P \<equiv> atS gc ls \<^bold>\<longrightarrow> LSTP P"
 
 context mut_m
 begin
 
 abbreviation
   valid_mut_syn :: "('field, 'mut, 'ref) gc_loc_comp \<Rightarrow> ('field, 'mut, 'ref) gc_pred \<Rightarrow> ('field, 'mut, 'ref) gc_com \<Rightarrow> ('field, 'mut, 'ref) gc_pred \<Rightarrow> bool"
                     ("_ \<Turnstile> \<lbrace>_\<rbrace>/ _/ \<lbrace>_\<rbrace>")
 where
   "afts \<Turnstile> \<lbrace>P\<rbrace> c \<lbrace>Q\<rbrace> \<equiv> gc_pgms, mutator m, afts \<Turnstile> \<lbrace>P\<rbrace> c \<lbrace>Q\<rbrace>"
 
 abbreviation valid_mut_inv_syn :: "('field, 'mut, 'ref) gc_loc_comp \<Rightarrow> ('field, 'mut, 'ref) gc_pred \<Rightarrow> ('field, 'mut, 'ref) gc_com \<Rightarrow> bool" ("_ \<Turnstile> \<lbrace>_\<rbrace>/ _") where
   "afts \<Turnstile> \<lbrace>P\<rbrace> c \<equiv> afts \<Turnstile> \<lbrace>P\<rbrace> c \<lbrace>P\<rbrace>"
 
 abbreviation at_mut :: "location \<Rightarrow> ('field, 'mut, 'ref) lsts_pred \<Rightarrow> ('field, 'mut, 'ref) gc_pred" where
   "at_mut l P \<equiv> at (mutator m) l \<^bold>\<longrightarrow> LSTP P"
 
 abbreviation atS_mut :: "location set \<Rightarrow> ('field, 'mut, 'ref) lsts_pred \<Rightarrow> ('field, 'mut, 'ref) gc_pred" where
   "atS_mut ls P \<equiv> atS (mutator m) ls \<^bold>\<longrightarrow> LSTP P"
 
 abbreviation "mut_cas_mark s \<equiv> cas_mark (s (mutator m))"
 abbreviation "mut_field s \<equiv> field (s (mutator m))"
 abbreviation "mut_fM s \<equiv> fM (s (mutator m))"
 abbreviation "mut_ghost_honorary_grey s \<equiv> ghost_honorary_grey (s (mutator m))"
 abbreviation "mut_ghost_handshake_phase s \<equiv> ghost_handshake_phase (s (mutator m))"
 abbreviation "mut_ghost_honorary_root s \<equiv> ghost_honorary_root (s (mutator m))"
 abbreviation "mut_mark s \<equiv> mark (s (mutator m))"
 abbreviation "mut_new_ref s \<equiv> new_ref (s (mutator m))"
 abbreviation "mut_phase s \<equiv> phase (s (mutator m))"
 abbreviation "mut_ref s \<equiv> ref (s (mutator m))"
 abbreviation "mut_tmp_ref s \<equiv> tmp_ref (s (mutator m))"
 abbreviation "mut_the_new_ref \<equiv> the \<circ> mut_new_ref"
 abbreviation "mut_the_ref \<equiv> the \<circ> mut_ref"
 abbreviation "mut_refs s \<equiv> refs (s (mutator m))"
 abbreviation "mut_roots s \<equiv> roots (s (mutator m))"
 abbreviation "mut_W s \<equiv> W (s (mutator m))"
 
 end
 
 context sys
 begin
 
 abbreviation
   valid_sys_syn :: "('field, 'mut, 'ref) gc_loc_comp \<Rightarrow> ('field, 'mut, 'ref) gc_pred \<Rightarrow> ('field, 'mut, 'ref) gc_com \<Rightarrow> ('field, 'mut, 'ref) gc_pred \<Rightarrow> bool"
                     ("_ \<Turnstile> \<lbrace>_\<rbrace>/ _/ \<lbrace>_\<rbrace>")
 where
   "afts \<Turnstile> \<lbrace>P\<rbrace> c \<lbrace>Q\<rbrace> \<equiv> gc_pgms, sys, afts \<Turnstile> \<lbrace>P\<rbrace> c \<lbrace>Q\<rbrace>"
 
 abbreviation valid_sys_inv_syn :: "('field, 'mut, 'ref) gc_loc_comp \<Rightarrow> ('field, 'mut, 'ref) gc_pred \<Rightarrow> ('field, 'mut, 'ref) gc_com \<Rightarrow> bool" ("_ \<Turnstile> \<lbrace>_\<rbrace>/ _") where
   "afts \<Turnstile> \<lbrace>P\<rbrace> c \<equiv> afts \<Turnstile> \<lbrace>P\<rbrace> c \<lbrace>P\<rbrace>"
 
 end
 
 abbreviation sys_heap :: "('field, 'mut, 'ref) lsts \<Rightarrow> 'ref \<Rightarrow> ('field, 'ref) object option" where "sys_heap s \<equiv> heap (s sys)"
 
 abbreviation "sys_fA s \<equiv> fA (s sys)"
 abbreviation "sys_fM s \<equiv> fM (s sys)"
 abbreviation "sys_ghost_honorary_grey s \<equiv> ghost_honorary_grey (s sys)"
 abbreviation "sys_ghost_handshake_in_sync m s \<equiv> ghost_handshake_in_sync (s sys) m"
 abbreviation "sys_ghost_handshake_phase s \<equiv> ghost_handshake_phase (s sys)"
 abbreviation "sys_handshake_pending m s \<equiv> handshake_pending (s sys) m"
 abbreviation "sys_handshake_type s \<equiv> handshake_type (s sys)"
 abbreviation "sys_mem_write_buffers p s \<equiv> mem_write_buffers (s sys) p"
 abbreviation "sys_mem_lock s \<equiv> mem_lock (s sys)"
 abbreviation "sys_phase s \<equiv> phase (s sys)"
 abbreviation "sys_W s \<equiv> W (s sys)"
 
 abbreviation atS_sys :: "location set \<Rightarrow> ('field, 'mut, 'ref) lsts_pred \<Rightarrow> ('field, 'mut, 'ref) gc_pred" where
   "atS_sys ls P \<equiv> atS sys ls \<^bold>\<longrightarrow> LSTP P"
 
 text\<open>Projections on TSO buffers.\<close>
 
 abbreviation (input) "tso_unlocked s \<equiv> mem_lock (s sys) = None"
 abbreviation (input) "tso_locked_by p s \<equiv> mem_lock (s sys) = Some p"
 
 abbreviation (input) "tso_pending p P s \<equiv> filter P (mem_write_buffers (s sys) p)"
 abbreviation (input) "tso_pending_write p w s \<equiv> w \<in> set (mem_write_buffers (s sys) p)"
 
 abbreviation (input) "tso_pending_fA p \<equiv> tso_pending p is_mw_fA"
 abbreviation (input) "tso_pending_fM p \<equiv> tso_pending p is_mw_fM"
 abbreviation (input) "tso_pending_mark p \<equiv> tso_pending p is_mw_Mark"
 abbreviation (input) "tso_pending_mutate p \<equiv> tso_pending p is_mw_Mutate"
 abbreviation (input) "tso_pending_phase p \<equiv> tso_pending p is_mw_Phase"
 
 abbreviation (input) "tso_no_pending_marks \<equiv> \<^bold>\<forall>p. LIST_NULL (tso_pending_mark p)"
 
 text\<open>
 
 A somewhat-useful abstraction of the heap, following l4.verified,
 which asserts that there is an object at the given reference with the
 given property.
 
 \<close>
 
 definition obj_at :: "(('field, 'ref) object \<Rightarrow> bool) \<Rightarrow> 'ref \<Rightarrow> ('field, 'mut, 'ref) lsts_pred" where
   "obj_at P r \<equiv> \<lambda>s. case sys_heap s r of None \<Rightarrow> False | Some obj \<Rightarrow> P obj"
 
 abbreviation (input) valid_ref :: "'ref \<Rightarrow> ('field, 'mut, 'ref) lsts_pred" where
   "valid_ref r \<equiv> obj_at \<langle>True\<rangle> r"
 
 definition valid_null_ref :: "'ref option \<Rightarrow> ('field, 'mut, 'ref) lsts_pred" where
   "valid_null_ref r \<equiv> case r of None \<Rightarrow> \<langle>True\<rangle> | Some r' \<Rightarrow> valid_ref r'"
 
 abbreviation pred_points_to :: "'ref \<Rightarrow> 'ref \<Rightarrow> ('field, 'mut, 'ref) lsts_pred" (infix "points'_to" 51) where
   "x points_to y \<equiv> \<lambda>s. obj_at (\<lambda>obj. y \<in> ran (obj_fields obj)) x s"
 
 text\<open>
 
 We use Isabelle's standard transitive-reflexive closure to define
 reachability through the heap.
 
 \<close>
 
 abbreviation pred_reaches :: "'ref \<Rightarrow> 'ref \<Rightarrow> ('field, 'mut, 'ref) lsts_pred" (infix "reaches" 51) where
   "x reaches y \<equiv> \<lambda>s. (\<lambda>x y. (x points_to y) s)\<^sup>*\<^sup>* x y"
 
 text\<open>
 
 The predicate \<open>obj_at_field_on_heap\<close> asserts that @{term \<open>valid_ref r\<close>}
 and if \<open>f\<close> is a field of the object referred to by \<open>r\<close> then it it satisfies \<open>P\<close>.
 
 \<close>
 
 (* FIXME rename *)
 definition obj_at_field_on_heap :: "('ref \<Rightarrow> bool) \<Rightarrow> 'ref \<Rightarrow> 'field \<Rightarrow> ('field, 'mut, 'ref) lsts_pred" where
   "obj_at_field_on_heap P r f \<equiv> \<lambda>s.
      case Option.map_option obj_fields (sys_heap s r) of
          None \<Rightarrow> False
        | Some fs \<Rightarrow> (case fs f of None \<Rightarrow> True
                                | Some r' \<Rightarrow> P r')"
 
 
 subsection\<open> Garbage collector locations \<close>
 
 locset_definition "idle_locs = prefixed ''idle''"
 locset_definition "init_locs = prefixed ''init''"
 locset_definition "mark_locs = prefixed ''mark''"
 locset_definition "mark_loop_locs = prefixed ''mark_loop''"
 locset_definition "sweep_locs = prefixed ''sweep''"
 
 (*<*)
 
 subsection\<open> Lemma bucket \<close>
 
 lemma obj_at_split:
   "Q (obj_at P r s) = ((sys_heap s r = None \<longrightarrow> Q False) \<and> (\<forall>obj. sys_heap s r = Some obj \<longrightarrow> Q (P obj)))"
 by (simp add: obj_at_def split: option.splits)
 
 lemma obj_at_split_asm:
   "Q (obj_at P r s) = (\<not> ((sys_heap s r = None \<and> \<not>Q False) \<or> (\<exists>obj. sys_heap s r = Some obj \<and> \<not> Q (P obj))))"
 by (simp add: obj_at_def split: option.splits)
 
 lemmas obj_at_splits = obj_at_split obj_at_split_asm
 
 lemma p_not_sys:
   "p \<noteq> sys \<longleftrightarrow> p = gc \<or> (\<exists>m. p = mutator m)"
 by (cases p) simp_all
 
 lemma (in mut_m') m'm[iff]: "m' \<noteq> m"
 using mm' by blast
 
 lemma obj_at_eq_imp:
   "eq_imp (\<lambda>(_::unit) s. map_option P (sys_heap s r))
           (obj_at P r)"
 by (simp add: eq_imp_def obj_at_def split: option.splits)
 
 lemmas obj_at_fun_upd[simp] = eq_imp_fun_upd[OF obj_at_eq_imp, simplified eq_imp_simps]
 
 simps_of_case handshake_step_simps[simp]: handshake_step_def (splits: handshake_phase.split)
 
 (* Looks like a good idea but seems very weak. The split rules do a better job. *)
 lemma obj_at_weakenE[elim]:
   "\<lbrakk> obj_at P r s; \<And>s. P s \<Longrightarrow> P' s \<rbrakk> \<Longrightarrow> obj_at P' r s"
 by (simp add: obj_at_def split: option.splits)
 
 lemma obj_at_ref_sweep_loop_free[simp]:
   "obj_at P r (s(sys := (s sys)\<lparr>heap := (sys_heap s)(r' := None)\<rparr>)) \<longleftrightarrow> obj_at P r s \<and> r \<noteq> r'"
 by (clarsimp split: obj_at_splits)
 
 lemma obj_at_alloc[simp]:
   "sys_heap s r' = None
   \<Longrightarrow> obj_at P r (s(Mut m := mut_m_s', sys := (s sys)\<lparr> heap := sys_heap s(r' \<mapsto> obj) \<rparr>))
   \<longleftrightarrow> (obj_at P r s \<or> (r = r' \<and> P obj))"
 by (simp add: ran_def split: obj_at_splits)
 
 simps_of_case do_read_action_simps[simp]: fun_cong[OF do_read_action_def[simplified atomize_eq]] (splits: mem_read_action.split)
 simps_of_case do_write_action_simps[simp]: fun_cong[OF do_write_action_def[simplified atomize_eq]] (splits: mem_write_action.split)
 
 (* This gives some indication of how much we're cheating on the TSO front. *)
 lemma do_write_action_prj_simps[simp]:
   "fM (do_write_action w s) = fl \<longleftrightarrow> (fM s = fl \<and> w \<noteq> mw_fM (\<not>fM s)) \<or> w = mw_fM fl"
   "fl = fM (do_write_action w s) \<longleftrightarrow> (fl = fM s \<and> w \<noteq> mw_fM (\<not>fM s)) \<or> w = mw_fM fl"
   "fA (do_write_action w s) = fl \<longleftrightarrow> (fA s = fl \<and> w \<noteq> mw_fA (\<not>fA s)) \<or> w = mw_fA fl"
   "fl = fA (do_write_action w s) \<longleftrightarrow> (fl = fA s \<and> w \<noteq> mw_fA (\<not>fA s)) \<or> w = mw_fA fl"
   "ghost_handshake_in_sync (do_write_action w s) = ghost_handshake_in_sync s"
   "ghost_handshake_phase (do_write_action w s) = ghost_handshake_phase s"
   "ghost_honorary_grey (do_write_action w s) = ghost_honorary_grey s"
   "handshake_pending (do_write_action w s) = handshake_pending s"
   "handshake_type (do_write_action w s) = handshake_type s"
   "heap (do_write_action w s) r = None \<longleftrightarrow> heap s r = None"
   "mem_lock (do_write_action w s) = mem_lock s"
   "phase (do_write_action w s) = ph \<longleftrightarrow> (phase s = ph \<and> (\<forall>ph'. w \<noteq> mw_Phase ph') \<or> w = mw_Phase ph)"
   "ph = phase (do_write_action w s) \<longleftrightarrow> (ph = phase s \<and> (\<forall>ph'. w \<noteq> mw_Phase ph') \<or> w = mw_Phase ph)"
   "W (do_write_action w s) = W s"
 by (auto simp: do_write_action_def split: mem_write_action.splits obj_at_splits)
 
 lemma valid_null_ref_eq_imp:
   "eq_imp (\<lambda>(_::unit) s. r \<bind> (Option.map_option \<langle>True\<rangle> \<circ> sys_heap s))
           (valid_null_ref r)"
 by (simp add: eq_imp_def obj_at_def valid_null_ref_def split: option.splits)
 
 lemmas valid_null_ref_fun_upd[simp] = eq_imp_fun_upd[OF valid_null_ref_eq_imp, simplified]
 
 lemma valid_null_ref_simps[simp]:
   "valid_null_ref None s"
   "valid_null_ref (Some r) s \<longleftrightarrow> valid_ref r s"
 by (simp_all add: valid_null_ref_def)
 
 lemma obj_at_field_on_heap_eq_imp:
   "eq_imp (\<lambda>(_::unit) s. sys_heap s r)
           (obj_at_field_on_heap P r f)"
 by (simp add: eq_imp_def obj_at_field_on_heap_def)
 
 lemmas obj_at_field_on_heap_fun_upd[simp] = eq_imp_fun_upd[OF obj_at_field_on_heap_eq_imp, simplified eq_imp_simps]
 
 lemma obj_at_field_on_heapE[elim]:
   "\<lbrakk> obj_at_field_on_heap P r f s; sys_heap s' r = sys_heap s r; \<And>r'. P r' \<Longrightarrow> P' r' \<rbrakk>
        \<Longrightarrow> obj_at_field_on_heap P' r f s'"
 by (simp add: obj_at_field_on_heap_def split: option.splits)
 
 lemma obj_at_field_on_heap_mw_simps[simp]:
   "obj_at_field_on_heap P r0 f0
          (s(sys := (s sys)\<lparr> heap := (sys_heap s)(r := Option.map_option (\<lambda>obj :: ('field, 'ref) object. obj\<lparr>obj_fields := (obj_fields obj)(f := opt_r')\<rparr>) (sys_heap s r)),
                             mem_write_buffers := (mem_write_buffers (s Sys))(p := ws) \<rparr>))
 \<longleftrightarrow> ( (r \<noteq> r0 \<or> f \<noteq> f0) \<and> obj_at_field_on_heap P r0 f0 s )
    \<or> (r = r0 \<and> f = f0 \<and> valid_ref r s \<and> (case opt_r' of Some r'' \<Rightarrow> P r'' | _ \<Rightarrow> True))"
   "obj_at_field_on_heap P r f (s(sys := s sys\<lparr>heap := (sys_heap s)(r' := Option.map_option (obj_mark_update (\<lambda>_. fl)) (sys_heap s r')), mem_write_buffers := sb'\<rparr>))
 \<longleftrightarrow> obj_at_field_on_heap P r f s"
 by (auto simp: obj_at_field_on_heap_def split: option.splits obj_at_splits)
 
 lemma obj_at_field_on_heap_no_pending_writes:
   "\<lbrakk> sys_read (mutator m) (mr_Ref r f) (s sys) = mv_Ref opt_r'; \<forall>opt_r'. mw_Mutate r f opt_r' \<notin> set (sys_mem_write_buffers (mutator m) s); valid_ref r s \<rbrakk>
      \<Longrightarrow> obj_at_field_on_heap (\<lambda>r. opt_r' = Some r) r f s"
 apply (clarsimp simp: sys_read_def fold_writes_def)
 apply (rule fold_invariant[where P="\<lambda>fr. obj_at_field_on_heap (\<lambda>r'. heap (fr (s sys)) r \<bind> (\<lambda>obj. obj_fields obj f) = Some r') r f s"
                              and Q="\<lambda>w. w \<in> set (sys_mem_write_buffers (mutator m) s)"])
   apply auto[1]
  apply (clarsimp simp: obj_at_field_on_heap_def split: option.splits obj_at_splits)
 apply (auto simp: obj_at_field_on_heap_def do_write_action_def Option.map_option_case
            split: option.splits obj_at_splits mem_write_action.splits)
 done
 
 lemma obj_at_field_on_heap_imp_valid_ref[elim]:
   "obj_at_field_on_heap P r f s \<Longrightarrow> valid_ref r s"
   "obj_at_field_on_heap P r f s \<Longrightarrow> valid_null_ref (Some r) s"
 by (auto simp: obj_at_field_on_heap_def valid_null_ref_def split: obj_at_splits option.splits)
 
 lemma obj_at_field_on_heap_weakenE[elim]:
   "\<lbrakk> obj_at_field_on_heap P r f s; \<And>s. P s \<Longrightarrow> P' s\<rbrakk> \<Longrightarrow> obj_at_field_on_heap P' r f s"
 by (clarsimp simp: obj_at_field_on_heap_def split: option.splits)
 
 lemma Set_bind_insert[simp]:
   "insert a A \<bind> B = B a \<union> (A \<bind> B)"
 by (auto simp: Set.bind_def)
 
 lemma option_bind_invE[elim]:
   "\<lbrakk> f \<bind> g = None; \<And>a. \<lbrakk> f = Some a; g a = None \<rbrakk> \<Longrightarrow> Q; f = None \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
   "\<lbrakk> f \<bind> g = Some x; \<And>a. \<lbrakk> f = Some a; g a = Some x \<rbrakk> \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
 by (case_tac [!] f) simp_all
 
 (*>*)
 (*<*)
 
 end
 (*>*)
diff --git a/thys/ConcurrentGC/StrongTricolour.thy b/thys/ConcurrentGC/StrongTricolour.thy
--- a/thys/ConcurrentGC/StrongTricolour.thy
+++ b/thys/ConcurrentGC/StrongTricolour.thy
@@ -1,3400 +1,3402 @@
 (*<*)
 (*
  * Copyright 2015, NICTA
  *
  * This software may be distributed and modified according to the terms of
  * the BSD 2-Clause license. Note that NO WARRANTY is provided.
  * See "LICENSE_BSD2.txt" for details.
  *
  * @TAG(NICTA_BSD)
  *)
 
 theory StrongTricolour
 imports
   MarkObject
 begin
 
+declare subst_all [simp del] [[simproc del: defined_all]]
+
 (*>*)
 subsection\<open>The strong-tricolour invariant \label{sec:strong-tricolour-invariant} \<close>
 
 text\<open>
 
 As the GC algorithm uses both insertion and deletion barriers, it
 preserves the \emph{strong tricolour-invariant}:
 
 \<close>
 
 abbreviation points_to_white :: "'ref \<Rightarrow> 'ref \<Rightarrow> ('field, 'mut, 'ref) lsts_pred" (infix "points'_to'_white" 51) where
   "x points_to_white y \<equiv> x points_to y \<^bold>\<and> white y"
 
 definition strong_tricolour_inv :: "('field, 'mut, 'ref) lsts_pred" where
   "strong_tricolour_inv = (\<^bold>\<forall>b w. black b \<^bold>\<longrightarrow> \<^bold>\<not>(b points_to_white w))"
 
 text\<open>
 
 Intuitively this invariant says that there are no pointers from
 completely processed objects to the unexplored space; i.e., the grey
 references properly separate the two. In contrast the weak tricolour
 invariant allows such pointers, provided there is a grey reference
 that protects the unexplored object.
 
 \<close>
 
 definition has_white_path_to :: "'ref \<Rightarrow> 'ref \<Rightarrow> ('field, 'mut, 'ref) lsts_pred" (infix "has'_white'_path'_to" 51) where
   "x has_white_path_to y \<equiv> \<lambda>s. (\<lambda>x y. (x points_to_white y) s)\<^sup>*\<^sup>* x y"
 
 definition grey_protects_white :: "'ref \<Rightarrow> 'ref \<Rightarrow> ('field, 'mut, 'ref) lsts_pred" (infix "grey'_protects'_white" 51) where
   "g grey_protects_white w = (grey g \<^bold>\<and> g has_white_path_to w)"
 
 definition weak_tricolour_inv :: "('field, 'mut, 'ref) lsts_pred" where
   "weak_tricolour_inv =
      (\<^bold>\<forall>b w. black b \<^bold>\<and> b points_to_white w \<^bold>\<longrightarrow> (\<^bold>\<exists>g. g grey_protects_white w))"
 
 lemma "strong_tricolour_inv s \<Longrightarrow> weak_tricolour_inv s"
 (*<*)
 by (clarsimp simp: strong_tricolour_inv_def weak_tricolour_inv_def grey_protects_white_def)
 
 (*>*)
 text\<open>
 
 The key invariant that the mutators establish as they perform \<open>get_roots\<close>: they protect their white-reachable references with grey
 objects.
 
 \<close>
 
 definition in_snapshot :: "'ref \<Rightarrow> ('field, 'mut, 'ref) lsts_pred" where
   "in_snapshot r = (black r \<^bold>\<or> (\<^bold>\<exists>g. g grey_protects_white r))"
 
 definition (in mut_m) reachable_snapshot_inv :: "('field, 'mut, 'ref) lsts_pred" where
   "reachable_snapshot_inv = (\<^bold>\<forall>r. reachable r \<^bold>\<longrightarrow> in_snapshot r)"
 
 text\<open>
 
 Note that it is not easy to specify precisely when the snapshot (of
 objects the GC will retain) is taken due to the raggedness of the
 initialisation.
 
 In some phases we need to know that the insertion and deletion
 barriers are installed, in order to preserve the snapshot. These can
 ignore TSO effects as marks hit system memory in a timely way.
 
 \<close>
 
 abbreviation marked_insertion :: "('field, 'ref) mem_write_action \<Rightarrow> ('field, 'mut, 'ref) lsts_pred" where
   "marked_insertion w \<equiv> \<lambda>s. case w of mw_Mutate r f (Some r') \<Rightarrow> marked r' s | _ \<Rightarrow> True"
 
 definition (in mut_m) marked_insertions :: "('field, 'mut, 'ref) lsts_pred" where
   "marked_insertions = (\<^bold>\<forall>w. tso_pending_write (mutator m) w \<^bold>\<longrightarrow> marked_insertion w)"
 
 abbreviation marked_deletion :: "('field, 'ref) mem_write_action \<Rightarrow> ('field, 'mut, 'ref) lsts_pred" where
   "marked_deletion w \<equiv> \<lambda>s. case w of mw_Mutate r f opt_r' \<Rightarrow> obj_at_field_on_heap (\<lambda>r'. marked r' s) r f s | _ \<Rightarrow> True"
 
 definition (in mut_m) marked_deletions :: "('field, 'mut, 'ref) lsts_pred" where
   "marked_deletions = (\<^bold>\<forall>w. tso_pending_write (mutator m) w \<^bold>\<longrightarrow> marked_deletion w)"
 
 text\<open>
 
 Finally, in some phases the heap is somewhat monochrome.
 
 \<close>
 
 definition black_heap :: "('field, 'mut, 'ref) lsts_pred" where
   "black_heap = (\<^bold>\<forall>r. valid_ref r \<^bold>\<longrightarrow> black r)"
 
 definition white_heap :: "('field, 'mut, 'ref) lsts_pred" where
   "white_heap = (\<^bold>\<forall>r. valid_ref r \<^bold>\<longrightarrow> white r)"
 
 definition no_black_refs :: "('field, 'mut, 'ref) lsts_pred" where
   "no_black_refs = (\<^bold>\<forall>r. \<^bold>\<not>(black r))"
 
 definition no_grey_refs :: "('field, 'mut, 'ref) lsts_pred" where
   "no_grey_refs = (\<^bold>\<forall>r. \<^bold>\<not>(grey r))"
 (*<*)
 
 lemma no_black_refsD:
   "no_black_refs s \<Longrightarrow> \<not>black r s"
 unfolding no_black_refs_def by simp
 
 lemma has_white_path_to_eq_imp:
   "eq_imp (\<lambda>(_::unit). sys_fM \<^bold>\<otimes> sys_heap)
           (x has_white_path_to y)"
 by (clarsimp simp: eq_imp_def has_white_path_to_def obj_at_def cong: option.case_cong)
 
 lemmas has_white_path_to_fun_upd[simp] = eq_imp_fun_upd[OF has_white_path_to_eq_imp, simplified eq_imp_simps, rule_format]
 
 lemma has_white_path_toD[dest]:
   "(x has_white_path_to y) s \<Longrightarrow> white y s \<or> x = y"
 unfolding has_white_path_to_def by (fastforce elim: rtranclp.cases)
 
 lemma has_white_path_toI[iff]:
   "(x has_white_path_to x) s"
 by (simp add: has_white_path_to_def)
 
 lemma has_white_path_toE[elim!]:
   "\<lbrakk> (x points_to y) s; white y s \<rbrakk> \<Longrightarrow> (x has_white_path_to y) s"
   "\<lbrakk> (x has_white_path_to y) s; (y points_to z) s; white z s \<rbrakk> \<Longrightarrow> (x has_white_path_to z) s"
 by (auto simp: has_white_path_to_def
          elim: rtranclp.intros(2))
 
 lemma has_white_path_to_reaches[elim]:
   "(x has_white_path_to y) s \<Longrightarrow> (x reaches y) s"
 unfolding has_white_path_to_def
 by (induct rule: rtranclp.induct)
    (auto intro: rtranclp.intros(2))
 
 lemma has_white_path_to_blacken[simp]:
   "(x has_white_path_to w) (s(gc := s gc\<lparr> W := gc_W s - rs \<rparr>)) \<longleftrightarrow> (x has_white_path_to w) s"
 by (simp add: has_white_path_to_def)
 
 text\<open>WL\<close>
 
 lemma WL_mo_co_mark[simp]:
   "ghost_honorary_grey (s p) = {}
      \<Longrightarrow> WL p' (s(p := s p\<lparr> ghost_honorary_grey := rs \<rparr>)) = WL p' s \<union> { r |r. p' = p \<and> r \<in> rs}"
 by (auto simp: WL_def)
 
 lemma WL_blacken[simp]:
   "gc_ghost_honorary_grey s = {}
     \<Longrightarrow> WL p (s(gc := s gc\<lparr> W := gc_W s - rs \<rparr>)) = WL p s - { r |r. p = gc \<and> r \<in> rs }"
 by (auto simp: WL_def)
 
 lemma WL_hs_done[simp]:
   "ghost_honorary_grey (s (mutator m)) = {}
      \<Longrightarrow> WL p (s(mutator m := s (mutator m)\<lparr> W := {}, ghost_handshake_phase := hp' \<rparr>,
                  sys   := s sys\<lparr> handshake_pending := hsp', W := sys_W s \<union> W (s (mutator m)),
                                  ghost_handshake_in_sync := in' \<rparr>))
       = (case p of gc \<Rightarrow> WL gc s | mutator m' \<Rightarrow> (if m' = m then {} else WL (mutator m') s) | sys \<Rightarrow> WL sys s \<union> WL (mutator m) s)"
   "ghost_honorary_grey (s (mutator m)) = {}
      \<Longrightarrow> WL p (s(mutator m := s (mutator m)\<lparr> W := {} \<rparr>,
                  sys   := s sys\<lparr> handshake_pending := hsp', W := sys_W s \<union> W (s (mutator m)),
                                  ghost_handshake_in_sync := in' \<rparr>))
       = (case p of gc \<Rightarrow> WL gc s | mutator m' \<Rightarrow> (if m' = m then {} else WL (mutator m') s) | sys \<Rightarrow> WL sys s \<union> WL (mutator m) s)"
 by (auto simp: WL_def split: process_name.splits)
 
 lemma colours_load_W[iff]:
   "gc_W s = {} \<Longrightarrow> black r (s(gc := (s gc)\<lparr>W := W (s sys)\<rparr>, sys := (s sys)\<lparr>W := {}\<rparr>)) \<longleftrightarrow> black r s"
   "gc_W s = {} \<Longrightarrow> grey r (s(gc := (s gc)\<lparr>W := W (s sys)\<rparr>, sys := (s sys)\<lparr>W := {}\<rparr>)) \<longleftrightarrow> grey r s"
 apply (simp_all add: black_def grey_def WL_def)
 apply safe
 apply (case_tac [!] x)
 apply blast+
 done
 
 lemma colours_sweep_loop_free[iff]:
   "black r (s(sys := s sys\<lparr>heap := (heap (s sys))(r' := None)\<rparr>)) \<longleftrightarrow> (black r s \<and> r \<noteq> r')"
   "grey r (s(sys := s sys\<lparr>heap := (heap (s sys))(r' := None)\<rparr>)) \<longleftrightarrow> (grey r s)"
   "white r (s(sys := s sys\<lparr>heap := (heap (s sys))(r' := None)\<rparr>)) \<longleftrightarrow> (white r s \<and> r \<noteq> r')"
 by (auto simp: black_def grey_def split: obj_at_splits)
 
 lemma colours_get_work_done[simp]:
   "black r (s(mutator m := (s (mutator m))\<lparr>W := {}\<rparr>,
               sys := (s sys)\<lparr> handshake_pending := hp', W := W (s sys) \<union> W (s (mutator m)),
                               ghost_handshake_in_sync := his' \<rparr>)) \<longleftrightarrow> black r s"
   "grey r (s(mutator m := (s (mutator m))\<lparr>W := {}\<rparr>,
               sys := (s sys)\<lparr> handshake_pending := hp', W := W (s sys) \<union> W (s (mutator m)),
                               ghost_handshake_in_sync := his' \<rparr>)) \<longleftrightarrow> grey r s"
   "white r (s(mutator m := (s (mutator m))\<lparr>W := {}\<rparr>,
               sys := (s sys)\<lparr> handshake_pending := hp', W := W (s sys) \<union> W (s (mutator m)),
                               ghost_handshake_in_sync := his' \<rparr>)) \<longleftrightarrow> white r s"
 apply (simp_all add: black_def grey_def WL_def split: obj_at_splits)
 apply auto
 apply (metis (full_types) process_name.distinct(3))
 by metis
 
 lemma colours_get_roots_done[simp]:
   "black r (s(mutator m := (s (mutator m))\<lparr> W := {}, ghost_handshake_phase := hs' \<rparr>,
               sys := (s sys)\<lparr> handshake_pending := hp', W := W (s sys) \<union> W (s (mutator m)),
                               ghost_handshake_in_sync := his' \<rparr>)) \<longleftrightarrow> black r s"
   "grey r (s(mutator m := (s (mutator m))\<lparr> W := {}, ghost_handshake_phase := hs' \<rparr>,
               sys := (s sys)\<lparr> handshake_pending := hp', W := W (s sys) \<union> W (s (mutator m)),
                               ghost_handshake_in_sync := his' \<rparr>)) \<longleftrightarrow> grey r s"
   "white r (s(mutator m := (s (mutator m))\<lparr> W := {}, ghost_handshake_phase := hs' \<rparr>,
               sys := (s sys)\<lparr> handshake_pending := hp', W := W (s sys) \<union> W (s (mutator m)),
                               ghost_handshake_in_sync := his' \<rparr>)) \<longleftrightarrow> white r s"
 apply (simp_all add: black_def grey_def WL_def split: obj_at_splits)
 apply auto
 apply (metis process_name.distinct(3))
 by metis
 
 lemma colours_mark[simp]:
   "\<lbrakk> ghost_honorary_grey (s p) = {} \<rbrakk> \<Longrightarrow> black b (s(p := s p\<lparr>ghost_honorary_grey := {r}\<rparr>)) \<longleftrightarrow> black b s \<and> b \<noteq> r"
   "\<lbrakk> ghost_honorary_grey (s p) = {} \<rbrakk> \<Longrightarrow> grey g (s(p := (s p)\<lparr>ghost_honorary_grey := {r}\<rparr>)) \<longleftrightarrow> grey g s \<or> g = r"
   "\<lbrakk> ghost_honorary_grey (s p) = {} \<rbrakk> \<Longrightarrow> white w (s(p := s p\<lparr>ghost_honorary_grey := {r}\<rparr>))  \<longleftrightarrow> white w s"
 by (auto simp: black_def grey_def)
 
 lemma colours_flip_fM[simp]:
   "fl \<noteq> sys_fM s \<Longrightarrow> black b (s(sys := (s sys)\<lparr>fM := fl, mem_write_buffers := (mem_write_buffers (s sys))(p := ws)\<rparr>)) \<longleftrightarrow> white b s \<and> \<not>grey b s"
 by (simp_all add: black_def)
 
 lemma colours_alloc[simp]:
   "heap (s sys) r' = None
      \<Longrightarrow> black r (s(mutator m := (s (mutator m))\<lparr> roots := roots' \<rparr>, sys := (s sys)\<lparr>heap := heap (s sys)(r' \<mapsto> \<lparr>obj_mark = fl, obj_fields = Map.empty\<rparr>)\<rparr>))
      \<longleftrightarrow> black r s \<or> (r' = r \<and> fl = sys_fM s \<and> \<not>grey r' s)"
   "grey r (s(mutator m := (s (mutator m))\<lparr> roots := roots' \<rparr>, sys := (s sys)\<lparr>heap := heap (s sys)(r' \<mapsto> \<lparr>obj_mark = fl, obj_fields = Map.empty\<rparr>)\<rparr>))
      \<longleftrightarrow> grey r s"
   "heap (s sys) r' = None
      \<Longrightarrow> white r (s(mutator m := (s (mutator m))\<lparr> roots := roots' \<rparr>, sys := (s sys)\<lparr>heap := heap (s sys)(r' \<mapsto> \<lparr>obj_mark = fl, obj_fields = Map.empty\<rparr>)\<rparr>))
      \<longleftrightarrow> white r s \<or> (r' = r \<and> fl \<noteq> sys_fM s)"
 by (auto simp: black_def split: obj_at_splits dest!: valid_refs_invD)
 
 lemma colours_blacken[simp]:
   "valid_W_inv s \<Longrightarrow> black b (s(gc := s gc\<lparr>W := gc_W s - {r}\<rparr>)) \<longleftrightarrow> black b s \<or> (r \<in> gc_W s \<and> b = r)"
   "\<lbrakk> r \<in> gc_W s; valid_W_inv s \<rbrakk> \<Longrightarrow> grey g (s(gc := s gc\<lparr>W := gc_W s - {r}\<rparr>)) \<longleftrightarrow> (grey g s \<and> g \<noteq> r)"
   "white w (s(gc := s gc\<lparr>W := gc_W s - {r}\<rparr>)) \<longleftrightarrow> white w s"
 apply (auto simp: black_def grey_def WL_def split: obj_at_splits)
 apply metis+
 done
 
 lemma colours_dequeue[simp]:
   "black b (s(sys := (s sys)\<lparr> heap := (sys_heap s)(r := Option.map_option (obj_mark_update (\<lambda>_. fl)) (sys_heap s r)), mem_write_buffers := (mem_write_buffers (s sys))(p := ws) \<rparr>))
 \<longleftrightarrow> (black b s \<and> b \<noteq> r) \<or> (b = r \<and> fl = sys_fM s \<and> valid_ref r s \<and> \<not>grey r s)"
 by (auto simp: black_def split: obj_at_splits)
 
 lemma W_load_W[simp]:
   "gc_W s = {} \<Longrightarrow> (\<Union>p. W (if p = sys then (s sys)\<lparr>W := {}\<rparr> else if p = gc then (s gc)\<lparr>W := sys_W s\<rparr> else s p)) = (\<Union>p. W (s p))"
 apply (rule equalityI)
  apply (fastforce split: if_splits)
 apply clarsimp
 apply (rename_tac x p)
 apply (case_tac p)
 apply force+
 done
 
 lemma WL_load_W[simp]:
   "gc_W s = {}
     \<Longrightarrow> (WL p (s(gc := (s gc)\<lparr>W := sys_W s\<rparr>, sys := (s sys)\<lparr>W := {}\<rparr>)))
      = (case p of gc \<Rightarrow> WL gc s \<union> sys_W s | mutator m \<Rightarrow> WL (mutator m) s | sys \<Rightarrow> sys_ghost_honorary_grey s)"
 by (auto simp: WL_def split: process_name.splits)
 
 lemma colours_mo_co_W[simp]:
   "ghost_honorary_grey (s p') = {r}
      \<Longrightarrow> (WL p (s(p' := (s p')\<lparr>W := insert r (W (s p')), ghost_honorary_grey := {}\<rparr>))) = (WL p s)"
   "ghost_honorary_grey (s p') = {r}
      \<Longrightarrow> grey g (s(p' := (s p')\<lparr>W := insert r (W (s p')), ghost_honorary_grey := {}\<rparr>)) \<longleftrightarrow> grey g s"
 by (force simp: grey_def WL_def split: process_name.splits if_splits)+
 
 lemma no_grey_refs_eq_imp:
   "eq_imp (\<lambda>(_::unit). (\<lambda>s. \<Union>p. WL p s))
           no_grey_refs"
 by (auto simp add: eq_imp_def grey_def no_grey_refs_def set_eq_iff)
 
 lemmas no_grey_refs_fun_upd[simp] = eq_imp_fun_upd[OF no_grey_refs_eq_imp, simplified eq_imp_simps, rule_format]
 
 lemma no_grey_refs_no_pending_marks:
   "\<lbrakk> no_grey_refs s; valid_W_inv s \<rbrakk> \<Longrightarrow> tso_no_pending_marks s"
 by (auto intro!: filter_False simp: no_grey_refs_def)
 
 lemma (in mut_m) reachable_blackD:
   "\<lbrakk> no_grey_refs s; reachable_snapshot_inv s; reachable r s \<rbrakk> \<Longrightarrow> black r s"
 by (simp add: no_grey_refs_def reachable_snapshot_inv_def in_snapshot_def grey_protects_white_def)
 
 lemma (in mut_m) no_grey_refs_not_reachable:
   "\<lbrakk> no_grey_refs s; reachable_snapshot_inv s; white r s \<rbrakk> \<Longrightarrow> \<not>reachable r s"
 by (fastforce simp: no_grey_refs_def reachable_snapshot_inv_def in_snapshot_def grey_protects_white_def
              split: obj_at_splits)
 
 lemma (in mut_m) no_grey_refs_not_rootD:
   "\<lbrakk> no_grey_refs s; reachable_snapshot_inv s; white r s \<rbrakk>
      \<Longrightarrow> r \<notin> mut_roots s \<and> r \<notin> mut_ghost_honorary_root s \<and> r \<notin> tso_write_refs s"
 apply (drule (2) no_grey_refs_not_reachable)
 apply (force simp: reachable_def)
 done
 
 lemma no_grey_refs_not_grey_reachableD:
   "no_grey_refs s \<Longrightarrow> \<not>grey_reachable x s"
 by (clarsimp simp: no_grey_refs_def grey_reachable_def)
 
 lemma (in mut_m) reachable_snapshot_inv_white_root:
   "\<lbrakk> white w s; w \<in> mut_roots s \<or> w \<in> mut_ghost_honorary_root s; reachable_snapshot_inv s \<rbrakk> \<Longrightarrow> \<exists>g. (g grey_protects_white w) s"
 by (auto simp: reachable_snapshot_inv_def in_snapshot_def
                reachable_def grey_protects_white_def)
 
 lemma no_grey_refsD:
   "no_grey_refs s \<Longrightarrow> r \<notin> W (s p)"
   "no_grey_refs s \<Longrightarrow> r \<notin> WL p s"
   "no_grey_refs s \<Longrightarrow> r \<notin> ghost_honorary_grey (s p)"
 by (auto simp: no_grey_refs_def)
 
 lemma no_grey_refs_marked[dest]:
   "\<lbrakk> marked r s; no_grey_refs s \<rbrakk> \<Longrightarrow> black r s"
 by (auto simp: no_grey_refs_def black_def)
 
 lemma no_grey_refs_bwD[dest]:
   "\<lbrakk> heap (s sys) r = Some obj; no_grey_refs s \<rbrakk> \<Longrightarrow> black r s \<or> white r s"
 by (clarsimp simp: black_def grey_def no_grey_refs_def split: obj_at_splits)
 
 text\<open>tso write refs\<close>
 
 lemma tso_write_refs_simps[simp]:
   "mut_m.tso_write_refs m (s(mutator m' := s (mutator m')\<lparr>roots := roots'\<rparr>))
  = mut_m.tso_write_refs m s"
   "mut_m.tso_write_refs m (s(mutator m' := s (mutator m')\<lparr>ghost_honorary_root := {}\<rparr>,
                              sys := s sys\<lparr>mem_write_buffers := (mem_write_buffers (s sys))(mutator m' := sys_mem_write_buffers (mutator m') s @ [mw_Mutate r f opt_r'])\<rparr>))
  = mut_m.tso_write_refs m s \<union> (if m' = m then write_refs (mw_Mutate r f opt_r') else {})"
   "mut_m.tso_write_refs m (s(sys := s sys\<lparr>heap := (sys_heap s)(r' := None)\<rparr>))
  = mut_m.tso_write_refs m s"
   "mut_m.tso_write_refs m (s(mutator m' := s (mutator m')\<lparr>roots := insert r (roots (s (mutator m')))\<rparr>, sys := s sys\<lparr>heap := sys_heap s(r \<mapsto> obj)\<rparr>))
  = mut_m.tso_write_refs m s"
   "mut_m.tso_write_refs m (s(mutator m' := s (mutator m')\<lparr>ghost_honorary_root := Option.set_option opt_r', ref := opt_r'\<rparr>))
  = mut_m.tso_write_refs m s"
   "mut_m.tso_write_refs m (s(sys := s sys\<lparr>heap := (sys_heap s)(r := Option.map_option (\<lambda>obj. obj\<lparr>obj_fields := (obj_fields obj)(f := opt_r')\<rparr>) (sys_heap s r)),
                                           mem_write_buffers := (mem_write_buffers (s sys))(p := ws)\<rparr>))
  = (if p = mutator m then \<Union>w \<in> set ws. write_refs w else mut_m.tso_write_refs m s)"
   "sys_mem_write_buffers p s = mw_Mark r fl # ws
 \<Longrightarrow> mut_m.tso_write_refs m (s(sys := s sys\<lparr>heap := (sys_heap s)(r := Option.map_option (obj_mark_update (\<lambda>_. fl)) (sys_heap s r)), mem_write_buffers := (mem_write_buffers (s sys))(p := ws)\<rparr>))
  = mut_m.tso_write_refs m s"
 by (auto simp: mut_m.tso_write_refs_def)
 
 lemma mutator_reachable_tso:
   "sys_mem_write_buffers (mutator m) s = mw_Mutate r f opt_r' # ws
     \<Longrightarrow> mut_m.reachable m r s \<and> (\<forall>r'. opt_r' = Some r' \<longrightarrow> mut_m.reachable m r' s)"
 by (auto simp: mut_m.tso_write_refs_def)
 
 text\<open>coloured heaps\<close>
 
 lemma black_heap_eq_imp:
   "eq_imp (\<lambda>(_::unit). (\<lambda>s. \<Union>p. WL p s) \<^bold>\<otimes> sys_fM \<^bold>\<otimes> (\<lambda>s. Option.map_option obj_mark \<circ> sys_heap s))
           black_heap"
 apply (clarsimp simp add: eq_imp_def black_heap_def black_def grey_def all_conj_distrib fun_eq_iff split: option.splits)
 apply (rename_tac s s')
 apply (subgoal_tac "\<forall>x. marked x s \<longleftrightarrow> marked x s'")
  apply (subgoal_tac "\<forall>x. valid_ref x s \<longleftrightarrow> valid_ref x s'")
   apply (subgoal_tac "\<forall>x. (\<forall>p. x \<notin> WL p s) \<longleftrightarrow> (\<forall>p. x \<notin> WL p s')")
    apply clarsimp
   apply (auto simp: set_eq_iff)[1]
  apply clarsimp
  apply (rename_tac x)
  apply (rule eq_impD[OF obj_at_eq_imp])
  apply (drule_tac x=x in spec)
  apply (drule_tac f="Option.map_option \<langle>True\<rangle>" in arg_cong)
  apply (clarsimp simp: map_option.compositionality o_def)
 apply (clarsimp simp: map_option.compositionality o_def)
 apply (rule eq_impD[OF obj_at_eq_imp])
 apply clarsimp
 apply (rename_tac x)
 apply (drule_tac x=x in spec)
 apply (drule_tac f="Option.map_option (\<lambda>fl. fl = sys_fM s)" in arg_cong)
 apply (simp add: map_option.compositionality o_def)
 done
 
 lemma white_heap_eq_imp:
   "eq_imp (\<lambda>(_::unit). sys_fM \<^bold>\<otimes> (\<lambda>s. Option.map_option obj_mark \<circ> sys_heap s))
           white_heap"
 apply (clarsimp simp: all_conj_distrib eq_imp_def white_heap_def obj_at_def fun_eq_iff
                split: option.splits)
 apply (rule iffI)
 apply (metis (hide_lams, no_types) map_option_eq_Some)+
 done
 
 lemma no_black_refs_eq_imp:
   "eq_imp (\<lambda>(_::unit). (\<lambda>s. (\<Union>p. WL p s)) \<^bold>\<otimes> sys_fM \<^bold>\<otimes> (\<lambda>s. Option.map_option obj_mark \<circ> sys_heap s))
           no_black_refs"
 apply (clarsimp simp add: eq_imp_def no_black_refs_def black_def grey_def all_conj_distrib fun_eq_iff set_eq_iff split: option.splits)
 apply (rename_tac s s')
 apply (subgoal_tac "\<forall>x. marked x s \<longleftrightarrow> marked x s'")
  apply clarsimp
 apply clarsimp
 apply (rename_tac x)
 apply ( (drule_tac x=x in spec)+ )[1]
 apply (auto split: obj_at_splits)
 done
 
 lemmas black_heap_fun_upd[simp] = eq_imp_fun_upd[OF black_heap_eq_imp, simplified eq_imp_simps, rule_format]
 lemmas white_heap_fun_upd[simp] = eq_imp_fun_upd[OF white_heap_eq_imp, simplified eq_imp_simps, rule_format]
 lemmas no_black_refs_fun_upd[simp] = eq_imp_fun_upd[OF no_black_refs_eq_imp, simplified eq_imp_simps, rule_format]
 
 lemma white_heap_imp_no_black_refs[elim!]:
   "white_heap s \<Longrightarrow> no_black_refs s"
 apply (clarsimp simp: white_heap_def no_black_refs_def black_def)
 apply (rename_tac x)
 apply (drule_tac x=x in spec)
 apply (clarsimp split: obj_at_splits)
 done
 
 lemma (in sys) no_black_refs_dequeue[simp]:
   "\<lbrakk> sys_mem_write_buffers p s = mw_Mark r fl # ws; no_black_refs s; valid_W_inv s \<rbrakk>
    \<Longrightarrow> no_black_refs (s(sys := s sys\<lparr>heap := (sys_heap s)(r := Option.map_option (obj_mark_update (\<lambda>_. fl)) (sys_heap s r)), mem_write_buffers := (mem_write_buffers (s sys))(p := ws)\<rparr>))"
   "\<lbrakk> sys_mem_write_buffers p s = mw_Mutate r f r' # ws; no_black_refs s \<rbrakk>
      \<Longrightarrow> no_black_refs (s(sys := s sys\<lparr>heap := (sys_heap s)(r := Option.map_option (\<lambda>obj. obj\<lparr>obj_fields := (obj_fields obj)(f := r')\<rparr>) (sys_heap s r)),
                                       mem_write_buffers := (mem_write_buffers (s sys))(p := ws)\<rparr>))"
 by (auto simp: no_black_refs_def map_option.compositionality o_def)
 
 lemma black_heap_no_greys[elim]:
   "\<lbrakk> black_heap s; valid_refs_inv s \<rbrakk> \<Longrightarrow> no_grey_refs s"
   "\<lbrakk> no_grey_refs s; \<forall>r. marked r s \<or> \<not>valid_ref r s \<rbrakk> \<Longrightarrow> black_heap s"
 by (auto simp: black_def black_heap_def no_grey_refs_def dest: valid_refs_invD)
 
 lemma heap_colours_alloc[simp]:
   "\<lbrakk> heap (s sys) r' = None; valid_refs_inv s \<rbrakk>
   \<Longrightarrow> black_heap (s(mutator m := s (mutator m)\<lparr>roots := insert r' (roots (s (mutator m)))\<rparr>, sys := s sys\<lparr>heap := sys_heap s(r' \<mapsto> \<lparr>obj_mark = fl, obj_fields = Map.empty\<rparr>)\<rparr>))
   \<longleftrightarrow> black_heap s \<and> fl = sys_fM s"
   "heap (s sys) r' = None
   \<Longrightarrow> white_heap (s(mutator m := s (mutator m)\<lparr>roots := insert r' (roots (s (mutator m)))\<rparr>, sys := s sys\<lparr>heap := sys_heap s(r' \<mapsto> \<lparr>obj_mark = fl, obj_fields = Map.empty\<rparr>)\<rparr>))
   \<longleftrightarrow> white_heap s \<and> fl \<noteq> sys_fM s"
  apply (simp_all add: black_heap_def white_heap_def split: obj_at_splits)
  apply (rule iffI)
   apply (intro allI conjI impI)
    apply (rename_tac x)
    apply (drule_tac x=x in spec)
    apply clarsimp
   apply (drule spec[where x=r'], auto dest!: valid_refs_invD split: obj_at_splits)[2]
 apply (rule iffI)
  apply (intro allI conjI impI)
   apply (rename_tac x obj)
   apply (drule_tac x=x in spec)
   apply clarsimp
  apply (drule spec[where x=r'], auto dest!: valid_refs_invD split: obj_at_splits)[2]
 done
 
 lemma heap_colours_colours:
   "black_heap s \<Longrightarrow> \<not>white r s"
   "white_heap s \<Longrightarrow> \<not>black r s"
 by (auto simp: black_heap_def white_heap_def
         dest!: spec[where x=r]
         split: obj_at_splits)
 
 lemma heap_colours_marked:
   "\<lbrakk> black_heap s; obj_at P r s \<rbrakk> \<Longrightarrow> marked r s"
   "\<lbrakk> white_heap s; obj_at P r s \<rbrakk> \<Longrightarrow> white r s"
 by (auto simp: black_heap_def white_heap_def
         dest!: spec[where x=r]
         split: obj_at_splits)
 
 lemma (in gc) obj_fields_marked_inv_blacken:
   "\<lbrakk> gc_field_set s = {}; obj_fields_marked_inv s; (gc_tmp_ref s points_to w) s; white w s; tso_writes_inv s \<rbrakk> \<Longrightarrow> False"
 by (simp add: obj_fields_marked_inv_def obj_at_field_on_heap_def ran_def split: option.splits obj_at_splits)
 
 lemma (in gc) obj_fields_marked_inv_has_white_path_to_blacken:
   "\<lbrakk> gc_field_set s = {}; gc_tmp_ref s \<in> gc_W s; (gc_tmp_ref s has_white_path_to w) s; obj_fields_marked_inv s; valid_W_inv s; tso_writes_inv s \<rbrakk> \<Longrightarrow> w = gc_tmp_ref s"
 apply (drule (1) valid_W_invD)
 apply (clarsimp simp: has_white_path_to_def)
 apply (erule converse_rtranclpE)
  apply (clarsimp split: obj_at_splits)
 apply clarsimp
 apply (simp add: obj_fields_marked_inv_def obj_at_field_on_heap_def ran_def split: option.splits obj_at_splits)
 done
 
 lemma fold_writes_points_to[rule_format, simplified conj_explode]:
   "heap (fold_writes ws (s sys)) r = Some obj \<and> obj_fields obj f = Some r'
      \<longrightarrow> (r points_to r') s \<or> (\<exists>w \<in> set ws. r' \<in> write_refs w)" (is "?P (fold_writes ws) obj")
 unfolding fold_writes_def
 apply (rule spec[OF fold_invariant[where P="\<lambda>fr. \<forall>obj. ?P fr obj" and Q="\<lambda>w. w \<in> set ws"]])
   apply simp
  apply (fastforce simp: ran_def split: obj_at_splits)
 apply clarsimp
 apply (drule (1) bspec)
 apply (clarsimp split: mem_write_action.split_asm if_splits)
 done
 
 lemma (in mut_m) reachable_load[simp]:
   assumes "sys_read (mutator m) (mr_Ref r f) (s sys) = mv_Ref r'"
   assumes "r \<in> mut_roots s"
   shows "mut_m.reachable m' y (s(mutator m := s (mutator m)\<lparr> roots := mut_roots s \<union> Option.set_option r' \<rparr>)) \<longleftrightarrow> mut_m.reachable m' y s" (is "?lhs = ?rhs")
 proof(cases "m' = m")
   case True show ?thesis
   proof(rule iffI)
     assume ?lhs with assms True show ?rhs
 apply (clarsimp simp: sys_read_def)
 apply (clarsimp simp: reachable_def tso_write_refs_def)
 apply (clarsimp simp: sys_read_def fold_writes_def)
  apply (elim disjE)
     apply blast
    defer
   apply blast
  apply blast
 
 apply (fold fold_writes_def)
 apply clarsimp
 apply (drule (1) fold_writes_points_to)
 apply (erule disjE)
  apply (fastforce elim!: converse_rtranclp_into_rtranclp[rotated] split: obj_at_splits intro!: ranI)
 apply clarsimp
 apply (case_tac w, simp_all)
 apply (erule disjE)
  apply (rule_tac x=x in exI)
  apply (fastforce elim!: converse_rtranclp_into_rtranclp[rotated] split: obj_at_splits intro!: ranI)
 apply (rule_tac x=x in exI)
 apply (fastforce elim!: converse_rtranclp_into_rtranclp[rotated] split: obj_at_splits intro!: ranI)
 done (* filthy *)
   next
     assume ?rhs with True show ?lhs by (fastforce simp: reachable_def)
   qed
 qed simp
 
 lemma (in mut_m) reachable_deref_del[simp]:
   "\<lbrakk> sys_read (mutator m) (mr_Ref r f) (s sys) = mv_Ref opt_r'; r \<in> mut_roots s; mut_ghost_honorary_root s = {} \<rbrakk>
    \<Longrightarrow> mut_m.reachable m' y (s(mutator m := s (mutator m)\<lparr> ghost_honorary_root := Option.set_option opt_r', ref := opt_r' \<rparr>))
    \<longleftrightarrow> mut_m.reachable m' y s"
 apply (clarsimp simp: mut_m.reachable_def sys_read_def)
 apply (rule iffI)
  apply clarsimp
  apply (elim disjE)
    apply metis
   apply (erule option_bind_invE; auto dest!: fold_writes_points_to)
  apply (auto elim!: converse_rtranclp_into_rtranclp[rotated]
               simp: tso_write_refs_def)
 done
 
 text\<open>strong tricolour\<close>
 
 lemma strong_tricolour_invD:
   "\<lbrakk> black x s; (x points_to y) s; valid_ref y s; strong_tricolour_inv s \<rbrakk>
      \<Longrightarrow> marked y s"
 apply (clarsimp simp: strong_tricolour_inv_def)
 apply (drule spec[where x=x])
 apply (auto split: obj_at_splits)
 done
 
 text\<open>grey protects white\<close>
 
 lemma grey_protects_whiteD[dest]:
   "(g grey_protects_white w) s \<Longrightarrow> grey g s \<and> (g = w \<or> white w s)"
 by (auto simp: grey_protects_white_def)
 
 lemma grey_protects_whiteI[iff]:
   "grey g s \<Longrightarrow> (g grey_protects_white g) s"
 by (simp add: grey_protects_white_def)
 
 lemma grey_protects_whiteE[elim!]:
   "\<lbrakk> (g points_to w) s; grey g s; white w s \<rbrakk> \<Longrightarrow> (g grey_protects_white w) s"
   "\<lbrakk> (g grey_protects_white y) s; (y points_to w) s; white w s \<rbrakk> \<Longrightarrow> (g grey_protects_white w) s"
 by (auto simp: grey_protects_white_def)
 
 lemma grey_protects_white_reaches[elim]:
   "(g grey_protects_white w) s \<Longrightarrow> (g reaches w) s"
 by (auto simp: grey_protects_white_def)
 
 lemma grey_protects_white_hs_done[simp]:
   "(g grey_protects_white w) (s(mutator m := s (mutator m)\<lparr> W := {}, ghost_handshake_phase := hs' \<rparr>,
                               sys := s sys\<lparr> handshake_pending := hp', W := sys_W s \<union> W (s (mutator m)),
                                             ghost_handshake_in_sync := his' \<rparr>))
   \<longleftrightarrow> (g grey_protects_white w) s"
 by (simp add: grey_protects_white_def)
 
 lemma grey_protects_white_alloc[simp]:
   "\<lbrakk> fl = sys_fM s; sys_heap s r = None \<rbrakk>
      \<Longrightarrow> (g grey_protects_white w) (s(mutator m := s (mutator m)\<lparr>roots := insert r (roots (s (mutator m)))\<rparr>, sys := s sys\<lparr>heap := sys_heap s(r \<mapsto> \<lparr>obj_mark = fl, obj_fields = Map.empty\<rparr>)\<rparr>))
      \<longleftrightarrow> (g grey_protects_white w) s"
 by (clarsimp simp: grey_protects_white_def has_white_path_to_def)
 
 text\<open>reachable snapshot inv\<close>
 
 lemma (in mut_m) reachable_snapshot_invI[intro]:
   "(\<And>y. reachable y s \<Longrightarrow> in_snapshot y s) \<Longrightarrow> reachable_snapshot_inv s"
 by (simp add: reachable_snapshot_inv_def)
 
 lemma (in mut_m) reachable_snapshot_inv_eq_imp:
   "eq_imp (\<lambda>r. mut_roots \<^bold>\<otimes> mut_ghost_honorary_root \<^bold>\<otimes> (\<lambda>s. r \<in> (\<Union>p. WL p s)) \<^bold>\<otimes> sys_fM \<^bold>\<otimes> sys_heap \<^bold>\<otimes> tso_pending_mutate (mutator m))
           reachable_snapshot_inv"
 apply (clarsimp simp: eq_imp_def mut_m.reachable_snapshot_inv_def in_snapshot_def grey_protects_white_def)
 apply (rename_tac s s')
 apply (clarsimp simp: black_def grey_def obj_at_def cong: option.case_cong)
 apply (subst eq_impD[OF has_white_path_to_eq_imp])
  defer
  apply (subst eq_impD[OF reachable_eq_imp])
   defer
   apply (subgoal_tac "\<forall>x. (\<forall>p. x \<notin> WL p s) \<longleftrightarrow> (\<forall>p. x \<notin> WL p s')")
    apply force
   apply blast
  apply simp
 apply simp
 done
 
 lemmas reachable_snapshot_fun_upd[simp] = eq_imp_fun_upd[OF mut_m.reachable_snapshot_inv_eq_imp, simplified eq_imp_simps, rule_format]
 
 lemma in_snapshotI[intro]:
   "black r s \<Longrightarrow> in_snapshot r s"
   "grey r s \<Longrightarrow> in_snapshot r s"
   "\<lbrakk> white w s; (g grey_protects_white w) s \<rbrakk> \<Longrightarrow> in_snapshot w s"
 by (auto simp: in_snapshot_def)
 
 lemma in_snapshot_colours:
   "in_snapshot r s \<Longrightarrow> black r s \<or> grey r s \<or> white r s"
 by (auto simp: in_snapshot_def)
 
 lemma in_snapshot_valid_ref:
   "\<lbrakk> in_snapshot r s; valid_refs_inv s \<rbrakk> \<Longrightarrow> valid_ref r s"
 by (fastforce dest: in_snapshot_colours)
 
 lemma (in mut_m) reachable_snapshot_inv_sweep_loop_free:
   fixes s :: "('field, 'mut, 'ref) lsts"
   assumes nmr: "white r s"
   assumes ngs: "no_grey_refs s"
   assumes rsi: "reachable_snapshot_inv s"
   shows "reachable_snapshot_inv (s(sys := (s sys)\<lparr>heap := (heap (s sys))(r := None)\<rparr>))" (is "reachable_snapshot_inv ?s'")
 proof
   fix y :: "'ref"
   assume rx: "reachable y ?s'"
   then have "black y s \<and> y \<noteq> r"
   proof(induct rule: reachable_induct)
     case (root x) with ngs nmr rsi show ?case
       by (auto dest: reachable_blackD)
   next
     case (ghost_honorary_root x) with ngs nmr rsi show ?case
       apply -
       apply (frule (1) reachable_blackD[where r=x])
        apply (auto simp: reachable_def)
       done
   next
     case (tso_root x) with ngs nmr rsi show ?case
       apply -
       apply (frule (1) reachable_blackD[where r=x])
        apply (auto simp: reachable_def tso_write_refs_def)
       done
   next
     case (reaches x y) with ngs nmr rsi show ?case
       apply (clarsimp simp: reachable_def)
       apply (drule predicate2D[OF rtranclp_mono[where s="\<lambda>x y. (x points_to y) s", OF predicate2I], rotated])
        apply (clarsimp split: obj_at_splits if_splits)
       apply (rule conjI)
        apply (rule reachable_blackD, assumption, assumption)
        apply (simp add: reachable_def)
        apply (blast intro: rtranclp.intros(2))
       apply clarsimp
       apply (frule (1) reachable_blackD[where r=r])
        apply (simp add: reachable_def)
        apply (blast intro: rtranclp.intros(2))
       apply auto
       done
   qed
   then show "in_snapshot y ?s'"
     unfolding in_snapshot_def by simp
 qed
 
 lemma reachableI2[intro]:
   "x \<in> mut_m.mut_ghost_honorary_root m s \<Longrightarrow> mut_m.reachable m x s"
 by (auto simp: mut_m.reachable_def)
 
 lemma reachable_alloc[simp]:
   assumes rn: "sys_heap s r = None"
   shows "mut_m.reachable m r' (s(mutator m' := (s (mutator m'))\<lparr>roots := insert r (roots (s (mutator m')))\<rparr>, sys := (s sys)\<lparr>heap := (sys_heap s)(r \<mapsto> \<lparr>obj_mark = fl, obj_fields = Map.empty\<rparr>)\<rparr>))
      \<longleftrightarrow> mut_m.reachable m r' s \<or> (m' = m \<and> r' = r)" (is "?lhs \<longleftrightarrow> ?rhs")
 proof(rule iffI)
   assume ?lhs from this assms show ?rhs
   proof(induct rule: reachable_induct)
     case (reaches x y) then show ?case by clarsimp (fastforce simp: mut_m.reachable_def elim: rtranclp.intros(2) split: obj_at_splits)
   qed (auto split: if_splits)
 next
   assume ?rhs then show ?lhs
   proof(rule disjE)
     assume "mut_m.reachable m r' s" then show ?thesis
     proof(induct rule: reachable_induct)
       case (tso_root x) then show ?case
         by (fastforce simp: mut_m.reachable_def simp del: fun_upd_apply)
     next
       case (reaches x y) with rn show ?case
         by (fastforce simp: mut_m.reachable_def simp del: fun_upd_apply elim: rtranclp.intros(2))
     qed auto
   next
     assume "m' = m \<and> r' = r" with rn show ?thesis
       by (fastforce simp: mut_m.reachable_def)
   qed
 qed
 
 lemma (in mut_m) reachable_snapshot_inv_alloc[simp]:
   fixes s :: "('field, 'mut, 'ref) lsts"
   assumes rn: "sys_heap s r = None"
   assumes fl: "fl = sys_fM s"
   assumes vri: "valid_refs_inv s"
   assumes rsi: "reachable_snapshot_inv s"
   shows "reachable_snapshot_inv (s(mutator m' := (s (mutator m'))\<lparr>roots := insert r (roots (s (mutator m')))\<rparr>, sys := (s sys)\<lparr>heap := (sys_heap s)(r \<mapsto> \<lparr>obj_mark = fl, obj_fields = Map.empty\<rparr>)\<rparr>))" (is "reachable_snapshot_inv ?s'")
 using assms unfolding reachable_snapshot_inv_def in_snapshot_def
 by (auto simp del: reachable_fun_upd)
 
 lemma (in mut_m) reachable_snapshot_inv_discard_roots[simp]:
   "\<lbrakk> reachable_snapshot_inv s; roots' \<subseteq> roots (s (mutator m)) \<rbrakk>
      \<Longrightarrow> reachable_snapshot_inv (s(mutator m := (s (mutator m))\<lparr>roots := roots'\<rparr>))"
 unfolding reachable_snapshot_inv_def reachable_def in_snapshot_def grey_protects_white_def by auto
 
 lemma grey_protects_white_mark[simp]:
   assumes ghg: "ghost_honorary_grey (s p) = {}"
   shows "(\<exists>g. (g grey_protects_white w) (s(p := s p\<lparr> ghost_honorary_grey := {r} \<rparr>)))
       \<longleftrightarrow> (\<exists>g'. (g' grey_protects_white w) s) \<or> (r has_white_path_to w) s" (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?lhs
   then obtain g where "(g grey_protects_white w) (s(p := s p\<lparr>ghost_honorary_grey := {r}\<rparr>))" by blast
   from this ghg show ?rhs
     apply (clarsimp simp: grey_protects_white_def has_white_path_to_def if_distrib cong: if_cong)
     apply (rotate_tac 2)
     apply (induct rule: rtranclp.induct)
     apply (auto intro: rtranclp.intros(2))
     done
 next
   assume ?rhs then show ?lhs
   proof(safe)
     fix g assume "(g grey_protects_white w) s"
     with ghg show ?thesis
       apply (clarsimp simp: grey_protects_white_def has_white_path_to_def)
       apply (rotate_tac 2)
       apply (induct rule: rtranclp.induct)
       apply (auto intro: rtranclp.intros(2))
       done
   next
     assume "(r has_white_path_to w) s" with ghg show ?thesis
       by (auto simp: grey_protects_white_def has_white_path_to_def)
   qed
 qed
 
 (*>*)
 subsection\<open>Invariants\<close>
 
 text (in mut_m) \<open>
 
 We need phase invariants in terms of both @{const
 "mut_ghost_handshake_phase"} and @{const "sys_ghost_handshake_phase"}
 which respectively track what the mutators and GC know by virtue of
 the synchronisation structure of the system.
 
 Read the following as ``when mutator \<open>m\<close> is past the specified
 handshake, and has yet to reach the next one, ... holds.''
 
 \<close>
 
 primrec (in mut_m) mutator_phase_inv_aux :: "handshake_phase \<Rightarrow> ('field, 'mut, 'ref) lsts_pred" where
   "mutator_phase_inv_aux hp_Idle          = \<langle>True\<rangle>"
 | "mutator_phase_inv_aux hp_IdleInit      = no_black_refs"
 | "mutator_phase_inv_aux hp_InitMark      = marked_insertions"
 | "mutator_phase_inv_aux hp_Mark          = (marked_insertions \<^bold>\<and> marked_deletions)"
 | "mutator_phase_inv_aux hp_IdleMarkSweep = (marked_insertions \<^bold>\<and> marked_deletions \<^bold>\<and> reachable_snapshot_inv)"
 
 abbreviation (in mut_m) mutator_phase_inv :: "('field, 'mut, 'ref) lsts_pred" where
   "mutator_phase_inv s \<equiv> mutator_phase_inv_aux (mut_ghost_handshake_phase s) s"
 
 abbreviation mutators_phase_inv :: "('field, 'mut, 'ref) lsts_pred" where
   "mutators_phase_inv \<equiv> (\<^bold>\<forall>m. mut_m.mutator_phase_inv m)"
 
 text\<open>
 
 This is what the GC guarantees. Read this as ``when the GC is at or
 past the specified handshake, ... holds.''
 
 \<close>
 
 primrec sys_phase_inv_aux :: "handshake_phase \<Rightarrow> ('field, 'mut, 'ref) lsts_pred" where
   "sys_phase_inv_aux hp_Idle          = ( (If sys_fA \<^bold>= sys_fM Then black_heap Else white_heap) \<^bold>\<and> no_grey_refs )"
 | "sys_phase_inv_aux hp_IdleInit      = no_black_refs"
 | "sys_phase_inv_aux hp_InitMark      = (sys_fA \<^bold>\<noteq> sys_fM \<^bold>\<longrightarrow> no_black_refs)"
 | "sys_phase_inv_aux hp_Mark          = \<langle>True\<rangle>"
 | "sys_phase_inv_aux hp_IdleMarkSweep = ( (sys_phase \<^bold>= \<langle>ph_Idle\<rangle> \<^bold>\<or> tso_pending_write gc (mw_Phase ph_Idle)) \<^bold>\<longrightarrow> no_grey_refs )"
 
 abbreviation sys_phase_inv :: "('field, 'mut, 'ref) lsts_pred" where
   "sys_phase_inv s \<equiv> sys_phase_inv_aux (sys_ghost_handshake_phase s) s"
 (*<*)
 
 declare mut_m.mutator_phase_inv_aux.simps[simp]
 case_of_simps mutator_phase_inv_aux_case: mut_m.mutator_phase_inv_aux.simps
 case_of_simps sys_phase_inv_aux_case: sys_phase_inv_aux.simps
 
 lemma tso_pending_mutate_cong:
   "\<lbrakk> filter is_mw_Mutate (sys_mem_write_buffers p s) = filter is_mw_Mutate (sys_mem_write_buffers p s'); \<And>r f r'. P r f r' \<longleftrightarrow> Q r f r' \<rbrakk>
      \<Longrightarrow> (\<forall>r f r'. mw_Mutate r f r' \<in> set (sys_mem_write_buffers p s)  \<longrightarrow> P r f r') =
         (\<forall>r f r'. mw_Mutate r f r' \<in> set (sys_mem_write_buffers p s') \<longrightarrow> Q r f r')"
 apply (intro iff_allI)
 apply (auto dest!: arg_cong[where f=set])
 done
 
 lemma (in mut_m) marked_insertions_eq_imp:
   "eq_imp (\<lambda>(_::unit). sys_fM \<^bold>\<otimes> (\<lambda>s. Option.map_option obj_mark \<circ> sys_heap s) \<^bold>\<otimes> tso_pending_mutate (mutator m))
           marked_insertions"
 apply (clarsimp simp: eq_imp_def marked_insertions_def obj_at_def fun_eq_iff
                split: mem_write_action.splits)
 apply (erule tso_pending_mutate_cong)
 apply (clarsimp split: option.splits obj_at_splits)
 apply (rename_tac s s' opt x)
 apply (drule_tac x=x in spec)
 apply auto
 done
 
 lemmas marked_insertions_fun_upd[simp] = eq_imp_fun_upd[OF mut_m.marked_insertions_eq_imp, simplified eq_imp_simps, rule_format]
 
 lemma marked_insertionD[elim!]:
   "\<lbrakk> sys_mem_write_buffers (mutator m) s = mw_Mutate r f (Some r') # ws; mut_m.marked_insertions m s \<rbrakk>
      \<Longrightarrow> marked r' s"
 by (auto simp: mut_m.marked_insertions_def)
 
 lemma (in mut_m) marked_insertions_store_buffer_empty[intro]:
   "tso_pending_mutate (mutator m) s = [] \<Longrightarrow> marked_insertions s"
 by (auto simp: marked_insertions_def filter_empty_conv
         split: mem_write_action.splits option.splits)
 
 lemma (in mut_m) marked_insertions_blacken[simp]:
   "marked_insertions (s(gc := (s gc)\<lparr> W := gc_W s - {r} \<rparr>)) \<longleftrightarrow> marked_insertions s"
 by (clarsimp simp: marked_insertions_def
             split: mem_write_action.splits option.splits)
 
 lemma (in mut_m) marked_insertions_alloc[simp]:
   "\<lbrakk> heap (s sys) r' = None; valid_refs_inv s \<rbrakk>
   \<Longrightarrow> marked_insertions (s(mutator m' := s (mutator m')\<lparr>roots := roots'\<rparr>, sys := s sys\<lparr>heap := sys_heap s(r' \<mapsto> obj')\<rparr>))
   \<longleftrightarrow> marked_insertions s"
 apply (clarsimp simp: mut_m.marked_insertions_def split: mem_write_action.splits option.splits)
 apply (rule iffI)
  apply clarsimp
  apply (rename_tac ref field x)
  apply (drule_tac x=ref in spec, drule_tac x=field in spec, drule_tac x=x in spec, clarsimp)
  apply (drule valid_refs_invD(6)[where x=r' and y=r'], simp_all)
 done
 
 lemma marked_insertions_free[simp]:
   "\<lbrakk> mut_m.marked_insertions m s; white r s \<rbrakk>
      \<Longrightarrow> mut_m.marked_insertions m (s(sys := (s sys)\<lparr>heap := (heap (s sys))(r := None)\<rparr>))"
 by (fastforce simp: mut_m.marked_insertions_def split: mem_write_action.splits obj_at_splits option.splits)
 
 lemma (in mut_m) marked_deletions_eq_imp:
   "eq_imp (\<lambda>(_::unit). sys_fM \<^bold>\<otimes> sys_heap \<^bold>\<otimes> tso_pending_mutate (mutator m))
           marked_deletions"
 apply (clarsimp simp: eq_imp_def fun_eq_iff marked_deletions_def obj_at_field_on_heap_def)
 apply (rule iffI)
  apply (clarsimp split: mem_write_action.splits)
  apply (rename_tac s s' ref field option)
  apply (drule_tac x="mw_Mutate ref field option" in spec)
  apply (drule mp)
   apply (metis (lifting, full_types) filter_set member_filter)
  apply clarsimp
  apply (subst eq_impD[OF obj_at_eq_imp])
   prefer 2
   apply (fastforce cong: option.case_cong)
  apply clarsimp
 (* opposite dir *)
 apply (clarsimp split: mem_write_action.splits)
 apply (rename_tac s s' ref field option)
 apply (drule_tac x="mw_Mutate ref field option" in spec)
 apply (drule mp)
  apply (metis (lifting, full_types) filter_set member_filter)
 apply clarsimp
 apply (subst eq_impD[OF obj_at_eq_imp])
  prefer 2
  apply (fastforce cong: option.case_cong)
 apply clarsimp
 done
 
 lemmas marked_deletions_fun_upd[simp] = eq_imp_fun_upd[OF mut_m.marked_deletions_eq_imp, simplified eq_imp_simps, rule_format]
 
 lemma (in mut_m) marked_deletions_store_buffer_empty[intro]:
   "tso_pending_mutate (mutator m) s = [] \<Longrightarrow> marked_deletions s"
 by (auto simp: marked_deletions_def filter_empty_conv
         split: mem_write_action.splits)
 
 lemma (in mut_m) marked_deletions_alloc[simp]:
   "\<lbrakk> marked_deletions s; heap (s sys) r' = None; valid_refs_inv s \<rbrakk>
   \<Longrightarrow> marked_deletions (s(mutator m' := s (mutator m')\<lparr>roots := roots'\<rparr>, sys := s sys\<lparr>heap := sys_heap s(r' \<mapsto> obj')\<rparr>))"
 apply (clarsimp simp: marked_deletions_def split: mem_write_action.splits)
 apply (rename_tac ref field option)
 apply (drule_tac x="mw_Mutate ref field option" in spec)
 apply clarsimp
 apply (case_tac "ref = r'")
  apply (auto simp: obj_at_field_on_heap_def split: option.splits)
 done
 
 (*>*)
 
 subsection\<open> Mutator proofs \<close>
 
 lemma (in mut_m) reachable_snapshot_inv_hs_get_roots_done[simp]:
   assumes sti: "strong_tricolour_inv s"
   assumes m: "\<forall>r \<in> mut_roots s. marked r s"
   assumes ghr: "mut_ghost_honorary_root s = {}"
   assumes t: "tso_pending_mutate (mutator m) s = []"
   assumes vri: "valid_refs_inv s"
   shows "reachable_snapshot_inv
                (s(mutator m := s (mutator m)\<lparr>W := {}, ghost_handshake_phase := ghp'\<rparr>,
                   sys := s sys\<lparr>handshake_pending := hp', W := sys_W s \<union> mut_W s, ghost_handshake_in_sync := in'\<rparr>))"
   (is "reachable_snapshot_inv ?s'")
 proof(rule, clarsimp)
   fix r assume "reachable r s"
   then show "in_snapshot r ?s'"
   proof (induct rule: reachable_induct)
     case (root x) with m show ?case
       apply (clarsimp simp: in_snapshot_def simp del: fun_upd_apply) (* FIXME intro rules *)
       apply (auto dest: marked_imp_black_or_grey)
       done
   next
     case (ghost_honorary_root x) with ghr show ?case by simp
   next
     case (tso_root x) with t show ?case
       apply (clarsimp simp: filter_empty_conv tso_write_refs_def)
       apply (force split: mem_write_action.splits)
       done
   next
     case (reaches x y)
     from reaches vri have "valid_ref x s" "valid_ref y s" by auto
     with reaches sti vri show ?case
       apply (clarsimp simp: in_snapshot_def simp del: fun_upd_apply)
       apply (elim disjE)
        apply (clarsimp simp: strong_tricolour_inv_def)
        apply (drule spec[where x=x])
        apply clarsimp
        apply (auto dest!: marked_imp_black_or_grey)[1]
       apply (cases "white y s")
       apply (auto dest: grey_protects_whiteE
                  dest!: marked_imp_black_or_grey)
         done
     qed
 qed
 
 lemma (in mut_m) reachable_snapshot_inv_hs_get_work_done[simp]:
   "reachable_snapshot_inv s
     \<Longrightarrow> reachable_snapshot_inv
                (s(mutator m := s (mutator m)\<lparr>W := {}\<rparr>,
                    sys := s sys\<lparr>handshake_pending := (handshake_pending (s sys))(m := False), W := sys_W s \<union> mut_W s,
                                 ghost_handshake_in_sync := (ghost_handshake_in_sync (s sys))(m := True)\<rparr>))"
 by (simp add: reachable_snapshot_inv_def in_snapshot_def grey_protects_white_def)
 
 lemma (in mut_m) reachable_write_enqueue[simp]:
   "reachable r (s(sys := s sys\<lparr>mem_write_buffers := (mem_write_buffers (s sys))(mutator m := sys_mem_write_buffers (mutator m) s @ [w])\<rparr>))
   \<longleftrightarrow> reachable r s \<or> (\<exists>x. x \<in> write_refs w \<and> (x reaches r) s)"
 by (auto simp: reachable_def tso_write_refs_def)
 
 lemma no_black_refs_mo_co_mark[simp]:
   "\<lbrakk> ghost_honorary_grey (s p) = {}; white r s \<rbrakk>
      \<Longrightarrow> no_black_refs (s(p := s p\<lparr>ghost_honorary_grey := {r}\<rparr>)) \<longleftrightarrow> no_black_refs s"
 by (auto simp: no_black_refs_def)
 
 lemma (in mut_m) reachable_snapshot_inv_mo_co_mark[simp]:
   "\<lbrakk> ghost_honorary_grey (s p) = {}; reachable_snapshot_inv s \<rbrakk>
      \<Longrightarrow> reachable_snapshot_inv (s(p := s p\<lparr> ghost_honorary_grey := {r} \<rparr>))"
 by (auto simp: in_snapshot_def reachable_snapshot_inv_def)
 
 lemma (in mut_m) no_black_refs_alloc[simp]:
   "\<lbrakk> heap (s sys) r' = None; no_black_refs s \<rbrakk>
      \<Longrightarrow> no_black_refs (s(mutator m' := s (mutator m')\<lparr>roots := roots'\<rparr>, sys := s sys\<lparr>heap := sys_heap s(r' \<mapsto> \<lparr>obj_mark = fl, obj_fields = Map.empty\<rparr>)\<rparr>))
      \<longleftrightarrow> fl \<noteq> sys_fM s \<or> grey r' s"
 by (auto simp: no_black_refs_def)
 
 lemma (in mut_m) reachable_snapshot_inv_load[simp]:
   "\<lbrakk> reachable_snapshot_inv s; sys_read (mutator m) (mr_Ref r f) (s sys) = mv_Ref r'; r \<in> mut_roots s \<rbrakk>
      \<Longrightarrow> reachable_snapshot_inv (s(mutator m := s (mutator m)\<lparr> roots := mut_roots s \<union> Option.set_option r' \<rparr>))"
 by (simp add: reachable_snapshot_inv_def in_snapshot_def grey_protects_white_def)
 
 lemma (in mut_m) reachable_snapshot_inv_store_ins[simp]:
   "\<lbrakk> reachable_snapshot_inv s; r \<in> mut_roots s; (\<exists>r'. opt_r' = Some r') \<longrightarrow> the opt_r' \<in> mut_roots s \<rbrakk>
      \<Longrightarrow> reachable_snapshot_inv (s(mutator m := s (mutator m)\<lparr>ghost_honorary_root := {}\<rparr>,
                                   sys := s sys\<lparr>  mem_write_buffers := (mem_write_buffers (s sys))(mutator m := sys_mem_write_buffers (mutator m) s @ [mw_Mutate r f opt_r']) \<rparr>))"
 apply (clarsimp simp: reachable_snapshot_inv_def in_snapshot_def grey_protects_white_def)
 apply (drule_tac x=x in spec)
 apply (auto simp: reachable_def)
 done
 
 lemma (in mut_m) marked_insertions_store_ins[simp]:
   "\<lbrakk> marked_insertions s; (\<exists>r'. opt_r' = Some r') \<longrightarrow> marked (the opt_r') s \<rbrakk>
      \<Longrightarrow> marked_insertions
                (s(mutator m := s (mutator m)\<lparr>ghost_honorary_root := {}\<rparr>,
                    sys := s sys
                      \<lparr>mem_write_buffers := (mem_write_buffers (s sys))(mutator m := sys_mem_write_buffers (mutator m) s @ [mw_Mutate r f opt_r'])\<rparr>))"
 by (auto simp: marked_insertions_def
         split: mem_write_action.splits option.splits)
 
 lemma (in mut_m) marked_deletions_store_ins[simp]:
   "\<lbrakk> marked_deletions s; obj_at_field_on_heap (\<lambda>r'. marked r' s) r f s \<rbrakk>
      \<Longrightarrow> marked_deletions
                (s(mutator m := s (mutator m)\<lparr>ghost_honorary_root := {}\<rparr>,
                    sys := s sys
                      \<lparr>mem_write_buffers := (mem_write_buffers (s sys))(mutator m := sys_mem_write_buffers (mutator m) s @ [mw_Mutate r f opt_r'])\<rparr>))"
 by (auto simp: marked_deletions_def
         split: mem_write_action.splits option.splits)
 
 lemma (in mut_m) reachable_snapshot_inv_deref_del[simp]:
   "\<lbrakk> reachable_snapshot_inv s; sys_read (mutator m) (mr_Ref r f) (s sys) = mv_Ref opt_r'; r \<in> mut_roots s; mut_ghost_honorary_root s = {} \<rbrakk>
      \<Longrightarrow> reachable_snapshot_inv (s(mutator m := s (mutator m)\<lparr>ghost_honorary_root := Option.set_option opt_r', ref := opt_r'\<rparr>))"
 by (clarsimp simp: reachable_snapshot_inv_def in_snapshot_def grey_protects_white_def)
 
 lemma (in mut_m) mutator_phase_inv[intro]:
   "\<lbrace> handshake_invL
        \<^bold>\<and> mark_object_invL
        \<^bold>\<and> mut_get_roots.mark_object_invL m
        \<^bold>\<and> mut_store_del.mark_object_invL m
        \<^bold>\<and> mut_store_ins.mark_object_invL m
        \<^bold>\<and> LSTP (fA_rel_inv \<^bold>\<and> fM_rel_inv \<^bold>\<and> handshake_phase_inv \<^bold>\<and> mutators_phase_inv \<^bold>\<and> phase_rel_inv \<^bold>\<and> strong_tricolour_inv \<^bold>\<and> sys_phase_inv \<^bold>\<and> valid_refs_inv \<^bold>\<and> valid_W_inv) \<rbrace>
      mutator m
    \<lbrace> LSTP mutator_phase_inv \<rbrace>"
 apply (vcg_jackhammer dest!: handshake_phase_invD simp: fA_rel_inv_def fM_rel_inv_def;
        simp add: mutator_phase_inv_aux_case split: handshake_phase.splits if_splits)
 
 subgoal
  apply (drule_tac x=m in spec)
  apply (clarsimp simp: fM_rel_def hp_step_rel_def)
  apply (intro conjI impI; simp)
   apply (elim disjE; force simp: fA_rel_def) (* FIXME annoying: unfolding fA_rel early leads to non-termination *)
  apply (rule reachable_snapshot_inv_alloc, simp_all)
  apply (elim disjE; force simp: fA_rel_def) (* FIXME annoying: unfolding fA_rel early leads to non-termination *)
  done
 
 subgoal for s s'
  apply (drule_tac x=m in spec)
  apply (intro conjI impI)
    apply clarsimp
    apply (rule marked_deletions_store_ins, assumption) (* FIXME shuffle the following into this lemma *)
     apply (cases "(\<forall>opt_r'. mw_Mutate (mut_tmp_ref s\<down>) (mut_field s\<down>) opt_r' \<notin> set (sys_mem_write_buffers (mutator m) s\<down>))")
     apply force
    apply (force simp: marked_deletions_def)
   apply clarsimp
   apply (erule marked_insertions_store_ins)
   apply (drule phase_rel_invD)
   apply (clarsimp simp: phase_rel_def hp_step_rel_def; elim disjE; fastforce dest: reachable_blackD elim: blackD)
  apply clarsimp
  apply (rule marked_deletions_store_ins, assumption) (* FIXME as above *)
  apply clarsimp
  apply (erule disjE)
   apply (drule phase_rel_invD)
   apply (clarsimp simp: phase_rel_def)
   apply (elim disjE, simp_all)[1]
    apply (clarsimp simp: hp_step_rel_def)
   apply (clarsimp simp: hp_step_rel_def)
   apply (case_tac "sys_ghost_handshake_phase s\<down>", simp_all)[1] (* FIXME invert handshake_phase_rel *)
    apply (clarsimp simp: fA_rel_def fM_rel_def)
    apply (elim disjE, simp_all)[1]
    apply (clarsimp simp: obj_at_field_on_heap_def split: option.splits)
    apply (rule conjI)
     apply fast
    apply clarsimp
    apply (frule_tac r=x2a in blackD(1)[OF reachable_blackD], simp_all)[1]
    apply (rule_tac x="mut_tmp_ref s\<down>" in reachableE; auto simp: ran_def split: obj_at_splits; fail)
   apply (clarsimp simp: obj_at_field_on_heap_def split: option.splits)
   apply (rule conjI)
    apply fast
   apply clarsimp
   apply (frule_tac r=x2a in blackD(1)[OF reachable_blackD], simp_all)[1]
   apply (rule_tac x="mut_tmp_ref s\<down>" in reachableE; auto simp: ran_def split: obj_at_splits; fail)
  apply (force simp: marked_deletions_def)
  done
 
 (* hs_noop_done *)
 subgoal for s s'
  apply (drule_tac x=m in spec)
  apply (simp add: fA_rel_def fM_rel_def hp_step_rel_def)
  apply (cases "mut_ghost_handshake_phase s\<down>", simp_all)[1] (* FIXME invert handshake_step *)
  apply (erule marked_insertions_store_buffer_empty) (* FIXME simp? *)
  apply (erule marked_deletions_store_buffer_empty) (* FIXME simp? *)
  done
 
 (* hs_get_roots_done *)
 subgoal
  apply (drule_tac x=m in spec)
  apply (simp add: fA_rel_def fM_rel_def hp_step_rel_def)
  done
 
 (* hs_get_work_done *)
 subgoal
  apply (drule_tac x=m in spec)
  apply (simp add: fA_rel_def fM_rel_def hp_step_rel_def)
  done
 
 done
 
 lemma (in mut_m') mutator_phase_inv[intro]:
   notes mut_m.mark_object_invL_def[inv]
   notes mut_m.handshake_invL_def[inv]
   shows
   "\<lbrace> handshake_invL \<^bold>\<and> mut_m.handshake_invL m'
        \<^bold>\<and> mut_m.mark_object_invL m'
        \<^bold>\<and> mut_get_roots.mark_object_invL m'
        \<^bold>\<and> mut_store_del.mark_object_invL m'
        \<^bold>\<and> mut_store_ins.mark_object_invL m'
        \<^bold>\<and> LSTP (fA_rel_inv \<^bold>\<and> fM_rel_inv \<^bold>\<and> handshake_phase_inv \<^bold>\<and> mutators_phase_inv \<^bold>\<and> valid_refs_inv) \<rbrace>
      mutator m'
    \<lbrace> LSTP mutator_phase_inv \<rbrace>"
 apply (vcg_jackhammer simp: fA_rel_inv_def fM_rel_inv_def dest!: handshake_phase_invD)
 apply (simp_all add: mutator_phase_inv_aux_case split: handshake_phase.splits)
 
 apply (drule spec[where x=m])
 apply (intro conjI impI)
  apply (clarsimp simp: fA_rel_def fM_rel_def hp_step_rel_def)
  apply (elim disjE, auto)[1]
 
  apply (rule reachable_snapshot_inv_alloc, simp_all)[1]
  apply (clarsimp simp: fA_rel_def fM_rel_def hp_step_rel_def)
  apply (elim disjE, auto)[1]
 
 apply (drule spec[where x=m])
 apply (clarsimp simp: no_black_refs_def)
 apply (clarsimp simp: reachable_snapshot_inv_def in_snapshot_def)
 
 apply (drule spec[where x=m])
 apply (clarsimp simp: no_black_refs_def reachable_snapshot_inv_def in_snapshot_def grey_protects_white_def)
 
 done
 
 lemma (in sys) grey_protects_white_dequeue_mark[simp]:
   assumes fl: "fl = sys_fM s"
   assumes "r \<in> ghost_honorary_grey (s p)"
   shows "(\<exists>g. (g grey_protects_white w) (s(sys := s sys\<lparr>heap := (sys_heap s)(r := Option.map_option (obj_mark_update (\<lambda>_. fl)) (sys_heap s r)), mem_write_buffers := (mem_write_buffers (s sys))(p := ws)\<rparr>)))
       \<longleftrightarrow> (\<exists>g. (g grey_protects_white w) s)" (is "(\<exists>g. (g grey_protects_white w) ?s') \<longleftrightarrow> ?rhs")
 proof
   assume "\<exists>g. (g grey_protects_white w) ?s'"
   then obtain g where "(g grey_protects_white w) ?s'" by blast
   with assms show ?rhs
     apply (clarsimp simp: grey_protects_white_def has_white_path_to_def)
     apply (rotate_tac -1)
     apply (induct rule: rtranclp.induct)
      apply fastforce
     apply clarsimp
     apply (rename_tac a b c g)
     apply (case_tac "white c s")
      apply (rule_tac x=g in exI)
      apply clarsimp
      apply (erule rtranclp.intros)
      apply clarsimp
     apply (auto split: obj_at_splits if_splits)
     done
 next
   assume ?rhs
   then obtain g' where "(g' grey_protects_white w) s" by blast
   with assms show "\<exists>g. (g grey_protects_white w) ?s'"
     apply (clarsimp simp: grey_protects_white_def has_white_path_to_def)
     apply (rotate_tac -1)
     apply (induct rule: rtranclp.induct)
      apply (fastforce simp: grey_def)
     apply clarsimp
     apply (rename_tac a b c g)
     apply (case_tac "c = r")
      apply (clarsimp simp: grey_def)
      apply blast
     apply (rule_tac x=g in exI)
     apply clarsimp
     apply (erule rtranclp.intros)
     apply clarsimp
     done
 qed
 
 lemma (in sys) reachable_snapshot_inv_dequeue_mark[simp]:
   "\<lbrakk> sys_mem_write_buffers p s = mw_Mark r fl # ws; mut_m.reachable_snapshot_inv m s; valid_W_inv s \<rbrakk>
      \<Longrightarrow> mut_m.reachable_snapshot_inv m (s(sys := s sys\<lparr>heap := (sys_heap s)(r := Option.map_option (obj_mark_update (\<lambda>_. fl)) (sys_heap s r)), mem_write_buffers := (mem_write_buffers (s sys))(p := ws)\<rparr>))"
 apply (clarsimp simp: mut_m.reachable_snapshot_inv_def in_snapshot_def)
 apply (rename_tac x)
 apply (subst (asm) reachable_fun_upd, simp_all)[1]
  apply auto[1]
 apply (drule_tac x=x in spec)
 apply clarsimp
 apply (subst (asm) arg_cong[where f=Not, OF grey_protects_white_dequeue_mark, simplified], simp_all)
   apply blast
  apply blast
 apply blast
 done
 
 lemma (in sys) marked_insertions_dequeue_mark[simp]:
   "\<lbrakk> sys_mem_write_buffers p s = mw_Mark r fl # ws; mut_m.marked_insertions m s; tso_writes_inv s; valid_W_inv s \<rbrakk>
      \<Longrightarrow> mut_m.marked_insertions m (s(sys := s sys\<lparr>heap := (sys_heap s)(r := Option.map_option (obj_mark_update (\<lambda>_. fl)) (sys_heap s r)), mem_write_buffers := (mem_write_buffers (s sys))(p := ws)\<rparr>))"
 apply (clarsimp simp: mut_m.marked_insertions_def)
 apply (cases "mutator m = p")
  apply clarsimp
  apply (rename_tac x)
  apply (drule_tac x=x in spec)
  apply (auto split: mem_write_action.splits option.splits obj_at_splits)[1]
 apply clarsimp
 apply (rename_tac x)
 apply (drule_tac x=x in spec)
 apply (auto split: mem_write_action.splits option.splits obj_at_splits)[1]
 done
 
 lemma (in sys) marked_insertions_dequeue_ref[simp]:
   "\<lbrakk> sys_mem_write_buffers p s = mw_Mutate r f r' # ws; mut_m.marked_insertions m s \<rbrakk>
      \<Longrightarrow> mut_m.marked_insertions m (s(sys := s sys\<lparr>heap := (sys_heap s)(r := Option.map_option (\<lambda>obj. obj\<lparr>obj_fields := (obj_fields obj)(f := r')\<rparr>) (sys_heap s r)),
                                                     mem_write_buffers := (mem_write_buffers (s sys))(p := ws)\<rparr>))"
 apply (clarsimp simp: mut_m.marked_insertions_def)
 apply (cases "mutator m = p")
  apply clarsimp
  apply (rename_tac x)
  apply (drule_tac x=x in spec)
  apply (auto split: mem_write_action.splits option.splits obj_at_splits)[1]
 apply clarsimp
 apply (rename_tac x)
 apply (drule_tac x=x in spec)
 apply (auto split: mem_write_action.splits option.splits obj_at_splits)[1]
 done
 
 (* redundant to fit with other rules. Perhaps want points_to with explicit witness for f? *)
 lemma points_to_mw_Mutate:
   "(x points_to y)
          (s(sys := (s sys)\<lparr> heap := (sys_heap s)(r := Option.map_option (\<lambda>obj :: ('field, 'ref) object. obj\<lparr>obj_fields := (obj_fields obj)(f := opt_r')\<rparr>) (sys_heap s r)),
                             mem_write_buffers := (mem_write_buffers (s sys))(p := ws) \<rparr>))
   \<longleftrightarrow> (r \<noteq> x \<and> (x points_to y) s) \<or> (r = x \<and> valid_ref r s \<and> (opt_r' = Some y \<or> ( (x points_to y) s \<and> obj_at (\<lambda>obj. \<exists>f'. obj_fields obj f' = Some y \<and> f \<noteq> f') r s)))"
 by (auto simp: ran_def split: obj_at_splits)
 
 (* shows the snapshot is preserved by the two marks. *)
 lemma (in sys) grey_protects_white_dequeue_ref[simp]:
   assumes sb: "sys_mem_write_buffers (mutator m) s = mw_Mutate r f opt_r' # ws"
   assumes mi: "mut_m.marked_insertions m s"
   assumes md: "mut_m.marked_deletions m s"
   notes map_option.compositionality[simp] o_def[simp]
   shows "(\<exists>g. (g grey_protects_white w) (s(sys := s sys\<lparr>heap := (sys_heap s)(r := Option.map_option (\<lambda>obj. obj\<lparr>obj_fields := (obj_fields obj)(f := opt_r')\<rparr>) (sys_heap s r)),
                                                         mem_write_buffers := (mem_write_buffers (s sys))(mutator m := ws)\<rparr>)))
       \<longleftrightarrow> (\<exists>g. (g grey_protects_white w) s)" (is "(\<exists>g. (g grey_protects_white w) ?s') \<longleftrightarrow> ?rhs")
 proof
   assume "(\<exists>g. (g grey_protects_white w) ?s')"
   then obtain g where "(g grey_protects_white w) ?s'" by blast
   with mi sb show ?rhs
     apply (clarsimp simp: grey_protects_white_def has_white_path_to_def)
     apply (rotate_tac -1)
     apply (induct rule: rtranclp.induct)
      apply fastforce
     apply (auto simp: points_to_mw_Mutate elim: rtranclp.intros(2))
     apply (rename_tac a c g)
     apply (clarsimp simp: mut_m.marked_insertions_def) (* FIXME rule *)
     apply (drule_tac x="mw_Mutate r f (Some c)" in spec)
     apply (simp split: obj_at_splits)
     done
 next
   assume ?rhs then show "(\<exists>g. (g grey_protects_white w) ?s')"
   proof(clarsimp)
     fix g assume "(g grey_protects_white w) s"
     with md sb show ?thesis
       apply (clarsimp simp: grey_protects_white_def has_white_path_to_def)
       apply (rotate_tac -1)
       apply (induct rule: rtranclp.induct)
        apply fastforce
       apply clarsimp
       apply (rename_tac a b c g)
 
       apply (case_tac "b = r")
        defer
        apply (auto simp: points_to_mw_Mutate elim: rtranclp.intros(2))[1]
       apply clarsimp
       apply (subst (asm) (3) obj_at_def) (* FIXME rule: witness field for r points_to c *)
       apply (clarsimp simp: ran_def split: option.splits)
       apply (rename_tac a c g x2 aa)
       apply (case_tac "aa = f")
        defer
        apply (rule_tac x=g in exI)
        apply clarsimp
        apply (erule rtranclp.intros)
        apply (auto split: obj_at_splits)[1]
       apply clarsimp
 
       apply (clarsimp simp: mut_m.marked_deletions_def) (* FIXME rule *)
       apply (drule spec[where x="mw_Mutate r f opt_r'"])
       apply (clarsimp simp: obj_at_field_on_heap_def)
       apply (simp split: obj_at_splits)
       done
   qed
 qed
 
 (* write barrier installed but not all mutators are necessarily past get_roots *)
 lemma (in sys) reachable_snapshot_inv_dequeue_ref[simp]:
   fixes s :: "('field, 'mut, 'ref) lsts"
   assumes sb: "sys_mem_write_buffers (mutator m') s = mw_Mutate r f opt_r' # ws"
   assumes mi: "mut_m.marked_insertions m' s"
   assumes md: "mut_m.marked_deletions m' s"
   assumes rsi: "mut_m.reachable_snapshot_inv m s"
   assumes sti: "strong_tricolour_inv s"
   assumes vri: "valid_refs_inv s"
   notes map_option.compositionality[simp] o_def[simp]
   shows "mut_m.reachable_snapshot_inv m (s(sys := s sys\<lparr>heap := (sys_heap s)(r := Option.map_option (\<lambda>obj. obj\<lparr>obj_fields := (obj_fields obj)(f := opt_r')\<rparr>) (sys_heap s r)),
                                                         mem_write_buffers := (mem_write_buffers (s sys))(mutator m' := ws)\<rparr>))" (is "mut_m.reachable_snapshot_inv m ?s'")
 proof(rule mut_m.reachable_snapshot_invI)
   fix y assume y: "mut_m.reachable m y ?s'"
   then have "(mut_m.reachable m y s \<or> mut_m.reachable m' y s) \<and> in_snapshot y ?s'"
   proof(induct rule: reachable_induct)
     case (root x) with mi md rsi sb show ?case
       apply (clarsimp simp: mut_m.reachable_snapshot_inv_def in_snapshot_def
                   simp del: fun_upd_apply)
       apply auto
       done
   next
     case (ghost_honorary_root x) with mi md rsi sb show ?case
       apply (clarsimp simp: mut_m.reachable_snapshot_inv_def in_snapshot_def
                   simp del: fun_upd_apply)
       apply auto
       done
   next
     case (tso_root x) with mi md rsi sb show ?case
       apply (clarsimp simp: mut_m.reachable_snapshot_inv_def in_snapshot_def
                   simp del: fun_upd_apply)
       apply (clarsimp split: if_splits)
        apply (rename_tac xa)
        apply (case_tac xa, simp_all)[1]
        apply (rename_tac ref field option)
        apply (clarsimp simp: mut_m.marked_deletions_def mut_m.marked_insertions_def)
        apply (drule_tac x="mw_Mutate ref field option" in spec)
        apply (drule_tac x="mw_Mutate ref field option" in spec)
        apply clarsimp
        apply (frule spec[where x=x])
        apply (subgoal_tac "mut_m.reachable m x s")
         apply force
        apply (rule reachableI(2))
        apply (force simp: mut_m.tso_write_refs_def)
       apply auto
       done
   next
     case (reaches x y)
     from reaches sb have y: "mut_m.reachable m y s \<or> mut_m.reachable m' y s"
       apply (clarsimp simp: points_to_mw_Mutate mut_m.reachable_snapshot_inv_def in_snapshot_def)
       apply (elim disjE, (force dest!: reachableE mutator_reachable_tso)+)[1]
       done
     moreover
     from y vri have "valid_ref y s" by auto
     with reaches mi md rsi sb sti y have "(black y s \<or> (\<exists>x. (x grey_protects_white y) s))"
       apply (clarsimp simp: mut_m.reachable_snapshot_inv_def in_snapshot_def
                   simp del: fun_upd_apply)
       apply clarsimp
       apply (drule spec[where x=y])
       apply (clarsimp simp: points_to_mw_Mutate mut_m.marked_insertions_def mut_m.marked_deletions_def) (* FIXME lemmas *)
       apply (drule spec[where x="mw_Mutate r f opt_r'"])+
       apply clarsimp
       apply (elim disjE, simp_all) (* FIXME probably want points_to_mw_Mutate as an elim rule to make this robust, reduce duplication *)
        apply (force dest!: reachableE)
        apply (force dest!: reachableE)
 
        apply clarsimp
        apply (drule (3) strong_tricolour_invD)
        apply (metis (no_types) grey_protects_whiteI marked_imp_black_or_grey(1))
 
        apply clarsimp
        apply (cases "white y s") (* FIXME lemma *)
         apply (drule (2) grey_protects_whiteE)
         apply blast
        apply (force simp: black_def split: obj_at_splits)
 
        apply clarsimp
        apply (elim disjE, simp_all)
         apply (force simp: black_def)
        apply clarsimp
        apply (drule (3) strong_tricolour_invD)
        apply (force simp: black_def)
 
        apply clarsimp
        apply (elim disjE, simp_all)
         apply (force simp: black_def)
        apply clarsimp
        apply (cases "white y s") (* FIXME lemma *)
         apply (drule (2) grey_protects_whiteE)
         apply blast
        apply (force simp: black_def split: obj_at_splits)
 
        apply clarsimp
        apply (elim disjE, simp_all)
         apply (force simp: black_def)
        apply clarsimp
        apply (drule (3) strong_tricolour_invD)
        apply (force simp: black_def)
 
        apply clarsimp
        apply (elim disjE, simp_all)
         apply (force simp: black_def)
        apply clarsimp
        apply (cases "white y s") (* FIXME lemma *)
         apply (drule (2) grey_protects_whiteE)
         apply blast
        apply (force simp: black_def split: obj_at_splits)
        done
     moreover note mi md rsi sb
     ultimately show ?case
       apply (clarsimp simp: mut_m.reachable_snapshot_inv_def in_snapshot_def
                   simp del: fun_upd_apply)
       apply clarsimp
       done
   qed
   then show "in_snapshot y ?s'" by blast
 qed
 
 lemma valid_refs_invI:
   "\<lbrakk> \<And>m x y. \<lbrakk> (x reaches y) s; x \<in> mut_m.mut_roots m s \<or> x \<in> mut_m.mut_ghost_honorary_root m s \<or> x \<in> mut_m.tso_write_refs m s \<or> grey x s \<rbrakk> \<Longrightarrow> valid_ref y s
    \<rbrakk> \<Longrightarrow> valid_refs_inv s"
 by (auto simp: valid_refs_inv_def mut_m.reachable_def grey_reachable_def)
 
 lemma black_heap_reachable:
   assumes "mut_m.reachable m y s"
   assumes bh: "black_heap s"
   assumes vri: "valid_refs_inv s"
   shows "black y s"
 using assms
 apply (induct rule: reachable_induct)
 apply (simp_all add: black_heap_def valid_refs_invD)
 apply (metis obj_at_weakenE reachableE valid_refs_inv_def)
 done
 
 lemma valid_refs_inv_dequeue_ref[simp]:
   notes map_option.compositionality[simp] o_def[simp]
   fixes s :: "('field, 'mut, 'ref) lsts"
   assumes vri: "valid_refs_inv s"
   assumes sb: "sys_mem_write_buffers (mutator m') s = mw_Mutate r f opt_r' # ws"
   shows "valid_refs_inv (s(sys := s sys\<lparr>heap := (sys_heap s)(r := Option.map_option (\<lambda>obj. obj\<lparr>obj_fields := (obj_fields obj)(f := opt_r')\<rparr>) (sys_heap s r)),
                                         mem_write_buffers := (mem_write_buffers (s sys))(mutator m' := ws)\<rparr>))" (is "valid_refs_inv ?s'")
 proof(rule valid_refs_invI)
   fix m
   let ?root = "\<lambda>m x (s::('field, 'mut, 'ref) lsts). x \<in> mut_m.mut_roots m s \<or> x \<in> mut_m.mut_ghost_honorary_root m s \<or> x \<in> mut_m.tso_write_refs m s \<or> grey x s"
   fix x y assume xy: "(x reaches y) ?s'" and x: "?root m x ?s'"
   from xy have "(\<exists>m x. ?root m x s \<and> (x reaches y) s) \<and> valid_ref y ?s'"
   proof induct
     case base with x sb vri show ?case
       apply -
       apply (subst obj_at_fun_upd)
        apply (auto simp: mut_m.tso_write_refs_def split: if_splits intro: valid_refs_invD(5)[where m=m])
       apply (metis list.set_intros(2) rtranclp.rtrancl_refl)
       done (* FIXME rules *)
   next
     case (step y z)
     with sb vri show ?case
       apply -
       apply (subst obj_at_fun_upd, clarsimp)
       apply (subst (asm) obj_at_fun_upd, fastforce)
       apply (clarsimp simp: points_to_mw_Mutate simp del: fun_upd_apply)
       apply (fastforce elim: rtranclp.intros(2) simp: mut_m.tso_write_refs_def intro: exI[where x=m'] valid_refs_invD(5)[where m=m'])
       done
    qed
   then show "valid_ref y ?s'" by blast
 qed
 
 declare map_option.compositionality[simp] o_def[simp]
 
 lemma (in sys) reachable_snapshot_inv_black_heap_no_grey_refs_dequeue_ref[simp]:
   assumes sb: "sys_mem_write_buffers (mutator m') s = mw_Mutate r f opt_r' # ws"
   assumes bh: "black_heap s"
   assumes ngr: "no_grey_refs s"
   assumes vri: "valid_refs_inv s"
   shows "mut_m.reachable_snapshot_inv m (s(sys := s sys\<lparr>heap := (sys_heap s)(r := Option.map_option (\<lambda>obj. obj\<lparr>obj_fields := (obj_fields obj)(f := opt_r')\<rparr>) (sys_heap s r)),
                                                         mem_write_buffers := (mem_write_buffers (s sys))(mutator m' := ws)\<rparr>))" (is "mut_m.reachable_snapshot_inv m ?s'")
 apply (rule mut_m.reachable_snapshot_invI)
 apply (rule in_snapshotI)
 apply (erule black_heap_reachable)
  using bh vri
  apply (simp add: black_heap_def)
 using bh ngr sb vri
 apply (subst valid_refs_inv_def)
 apply clarsimp
 apply (simp add: no_grey_refs_def grey_reachable_def)
 apply clarsimp
 apply (drule black_heap_reachable)
   apply (simp add: black_heap_def)
  apply clarsimp
 apply auto
 done
 
 lemma (in sys) marked_deletions_dequeue_mark[simp]:
   "\<lbrakk> sys_mem_write_buffers p s = mw_Mark r fl # ws; mut_m.marked_deletions m s; tso_writes_inv s; valid_W_inv s \<rbrakk>
      \<Longrightarrow> mut_m.marked_deletions m (s(sys := s sys\<lparr>heap := (sys_heap s)(r := Option.map_option (obj_mark_update (\<lambda>_. fl)) (sys_heap s r)), mem_write_buffers := (mem_write_buffers (s sys))(p := ws)\<rparr>))"
 apply (clarsimp simp: mut_m.marked_deletions_def)
 apply (cases "mutator m = p")
  apply clarsimp
  apply (rename_tac x)
  apply (drule_tac x=x in spec)
  apply (clarsimp split: mem_write_action.splits)
  apply (simp add: obj_at_field_on_heap_def cong: option.case_cong)
  apply (auto split: option.splits)[1]
 apply clarsimp
 apply (rename_tac x)
 apply (drule_tac x=x in spec)
 apply (clarsimp split: mem_write_action.splits)
 apply (simp add: obj_at_field_on_heap_def cong: option.case_cong)
 apply (auto split: option.splits)[1]
 done
 
 lemma (in sys) marked_deletions_dequeue_ref[simp]:
   "\<lbrakk> sys_mem_write_buffers (mutator m') s = mw_Mutate r f opt_r' # ws; mut_m.marked_deletions m s; mut_m.marked_insertions m' s \<rbrakk>
      \<Longrightarrow> mut_m.marked_deletions m (s(sys := s sys\<lparr>heap := (sys_heap s)(r := Option.map_option (\<lambda>obj. obj\<lparr>obj_fields := (obj_fields obj)(f := opt_r')\<rparr>) (sys_heap s r)),
                                                  mem_write_buffers := (mem_write_buffers (s sys))((mutator m') := ws)\<rparr>))"
 supply [[simproc del: defined_all]]
 apply (clarsimp simp: mut_m.marked_deletions_def)
 apply (cases "m = m'")
  apply clarsimp
  apply (rename_tac x)
  apply (drule_tac x=x in spec)
  apply (fastforce simp: obj_at_field_on_heap_def mut_m.marked_insertions_def split: mem_write_action.splits obj_at_splits option.splits)
 apply clarsimp
 apply (rename_tac x)
 apply (drule_tac x=x in spec)
 apply (fastforce simp: obj_at_field_on_heap_def mut_m.marked_insertions_def split: mem_write_action.splits obj_at_splits option.splits)
 done
 
 lemma (in sys) black_heap_marked_insertions_dequeue[simp]:
   "\<lbrakk> black_heap s; valid_refs_inv s \<rbrakk> \<Longrightarrow> mut_m.marked_insertions m s"
 by (auto simp: mut_m.marked_insertions_def black_heap_def black_def
         split: mem_write_action.splits option.splits
          dest: valid_refs_invD)
 
 lemma (in sys) mutator_phase_inv[intro]:
   "\<lbrace> LSTP (fA_rel_inv \<^bold>\<and> fM_rel_inv \<^bold>\<and> handshake_phase_inv \<^bold>\<and> mutators_phase_inv \<^bold>\<and> strong_tricolour_inv \<^bold>\<and> sys_phase_inv \<^bold>\<and> tso_writes_inv \<^bold>\<and> valid_refs_inv \<^bold>\<and> valid_W_inv) \<rbrace>
      sys
    \<lbrace> LSTP (mut_m.mutator_phase_inv m) \<rbrace>"
 apply vcg_nihe
 apply vcg_ni
 
 apply (clarsimp simp: fA_rel_inv_def fM_rel_inv_def mutator_phase_inv_aux_case p_not_sys hp_step_rel_def do_write_action_def
                split: handshake_phase.splits mem_write_action.splits)
 
 (* fM *)
 prefer 2
 apply (drule mut_m.handshake_phase_invD[where m=m])
 apply (erule disjE)
  apply (clarsimp simp: fM_rel_def hp_step_rel_def)
 apply clarsimp
 
 (* FIXME mess *)
 apply (frule mut_m.handshake_phase_invD[where m=m])
 apply (intro allI conjI impI)
   apply (erule disjE)
    apply auto[1]
   apply clarsimp
   apply (rename_tac s s' ws ref field option ma)
   apply (rule marked_deletions_dequeue_ref, simp_all)
   apply (drule_tac x=ma in spec)
   apply (frule_tac m=ma in mut_m.handshake_phase_invD, clarsimp simp: hp_step_rel_def)
   apply (elim disjE, simp_all)[1]
  apply (erule disjE)
   apply auto[1]
  apply clarsimp
  apply (rule marked_deletions_dequeue_ref, simp_all)
  apply (drule_tac x=ma in spec)
  apply (frule_tac m=ma in mut_m.handshake_phase_invD, clarsimp simp: hp_step_rel_def)
  apply (elim disjE, simp_all)[1]
  apply (clarsimp simp: fA_rel_def fM_rel_def if_splits)
  apply (elim disjE, simp_all)[1]
 
 apply (erule disjE, simp)
 apply (clarsimp simp: hp_step_rel_def)
 apply (frule_tac m=ma in mut_m.handshake_phase_invD, clarsimp simp: hp_step_rel_def)
 apply (elim disjE, simp_all split: if_splits)[1]
 apply (clarsimp simp: fA_rel_def fM_rel_def, blast)
 done
 
 (*>*)
 
 subsection\<open>The infamous termination argument.\<close>
 
 text\<open>
 
 We need to know that if the GC does not receive any further work to do
 at \<open>get_roots\<close> and \<open>get_work\<close>, then there are no grey
 objects left. Essentially this encodes the stability property that
 grey objects must exist for mutators to create grey objects.
 
 Note that this is not invariant across the scan: it is possible for
 the GC to hold all the grey references. The two handshakes transform
 the GC's local knowledge that it has no more work to do into a global
 property, or gives it more work.
 
 \<close>
 
 definition (in mut_m) gc_W_empty_mut_inv :: "('field, 'mut, 'ref) lsts_pred" where
   "gc_W_empty_mut_inv =
       ((EMPTY sys_W \<^bold>\<and> sys_ghost_handshake_in_sync m \<^bold>\<and> \<^bold>\<not>(EMPTY (WL (mutator m))))
    \<^bold>\<longrightarrow> (\<^bold>\<exists>m'. \<^bold>\<not>(sys_ghost_handshake_in_sync m') \<^bold>\<and> \<^bold>\<not>(EMPTY (WL (mutator m')))))"
 
 locset_definition (in -) gc_W_empty_locs :: "location set" where
   "gc_W_empty_locs \<equiv>
        idle_locs \<union> init_locs \<union> sweep_locs \<union> { ''mark_read_fM'', ''mark_write_fA'', ''mark_end'' }
      \<union> prefixed ''mark_noop''
      \<union> prefixed ''mark_loop_get_roots''
      \<union> prefixed ''mark_loop_get_work''"
 
 locset_definition "black_heap_locs = { ''sweep_idle'', ''idle_noop_mfence'', ''idle_noop_init_type'' }"
 locset_definition "no_grey_refs_locs = black_heap_locs \<union> sweep_locs \<union> {''mark_end''}"
 
 inv_definition (in gc) gc_W_empty_invL :: "('field, 'mut, 'ref) gc_pred" where
   "gc_W_empty_invL =
    (atS_gc (hs_get_roots_locs \<union> hs_get_work_locs)  (\<^bold>\<forall>m. mut_m.gc_W_empty_mut_inv m)
   \<^bold>\<and> at_gc ''mark_loop_get_roots_load_W''          (EMPTY sys_W \<^bold>\<longrightarrow> no_grey_refs)
   \<^bold>\<and> at_gc ''mark_loop_get_work_load_W''           (EMPTY sys_W \<^bold>\<longrightarrow> no_grey_refs)
   \<^bold>\<and> at_gc ''mark_loop''                           (EMPTY gc_W \<^bold>\<longrightarrow> no_grey_refs)
   \<^bold>\<and> atS_gc no_grey_refs_locs                      no_grey_refs
   \<^bold>\<and> atS_gc gc_W_empty_locs                        (EMPTY gc_W))"
 (*<*)
 
 lemma (in mut_m) gc_W_empty_mut_inv_eq_imp:
   "eq_imp (\<lambda>m'. sys_W \<^bold>\<otimes> WL (mutator m') \<^bold>\<otimes> sys_ghost_handshake_in_sync m')
           gc_W_empty_mut_inv"
 by (simp add: eq_imp_def gc_W_empty_mut_inv_def)
 
 lemmas gc_W_empty_mut_inv_fun_upd[simp] = eq_imp_fun_upd[OF mut_m.gc_W_empty_mut_inv_eq_imp, simplified eq_imp_simps, rule_format]
 
 lemma (in gc) gc_W_empty_invL_eq_imp:
   "eq_imp (\<lambda>(m', p) s. (AT s gc, s\<down> gc, sys_W s\<down>, WL p s\<down>, sys_ghost_handshake_in_sync m' s\<down>))
           gc_W_empty_invL"
 by (simp add: eq_imp_def gc_W_empty_invL_def mut_m.gc_W_empty_mut_inv_def no_grey_refs_def grey_def)
 
 lemmas gc_W_empty_invL_niE[nie] =
   iffD1[OF gc.gc_W_empty_invL_eq_imp[simplified eq_imp_simps, rule_format, unfolded conj_explode, rule_format], rotated -1]
 
 lemma get_roots_get_work_subseteq_gc_W_empty_locs:
   "hs_get_roots_locs \<union> hs_get_work_locs \<subseteq> gc_W_empty_locs"
 by (auto simp: hs_get_roots_locs_def hs_get_work_locs_def gc_W_empty_locs_def)
 
 lemma (in gc) gc_W_empty_mut_inv_handshake_init[iff]:
   "mut_m.gc_W_empty_mut_inv m (s(sys := s sys\<lparr>handshake_type := ht, ghost_handshake_in_sync := \<langle>False\<rangle>\<rparr>))"
   "mut_m.gc_W_empty_mut_inv m (s(sys := s sys\<lparr>handshake_type := ht, ghost_handshake_in_sync := \<langle>False\<rangle>, ghost_handshake_phase := hp' \<rparr>))"
 by (simp_all add: mut_m.gc_W_empty_mut_inv_def)
 
 lemma gc_W_empty_mut_inv_load_W:
   "\<lbrakk> \<forall>m. mut_m.gc_W_empty_mut_inv m s; \<forall>m. sys_ghost_handshake_in_sync m s; WL gc s = {}; WL sys s = {} \<rbrakk>
      \<Longrightarrow> no_grey_refs s"
 apply (clarsimp simp: mut_m.gc_W_empty_mut_inv_def no_grey_refs_def grey_def)
 apply (rename_tac x xa)
 apply (case_tac xa)
 apply (simp_all add: WL_def)
 done
 
 lemma (in gc) gc_W_empty_invL[intro]:
   "\<lbrace> handshake_invL \<^bold>\<and> obj_fields_marked_invL \<^bold>\<and> gc_W_empty_invL \<^bold>\<and> LSTP valid_W_inv \<rbrace>
      gc
    \<lbrace> gc_W_empty_invL \<rbrace>"
 apply vcg_jackhammer
 apply (auto elim: gc_W_empty_mut_inv_load_W simp: WL_def)
 done
 
 lemma (in sys) gc_gc_W_empty_invL[intro]:
   "\<lbrace> gc.gc_W_empty_invL \<rbrace> sys"
 by vcg_nihe
 
 lemma (in gc) handshake_get_rootsD:
   "\<lbrakk> atS gc hs_get_roots_locs s; handshake_invL s \<rbrakk> \<Longrightarrow> sys_ghost_handshake_phase s\<down> = hp_IdleMarkSweep \<and> sys_handshake_type s\<down> = ht_GetRoots"
 apply (simp add: handshake_invL_def)
 apply (elim conjE)
 apply (drule mp, erule atS_mono[OF _ hs_get_roots_locs_subseteq_hp_IdleMarkSweep_locs])
 apply simp
 done
 
 lemma (in gc) handshake_get_workD:
   "\<lbrakk> atS gc hs_get_work_locs s; handshake_invL s \<rbrakk> \<Longrightarrow> sys_ghost_handshake_phase s\<down> = hp_IdleMarkSweep \<and> sys_handshake_type s\<down> = ht_GetWork"
 apply (simp add: handshake_invL_def)
 apply (elim conjE)
 apply (drule mp, erule atS_mono[OF _ hs_get_work_locs_subseteq_hp_IdleMarkSweep_locs])
 apply simp
 done
 
 lemma (in gc) handshake_get_roots_get_workD:
   "\<lbrakk> atS gc (hs_get_roots_locs \<union> hs_get_work_locs) s; handshake_invL s \<rbrakk> \<Longrightarrow> sys_ghost_handshake_phase s\<down> = hp_IdleMarkSweep \<and> sys_handshake_type s\<down> \<in> {ht_GetWork, ht_GetRoots}"
 apply (simp add: handshake_invL_def)
 apply (elim conjE)
 apply (drule mp, rule atS_mono[OF _ iffD2[OF Un_subset_iff, unfolded conj_explode, OF hs_get_roots_locs_subseteq_hp_IdleMarkSweep_locs hs_get_work_locs_subseteq_hp_IdleMarkSweep_locs]], assumption)
 apply (auto simp: atS_un)
 done
 
 lemma no_grey_refs_locs_subseteq_hs_in_sync_locs:
   "no_grey_refs_locs \<subseteq> hs_in_sync_locs"
 by (auto simp: no_grey_refs_locs_def black_heap_locs_def hs_in_sync_locs_def hs_done_locs_def sweep_locs_def
          dest: prefix_same_cases)
 
 lemma (in mut_m) handshake_sweep_mark_endD:
   "\<lbrakk> atS gc no_grey_refs_locs s; gc.handshake_invL s; handshake_phase_inv s\<down> \<rbrakk>
      \<Longrightarrow> mut_ghost_handshake_phase s\<down> = hp_IdleMarkSweep \<and> All (ghost_handshake_in_sync (s\<down> sys))"
 apply (simp add: gc.handshake_invL_def)
 apply (elim conjE)
 apply (drule mp, erule atS_mono[OF _ no_grey_refs_locs_subseteq_hs_in_sync_locs])
 apply (drule handshake_phase_invD)
 apply (simp only: no_grey_refs_locs_def cong del: atS_state_cong)
 apply (clarsimp simp: atS_un)
 apply (elim disjE)
   apply (drule mp, erule atS_mono[where ls'="hp_IdleMarkSweep_locs"])
    apply (clarsimp simp: black_heap_locs_def loc)
   apply (clarsimp simp: hp_step_rel_def)
   apply blast
  apply (drule mp, erule atS_mono[where ls'="hp_IdleMarkSweep_locs"])
   apply (clarsimp simp: hp_IdleMarkSweep_locs_def hp_step_rel_def)
  apply (clarsimp simp: hp_step_rel_def)
  apply blast
 apply (clarsimp simp: atS_simps loc hp_step_rel_def)
 apply blast
 done
 
 lemma empty_WL_GC:
   "\<lbrakk> atS gc (hs_get_roots_locs \<union> hs_get_work_locs) s; gc.obj_fields_marked_invL s \<rbrakk> \<Longrightarrow> gc_ghost_honorary_grey s\<down> = {}"
 by (clarsimp simp: gc.obj_fields_marked_invL_def
             dest!: atS_mono[OF _ get_roots_get_work_subseteq_ghost_honorary_grey_empty_locs])
 
 (* think about showing gc_W_empty_invL instead *)
 lemma (in mut_m) gc_W_empty_mut_mo_co_mark[simp]:
   "\<lbrakk> \<forall>x. mut_m.gc_W_empty_mut_inv x s\<down>; mutators_phase_inv s\<down>;
      mut_ghost_honorary_grey s\<down> = {};
      r \<in> mut_roots s\<down> \<union> mut_ghost_honorary_root s\<down>; white r s\<down>;
      atS gc (hs_get_roots_locs \<union> hs_get_work_locs) s; gc.handshake_invL s; gc.obj_fields_marked_invL s;
      atS gc gc_W_empty_locs s \<longrightarrow> gc_W s\<down> = {};
      handshake_phase_inv s\<down>; valid_W_inv s\<down> \<rbrakk>
     \<Longrightarrow> mut_m.gc_W_empty_mut_inv m' (s\<down>(mutator m := s\<down> (mutator m)\<lparr>ghost_honorary_grey := {r}\<rparr>))"
 apply (frule (1) gc.handshake_get_roots_get_workD)
 apply (frule handshake_phase_invD)
 apply (clarsimp simp: hp_step_rel_def simp del: Un_iff)
 apply (elim disjE, simp_all)
    (* before get work *)
    apply (clarsimp simp: mut_m.gc_W_empty_mut_inv_def)
    apply blast
   (* past get work *)
   apply (clarsimp simp: mut_m.gc_W_empty_mut_inv_def)
   apply (frule spec[where x=m], clarsimp)
   apply (frule (2) reachable_snapshot_inv_white_root)
   apply clarsimp
   apply (drule grey_protects_whiteD)
   apply (clarsimp simp: grey_def)
   apply (rename_tac g x)
   apply (case_tac x, simp_all)
     (* Can't be the GC *)
     prefer 2
     apply (frule (1) empty_WL_GC)
     apply (drule mp, erule atS_mono[OF _ get_roots_get_work_subseteq_gc_W_empty_locs])
     apply (clarsimp simp: WL_def)
    (* Can't be sys *)
    prefer 2
    apply (clarsimp simp: WL_def)
   apply clarsimp
   apply (rename_tac g mut)
   apply (case_tac "sys_ghost_handshake_in_sync mut s\<down>")
    apply (drule mp, rule_tac x=mut in exI, clarsimp)
    apply blast
   apply (rule_tac x=mut in exI)
   apply clarsimp
  (* before get roots *)
  apply (clarsimp simp: mut_m.gc_W_empty_mut_inv_def)
  apply blast
 (* after get roots *)
 apply (clarsimp simp: mut_m.gc_W_empty_mut_inv_def)
 apply (frule spec[where x=m], clarsimp)
 apply (frule (2) reachable_snapshot_inv_white_root)
 apply clarsimp
 apply (drule grey_protects_whiteD)
 apply (clarsimp simp: grey_def)
 apply (rename_tac g x)
 apply (case_tac x, simp_all)
   (* Can't be the GC *)
   prefer 2
   apply (frule (1) empty_WL_GC)
   apply (drule mp, erule atS_mono[OF _ get_roots_get_work_subseteq_gc_W_empty_locs])
   apply (clarsimp simp: WL_def)
  (* Can't be sys *)
  prefer 2
  apply (clarsimp simp: WL_def)
 apply clarsimp
 apply (rename_tac g mut)
 apply (case_tac "sys_ghost_handshake_in_sync mut s\<down>")
  apply (drule mp, rule_tac x=mut in exI, clarsimp)
  apply blast
 apply (rule_tac x=mut in exI)
 apply clarsimp
 done (* FIXME common up *)
 
 lemma (in mut_m) no_grey_refs_mo_co_mark[simp]:
   "\<lbrakk> mutators_phase_inv s\<down>;
      no_grey_refs s\<down>;
      gc.handshake_invL s;
      at gc ''mark_loop'' s \<or> at gc ''mark_loop_get_roots_load_W'' s \<or> at gc ''mark_loop_get_work_load_W'' s \<or> atS gc no_grey_refs_locs s;
      r \<in> mut_roots s\<down> \<union> mut_ghost_honorary_root s\<down>; white r s\<down>;
      handshake_phase_inv s\<down> \<rbrakk>
     \<Longrightarrow> no_grey_refs (s\<down>(mutator m := s\<down> (mutator m)\<lparr>ghost_honorary_grey := {r}\<rparr>))"
 apply (elim disjE)
    apply (clarsimp simp: atS_simps gc.handshake_invL_def loc)
    apply (frule handshake_phase_invD)
    apply (clarsimp simp: hp_step_rel_def)
    apply (drule spec[where x=m])
    apply (clarsimp simp: conj_disj_distribR[symmetric])
    apply (drule (2) no_grey_refs_not_rootD)
    apply blast
   apply (clarsimp simp: atS_simps gc.handshake_invL_def loc)
   apply (frule handshake_phase_invD)
   apply (clarsimp simp: hp_step_rel_def)
   apply (drule spec[where x=m])
   apply (clarsimp simp: conj_disj_distribR[symmetric])
   apply (drule (2) no_grey_refs_not_rootD)
   apply blast
  apply (clarsimp simp: atS_simps gc.handshake_invL_def loc)
  apply (frule handshake_phase_invD)
  apply (clarsimp simp: hp_step_rel_def)
  apply (drule spec[where x=m])
  apply clarsimp
  apply (drule (2) no_grey_refs_not_rootD)
  apply blast
 apply (frule (2) handshake_sweep_mark_endD)
 apply (drule spec[where x=m])
 apply clarsimp
 apply (drule (2) no_grey_refs_not_rootD)
 apply blast
 done
 
 lemma (in mut_m) gc_W_empty_invL[intro]:
   notes gc.gc_W_empty_invL_def[inv]
   shows
   "\<lbrace> handshake_invL \<^bold>\<and> mark_object_invL \<^bold>\<and> tso_lock_invL
              \<^bold>\<and> mut_get_roots.mark_object_invL m
              \<^bold>\<and> mut_store_del.mark_object_invL m
              \<^bold>\<and> mut_store_ins.mark_object_invL m
            \<^bold>\<and> gc.handshake_invL \<^bold>\<and> gc.obj_fields_marked_invL
            \<^bold>\<and> gc.gc_W_empty_invL
              \<^bold>\<and> LSTP (handshake_phase_inv \<^bold>\<and> mutators_phase_inv \<^bold>\<and> valid_W_inv) \<rbrace>
      mutator m
    \<lbrace> gc.gc_W_empty_invL \<rbrace>"
 apply vcg_nihe
 (* apply vcg_ni -- very slow *)
 apply(tactic \<open>
 let val ctxt = @{context} in
 
   TRY (HEADGOAL (vcg_clarsimp_tac ctxt))
 THEN
   PARALLEL_ALLGOALS (
                vcg_sem_tac ctxt
          THEN' (TRY o SELECT_GOAL (Local_Defs.unfold_tac ctxt (Named_Theorems.get ctxt @{named_theorems inv})))
          THEN' (TRY o REPEAT_ALL_NEW (Tactic.match_tac ctxt @{thms conjI})) (* expose the location predicates, do not split the consequents *)
   THEN_ALL_NEW (TRY o REPEAT_ALL_NEW (Tactic.match_tac ctxt @{thms impI}))
                    (* Preserve the label sets in atS but normalise the label in at; turn s' into s *)
   THEN_ALL_NEW full_simp_tac ctxt (* FIXME vcg_ni uses asm_full_simp_tac here *)
   THEN_ALL_NEW (TRY o REPEAT_ALL_NEW (Tactic.ematch_tac ctxt @{thms conjE}))
                    (* The effect of vcg_pre: should be cheap *)
   THEN_ALL_NEW (TRY o REPEAT_ALL_NEW (Tactic.ematch_tac ctxt @{thms thin_locs} THEN' REPEAT1 o assume_tac ctxt))
   THEN_ALL_NEW asm_full_simp_tac (ss_only (@{thms loc_simps} @ Named_Theorems.get ctxt @{named_theorems loc}) ctxt)
   THEN_ALL_NEW (TRY o REPEAT_ALL_NEW (Rule_Insts.thin_tac ctxt "True" []))
   THEN_ALL_NEW clarsimp_tac ctxt)
 
 end
 \<close>)
 
 (* hs_noop_done *)
 apply (clarsimp simp: atS_un gc.handshake_invL_def)
 
 (* hs_get_roots_done: gc_W_empty *)
 apply (clarsimp simp: mut_m.gc_W_empty_mut_inv_def)
 apply (rule conjI)
  apply (clarsimp simp: WL_def)
 apply clarsimp
 apply (drule mp)
  apply blast
 apply (clarsimp simp: WL_def)
 apply (rename_tac xa)
 apply (rule_tac x=xa in exI)
 apply clarsimp
 
 (* hs_get_roots_done: no_grey_refs *)
 apply (simp add: no_grey_refs_def)
 apply (simp add: no_grey_refs_def)
 
 (* hs_get_work_done: gc_W_empty *)
 apply (clarsimp simp: mut_m.gc_W_empty_mut_inv_def)
 apply (rule conjI)
  apply (clarsimp simp: WL_def)
 apply clarsimp
 apply (drule mp)
  apply blast
 apply (clarsimp simp: WL_def)
 apply (rename_tac xa)
 apply (rule_tac x=xa in exI)
 apply clarsimp
 
 (* hs_get_work_done: no_grey_refs *)
 apply (simp add: no_grey_refs_def)
 apply (simp add: no_grey_refs_def)
 
 done
 
 (*>*)
 
 subsection\<open>Sweep loop invariants\<close>
 
 locset_definition "sweep_loop_locs = prefixed ''sweep_loop''"
 
 inv_definition (in gc) sweep_loop_invL :: "('field, 'mut, 'ref) gc_pred" where
   "sweep_loop_invL =
    (at_gc ''sweep_loop_check''        ( (\<^bold>\<not>(NULL gc_mark) \<^bold>\<longrightarrow> (\<lambda>s. obj_at (\<lambda>obj. Some (obj_mark obj) = gc_mark s) (gc_tmp_ref s) s))
                                       \<^bold>\<and> (  NULL gc_mark \<^bold>\<longrightarrow> valid_ref \<^bold>$ gc_tmp_ref \<^bold>\<longrightarrow> marked \<^bold>$ gc_tmp_ref ) )
   \<^bold>\<and> at_gc ''sweep_loop_free''         ( \<^bold>\<not>(NULL gc_mark) \<^bold>\<and> the \<circ> gc_mark \<^bold>\<noteq> gc_fM \<^bold>\<and> (\<lambda>s. obj_at (\<lambda>obj. Some (obj_mark obj) = gc_mark s) (gc_tmp_ref s) s) )
   \<^bold>\<and> at_gc ''sweep_loop_ref_done''     (valid_ref \<^bold>$ gc_tmp_ref \<^bold>\<longrightarrow> marked \<^bold>$ gc_tmp_ref)
   \<^bold>\<and> atS_gc sweep_loop_locs            (\<^bold>\<forall>r. \<^bold>\<not>(\<langle>r\<rangle> \<^bold>\<in> gc_refs) \<^bold>\<longrightarrow> valid_ref r \<^bold>\<longrightarrow> marked r)
   \<^bold>\<and> atS_gc black_heap_locs            (\<^bold>\<forall>r. valid_ref r \<^bold>\<longrightarrow> marked r)
   \<^bold>\<and> atS_gc (prefixed ''sweep_loop_'' - { ''sweep_loop_choose_ref'' }) (gc_tmp_ref \<^bold>\<in> gc_refs))"
 (*<*)
 
 lemma (in gc) sweep_loop_invL_eq_imp:
   "eq_imp (\<lambda>(_::unit) (s :: ('field, 'mut, 'ref) gc_pred_state). (AT s gc, s\<down> gc, sys_fM s\<down>, Option.map_option obj_mark \<circ> sys_heap s\<down>))
           sweep_loop_invL"
 apply (clarsimp simp: eq_imp_def inv)
 apply (rename_tac s s')
 apply (subgoal_tac "\<forall>r. valid_ref r s\<down> \<longleftrightarrow> valid_ref r s'\<down>")
  apply (subgoal_tac "\<forall>P r. obj_at (\<lambda>obj. P (obj_mark obj)) r s\<down> \<longleftrightarrow> obj_at (\<lambda>obj. P (obj_mark obj)) r s'\<down>")
   apply (frule_tac x="\<lambda>mark. Some mark = gc_mark s'\<down>" in spec)
   apply (frule_tac x="\<lambda>mark. mark = sys_fM s'\<down>" in spec)
   apply clarsimp
  apply (clarsimp simp: fun_eq_iff split: obj_at_splits)
  apply (rename_tac r)
  apply ( (drule_tac x=r in spec)+, auto)[1]
 apply (clarsimp simp: fun_eq_iff split: obj_at_splits)
 apply (rename_tac r)
 apply (drule_tac x=r in spec, auto)[1]
 apply (metis map_option_eq_Some)+
 done
 
 lemmas gc_sweep_loop_invL_niE[nie] =
   iffD1[OF gc.sweep_loop_invL_eq_imp[simplified eq_imp_simps, rule_format, unfolded conj_explode, rule_format], rotated -1]
 
 lemma (in gc) sweep_loop_invL[intro]:
   "\<lbrace> fM_fA_invL \<^bold>\<and> phase_invL \<^bold>\<and> sweep_loop_invL \<^bold>\<and> tso_lock_invL
          \<^bold>\<and> LSTP (phase_rel_inv \<^bold>\<and> mutators_phase_inv \<^bold>\<and> valid_W_inv) \<rbrace>
      gc
    \<lbrace> sweep_loop_invL \<rbrace>"
 apply (vcg_jackhammer simp: no_grey_refs_def phase_rel_inv_def phase_rel_def)
 
 apply (rename_tac s s' x)
 apply (case_tac "x \<in> gc_refs s\<down>")
  apply force
 apply blast
 
 apply (clarsimp split: obj_at_splits)
 done
 
 lemma sweep_loop_sweep_locs[iff]:
   "sweep_loop_locs \<subseteq> sweep_locs"
 by (auto simp: sweep_loop_locs_def sweep_locs_def intro: append_prefixD)
 
 lemma sweep_locs_subseteq_fM_tso_empty_locs[iff]:
   "sweep_locs \<subseteq> fM_tso_empty_locs"
 by (auto simp: sweep_locs_def fM_tso_empty_locs_def)
 
 lemma sweep_loop_locs_fM_eq_locs:
   "sweep_loop_locs \<subseteq> fM_eq_locs"
 by (auto simp: sweep_loop_locs_def fM_eq_locs_def sweep_locs_def)
 
 lemma sweep_loop_locs_fA_eq_locs:
   "sweep_loop_locs \<subseteq> fA_eq_locs"
 apply (simp add: sweep_loop_locs_def fA_eq_locs_def sweep_locs_def)
 apply (intro subset_insertI2)
 apply (auto intro: append_prefixD)
 done
 
 lemma black_heap_locs_subseteq_fM_tso_empty_locs[iff]:
   "black_heap_locs \<subseteq> fM_tso_empty_locs"
 by (auto simp: black_heap_locs_def fM_tso_empty_locs_def)
 
 lemma black_heap_locs_fM_eq_locs:
   "black_heap_locs \<subseteq> fM_eq_locs"
 by (simp add: black_heap_locs_def fM_eq_locs_def)
 
 lemma black_heap_locs_fA_eq_locs:
   "black_heap_locs \<subseteq> fA_eq_locs"
 by (simp add: black_heap_locs_def fA_eq_locs_def sweep_locs_def)
 
 lemma (in gc) fM_invL_tso_emptyD:
   "\<lbrakk> atS gc ls s; fM_fA_invL s; ls \<subseteq> fM_tso_empty_locs \<rbrakk> \<Longrightarrow> tso_pending_fM gc s\<down> = []"
 by (auto simp: fM_fA_invL_def dest: atS_mono)
 
 lemma gc_sweep_loop_invL_locsE[rule_format]:
   "(atS gc (sweep_locs \<union> black_heap_locs) s \<longrightarrow> False) \<Longrightarrow> gc.sweep_loop_invL s"
 apply (simp add: gc.sweep_loop_invL_def atS_un)
 apply (auto simp: loc atS_simps dest: atS_mono)
 apply (clarsimp simp: atS_def)
 apply (rename_tac x)
 apply (drule_tac x=x in bspec)
 apply (auto simp: sweep_locs_def intro: append_prefixD)
 done
 
 lemma (in sys) gc_sweep_loop_invL[intro]:
   "\<lbrace> gc.fM_fA_invL \<^bold>\<and> gc.gc_W_empty_invL \<^bold>\<and> gc.handshake_invL \<^bold>\<and> gc.phase_invL \<^bold>\<and> gc.sweep_loop_invL
        \<^bold>\<and> LSTP (mutators_phase_inv \<^bold>\<and> tso_writes_inv \<^bold>\<and> valid_W_inv) \<rbrace>
      sys
    \<lbrace> gc.sweep_loop_invL \<rbrace>"
 apply vcg_nihe
 apply vcg_ni
 apply (clarsimp simp: do_write_action_def
                split: mem_write_action.splits
                 elim: gc_sweep_loop_invL_niE) (* FIXME elimination rule using tso_writes_inv *)
 
 (* mw_Mark *)
 apply (rename_tac s s' p ws ref bool)
 apply (rule gc_sweep_loop_invL_locsE)
 apply (simp only: gc.gc_W_empty_invL_def no_grey_refs_locs_def cong del: atS_state_cong)
 apply (clarsimp simp: atS_un)
 apply (erule disjE)
  apply clarsimp
  apply (drule (1) no_grey_refs_no_pending_marks)
  apply (clarsimp simp: filter_empty_conv)
  apply (drule_tac x=p in spec)
  apply fastforce
 apply clarsimp
 apply (drule (1) no_grey_refs_no_pending_marks)
 apply (clarsimp simp: filter_empty_conv)
 apply (drule_tac x=p in spec)
 apply fastforce
 
 (* mw_Mutate *)
 apply (erule gc_sweep_loop_invL_niE, simp_all add: fun_eq_iff)[1] (* FIXME should be automatic *)
 
 (* mw_fA *)
 apply (erule gc_sweep_loop_invL_niE, simp_all add: fun_eq_iff)[1] (* FIXME should be automatic *)
 
 (* mw_fM *)
 apply (rename_tac s s' p ws bool)
 apply (rule gc_sweep_loop_invL_locsE)
 apply (case_tac p, clarsimp+)
 apply (drule (1) gc.fM_invL_tso_emptyD)
 apply simp_all
 
 (* mv_Phase *)
 apply (erule gc_sweep_loop_invL_niE, simp_all add: fun_eq_iff)[1] (* FIXME should be automatic *)
 
 done (* FIXME weird: expect more aggressive use of gc_sweep_loop_invL_niE by clarsimp *)
 
 lemma (in mut_m) gc_sweep_loop_invL[intro]:
   "\<lbrace> gc.fM_fA_invL \<^bold>\<and> gc.handshake_invL \<^bold>\<and> gc.sweep_loop_invL
        \<^bold>\<and> LSTP (mutators_phase_inv \<^bold>\<and> valid_refs_inv) \<rbrace>
      mutator m
    \<lbrace> gc.sweep_loop_invL \<rbrace>"
 apply vcg_nihe
 apply vcg_ni
 apply (clarsimp simp: inv gc.sweep_loop_invL_def gc.fM_fA_invL_def)
 apply (intro allI conjI impI)
  (* four subgoals *)
  apply ((erule (1) thin_locs)+)[1]
  apply (force simp: loc)
 
  apply ((erule (1) thin_locs)+)[1]
  apply (force simp: loc)
 
  apply (rename_tac s s' ra)
  apply (drule mp, erule atS_mono[OF _ sweep_loop_locs_fA_eq_locs])
  apply (drule mp, erule atS_mono[OF _ sweep_loop_locs_fM_eq_locs])
  apply force
 
  apply (rename_tac s s' ra)
  apply (drule mp, erule atS_mono[OF _ black_heap_locs_fA_eq_locs])
  apply (drule mp, erule atS_mono[OF _ black_heap_locs_fM_eq_locs])
  apply force
 done (* FIXME crappy split *)
 
 lemma (in gc) sys_phase_inv[intro]:
   "\<lbrace> fM_fA_invL \<^bold>\<and> gc_W_empty_invL \<^bold>\<and> handshake_invL \<^bold>\<and> obj_fields_marked_invL
        \<^bold>\<and> phase_invL \<^bold>\<and> sweep_loop_invL
        \<^bold>\<and> LSTP (phase_rel_inv \<^bold>\<and> sys_phase_inv \<^bold>\<and> valid_W_inv \<^bold>\<and> tso_writes_inv) \<rbrace>
      gc
    \<lbrace> LSTP sys_phase_inv \<rbrace>"
 apply vcg_jackhammer
 apply ( (erule black_heap_no_greys, simp)
       | fastforce dest!: phase_rel_invD simp: phase_rel_def filter_empty_conv )+
 done
 
 lemma (in gc) no_black_refs_sweep_loop_free[simp]:
   "no_black_refs s \<Longrightarrow> no_black_refs (s(sys := s sys\<lparr>heap := (sys_heap s)(gc_tmp_ref s := None)\<rparr>))"
 by (simp add: no_black_refs_def)
 
 lemma (in gc) no_black_refs_load_W[simp]:
   "\<lbrakk> no_black_refs s; gc_W s = {} \<rbrakk>
      \<Longrightarrow> no_black_refs (s(gc := s gc\<lparr>W := sys_W s\<rparr>, sys := s sys\<lparr>W := {}\<rparr>))"
 by (simp add: no_black_refs_def)
 
 lemma marked_deletions_sweep_loop_free[simp]:
   "\<lbrakk> mut_m.marked_deletions m s; mut_m.reachable_snapshot_inv m s; no_grey_refs s; white r s \<rbrakk>
      \<Longrightarrow> mut_m.marked_deletions m (s(sys := s sys\<lparr>heap := (sys_heap s)(r := None)\<rparr>))"
 apply (clarsimp simp: mut_m.marked_deletions_def split: mem_write_action.splits)
 apply (rename_tac ref field option)
 apply (drule_tac x="mw_Mutate ref field option" in spec)
 apply clarsimp
 apply (clarsimp simp: obj_at_field_on_heap_def split: option.splits)
  apply (rule conjI)
   apply (clarsimp simp: mut_m.reachable_snapshot_inv_def)
   apply (drule spec[where x=r], clarsimp simp: in_snapshot_def)
   apply (drule mp, auto simp: mut_m.reachable_def mut_m.tso_write_refs_def split: mem_write_action.splits)[1] (* FIXME rule *)
   apply (drule grey_protects_whiteD)
   apply (clarsimp simp: no_grey_refs_def)
  apply clarsimp
 apply (rule conjI)
  apply clarsimp
 apply clarsimp
 apply (rule conjI)
  apply (clarsimp simp: mut_m.reachable_snapshot_inv_def)
  apply (drule spec[where x=r], clarsimp simp: in_snapshot_def)
  apply (drule mp, auto simp: mut_m.reachable_def mut_m.tso_write_refs_def split: mem_write_action.splits)[1] (* FIXME rule *)
  apply (drule grey_protects_whiteD)
  apply (clarsimp simp: no_grey_refs_def)
 apply (clarsimp split: obj_at_splits)
 done
 
 lemma (in gc) mutator_phase_inv[intro]:
   "\<lbrace> fM_fA_invL \<^bold>\<and> gc_W_empty_invL \<^bold>\<and> handshake_invL \<^bold>\<and> obj_fields_marked_invL \<^bold>\<and> sweep_loop_invL
        \<^bold>\<and> gc_mark.mark_object_invL
        \<^bold>\<and> LSTP (handshake_phase_inv \<^bold>\<and> mutators_phase_inv \<^bold>\<and> tso_writes_inv \<^bold>\<and> valid_refs_inv \<^bold>\<and> valid_W_inv) \<rbrace>
      gc
    \<lbrace> LSTP (mut_m.mutator_phase_inv m) \<rbrace>"
 apply vcg_jackhammer
 apply (simp_all add: mutator_phase_inv_aux_case split: handshake_phase.splits)
 
 (* sweep_loop_free *)
 apply (intro allI conjI impI)
  apply (drule mut_m.handshake_phase_invD[where m=m], clarsimp simp: hp_step_rel_def)
 apply (rule mut_m.reachable_snapshot_inv_sweep_loop_free, simp_all)
 
 (* ''mark_loop_get_work_load_W'' *)
 apply clarsimp
 apply (drule spec[where x=m])
 apply (clarsimp simp: mut_m.reachable_snapshot_inv_def in_snapshot_def grey_protects_white_def) (* FIXME rule *)
 
 (* mark_loop_blacken *)
 apply (drule spec[where x=m])
 apply clarsimp
 apply (intro allI conjI impI)
  apply clarsimp
  apply (drule mut_m.handshake_phase_invD[where m=m], clarsimp simp: hp_step_rel_def)
 apply (clarsimp simp: mut_m.reachable_snapshot_inv_def in_snapshot_def grey_protects_white_def)
 apply (rename_tac s s' x)
 apply (drule_tac x=x in spec)
 apply clarsimp
 apply (rename_tac s s' x xa)
 apply (drule_tac x=xa in spec)
 apply clarsimp
 apply (rule obj_fields_marked_inv_has_white_path_to_blacken, simp_all)[1]
 
 (* mark_loop_mo_co_mark *)
 apply clarsimp
 apply (erule mut_m.reachable_snapshot_inv_mo_co_mark) (* FIXME hoist to the top level *)
 apply blast
 
 (* mark_loop_get_roots_load_W *)
 apply clarsimp
 apply (drule spec[where x=m])
 apply (clarsimp simp: mut_m.reachable_snapshot_inv_def in_snapshot_def grey_protects_white_def) (* FIXME rule *)
 
 done
 
 lemma (in mut_m) sys_phase_inv[intro]:
   "\<lbrace> handshake_invL
              \<^bold>\<and> mark_object_invL
              \<^bold>\<and> mut_get_roots.mark_object_invL m
              \<^bold>\<and> mut_store_del.mark_object_invL m
              \<^bold>\<and> mut_store_ins.mark_object_invL m
         \<^bold>\<and> LSTP (fA_rel_inv \<^bold>\<and> fM_rel_inv \<^bold>\<and> handshake_phase_inv \<^bold>\<and> mutators_phase_inv \<^bold>\<and> phase_rel_inv \<^bold>\<and> sys_phase_inv \<^bold>\<and> valid_refs_inv) \<rbrace>
      mutator m
    \<lbrace> LSTP sys_phase_inv \<rbrace>"
 apply (vcg_jackhammer simp: fA_rel_inv_def fM_rel_inv_def)
 apply (simp_all add: sys_phase_inv_aux_case heap_colours_colours
               split: handshake_phase.splits if_splits)
 
 (* alloc *)
 subgoal by (clarsimp simp: fA_rel_def fM_rel_def no_black_refs_def
                dest!: handshake_phase_invD phase_rel_invD
                split: handshake_phase.splits)
 
 (* store_ins_mo_co_mark *)
 subgoal by (fastforce simp: fA_rel_def fM_rel_def hp_step_rel_def
                 dest!: handshake_phase_invD phase_rel_invD)
 subgoal
   apply (drule spec[where x=m])
   apply (rule conjI)
    apply (clarsimp simp: hp_step_rel_def phase_rel_def conj_disj_distribR[symmetric]
                   dest!: handshake_phase_invD phase_rel_invD)
    apply (elim disjE, simp_all add: no_grey_refs_not_rootD)[1]
   apply (clarsimp simp: hp_step_rel_def phase_rel_def
                  dest!: handshake_phase_invD phase_rel_invD)
   apply (elim disjE, simp_all add: no_grey_refs_not_rootD)[1]
   apply clarsimp
   apply (elim disjE, simp_all add: no_grey_refs_not_rootD filter_empty_conv)[1]
   apply fastforce
   done
 
 (* store_del_mo_co_unlock *)
 subgoal by (fastforce simp: fA_rel_def fM_rel_def hp_step_rel_def
                 dest!: handshake_phase_invD phase_rel_invD)
 
 subgoal
   apply (drule spec[where x=m])
   apply (rule conjI)
    apply (clarsimp simp: hp_step_rel_def phase_rel_def conj_disj_distribR[symmetric] no_grey_refs_not_rootD
                   dest!: handshake_phase_invD phase_rel_invD)
   apply (clarsimp simp: hp_step_rel_def phase_rel_def
                  dest!: handshake_phase_invD phase_rel_invD)
   apply (elim disjE, simp_all add: no_grey_refs_not_rootD)[1]
   apply clarsimp
   apply (elim disjE, simp_all add: no_grey_refs_not_rootD filter_empty_conv)[1]
   apply fastforce
   done
 
 (* hs_get_roots_done *)
 subgoal by (clarsimp simp: hp_step_rel_def
                dest!: handshake_phase_invD phase_rel_invD)
 subgoal by (clarsimp simp: hp_step_rel_def
                dest!: handshake_phase_invD phase_rel_invD)
 subgoal by (clarsimp simp: hp_step_rel_def
                dest!: handshake_phase_invD phase_rel_invD)
 subgoal by (clarsimp simp: hp_step_rel_def
                dest!: handshake_phase_invD phase_rel_invD)
 subgoal
   apply (clarsimp simp: hp_step_rel_def phase_rel_def filter_empty_conv
                dest!: handshake_phase_invD phase_rel_invD)
   apply auto
   done
 
 (* hs_get_roots_loop_mo_co_mark *)
 subgoal by (clarsimp simp: hp_step_rel_def
                  dest!: handshake_phase_invD phase_rel_invD)
 subgoal
   apply (clarsimp simp: hp_step_rel_def phase_rel_def filter_empty_conv
                  dest!: handshake_phase_invD phase_rel_invD)
   apply auto
   done
 
 (* hs_get_work_done *)
 subgoal by (clarsimp simp: hp_step_rel_def
                dest!: handshake_phase_invD phase_rel_invD)
 subgoal by (clarsimp simp: hp_step_rel_def
                dest!: handshake_phase_invD phase_rel_invD)
 subgoal by (clarsimp simp: hp_step_rel_def
                dest!: handshake_phase_invD phase_rel_invD)
 subgoal by (clarsimp simp: hp_step_rel_def
                dest!: handshake_phase_invD phase_rel_invD)
 subgoal
   apply (clarsimp simp: hp_step_rel_def phase_rel_def filter_empty_conv
                dest!: handshake_phase_invD phase_rel_invD)
   apply auto
   done
 done
 
 lemma no_grey_refs_no_marks[simp]:
   "\<lbrakk> no_grey_refs s; valid_W_inv s \<rbrakk> \<Longrightarrow> \<not>sys_mem_write_buffers p s = mw_Mark r fl # ws"
 by (auto simp: no_grey_refs_def)
 
 context sys
 begin
 
 lemma black_heap_dequeue_mark[iff]:
   "\<lbrakk> sys_mem_write_buffers p s = mw_Mark r fl # ws; black_heap s; valid_W_inv s \<rbrakk>
    \<Longrightarrow> black_heap (s(sys := s sys\<lparr>heap := (sys_heap s)(r := Option.map_option (obj_mark_update (\<lambda>_. fl)) (sys_heap s r)), mem_write_buffers := (mem_write_buffers (s sys))(p := ws)\<rparr>))"
 by (auto simp: black_heap_def)
 
 lemma black_heap_dequeue_ref[iff]:
   "\<lbrakk> sys_mem_write_buffers p s = mw_Mutate r f r' # ws; black_heap s \<rbrakk>
      \<Longrightarrow> black_heap (s(sys := s sys\<lparr>heap := (sys_heap s)(r := Option.map_option (\<lambda>obj. obj\<lparr>obj_fields := (obj_fields obj)(f := r')\<rparr>) (sys_heap s r)),
                                    mem_write_buffers := (mem_write_buffers (s sys))(p := ws)\<rparr>))"
 by (simp add: black_heap_def black_def)
 
 lemma white_heap_dequeue_fM[iff]:
   "black_heap s\<down>
      \<Longrightarrow> white_heap (s\<down>(sys := s\<down> sys\<lparr>fM := \<not> sys_fM s\<down>, mem_write_buffers := (mem_write_buffers (s\<down> sys))(gc := ws)\<rparr>))"
 by (auto simp: black_heap_def white_heap_def)
 
 lemma black_heap_dequeue_fM[iff]:
   "\<lbrakk> white_heap s\<down>; no_grey_refs s\<down> \<rbrakk>
      \<Longrightarrow> black_heap (s\<down>(sys := s\<down> sys\<lparr>fM := \<not> sys_fM s\<down>, mem_write_buffers := (mem_write_buffers (s\<down> sys))(gc := ws)\<rparr>))"
 by (auto simp: black_heap_def white_heap_def no_grey_refs_def)
 
 lemma white_heap_dequeue_ref[iff]:
   "\<lbrakk> sys_mem_write_buffers p s = mw_Mutate r f r' # ws; white_heap s \<rbrakk>
      \<Longrightarrow> white_heap (s(sys := s sys\<lparr>heap := (sys_heap s)(r := Option.map_option (\<lambda>obj. obj\<lparr>obj_fields := (obj_fields obj)(f := r')\<rparr>) (sys_heap s r)),
                                    mem_write_buffers := (mem_write_buffers (s sys))(p := ws)\<rparr>))"
 by (simp add: white_heap_def)
 
 lemma (in sys) sys_phase_inv[intro]:
   "\<lbrace> LSTP (fA_rel_inv \<^bold>\<and> fM_rel_inv \<^bold>\<and> handshake_phase_inv \<^bold>\<and> mutators_phase_inv \<^bold>\<and> phase_rel_inv \<^bold>\<and> sys_phase_inv \<^bold>\<and> tso_writes_inv \<^bold>\<and> valid_W_inv) \<rbrace>
      sys
    \<lbrace> LSTP sys_phase_inv \<rbrace>"
 by (vcg_jackhammer simp: fA_rel_inv_def fM_rel_inv_def p_not_sys)
    (clarsimp simp: do_write_action_def sys_phase_inv_aux_case
                split: mem_write_action.splits handshake_phase.splits if_splits;
     erule disjE; clarsimp simp: fA_rel_def fM_rel_def; fail)
 
 end
 
 lemma valid_W_inv_unlockE[iff]:
   "\<lbrakk> sys_mem_lock s = Some p; sys_mem_write_buffers p s = [];
      \<And>r. r \<in> ghost_honorary_grey (s p) \<Longrightarrow> marked r s;
      valid_W_inv s
    \<rbrakk> \<Longrightarrow> valid_W_inv (s(sys := mem_lock_update Map.empty (s sys)))"
 unfolding valid_W_inv_def by clarsimp (metis emptyE empty_set)
 
 lemma valid_W_inv_mark:
   "\<lbrakk> sys_mem_lock s = Some p; white w s; valid_W_inv s \<rbrakk>
      \<Longrightarrow> w \<in> ghost_honorary_grey (s p) \<or> (\<forall>q. w \<notin> WL q s)"
 by (metis Un_iff WL_def marked_not_white option.inject valid_W_invD(1) valid_W_invD3(2))
 
 lemma (in gc) valid_W_inv[intro]:
   notes valid_W_invD2[dest!, simp]
   notes valid_W_invD3[dest, simp]
   shows
   "\<lbrace> fM_invL \<^bold>\<and> gc_mark.mark_object_invL \<^bold>\<and> gc_W_empty_invL
        \<^bold>\<and> obj_fields_marked_invL
        \<^bold>\<and> sweep_loop_invL \<^bold>\<and> tso_lock_invL
        \<^bold>\<and> LSTP (tso_writes_inv \<^bold>\<and> valid_W_inv) \<rbrace>
      gc
    \<lbrace> LSTP valid_W_inv \<rbrace>"
 apply (vcg_jackhammer simp: fM_rel_def)
 
 (* sweep loop free: what's with the case splitting? *)
 subgoal for s s'
   apply (subst valid_W_inv_def)
   apply (intro allI conjI impI; clarsimp simp: p_not_sys split: if_splits)
        apply blast
       apply blast
      apply blast
     apply blast
    apply (rename_tac p x)
    apply (case_tac p; auto)
   apply (rename_tac p)
   apply (case_tac p; force simp: no_grey_refs_def)
   done
 
 (* mark_loop_get_work_load_W *)
 subgoal by (subst valid_W_inv_def) (auto simp: all_conj_distrib split: process_name.splits)
 
 (* mark_loop_blacken *)
 subgoal by (subst valid_W_inv_def) (auto simp: all_conj_distrib)
 
 (* mark_loop_mo_co_W *)
 subgoal
   apply (subst valid_W_inv_def)
   apply clarsimp
   apply blast
   done
 
 (* mark_loop_mo_co_unlock *)
 subgoal
   apply (subst valid_W_inv_def)
   apply (clarsimp simp: all_conj_distrib)
   apply (intro allI conjI impI)
         apply blast
        apply blast
       apply (auto iff: p_not_sys split: if_splits)[1]
      apply blast
     apply blast
    apply blast
   apply force
   done
 
 (* mark_loop_mo_co_mark *)
 subgoal
   apply (subst valid_W_inv_def)
   apply (clarsimp simp: all_conj_distrib)
   apply (intro allI conjI impI)
                apply blast
               apply blast
              apply blast
             apply (frule (2) valid_W_inv_mark; auto)[1]
            apply (clarsimp dest!: valid_W_invD(1) split: obj_at_splits) (* FIXME want a cheaper contradiction between white and marked *)
           apply (clarsimp dest!: valid_W_invD(1) split: obj_at_splits)
          apply (clarsimp dest!: valid_W_invD(1) split: obj_at_splits)
         apply blast
        apply blast
       apply blast
      apply blast
     apply blast
    apply blast
   apply force
   done
 
 (* mark_loop_mo_co_lock *)
 subgoal
   apply (subst valid_W_inv_def)
   apply (auto simp: all_conj_distrib)
   done
 
 (* ''mark_loop_get_roots_load_W'' *)
 subgoal
   apply (subst valid_W_inv_def)
   apply (auto simp: all_conj_distrib split: process_name.splits)
   done
 
 done
 
 lemma (in mut_m) valid_W_inv[intro]:
   notes valid_W_invD2[dest!, simp]
   notes valid_W_invD3[dest, simp]
   shows
   "\<lbrace> handshake_invL \<^bold>\<and> mark_object_invL \<^bold>\<and> tso_lock_invL
       \<^bold>\<and> mut_get_roots.mark_object_invL m
       \<^bold>\<and> mut_store_del.mark_object_invL m
       \<^bold>\<and> mut_store_ins.mark_object_invL m
        \<^bold>\<and> LSTP (fM_rel_inv \<^bold>\<and> sys_phase_inv \<^bold>\<and> tso_writes_inv \<^bold>\<and> valid_refs_inv \<^bold>\<and> valid_W_inv) \<rbrace>
      mutator m
    \<lbrace> LSTP valid_W_inv \<rbrace>"
 apply (vcg_jackhammer simp: fM_rel_inv_def fM_rel_def)
 
 (* alloc *)
 subgoal
   apply (subst valid_W_inv_def)
   apply (clarsimp simp: all_conj_distrib)
   apply (intro allI conjI impI; auto)
   done
 
 (* store ins mo co W *)
 subgoal
   apply (subst valid_W_inv_def)
   apply clarsimp
   apply blast
   done
 
 (* store ins mo co unlock *)
 subgoal for s s' y
   apply (subst valid_W_inv_def)
   apply (clarsimp simp: all_conj_distrib)
   apply (intro allI conjI impI)
         subgoal by blast
        subgoal by blast
       subgoal for p x by (case_tac "p = mutator m"; force split: if_splits)
      subgoal by blast
     subgoal by blast
    subgoal by blast
   subgoal by force
   done
 
 (* store ins mo co mark *)
 subgoal
   apply (subst valid_W_inv_def)
   apply (clarsimp simp: all_conj_distrib)
   apply (intro allI conjI impI)
                subgoal by blast
               subgoal by blast
              subgoal by blast
             subgoal by (blast dest: valid_W_inv_mark)
            subgoal by (clarsimp dest!: valid_W_invD(1) split: obj_at_splits) (* FIXME want a cheaper contradiction between white and marked *)
           subgoal by (clarsimp dest!: valid_W_invD(1) split: obj_at_splits)
          subgoal by (clarsimp dest!: valid_W_invD(1) split: obj_at_splits)
         subgoal by blast
        subgoal by blast
       subgoal by blast
      subgoal by blast
     subgoal by blast
    subgoal by blast
   subgoal by force
   done
 
 (* store ins mo co lock *)
 subgoal
   apply (subst valid_W_inv_def)
   apply (clarsimp simp: all_conj_distrib)
   apply (intro allI conjI impI)
           subgoal by blast
          subgoal by blast
         subgoal by force
        subgoal by blast
       subgoal by blast
      subgoal by blast
     subgoal by force
    subgoal by blast
   subgoal by force
   done
 
 (* store del mo co W *)
 subgoal
   apply (subst valid_W_inv_def)
   apply clarsimp
   apply blast
   done
 
 (* store del mo co unlock *)
 subgoal for s s' y
   apply (subst valid_W_inv_def)
   apply (clarsimp simp: all_conj_distrib)
   apply (intro allI conjI impI)
         subgoal by blast
        subgoal by blast
       subgoal for p x by (cases "p = mutator m") (auto split: if_splits)
      subgoal by blast
     subgoal by blast
    subgoal by blast
   subgoal by force
   done
 
 (* store del mo co mark *)
 subgoal
   apply (subst valid_W_inv_def)
   apply (clarsimp simp: all_conj_distrib)
   apply (intro allI conjI impI)
                subgoal by blast
               subgoal by blast
              subgoal by blast
             subgoal by (frule (2) valid_W_inv_mark; auto)
            subgoal by (clarsimp dest!: valid_W_invD(1) split: obj_at_splits) (* FIXME want a cheaper contradiction between white and marked *)
           subgoal by (clarsimp dest!: valid_W_invD(1) split: obj_at_splits)
          subgoal by (clarsimp dest!: valid_W_invD(1) split: obj_at_splits)
         subgoal by blast
        subgoal by blast
       subgoal by blast
      subgoal by blast
     subgoal by blast
    subgoal by blast
   subgoal by force
   done
 
 (* store del mo co lock *)
 subgoal
   apply (subst valid_W_inv_def)
   apply (clarsimp simp: all_conj_distrib)
   apply (intro allI conjI impI)
           subgoal by blast
          subgoal by blast
         subgoal by force
        subgoal by blast
       subgoal by blast
      subgoal by blast
     subgoal by force
    subgoal by blast
   subgoal by force
   done
 
 (* get roots done *)
 subgoal
   apply (subst valid_W_inv_def)
   apply (clarsimp simp: all_conj_distrib)
   apply (intro allI conjI impI)
             subgoal by blast
            subgoal by blast
           subgoal by blast
          subgoal by blast
         subgoal by (auto split: if_splits obj_at_splits process_name.splits)
        subgoal by blast
       subgoal by blast
      subgoal by blast
     subgoal by (auto split: if_splits obj_at_splits process_name.splits)
    subgoal by blast
   subgoal by blast
   done
 
 (* hs get roots loop mo co W *)
 subgoal
   apply (subst valid_W_inv_def)
   apply clarsimp
   apply blast
   done
 
 (* hs get roots loop mo co unlock *)
 subgoal for s s' y
   apply (subst valid_W_inv_def)
   apply (clarsimp simp: all_conj_distrib)
   apply (intro allI conjI impI)
         subgoal by blast
        subgoal by blast
       subgoal for p x by (cases "p = mutator m") (auto split: if_splits)
      subgoal by blast
     subgoal by blast
    subgoal by blast
   subgoal by force
   done
 
 (* hs get roots loop mo co mark *)
 subgoal
   apply (subst valid_W_inv_def)
   apply (clarsimp simp: all_conj_distrib)
   apply (intro allI conjI impI)
                subgoal by blast
               subgoal by blast
              subgoal by blast
             subgoal by (frule (2) valid_W_inv_mark; auto)
            subgoal by (clarsimp dest!: valid_W_invD(1) split: obj_at_splits) (* FIXME want a cheaper contradiction between white and marked *)
           subgoal by (clarsimp dest!: valid_W_invD(1) split: obj_at_splits)
          subgoal by (clarsimp dest!: valid_W_invD(1) split: obj_at_splits)
         subgoal by blast
        subgoal by blast
       subgoal by blast
      subgoal by blast
     subgoal by blast
    subgoal by blast
   subgoal by force
   done
 
 (* hs get roots loop mo co lock *)
 subgoal
   apply (subst valid_W_inv_def)
   apply (clarsimp simp: all_conj_distrib)
   apply (intro allI conjI impI)
           subgoal by blast
          subgoal by blast
         subgoal by force
        subgoal by blast
       subgoal by blast
      subgoal by blast
     subgoal by force
    subgoal by blast
   subgoal by force
   done
 
 (* hs get work done *)
 subgoal
   apply (subst valid_W_inv_def)
   apply (clarsimp simp: all_conj_distrib)
   apply (intro allI conjI impI)
             subgoal by blast
            subgoal by blast
           subgoal by blast
          subgoal by blast
         subgoal by (auto split: if_splits obj_at_splits process_name.splits)
        subgoal by blast
       subgoal by blast
      subgoal by blast
     subgoal by force
    subgoal by blast
   subgoal by blast
   done
 
 done
 
 lemma (in sys) valid_W_inv[intro]:
   notes valid_W_invD2[dest!, simp]
   notes valid_W_invD3[dest, simp]
   notes valid_W_invD4[dest!, simp]
   notes o_def[simp]
   shows
   "\<lbrace> LSTP (fM_rel_inv \<^bold>\<and> sys_phase_inv \<^bold>\<and> tso_writes_inv \<^bold>\<and> valid_refs_inv \<^bold>\<and> valid_W_inv) \<rbrace>
      sys
    \<lbrace> LSTP valid_W_inv \<rbrace>"
 apply vcg_jackhammer
 apply (subst valid_W_inv_def)
 apply (clarsimp simp: do_write_action_def all_conj_distrib fM_rel_inv_def
                split: mem_write_action.splits)
 
 (* mw_Mark *)
 subgoal
   apply (intro allI conjI impI)
              apply blast
             apply blast
            apply blast
           apply blast
          apply blast
         apply force
        apply blast
       apply blast
      apply blast
     apply (force simp: filter_empty_conv)
    apply force
   apply blast
   done
 
 (* mw_Mutate, mw_fA *)
 subgoal by (intro allI conjI impI; auto)
 subgoal by (intro allI conjI impI; auto)
 
 (* mw_fM *)
 subgoal for s s' p ws bool
   apply (clarsimp simp: fM_rel_def)
   apply (rule disjE[OF iffD1[OF p_not_sys]], assumption)
    prefer 2
    apply clarsimp
   apply (case_tac "sys_ghost_handshake_phase s\<down> = hp_Idle"; clarsimp)
   apply (intro allI conjI impI)
             subgoal by blast
            subgoal by blast
           subgoal by blast
          subgoal by blast
         subgoal by blast
        subgoal by force
       subgoal by (force dest: no_grey_refs_no_pending_marks)
      subgoal by blast
     subgoal by force
    subgoal by (fastforce dest: no_grey_refs_no_pending_marks)
   subgoal by (fastforce dest: no_grey_refs_no_pending_marks)
   done
 
 (* mw_Phase *)
 apply (intro allI conjI impI; auto)
 done
 
 lemma (in gc) strong_tricolour_inv[intro]:
   "\<lbrace> fM_fA_invL \<^bold>\<and> gc_W_empty_invL \<^bold>\<and> gc_mark.mark_object_invL \<^bold>\<and> obj_fields_marked_invL \<^bold>\<and> sweep_loop_invL
        \<^bold>\<and> LSTP (strong_tricolour_inv \<^bold>\<and> tso_writes_inv \<^bold>\<and> valid_W_inv) \<rbrace>
      gc
    \<lbrace> LSTP strong_tricolour_inv \<rbrace>"
 apply (vcg_jackhammer simp: strong_tricolour_inv_def)
 apply (fastforce elim!: obj_fields_marked_inv_blacken)
 done
 
 lemma (in mut_m) strong_tricolour[intro]:
   "\<lbrace> mark_object_invL
       \<^bold>\<and> mut_get_roots.mark_object_invL m
       \<^bold>\<and> mut_store_del.mark_object_invL m
       \<^bold>\<and> mut_store_ins.mark_object_invL m
       \<^bold>\<and> LSTP (fA_rel_inv \<^bold>\<and> fM_rel_inv \<^bold>\<and> handshake_phase_inv \<^bold>\<and> mutators_phase_inv \<^bold>\<and> strong_tricolour_inv \<^bold>\<and> sys_phase_inv \<^bold>\<and> valid_refs_inv) \<rbrace>
      mutator m
    \<lbrace> LSTP strong_tricolour_inv \<rbrace>"
 apply (vcg_jackhammer simp: strong_tricolour_inv_def fA_rel_inv_def fM_rel_inv_def)
 
 apply (drule handshake_phase_invD)
 apply (clarsimp simp: sys_phase_inv_aux_case
                split: handshake_phase.splits if_splits)
 
  apply (blast dest: heap_colours_colours)
  apply (blast dest: heap_colours_colours)
 
  apply (clarsimp simp: fA_rel_def fM_rel_def no_black_refs_def) (* FIXME rule *)
 
  apply (drule_tac x=m in spec)
  apply (clarsimp simp: hp_step_rel_def)
  apply (elim disjE, simp_all)
   apply (auto dest: no_black_refsD)[1]
   apply (auto dest: no_black_refsD)[1]
 
   apply (clarsimp simp: fA_rel_def fM_rel_def)
   apply (clarsimp split: obj_at_splits)
 
  apply (drule spec[where x=m])
  apply (clarsimp simp: hp_step_rel_def)
  apply (elim disjE; force simp: fA_rel_def fM_rel_def split: obj_at_splits)
 
  apply (drule spec[where x=m])
  apply (clarsimp simp: hp_step_rel_def)
  apply (elim disjE; force simp: fA_rel_def fM_rel_def split: obj_at_splits)
 done
 
 lemma (in sys) strong_tricolour_inv[intro]:
   "\<lbrace> LSTP (fM_rel_inv \<^bold>\<and> handshake_phase_inv \<^bold>\<and> mutators_phase_inv \<^bold>\<and> strong_tricolour_inv \<^bold>\<and> sys_phase_inv \<^bold>\<and> tso_writes_inv \<^bold>\<and> valid_W_inv) \<rbrace>
      sys
    \<lbrace> LSTP strong_tricolour_inv \<rbrace>"
 supply [[simproc del: defined_all]]
 apply (vcg_jackhammer simp: strong_tricolour_inv_def p_not_sys)
 apply (clarsimp simp: do_write_action_def fM_rel_inv_def
                split: mem_write_action.splits)
 apply (rename_tac ref field)
 
 (* mw_Mark *)
 subgoal for s s' p ws x xa ref field
   apply (frule (1) valid_W_invD2)
   apply clarsimp
   apply (case_tac "x = ref", simp_all)
   apply (clarsimp simp: grey_def WL_def)
   done
 
 (* mw_Mutate *)
 apply (elim disjE, simp_all)
 apply (clarsimp simp: points_to_mw_Mutate)
 apply (elim disjE, simp_all)
 apply (rename_tac s s' ws x xa ref field option m)
 apply (drule_tac m=m in mut_m.handshake_phase_invD)
 apply (frule_tac x=m in spec)
 apply (clarsimp simp: mutator_phase_inv_aux_case hp_step_rel_def
                split: handshake_phase.splits)
 
  apply (elim disjE, simp_all split: if_splits)
   apply (blast dest!: heap_colours_colours)
   apply (blast dest!: heap_colours_colours)
 
   apply (drule_tac x=m in spec)
   apply (clarsimp simp: no_black_refs_def)
 
   apply (drule_tac x=m in spec)
   apply (clarsimp simp: no_black_refsD)
 
   (* FIXME split less *)
   apply (drule_tac x=m in spec)
   apply (clarsimp simp: mut_m.marked_insertions_def)
   apply (drule_tac x="mw_Mutate x field (Some xa)" in spec)
   apply (clarsimp dest!: marked_not_white)
 
   apply (drule_tac x=m in spec)
   apply (clarsimp simp: mut_m.marked_insertions_def)
   apply (drule_tac x="mw_Mutate x field (Some xa)" in spec)
   apply (clarsimp dest!: marked_not_white)
 
   apply (drule_tac x=m in spec)
   apply (clarsimp simp: mut_m.marked_insertions_def)
   apply (drule_tac x="mw_Mutate x field (Some xa)" in spec)
   apply (clarsimp dest!: marked_not_white)
 
   apply (drule_tac x=m in spec)
   apply (clarsimp simp: mut_m.marked_insertions_def)
   apply (drule_tac x="mw_Mutate x field (Some xa)" in spec)
   apply (clarsimp dest!: marked_not_white)
 
   apply (drule_tac x=m in spec)
   apply (clarsimp simp: mut_m.marked_insertions_def)
   apply (drule_tac x="mw_Mutate x field (Some xa)" in spec)
   apply (clarsimp dest!: marked_not_white)
 
   apply clarsimp
   apply (elim disjE, simp_all split: if_splits)
    apply (blast dest!: heap_colours_colours)
    apply (blast dest!: heap_colours_colours)
 
    apply (drule_tac x=m in spec)
    apply (clarsimp simp: no_black_refs_def)
 
    apply (drule_tac x=m in spec)
    apply (clarsimp simp: mut_m.marked_insertions_def)
    apply (drule_tac x="mw_Mutate x field (Some xa)" in spec)
    apply (clarsimp dest!: marked_not_white)
 
    apply (drule_tac x=m in spec)
    apply (clarsimp simp: mut_m.marked_insertions_def)
    apply (drule_tac x="mw_Mutate x field (Some xa)" in spec)
    apply (clarsimp dest!: marked_not_white)
 
 (* mw_fM *)
 apply (rename_tac s s' p ws x xa bool)
 apply (erule disjE)
  apply (clarsimp simp: fM_rel_def black_heap_def split: if_splits)
   apply ( (drule_tac x=x in spec)+ )[1]
   apply (frule colours_distinct)
   apply (clarsimp split: obj_at_splits)
  apply (clarsimp simp: white_heap_def)
  apply ( (drule_tac x=xa in spec)+ )[1]
  apply (clarsimp split: obj_at_splits)
 apply fastforce
 
 done
 
 text\<open>Remaining non-interference proofs.\<close>
 
 lemma marked_insertionsD:
   "\<lbrakk> sys_mem_write_buffers (mutator m) s = mw_Mutate r f (Some r') # ws; mut_m.marked_insertions m s \<rbrakk>
      \<Longrightarrow> marked r' s"
 by (clarsimp simp: mut_m.marked_insertions_def)
 
 lemma mut_hs_get_roots_loop_locs_subseteq_hs_get_roots:
   "mut_hs_get_roots_loop_locs \<subseteq> prefixed ''hs_get_roots_''"
 by (auto simp: mut_hs_get_roots_loop_locs_def intro: append_prefixD)
 
 lemma mut_m_handshake_invL_get_roots:
   "\<lbrakk> mut_m.handshake_invL m s; atS (mutator m) mut_hs_get_roots_loop_locs s \<rbrakk>
      \<Longrightarrow> sys_handshake_type s\<down> = ht_GetRoots \<and> sys_handshake_pending m s\<down>"
 unfolding mut_m.handshake_invL_def
  apply (elim conjE)
  apply (drule mp, erule (1) atS_mono[OF _ mut_hs_get_roots_loop_locs_subseteq_hs_get_roots])
 done
 
 lemma subseteq_mut_mo_valid_ref_locs:
   "prefixed ''store_del_mo'' \<union> {''lop_store_ins''} \<subseteq> mut_mo_valid_ref_locs"
 by (auto simp: mut_mo_valid_ref_locs_def intro: append_prefixD)
 
 lemma subseteq_mut_mo_valid_ref_locs2:
   "prefixed ''store_ins'' \<subseteq> mut_mo_valid_ref_locs"
 by (clarsimp simp: mut_mo_valid_ref_locs_def)
 
 lemma mut_phase_inv:
   "\<lbrakk> ghost_handshake_phase (s (mutator m)) = hp_Mark \<or> ghost_handshake_phase (s (mutator m)) = hp_IdleMarkSweep \<and> sys_phase s \<noteq> ph_Idle;
      mut_m.mutator_phase_inv_aux m (ghost_handshake_phase (s (mutator m))) s \<rbrakk>
      \<Longrightarrow> mut_m.marked_insertions m s \<and> mut_m.marked_deletions m s"
 by (cases "ghost_handshake_phase (s (mutator m))", simp_all)
 
 lemma (in sys) mut_mark_object_invL[intro]:
   notes mut_m.mark_object_invL_def[inv]
   notes do_write_action_fM[where m=m, simp]
   notes do_write_action_prj_simps(1)[simp del] do_write_action_prj_simps(2)[simp del]
   notes mut_m_get_roots_no_fM_write[where m=m, simp]
   notes mut_m_get_roots_no_phase_write[where m=m, simp]
   notes mut_m_ghost_handshake_phase_not_hp_Idle[where m=m, simp]
   notes atS_simps[simp] filter_empty_conv[simp]
   shows "\<lbrace> mut_m.handshake_invL m \<^bold>\<and> mut_m.mark_object_invL m
              \<^bold>\<and> LSTP (fA_rel_inv \<^bold>\<and> fM_rel_inv \<^bold>\<and> handshake_phase_inv \<^bold>\<and> mutators_phase_inv \<^bold>\<and> phase_rel_inv \<^bold>\<and> valid_refs_inv \<^bold>\<and> valid_W_inv \<^bold>\<and> tso_writes_inv) \<rbrace>
            sys
          \<lbrace> mut_m.mark_object_invL m \<rbrace>"
 apply vcg_nihe
 apply vcg_ni
 
 subgoal by (clarsimp simp: do_write_action_def filter_empty_conv p_not_sys
                dest!: valid_W_invD2
                elim!: obj_at_weakenE
                split: mem_write_action.splits)
 
 subgoal by (clarsimp simp: do_write_action_def filter_empty_conv p_not_sys
                dest!: valid_W_invD2
                elim!: obj_at_weakenE
                split: mem_write_action.splits)
 
 subgoal by (clarsimp simp: do_write_action_def filter_empty_conv p_not_sys loc
                dest!: valid_W_invD2
                elim!: obj_at_weakenE
                split: mem_write_action.splits)
 
 subgoal
   apply (drule phase_rel_invD)
   apply (drule mut_m.handshake_phase_invD[where m=m])
   apply (clarsimp simp: p_not_sys)
   apply (erule disjE)
    apply (clarsimp simp: hp_step_rel_def)
    apply (elim disjE, simp_all add: phase_rel_def)[1]
   apply force
   done
 
 subgoal
   apply (clarsimp simp: do_write_action_def filter_empty_conv p_not_sys loc fM_rel_inv_def
                  dest!: valid_W_invD2
                  elim!: obj_at_weakenE
                  split: mem_write_action.splits)
     apply (rule conjI)
      apply (clarsimp elim!: obj_at_weakenE)
     apply clarsimp
    apply (drule mut_m.handshake_phase_invD[where m=m])
    apply (erule disjE)
     apply (auto simp: fM_rel_def hp_step_rel_def)[1]
    apply force
   apply (erule disjE)
    apply (drule mut_m.handshake_phase_invD[where m=m])
    apply (drule phase_rel_invD)
    apply (clarsimp simp: hp_step_rel_def)
    apply (auto simp: phase_rel_def)[1]
   apply force
   done
 
 subgoal for s s' p w ws
   apply (drule mp, erule atS_mono[OF _ subseteq_mut_mo_valid_ref_locs])
   apply ((thin_tac "atS p ls s \<longrightarrow> Q" for p ls s Q)+)[1]
   apply ((thin_tac "at p ls s \<longrightarrow> Q" for p ls s Q)+)[1]
   apply (clarsimp simp: do_write_action_def p_not_sys loc
                  split: mem_write_action.splits if_splits)
        apply (drule (1) valid_W_invD2)
        apply (erule obj_at_field_on_heap_weakenE)
        apply (fastforce split: obj_at_splits)
       apply (drule (1) valid_W_invD2)
       apply (erule obj_at_field_on_heap_weakenE)
       apply (fastforce split: obj_at_splits)
      apply (drule spec[where x=m])
      apply (frule (1) mut_phase_inv)
      apply (rename_tac refa fielda option)
      apply (frule_tac y="refa" in valid_refs_invD3, simp_all)[1]
      apply (frule_tac y="tmp_ref (s\<down> (mutator m))" in valid_refs_invD(2), simp_all)[1]
      apply (clarsimp split: obj_at_splits option.splits)
       apply force
      apply (frule (1) marked_insertionsD)
      apply (auto split: obj_at_splits; fail)[1]
     apply (erule disjE) (* super messy case *)
      apply force
     apply (rule conjI)
      apply (erule obj_at_field_on_heap_imp_valid_ref)
     apply (clarsimp split: option.splits)
     apply (drule phase_rel_invD)
     apply (frule mut_m.handshake_phase_invD[where m=m])
     apply (rename_tac ma x2)
     apply (drule_tac m=ma in mut_m.handshake_phase_invD)
     apply (frule spec[where x=m])
     apply (drule_tac x=ma in spec)
     apply (clarsimp simp: hp_step_rel_def)
     apply (elim disjE, auto simp: phase_rel_def dest: marked_insertionsD; fail)[1]
    apply (erule disjE; clarsimp)
    apply (drule mut_m.handshake_phase_invD[where m=m])
    apply (clarsimp simp: fM_rel_inv_def fM_rel_def hp_step_rel_def)
    apply (metis (no_types, lifting) handshake_phase.distinct(5) handshake_phase.distinct(7))
   apply (erule disjE; clarsimp)
   apply (drule mut_m.handshake_phase_invD[where m=m])
   apply (drule phase_rel_invD)
   apply (clarsimp simp: hp_step_rel_def phase_rel_def)
   done
 
 subgoal for s s' p w ws y
   apply (clarsimp simp: do_write_action_def p_not_sys
                  split: mem_write_action.splits if_splits)
     apply (auto split: obj_at_splits; fail)[1]
    apply (erule disjE; clarsimp)
    apply (drule mut_m.handshake_phase_invD[where m=m])
    apply (clarsimp simp: fM_rel_inv_def fM_rel_def hp_step_rel_def)
    apply (metis (no_types, lifting) handshake_phase.distinct(5) handshake_phase.distinct(7))
   apply (erule disjE; clarsimp)
   apply (drule mut_m.handshake_phase_invD[where m=m])
   apply (drule phase_rel_invD)
   apply (clarsimp simp: hp_step_rel_def phase_rel_def)
   done
 
 subgoal for s s' p w ws
   apply (drule mp, erule atS_mono[OF _ subseteq_mut_mo_valid_ref_locs2])
   apply ((thin_tac "atS p ls s \<longrightarrow> Q" for p ls s Q)+)[1]
   apply ((thin_tac "at p ls s \<longrightarrow> Q" for p ls s Q)+)[1]
   apply (subst do_write_action_fM[where m=m], simp_all)[1]
    apply (elim disjE, simp_all)[1]
   apply (clarsimp simp: do_write_action_def p_not_sys
                  split: mem_write_action.splits if_splits)
       apply (erule obj_at_field_on_heap_weakenE, auto)[1]
      apply (erule obj_at_field_on_heap_weakenE, auto split: obj_at_splits)[1]
     apply (drule spec[where x=m])
     apply (frule (1) mut_phase_inv)
     apply (rename_tac refa fielda option)
     apply (frule_tac y="refa" in valid_refs_invD3, simp_all)[1]
     apply (frule_tac y="tmp_ref (s\<down> (mutator m))" in valid_refs_invD(2), simp_all)[1]
     apply (clarsimp split: obj_at_splits option.splits)
      apply auto[1]
     apply (frule (1) marked_insertionsD)
     apply (auto split: obj_at_splits)[1]
    apply (erule disjE) (* super messy case *)
     apply force
    apply (rule conjI)
     apply (erule obj_at_field_on_heap_imp_valid_ref)
    apply (clarsimp split: option.splits)
    apply (drule phase_rel_invD)
    apply (frule mut_m.handshake_phase_invD[where m=m])
    apply (rename_tac ma x2)
    apply (drule_tac m=ma in mut_m.handshake_phase_invD)
    apply (frule spec[where x=m])
    apply (drule_tac x=ma in spec)
    apply (clarsimp simp: hp_step_rel_def)
    apply (elim disjE, auto simp: phase_rel_def dest: marked_insertionsD)[1]
   apply (erule disjE)
    apply (drule mut_m.handshake_phase_invD[where m=m])
    apply (drule phase_rel_invD)
    apply (clarsimp simp: hp_step_rel_def phase_rel_def)
   apply force
   done
 
 done
 
 lemma (in gc) mut_mark_object_invL[intro]:
   notes mut_m.mark_object_invL_def[inv]
   notes atS_simps[simp]
   shows "\<lbrace> fM_fA_invL \<^bold>\<and> gc_W_empty_invL \<^bold>\<and> handshake_invL \<^bold>\<and> sweep_loop_invL
             \<^bold>\<and> mut_m.handshake_invL m
             \<^bold>\<and> mut_m.mark_object_invL m
             \<^bold>\<and> LSTP (fM_rel_inv \<^bold>\<and> handshake_phase_inv \<^bold>\<and> mutators_phase_inv \<^bold>\<and> sys_phase_inv) \<rbrace>
            gc
          \<lbrace> mut_m.mark_object_invL m \<rbrace>"
 apply vcg_nihe
 apply vcg_ni
 
 subgoal
  apply (drule (1) mut_m_handshake_invL_get_roots)
  apply clarsimp
  done
 
 subgoal by (simp add: mut_m.handshake_invL_def)
 
 subgoal by (fastforce simp: fM_rel_inv_def fM_rel_def hp_step_rel_def split: obj_at_splits)
 
 subgoal
  apply (drule mut_m.handshake_phase_invD[where m=m])
  apply (drule spec[where x=m])
  apply (clarsimp simp: valid_null_ref_def hp_step_rel_def conj_disj_distribR[symmetric] split: option.splits)
  apply (drule (1) mut_m.reachable_blackD)
   apply blast
  apply (clarsimp split: obj_at_splits)
  done
 
 subgoal
  apply (drule mp, erule atS_mono[OF _ subseteq_mut_mo_valid_ref_locs])
  apply ((thin_tac "atS p ls s \<longrightarrow> Q" for p ls s Q)+)[1]
  apply ((thin_tac "at p ls s \<longrightarrow> Q" for p ls s Q)+)[1]
  apply (drule mut_m.handshake_phase_invD[where m=m])
  apply (drule spec[where x=m])
  apply (clarsimp simp: valid_null_ref_def hp_step_rel_def conj_disj_distribR[symmetric] split: option.splits)
  apply (drule (1) mut_m.reachable_blackD)
   apply blast
  apply (auto simp: obj_at_field_on_heap_def black_def split: obj_at_splits option.splits)[1]
  done
 
 subgoal by (clarsimp split: obj_at_splits)
 
 subgoal
  apply (drule mp, erule atS_mono[OF _ subseteq_mut_mo_valid_ref_locs2])
  apply ((thin_tac "atS p ls s \<longrightarrow> Q" for p ls s Q)+)[1]
  apply ((thin_tac "at p ls s \<longrightarrow> Q" for p ls s Q)+)[1]
  apply (drule mut_m.handshake_phase_invD[where m=m])
  apply (drule spec[where x=m])
  apply (clarsimp simp: valid_null_ref_def hp_step_rel_def conj_disj_distribR[symmetric] split: option.splits)
  apply (drule (1) mut_m.reachable_blackD)
   apply blast
  apply (auto simp: obj_at_field_on_heap_def black_def split: obj_at_splits option.splits)[1]
 done
 
 done
 
 lemma (in gc) mut_store_old_mark_object_invL[intro]:
   notes mut_m.mark_object_invL_def[inv]
   shows
   "\<lbrace> fM_fA_invL \<^bold>\<and> handshake_invL \<^bold>\<and> sweep_loop_invL \<^bold>\<and> gc_W_empty_invL
       \<^bold>\<and> mut_m.mark_object_invL m
       \<^bold>\<and> mut_store_del.mark_object_invL m
       \<^bold>\<and> LSTP (handshake_phase_inv \<^bold>\<and> mut_m.mutator_phase_inv m) \<rbrace>
      gc
    \<lbrace> mut_store_del.mark_object_invL m \<rbrace>"
 apply vcg_nihe
 apply vcg_ni
  apply ( (clarsimp dest!: mut_m.handshake_phase_invD[where m=m]
                    simp: hp_step_rel_def conj_disj_distribR[symmetric]
         , drule_tac r="gc_tmp_ref s\<down>" in mut_m.no_grey_refs_not_rootD[where m=m]
         , auto split: obj_at_splits if_splits)[1] )+
 done
 
 lemma (in gc) mut_store_ins_mark_object_invL[intro]:
   notes mut_m.mark_object_invL_def[inv]
   shows
   "\<lbrace> fM_fA_invL \<^bold>\<and> handshake_invL \<^bold>\<and> sweep_loop_invL \<^bold>\<and> gc_W_empty_invL
       \<^bold>\<and> mut_m.mark_object_invL m
       \<^bold>\<and> mut_store_ins.mark_object_invL m
       \<^bold>\<and> LSTP (handshake_phase_inv \<^bold>\<and> mut_m.mutator_phase_inv m) \<rbrace>
      gc
    \<lbrace> mut_store_ins.mark_object_invL m \<rbrace>"
 apply vcg_nihe
 apply vcg_ni
  apply ( (clarsimp dest!: mut_m.handshake_phase_invD[where m=m]
                    simp: hp_step_rel_def conj_disj_distribR[symmetric]
         , drule_tac r="gc_tmp_ref s\<down>" in mut_m.no_grey_refs_not_rootD[where m=m]
         , auto split: obj_at_splits if_splits)[1] )+
 done
 
 lemma obj_fields_marked_locs_subseteq_hp_IdleMarkSweep_locs:
   "obj_fields_marked_locs \<subseteq> hp_IdleMarkSweep_locs"
 apply (clarsimp simp: obj_fields_marked_locs_def hp_IdleMarkSweep_locs_def mark_loop_locs_def)
 apply (drule mp)
 apply (auto intro: append_prefixD)
 done
 
 lemma obj_fields_marked_locs_subseteq_hs_in_sync_locs:
   "obj_fields_marked_locs \<subseteq> hs_in_sync_locs"
 by (auto simp: obj_fields_marked_locs_def hs_in_sync_locs_def hs_done_locs_def
          dest: prefix_same_cases)
 
 lemma handshake_obj_fields_markedD:
   "\<lbrakk> atS gc obj_fields_marked_locs s; gc.handshake_invL s \<rbrakk> \<Longrightarrow> sys_ghost_handshake_phase s\<down> = hp_IdleMarkSweep \<and> All (ghost_handshake_in_sync (s\<down> sys))"
 apply (simp add: gc.handshake_invL_def)
 apply (elim conjE)
 apply (drule mp, erule atS_mono[OF _ obj_fields_marked_locs_subseteq_hp_IdleMarkSweep_locs])
 apply (drule mp, erule atS_mono[OF _ obj_fields_marked_locs_subseteq_hs_in_sync_locs])
 apply clarsimp
 done
 
 lemma mark_loop_mo_mark_loop_field_done_subseteq_hp_IdleMarkSweep_locs:
   "prefixed ''mark_loop_mo'' \<union> {''mark_loop_mark_field_done''} \<subseteq> hp_IdleMarkSweep_locs"
 apply (clarsimp simp: hp_IdleMarkSweep_locs_def mark_loop_locs_def)
 apply (drule mp)
 apply (auto intro: append_prefixD)
 done
 
 lemma mark_loop_mo_mark_loop_field_done_subseteq_hs_in_sync_locs:
   "prefixed ''mark_loop_mo'' \<union> {''mark_loop_mark_field_done''} \<subseteq> hs_in_sync_locs"
 by (auto simp: hs_in_sync_locs_def hs_done_locs_def
          dest: prefix_same_cases)
 
 lemma mark_loop_mo_mark_loop_field_done_hp_phaseD:
   "\<lbrakk> atS gc (prefixed ''mark_loop_mo'' \<union> {''mark_loop_mark_field_done''}) s; gc.handshake_invL s \<rbrakk> \<Longrightarrow> sys_ghost_handshake_phase s\<down> = hp_IdleMarkSweep \<and> All (ghost_handshake_in_sync (s\<down> sys))"
 apply (simp add: gc.handshake_invL_def)
 apply (elim conjE)
 apply (drule mp, erule atS_mono[OF _ mark_loop_mo_mark_loop_field_done_subseteq_hp_IdleMarkSweep_locs])
 apply (drule mp, erule atS_mono[OF _ mark_loop_mo_mark_loop_field_done_subseteq_hs_in_sync_locs])
 apply clarsimp
 done
 
 (* an alternative is some kind of ghost_honorary_XXX for the GC while marking *)
 lemma gc_marking_reaches_mw_Mutate:
   assumes xys: "\<forall>y. (x reaches y) s \<longrightarrow> valid_ref y s"
   assumes xy: "(x reaches y) (s(sys := s sys\<lparr>heap := (sys_heap s)(r := Option.map_option (\<lambda>obj. obj\<lparr>obj_fields := (obj_fields obj)(f := opt_r')\<rparr>) (sys_heap s r)),
                                              mem_write_buffers := (mem_write_buffers (s sys))(p := ws)\<rparr>))"
   assumes sb: "sys_mem_write_buffers (mutator m) s = mw_Mutate r f opt_r' # ws"
   assumes vri: "valid_refs_inv s"
   shows "valid_ref y s"
 proof -
   from xy xys
   have "\<exists>z. z \<in> {x} \<union> mut_m.tso_write_refs m s \<and> (z reaches y) s \<and> valid_ref y s"
   proof(induct rule: rtranclp.induct)
     case (rtrancl_refl x) then show ?case by auto
   next
     case (rtrancl_into_rtrancl x y z) with sb vri show ?case
       apply (clarsimp simp: points_to_mw_Mutate)
       apply (elim disjE)
          apply (force dest: rtranclp.intros(2))
         apply (force dest: rtranclp.intros(2))
        apply clarsimp
        apply (elim disjE)
         apply (rule exI[where x=z])
         apply (clarsimp simp: mut_m.tso_write_refs_def)
         apply (rule valid_refs_invD(3)[where m=m and x=z], auto simp: mut_m.tso_write_refs_def)[1]
        apply (force dest: rtranclp.intros(2))
       apply clarsimp
       apply (elim disjE)
        apply (rule exI[where x=z])
        apply (clarsimp simp: mut_m.tso_write_refs_def)
        apply (rule valid_refs_invD(3)[where m=m and x=z], auto simp: mut_m.tso_write_refs_def)[1]
       apply (force dest: rtranclp.intros(2))
       done
   qed
   then show ?thesis by blast
 qed
 
 lemma (in sys) gc_obj_fields_marked_invL[intro]:
   notes gc.obj_fields_marked_invL_def[inv]
   shows
   "\<lbrace> gc.fM_fA_invL \<^bold>\<and> gc.handshake_invL \<^bold>\<and> gc.obj_fields_marked_invL
        \<^bold>\<and> LSTP (fM_rel_inv \<^bold>\<and> handshake_phase_inv \<^bold>\<and> mutators_phase_inv \<^bold>\<and> tso_writes_inv \<^bold>\<and> valid_refs_inv \<^bold>\<and> valid_W_inv) \<rbrace>
      sys
    \<lbrace> gc.obj_fields_marked_invL \<rbrace>"
 apply vcg_nihe
 apply (vcg_ni simp: p_not_sys fM_rel_inv_def)
  apply (clarsimp simp: gc.obj_fields_marked_inv_def)
  apply (frule (1) handshake_obj_fields_markedD)
  apply (clarsimp simp: do_write_action_def
                 split: mem_write_action.splits)
 
 (* mark *)
 subgoal for s s' p ws x ref bool
  apply (frule (1) valid_W_invD2)
  apply (drule_tac x=x in spec)
  apply clarsimp
  apply (erule obj_at_field_on_heap_weakenE)
  apply (clarsimp split: obj_at_splits)
  done
 
 (* ref *)
 subgoal for s s' p ws x x23
   apply (erule disjE; clarsimp)
   apply (rename_tac m)
   apply (drule_tac m=m in mut_m.handshake_phase_invD; clarsimp simp: hp_step_rel_def conj_disj_distribR[symmetric])
   apply (drule_tac x=m in spec; clarsimp)
   apply (drule_tac x=x in spec; clarsimp)
   apply (auto split: option.splits)
   done
 
 (* fM *)
 subgoal for s s' p ws x x4
    apply (erule disjE)
     apply (auto simp: fM_rel_def filter_empty_conv)[1]
    apply clarsimp
    done
 
 subgoal for s s' p w ws
    apply (clarsimp simp: gc.obj_fields_marked_inv_def)
    apply (frule (1) mark_loop_mo_mark_loop_field_done_hp_phaseD)
    apply (clarsimp simp: do_write_action_def
                   split: mem_write_action.splits)
    (* mark *)
    apply (frule (1) valid_W_invD2)
    apply (erule obj_at_field_on_heap_weakenE)
    apply (clarsimp split: obj_at_splits)
   (* ref *)
   apply (erule disjE, clarsimp+)[1]
   apply (rename_tac option m)
   apply (drule_tac m=m in mut_m.handshake_phase_invD, clarsimp simp: hp_step_rel_def conj_disj_distribR[symmetric])
   apply (drule_tac x=m in spec, clarsimp)
   apply (rule conjI)
    apply (rule_tac x="gc_tmp_ref s\<down>" and m=m in valid_refs_invD(3), auto simp: mut_m.tso_write_refs_def)[1]
   apply (clarsimp split: option.splits dest!: marked_insertionD)
  (* fM *)
  apply (erule disjE)
   apply (auto simp: fM_rel_def filter_empty_conv)[1]
  apply clarsimp
  done
 
 subgoal for s s' p w ws x y
  apply (clarsimp simp: do_write_action_def
                 split: mem_write_action.splits)
   (* mark *)
   subgoal
     apply (drule_tac x=x in spec)
     apply (drule mp, erule predicate2D[OF rtranclp_mono[OF predicate2I], rotated])
      apply clarsimp
     apply assumption
     done
  (* ref *)
  subgoal
    apply (clarsimp simp: atS_un)
    apply (erule disjE; clarsimp)
    apply (erule gc_marking_reaches_mw_Mutate; blast)
    done
  done
 
 (* mark loop mark field done *)
 subgoal
  apply (clarsimp simp: do_write_action_def
                split: mem_write_action.splits)
   (* mark *)
   apply fast
  (* fM *)
  apply (clarsimp simp: gc.handshake_invL_def loc atS_simps)
  apply (erule disjE)
   apply (auto simp: fM_rel_def filter_empty_conv)[1]
  apply clarsimp
  done
 
 done
 
 lemma reachable_sweep_loop_free:
   "mut_m.reachable m r (s(sys := s sys\<lparr>heap := (sys_heap s)(r' := None)\<rparr>))
    \<Longrightarrow> mut_m.reachable m r s"
 apply (clarsimp simp: mut_m.reachable_def)
 apply (rename_tac x)
 apply (rule_tac x=x in exI, simp)
 apply (erule predicate2D[OF rtranclp_mono[OF predicate2I], rotated], clarsimp split: if_splits obj_at_splits)
 done
 
 lemma valid_refs_inv_sweep_loop_free[simp]:
   assumes "valid_refs_inv s"
   assumes ngr: "no_grey_refs s"
   assumes rsi: "\<forall>m'. mut_m.reachable_snapshot_inv m' s"
   assumes "white r' s"
   shows "valid_refs_inv (s(sys := s sys\<lparr>heap := (sys_heap s)(r' := None)\<rparr>))"
 using assms
 apply (clarsimp simp: valid_refs_inv_def grey_reachable_def no_grey_refs_def dest!: reachable_sweep_loop_free)
 apply (drule mut_m.reachable_blackD[OF ngr spec[OF rsi]])
 apply (auto split: obj_at_splits)
 done
 
 lemma (in gc) valid_refs_inv[intro]:
   "\<lbrace> fM_fA_invL \<^bold>\<and> handshake_invL \<^bold>\<and> gc_W_empty_invL \<^bold>\<and> gc_mark.mark_object_invL \<^bold>\<and> obj_fields_marked_invL \<^bold>\<and> phase_invL \<^bold>\<and> sweep_loop_invL
        \<^bold>\<and> LSTP (handshake_phase_inv \<^bold>\<and> mutators_phase_inv \<^bold>\<and> sys_phase_inv \<^bold>\<and> valid_refs_inv \<^bold>\<and> valid_W_inv) \<rbrace>
      gc
    \<lbrace> LSTP valid_refs_inv \<rbrace>"
 apply vcg_jackhammer
 
 (* sweep loop free *)
 apply (drule (1) handshake_in_syncD)
 apply clarsimp
 
 apply (auto simp: valid_refs_inv_def grey_reachable_def)
 done
 
 lemma (in sys) valid_refs_inv[intro]:
   "\<lbrace> LSTP (valid_refs_inv \<^bold>\<and> tso_writes_inv) \<rbrace> sys \<lbrace> LSTP valid_refs_inv \<rbrace>"
 apply vcg_jackhammer
 apply (auto simp: do_write_action_def p_not_sys
            split: mem_write_action.splits)
 done
 
 lemma (in mut_m) valid_refs_inv_discard_roots[simp]:
   "\<lbrakk> valid_refs_inv s; roots' \<subseteq> mut_roots s \<rbrakk>
      \<Longrightarrow> valid_refs_inv (s(mutator m := s (mutator m)\<lparr>roots := roots'\<rparr>))"
 by (auto simp: valid_refs_inv_def mut_m.reachable_def split: if_splits)
 
 lemma (in mut_m) valid_refs_inv_load[simp]:
   "\<lbrakk> valid_refs_inv s; sys_read (mutator m) (mr_Ref r f) (s sys) = mv_Ref r'; r \<in> mut_roots s \<rbrakk>
      \<Longrightarrow> valid_refs_inv (s(mutator m := s (mutator m)\<lparr>roots := mut_roots s \<union> Option.set_option r'\<rparr>))"
 by (auto simp: valid_refs_inv_def)
 
 lemma (in mut_m) valid_refs_inv_alloc[simp]:
   "\<lbrakk> valid_refs_inv s; sys_heap s r' = None \<rbrakk>
      \<Longrightarrow> valid_refs_inv (s(mutator m := s (mutator m)\<lparr>roots := insert r' (mut_roots s)\<rparr>, sys := s sys\<lparr>heap := sys_heap s(r' \<mapsto> \<lparr>obj_mark = fl, obj_fields = Map.empty\<rparr>)\<rparr>))"
 apply (clarsimp simp: valid_refs_inv_def)
 apply (clarsimp simp: mut_m.reachable_def split: if_splits)
 apply (auto elim: converse_rtranclpE split: obj_at_splits)
 done
 
 lemma (in mut_m) valid_refs_inv_store_ins[simp]:
   "\<lbrakk> valid_refs_inv s; r \<in> mut_roots s; (\<exists>r'. opt_r' = Some r') \<longrightarrow> the opt_r' \<in> mut_roots s \<rbrakk>
      \<Longrightarrow> valid_refs_inv (s(mutator m := s (mutator m)\<lparr> ghost_honorary_root := {} \<rparr>,
                           sys := s sys\<lparr> mem_write_buffers := (mem_write_buffers (s sys))(mutator m := sys_mem_write_buffers (mutator m) s @ [mw_Mutate r f opt_r']) \<rparr>))"
 apply (subst valid_refs_inv_def)
 apply (clarsimp simp: grey_reachable_def mut_m.reachable_def)
 apply (rule conjI)
  apply clarsimp
  apply (rename_tac x xa)
  apply (case_tac "xa = m")
   apply clarsimp
   apply fastforce
  apply clarsimp
  apply (fastforce dest: valid_refs_invD)
 apply fastforce
 done
 
 lemma (in mut_m) valid_refs_inv_deref_del[simp]:
   "\<lbrakk> valid_refs_inv s; sys_read (mutator m) (mr_Ref r f) (s sys) = mv_Ref opt_r'; r \<in> mut_roots s; mut_ghost_honorary_root s = {} \<rbrakk>
      \<Longrightarrow> valid_refs_inv (s(mutator m := s (mutator m)\<lparr>ghost_honorary_root := Option.set_option opt_r', ref := opt_r'\<rparr>))"
 by (clarsimp simp: valid_refs_inv_def)
 
 lemma (in mut_m) valid_refs_inv[intro]:
   "\<lbrace> mark_object_invL
        \<^bold>\<and> mut_get_roots.mark_object_invL m
        \<^bold>\<and> mut_store_del.mark_object_invL m
        \<^bold>\<and> mut_store_ins.mark_object_invL m
        \<^bold>\<and> LSTP valid_refs_inv \<rbrace>
      mutator m
    \<lbrace> LSTP valid_refs_inv \<rbrace>"
 apply vcg_jackhammer
 
 (* store ins mo co mark - FIXME some elim/dest rule really gets in the way here *)
 subgoal
   apply (subst valid_refs_inv_def)
   apply clarsimp
   apply (rule conjI)
    apply clarsimp
    apply (erule (1) valid_refs_invD)
   apply (clarsimp simp: grey_reachable_def)
   apply (erule disjE)
    apply (erule (1) valid_refs_invD, simp)
   apply clarsimp
   apply (erule (1) valid_refs_invD, simp)
   done
 
 (* store del mo co mark *)
 subgoal
   apply (subst valid_refs_inv_def)
   apply clarsimp
   apply (rule conjI)
    apply clarsimp
    apply (erule (1) valid_refs_invD)
   apply (clarsimp simp: grey_reachable_def)
   apply (erule disjE)
    apply (erule (1) valid_refs_invD, simp)
   apply clarsimp
   apply (erule (1) valid_refs_invD, simp)
   done
 
 (* get roots done *)
 subgoal by (clarsimp simp: valid_refs_inv_def grey_reachable_def)
 
 (* get roots loop mo co mark *)
 subgoal by (auto simp: valid_refs_inv_def grey_reachable_def)
 
 (* get work done *)
 subgoal by (clarsimp simp: valid_refs_inv_def grey_reachable_def)
 
 done
 
 (*>*)
 (*<*)
 
 end
 (*>*)
diff --git a/thys/ConcurrentGC/TSO.thy b/thys/ConcurrentGC/TSO.thy
--- a/thys/ConcurrentGC/TSO.thy
+++ b/thys/ConcurrentGC/TSO.thy
@@ -1,201 +1,203 @@
 (*<*)
 (*
  * Copyright 2015, NICTA
  *
  * This software may be distributed and modified according to the terms of
  * the BSD 2-Clause license. Note that NO WARRANTY is provided.
  * See "LICENSE_BSD2.txt" for details.
  *
  * @TAG(NICTA_BSD)
  *)
 
 theory TSO
 imports
   Proofs_basis
 begin
 
+declare subst_all [simp del] [[simproc del: defined_all]]
+
 (*>*)
 subsection\<open>Coarse TSO invariants\<close>
 
 text\<open>
 
 Very coarse invariants about what processes write, and when they hold
 the TSO lock.
 
 \<close>
 
 abbreviation gc_writes :: "('field, 'ref) mem_write_action \<Rightarrow> bool" where
   "gc_writes w \<equiv> case w of mw_Mark _ _ \<Rightarrow> True | mw_Phase _ \<Rightarrow> True | mw_fM _ \<Rightarrow> True | mw_fA _ \<Rightarrow> True | _ \<Rightarrow> False"
 
 abbreviation mut_writes :: "('field, 'ref) mem_write_action \<Rightarrow> bool" where
   "mut_writes w \<equiv> case w of mw_Mutate _ _ _ \<Rightarrow> True | mw_Mark _ _ \<Rightarrow> True | _ \<Rightarrow> False"
 
 definition tso_writes_inv :: "('field, 'mut, 'ref) lsts_pred" where
   "tso_writes_inv \<equiv>
       (\<^bold>\<forall>w.   tso_pending_write gc          w \<^bold>\<longrightarrow> \<langle>gc_writes w\<rangle>)
    \<^bold>\<and> (\<^bold>\<forall>m w. tso_pending_write (mutator m) w \<^bold>\<longrightarrow> \<langle>mut_writes w\<rangle>)"
 (*<*)
 
 lemma tso_writes_inv_eq_imp:
   "eq_imp (\<lambda>p s. mem_write_buffers (s sys) p)
           tso_writes_inv"
 by (simp add: eq_imp_def tso_writes_inv_def)
 
 lemmas tso_writes_inv_fun_upd[simp] = eq_imp_fun_upd[OF tso_writes_inv_eq_imp, simplified eq_imp_simps, rule_format]
 
 lemma tso_writes_invD[simp]:
   "tso_writes_inv s \<Longrightarrow> \<not>sys_mem_write_buffers gc s = mw_Mutate r f r' # ws"
   "tso_writes_inv s \<Longrightarrow> \<not>sys_mem_write_buffers (mutator m) s = mw_fA fl # ws"
   "tso_writes_inv s \<Longrightarrow> \<not>sys_mem_write_buffers (mutator m) s = mw_fM fl # ws"
   "tso_writes_inv s \<Longrightarrow> \<not>sys_mem_write_buffers (mutator m) s = mw_Phase ph # ws"
 by (auto simp: tso_writes_inv_def dest!: spec[where x=m])
 
 lemma mut_do_write_action[simp]:
   "\<lbrakk> sys_mem_write_buffers (mutator m) s = w # ws; tso_writes_inv s \<rbrakk> \<Longrightarrow> fA (do_write_action w (s sys)) = sys_fA s"
   "\<lbrakk> sys_mem_write_buffers (mutator m) s = w # ws; tso_writes_inv s \<rbrakk> \<Longrightarrow> fM (do_write_action w (s sys)) = sys_fM s"
   "\<lbrakk> sys_mem_write_buffers (mutator m) s = w # ws; tso_writes_inv s \<rbrakk> \<Longrightarrow> phase (do_write_action w (s sys)) = sys_phase s"
 by (auto simp: do_write_action_def split: mem_write_action.splits)
 
 lemma tso_writes_inv_sys_read_Mut[simp]:
   assumes "tso_writes_inv s"
   assumes "(ract, v) \<in> { (mr_fM, mv_Mark (Some (sys_fM s))), (mr_fA, mv_Mark (Some (sys_fA s))), (mr_Phase, mv_Phase (sys_phase s)) }"
   shows "sys_read (mutator m) ract (s sys) = v"
 using assms
 apply (clarsimp simp: sys_read_def fold_writes_def)
 apply (rule fold_invariant[where P="\<lambda>fr. do_read_action ract (fr (s sys)) = v" and Q="mut_writes"])
   apply (fastforce simp: tso_writes_inv_def)
  apply (auto simp: do_read_action_def split: mem_write_action.splits)
 done
 
 lemma tso_writes_inv_sys_read_GC[simp]:
   assumes "tso_writes_inv s"
   shows "sys_read gc (mr_Ref r f) (s sys) = mv_Ref (sys_heap s r \<bind> (\<lambda>obj. obj_fields obj f))" (is "?lhs = mv_Ref ?rhs")
 using assms
 apply (simp add: sys_read_def fold_writes_def)
 apply (rule fold_invariant[where P="\<lambda>fr. heap (fr (s sys)) r \<bind> (\<lambda>obj. obj_fields obj f) = ?rhs"
                              and Q="\<lambda>w. \<forall>r f r'. w \<noteq> mw_Mutate r f r'"])
   apply (force simp: tso_writes_inv_def)
  apply (auto simp: do_write_action_def Option.map_option_case
             split: mem_write_action.splits option.splits)
 done
 
 lemma tso_no_pending_marksD[simp]:
   assumes "tso_pending_mark p s = []"
   shows "sys_read p (mr_Mark r) (s sys) = mv_Mark (Option.map_option obj_mark (sys_heap s r))"
 using assms
 apply (clarsimp simp: sys_read_def fold_writes_def)
 apply (rule fold_invariant[where P="\<lambda>fr. Option.map_option obj_mark (heap (fr (s sys)) r) = Option.map_option obj_mark (sys_heap s r)"
                              and Q="\<lambda>w. \<forall>fl. w \<noteq> mw_Mark r fl"])
   apply (auto simp: Option.map_option_case do_write_action_def filter_empty_conv
              split: mem_write_action.splits option.splits)
 done
 
 lemma no_pending_phase_sys_read[simp]:
   assumes "tso_pending_phase p s = []"
   shows "sys_read p mr_Phase (s sys) = mv_Phase (sys_phase s)"
 using assms
 apply (clarsimp simp: sys_read_def fold_writes_def)
 apply (rule fold_invariant[where P="\<lambda>fr. phase (fr (s sys)) = sys_phase s" and Q="\<lambda>w. \<forall>ph. w \<noteq> mw_Phase ph"])
   apply (auto simp: do_write_action_def filter_empty_conv
              split: mem_write_action.splits)
 done
 
 lemma gc_no_pending_fM_write[simp]:
   assumes "tso_pending_fM gc s = []"
   shows "sys_read gc mr_fM (s sys) = mv_Mark (Some (sys_fM s))"
 using assms
 apply (clarsimp simp: sys_read_def fold_writes_def)
 apply (rule fold_invariant[where P="\<lambda>fr. fM (fr (s sys)) = sys_fM s" and Q="\<lambda>w. \<forall>fl. w \<noteq> mw_fM fl"])
   apply (auto simp: do_write_action_def filter_empty_conv
              split: mem_write_action.splits)
 done
 
 lemma (in sys) tso_gc_writes_inv[intro]:
   "\<lbrace> LSTP tso_writes_inv \<rbrace> sys"
 apply (vcg_jackhammer simp: tso_writes_inv_def)
 apply (metis (no_types) list.set_intros(2))
 done
 
 lemma (in gc) tso_writes_inv[intro]:
   "\<lbrace> LSTP tso_writes_inv \<rbrace> gc"
 by (vcg_jackhammer simp: tso_writes_inv_def)
 
 lemma (in mut_m) tso_writes_inv[intro]:
   "\<lbrace> LSTP tso_writes_inv \<rbrace> mutator m"
 by (vcg_jackhammer simp: tso_writes_inv_def)
 
 (*>*)
 
 subsubsection\<open>Locations where the TSO lock is held\<close>
 
 text (in gc) \<open>
 
 The GC holds the TSO lock only during the \texttt{CAS} in @{const
 "mark_object"}.
 
 \<close>
 
 locset_definition gc_tso_lock_locs :: "location set" where
   "gc_tso_lock_locs \<equiv> \<Union>l\<in>{ ''mo_co_cmark'', ''mo_co_ctest'', ''mo_co_mark'', ''mo_co_unlock'' }. suffixed l"
 
 inv_definition (in gc) tso_lock_invL :: "('field, 'mut, 'ref) gc_pred" where
   "tso_lock_invL \<equiv>
      atS_gc gc_tso_lock_locs (tso_locked_by gc)
    \<^bold>\<and> atS_gc (- gc_tso_lock_locs) (\<^bold>\<not> (tso_locked_by gc))"
 
 (*<*)
 
 lemma (in gc) tso_lock_invL[intro]:
   "\<lbrace> tso_lock_invL \<rbrace> gc"
 by vcg_jackhammer
 
 lemma (in sys) gc_tso_lock_invL[intro]:
   notes gc.tso_lock_invL_def[inv]
   shows "\<lbrace> gc.tso_lock_invL \<rbrace> sys"
 by vcg_ni
 
 lemma (in mut_m) gc_tso_lock_invL[intro]:
   notes gc.tso_lock_invL_def[inv]
   shows "\<lbrace> gc.tso_lock_invL \<rbrace> mutator m"
 by vcg_ni
 
 (*>*)
 text (in mut_m) \<open>
 
 A mutator holds the TSO lock only during the \texttt{CAS}s in @{const
 "mark_object"}.
 
 \<close>
 
 locset_definition "mut_tso_lock_locs =
   (\<Union>l\<in>{ ''mo_co_cmark'', ''mo_co_ctest'', ''mo_co_mark'', ''mo_co_unlock'' }. suffixed l)"
 
 inv_definition (in mut_m) tso_lock_invL :: "('field, 'mut, 'ref) gc_pred" where
   "tso_lock_invL =
     (atS_mut mut_tso_lock_locs     (tso_locked_by (mutator m))
    \<^bold>\<and> atS_mut (- mut_tso_lock_locs) (\<^bold>\<not>(tso_locked_by (mutator m))))"
 (*<*)
 
 lemma (in mut_m) tso_lock_invL[intro]:
   "\<lbrace> tso_lock_invL \<rbrace> mutator m"
 by vcg_jackhammer
 
 lemma (in gc) mut_tso_lock_invL[intro]:
   notes mut_m.tso_lock_invL_def[inv]
   shows "\<lbrace> mut_m.tso_lock_invL m \<rbrace> gc"
 by vcg_ni
 
 lemma (in sys) mut_tso_lock_invL[intro]:
   notes mut_m.tso_lock_invL_def[inv]
   shows "\<lbrace> mut_m.tso_lock_invL m \<rbrace> sys"
 by vcg_ni
 
 lemma (in mut_m') tso_lock_invL[intro]:
   "\<lbrace> tso_lock_invL \<rbrace> mutator m'"
 by vcg_ni
 
 (*>*)
 (*<*)
 
 end
 (*>*)
diff --git a/thys/ConcurrentGC/Tactics.thy b/thys/ConcurrentGC/Tactics.thy
--- a/thys/ConcurrentGC/Tactics.thy
+++ b/thys/ConcurrentGC/Tactics.thy
@@ -1,307 +1,309 @@
 (*<*)
 (*
  * Copyright 2015, NICTA
  *
  * This software may be distributed and modified according to the terms of
  * the BSD 2-Clause license. Note that NO WARRANTY is provided.
  * See "LICENSE_BSD2.txt" for details.
  *
  * @TAG(NICTA_BSD)
  *)
 
 theory Tactics
 imports
   Model
   "HOL-Library.Sublist"
 begin
 
+declare subst_all [simp del] [[simproc del: defined_all]]
+
 (*>*)
 section\<open>Invariants and Proofs \label{sec:gc-invs}\<close>
 
 subsection\<open>Constructors for sets of locations.\<close>
 
 abbreviation prefixed :: "location \<Rightarrow> location set" where
   "prefixed p \<equiv> { l . prefix p l }"
 
 abbreviation suffixed :: "location \<Rightarrow> location set" where
   "suffixed p \<equiv> { l . suffix p l }"
 
 subsection\<open>Hoare triples\<close>
 
 text\<open>
 
 Specialise CIMP's pre/post validity to our system.
 
 \<close>
 
 definition
   valid_proc :: "('field, 'mut, 'ref) gc_pred \<Rightarrow> 'mut process_name \<Rightarrow> ('field, 'mut, 'ref) gc_pred \<Rightarrow> bool" ("\<lbrace>_\<rbrace> _ \<lbrace>_\<rbrace>")
 where
   "\<lbrace>P\<rbrace> p \<lbrace>Q\<rbrace> \<equiv> \<forall>(c, afts) \<in> vcg_fragments (gc_pgms p). (gc_pgms, p, afts \<Turnstile> \<lbrace>P\<rbrace> c \<lbrace>Q\<rbrace>)"
 
 abbreviation
   valid_proc_inv_syn :: "('field, 'mut, 'ref) gc_pred \<Rightarrow> 'mut process_name \<Rightarrow> bool" ("\<lbrace>_\<rbrace> _" [100,0] 100)
 where
   "\<lbrace>P\<rbrace> p \<equiv> \<lbrace>P\<rbrace> p \<lbrace>P\<rbrace>"
 (*<*)
 
 lemma valid_pre:
   assumes "\<lbrace>Q\<rbrace> p \<lbrace>R\<rbrace>"
   assumes "\<And>s. P s \<Longrightarrow> Q s"
   shows "\<lbrace>P\<rbrace> p \<lbrace>R\<rbrace>"
 using assms
 apply (clarsimp simp: valid_proc_def)
 apply (drule (1) bspec)
 apply (auto elim: vcg_pre)
 done
 
 lemma valid_conj_lift:
   assumes x: "\<lbrace>P\<rbrace> p \<lbrace>Q\<rbrace>"
   assumes y: "\<lbrace>P'\<rbrace> p \<lbrace>Q'\<rbrace>"
   shows      "\<lbrace>P \<^bold>\<and> P'\<rbrace> p \<lbrace>Q \<^bold>\<and> Q'\<rbrace>"
 apply (clarsimp simp: valid_proc_def)
 apply (rule vcg_conj)
  apply (rule vcg_pre[OF spec[OF spec[OF x[unfolded Ball_def valid_proc_def split_paired_All]], simplified, rule_format]], simp, simp)
 apply (rule vcg_pre[OF spec[OF spec[OF y[unfolded Ball_def valid_proc_def split_paired_All]], simplified, rule_format]], simp, simp)
 done
 
 lemma valid_all_lift:
   assumes "\<And>x. \<lbrace>P x\<rbrace> p \<lbrace>Q x\<rbrace>"
   shows "\<lbrace>\<lambda>s. \<forall>x. P x s\<rbrace> p \<lbrace>\<lambda>s. \<forall>x. Q x s\<rbrace>"
 using assms by (fastforce simp: valid_proc_def intro: vcg_all_lift)
 
 (*>*)
 text\<open>
 
 As we elide formal proofs in this document, we also omit our
 specialised proof tactics. These support essentially traditional local
 correctness and non-interference proofs. Their most interesting aspect
 is the use of Isabelle's parallelism to greatly reduce system latency.
 
 \<close>
 (*<*)
 
 subsection\<open>Tactics\<close>
 
 named_theorems nie "Non-interference elimination rules"
 
 text\<open>
 
 Collect the component definitions. Inline everything.
 
 \<close>
 
 lemmas gc_defs =
   (* gc.com_def *) gc.handshake_done_def gc.handshake_init_def gc.handshake_noop_def gc.handshake_get_roots_def gc.handshake_get_work_def
   mark_object_fn_def
 
 lemmas mut_defs =
   (* mut.com_def *) mut_m.handshake_def mut_m.store_def
   mark_object_fn_def
 
 lemmas sys_defs =
   (* sys.com_def *) sys.alloc_def sys.free_def sys.mem_TSO_def sys.handshake_def
 
 lemmas gc_all_defs[com] =
   gc.com_def[simplified gc_defs append.simps if_True if_False]
   mut_m.com_def[simplified mut_defs append.simps if_True if_False]
   sys.com_def[simplified sys_defs append.simps if_True if_False]
 
 (* FIXME not automation friendly. *)
 lemma atS_dests:
   "\<lbrakk> atS p ls s; atS p ls' s \<rbrakk> \<Longrightarrow> atS p (ls \<union> ls') s"
   "\<lbrakk> \<not>atS p ls s; \<not>atS p ls' s \<rbrakk> \<Longrightarrow> \<not>atS p (ls \<union> ls') s"
   "\<lbrakk> \<not>atS p ls s; atS p ls' s \<rbrakk> \<Longrightarrow> atS p (ls' - ls) s"
   "\<lbrakk> \<not>atS p ls s; at p l s \<rbrakk> \<Longrightarrow> atS p ({l} - ls) s"
 by (auto simp: atS_def)
 
 (* FIXME these leave \<not>at ... assumptions when P is easy to contradict. *)
 lemma thin_locs:
   "\<lbrakk> at p l' s \<longrightarrow> P; at p l s; l' \<noteq> l \<or> P \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
   "\<lbrakk> atS p ls s \<longrightarrow> P; at p l s; l \<notin> ls \<or> P \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
 (*  "\<lbrakk> at p l' s \<longrightarrow> P; atS p ls s; ... FIXME strategy: reduce atS to at and use the first of thin_locs. *)
 (*  "\<lbrakk> atS p ls' s \<longrightarrow> P; atS p ls s; \<not>atS p (ls' \<inter> ls) s \<or> P \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q" *)
 by (auto simp: atS_def)
 
 text\<open>
 
 The following is unfortunately overspecialised to the GC. One might
 hope for general tactics that work on all CIMP programs.
 
 The system responds to all requests. The schematic variable is
 instantiated with the semantics of the responses. Thanks to Thomas
 Sewell for the hackery.
 
 \<close>
 
 schematic_goal system_responds_actionE:
   "\<lbrakk> (\<lbrace>l\<rbrace> Response action, afts) \<in> fragments (gc_pgms p) \<langle>False\<rangle>; v \<in> action x s;
      \<lbrakk> p = sys; ?P \<rbrakk> \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
 apply (cases p)
 apply (simp_all add: gc_all_defs)
 apply atomize
 
 apply (drule_tac P="x \<or> y" and Q="v \<in> action p k" for x y p k in conjI, assumption)
 apply (thin_tac "v \<in> action p k" for p k)
 apply (simp only: conj_disj_distribR conj_assoc mem_Collect_eq cong: conj_cong)
 
 apply (erule mp)
 apply (thin_tac "p = sys")
 apply (assumption)
 done
 
 lemma triv: "P \<Longrightarrow> P"
   by simp
 
 schematic_goal system_responds_action_caseE:
   "\<lbrakk> (\<lbrace>l\<rbrace> Response action, afts) \<in> fragments (gc_pgms p) \<langle>False\<rangle>; v \<in> action (pname, req) s;
      \<lbrakk> p = sys; case_request_op ?P1 ?P2 ?P3 ?P4 ?P5 ?P6 ?P7 ?P8 ?P9 ?P10 ?P11 ?P12 ?P13 req \<rbrakk> \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
   apply (erule(1) system_responds_actionE)
   apply (cases req, simp_all only: request_op.simps prod.inject simp_thms fst_conv snd_conv)
   apply (drule meta_mp[OF _ TrueI], erule meta_mp, erule_tac P="A \<and> B" for A B in triv)+
   done
 
 schematic_goal system_responds_action_specE:
   "\<lbrakk> (\<lbrace>l\<rbrace> Response action, afts) \<in> fragments (gc_pgms p) \<langle>False\<rangle>; v \<in> action x s;
      \<lbrakk> p = sys; case_request_op ?P1 ?P2 ?P3 ?P4 ?P5 ?P6 ?P7 ?P8 ?P9 ?P10 ?P11 ?P12 ?P13 (snd x) \<rbrakk> \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
   apply (erule system_responds_action_caseE[where pname="fst x" and req="snd x"])
    apply simp
   apply assumption
   done
 
 (* Simplification rules for locations. *)
 lemmas loc_simps =
   bex_simps
   append.simps list.simps rev.simps (* evaluate string equality *)
   char.inject cong_exp_iff_simps (* evaluate character equality *)
   prefix_code suffix_to_prefix
   mem_Collect_eq Un_iff UNION_eq Compl_iff insertI1 insertI2 singleton_iff Diff_iff UNIV_I
   if_True if_False
   fun_upd_same fun_upd_other process_name.simps
   refl simp_thms
   atS_simps
 
 lemmas vcg_fragments'_simps =
   valid_proc_def gc_pgms.simps vcg_fragments'.simps atC.simps
   ball_Un bool_simps if_False if_True
 
 (* equations for deriving useful things from eq_imp facts. *)
 lemmas eq_imp_simps =
   eq_imp_def
   all_conj_distrib
   split_paired_All split_def fst_conv snd_conv prod_eq_iff
   conj_explode
   simp_thms
 
 (* Tweak the default simpset:
   - "not in dom" as a premise negates the goal
   - we always want to execute suffix
   - we may as well simplify under our non-recursive datatypes.
 *)
 declare dom_def[simp]
 declare suffix_to_prefix[simp]
 
 declare gc_phase.case_cong[cong]
 declare mem_write_action.case_cong[cong]
 declare process_name.case_cong[cong]
 declare handshake_phase.case_cong[cong]
 
 ML \<open>
 
 (* Thanks BNF people. *)
 fun ss_only thms ctxt = clear_simpset (put_simpset HOL_basic_ss ctxt) addsimps thms;
 
 (* Thanks BNF people. Actually use HOL_ss rather than HOL_basic_ss *)
 fun HOL_ss_only thms ctxt = clear_simpset (put_simpset HOL_ss ctxt) addsimps thms;
 
 fun vcg_clarsimp_tac ctxt =
         simp_tac (ss_only (@{thms vcg_fragments'_simps} @ Named_Theorems.get ctxt @{named_theorems com}) ctxt)
   THEN' SELECT_GOAL (safe_tac ctxt)
 
 val _ =
   Theory.setup (Method.setup @{binding vcg_clarsimp}
     (Method.sections clasimp_modifiers >> K (SIMPLE_METHOD' o vcg_clarsimp_tac))
     "unfold com defs, execute vcg_fragments' and split goals")
 
 fun vcg_sem_tac ctxt =
         Tactic.match_tac ctxt @{thms vcg.intros}
   THEN' (TRY o (Tactic.ematch_tac ctxt @{thms system_responds_action_specE} THEN' assume_tac ctxt))
   THEN' Rule_Insts.thin_tac ctxt "hist s = h" [(@{binding s}, NONE, NoSyn), (@{binding h}, NONE, NoSyn)] (* FIXME discard history: we don't use it here *)
   THEN' clarsimp_tac ctxt
 
 val _ =
   Theory.setup (Method.setup @{binding vcg_sem}
     (Method.sections clasimp_modifiers >> K (SIMPLE_METHOD' o vcg_sem_tac))
     "turn VCG goal into semantics and clarsimp")
 
 fun vcg_jackhammer_gen_tac terminal_tac ctxt =
   SELECT_GOAL (
     HEADGOAL (vcg_clarsimp_tac ctxt)
   THEN
     PARALLEL_ALLGOALS (
                  vcg_sem_tac ctxt
     THEN_ALL_NEW (full_simp_tac (Splitter.add_split @{thm lcond_split_asm} (ctxt addsimps Named_Theorems.get ctxt @{named_theorems inv})))
     THEN_ALL_NEW ( (TRY o REPEAT_ALL_NEW (Tactic.ematch_tac ctxt @{thms conjE}))
              THEN' (TRY o REPEAT_ALL_NEW (Tactic.ematch_tac ctxt @{thms thin_locs} THEN' REPEAT1 o assume_tac ctxt))
              THEN' asm_full_simp_tac (ss_only (@{thms loc_simps} @ Named_Theorems.get ctxt @{named_theorems loc}) ctxt)
              THEN_ALL_NEW (TRY o REPEAT_ALL_NEW (Rule_Insts.thin_tac ctxt "True" [])) (* FIXME weird, must be a standard way to do this. Leaving them in can cause simp to diverge ?? *)
              THEN_ALL_NEW clarsimp_tac (ctxt addsimps (Named_Theorems.get ctxt @{named_theorems loc} @ @{thms atS_simps})) (* FIXME smelly *)
              THEN_ALL_NEW Rule_Insts.thin_tac ctxt "AT _ = _" [] (* FIXME discard \<open>AT s = s'(funupd)\<close> fact *)
              THEN_ALL_NEW TRY o terminal_tac ctxt)))
 
 val _ =
   Theory.setup (Method.setup @{binding vcg_jackhammer}
     (Method.sections clasimp_modifiers >> K (SIMPLE_METHOD' o vcg_jackhammer_gen_tac (fn _ => SELECT_GOAL all_tac)))
     "VCG supertactic, no terminal method")
 
 val _ =
   Theory.setup (Method.setup @{binding vcg_jackhammer_ff}
     (Method.sections clasimp_modifiers >> K (SIMPLE_METHOD' o vcg_jackhammer_gen_tac fast_force_tac))
     "VCG supertactic, fastforce the survivors")
 
 fun vcg_ni_tac ctxt =
   SELECT_GOAL (
     HEADGOAL (TRY o vcg_clarsimp_tac ctxt)
   THEN
     PARALLEL_ALLGOALS (
                    vcg_sem_tac ctxt
              THEN' (TRY o SELECT_GOAL (Local_Defs.unfold_tac ctxt (Named_Theorems.get ctxt @{named_theorems inv})))
              THEN' (TRY o REPEAT_ALL_NEW (Tactic.match_tac ctxt @{thms conjI})) (* expose the location predicates, do not split the consequents *)
       THEN_ALL_NEW (TRY o REPEAT_ALL_NEW (Tactic.match_tac ctxt @{thms impI}))
                        (* Preserve the label sets in atS but normalise the label in at; turn s' into s *)
       THEN_ALL_NEW asm_full_simp_tac ctxt (* FIXME diverges on some invariants *)
       THEN_ALL_NEW (TRY o REPEAT_ALL_NEW (Tactic.ematch_tac ctxt @{thms conjE}))
                        (* The effect of vcg_pre: should be cheap *)
       THEN_ALL_NEW (TRY o REPEAT_ALL_NEW (Tactic.ematch_tac ctxt @{thms thin_locs} THEN' REPEAT1 o assume_tac ctxt))
       THEN_ALL_NEW asm_full_simp_tac (ss_only (@{thms loc_simps} @ Named_Theorems.get ctxt @{named_theorems loc}) ctxt)
       THEN_ALL_NEW (TRY o REPEAT_ALL_NEW (Rule_Insts.thin_tac ctxt "True" [])) (* FIXME weird, must be a standard way to do this. Leaving them in can cause simp to diverge ?? *)
 (*      THEN_ALL_NEW Rule_Insts.thin_tac ctxt "AT _ = _" [] (* FIXME discard \<open>AT s = s'(funupd)\<close> fact *) doesn't work when processes communicate! see gc_sweep_loop_invL *)
       THEN_ALL_NEW clarsimp_tac ctxt))
 
 fun vcg_nihe_tac ctxt =
   SELECT_GOAL (
     HEADGOAL (vcg_clarsimp_tac ctxt)
   THEN
     PARALLEL_ALLGOALS (
                      (vcg_sem_tac ctxt
         THEN_ALL_NEW (Tactic.ematch_tac ctxt (Named_Theorems.get ctxt @{named_theorems nie})
         THEN_ALL_NEW clarsimp_tac ctxt
         THEN_ALL_NEW SELECT_GOAL no_tac))
       ORELSE' SELECT_GOAL all_tac)) (* FIXME perhaps replace with vcg_ni? but less diagnosable then *)
 
 val _ =
   Theory.setup (Method.setup @{binding vcg_ni}
     (Method.sections clasimp_modifiers >> K (SIMPLE_METHOD' o vcg_ni_tac))
     "VCG non-interference supertactic, no terminal method")
 
 val _ =
   Theory.setup (Method.setup @{binding vcg_nihe}
     (Method.sections clasimp_modifiers >> K (SIMPLE_METHOD' o vcg_nihe_tac))
     "cheap VCG non-interference tactic: apply non-interference Hoare and elimination rules, leaving remaining goals as Hoare triples")
 \<close>
 
 (*>*)
 (*<*)
 
 end
 (*>*)
diff --git a/thys/ConcurrentGC/concrete/Concrete.thy b/thys/ConcurrentGC/concrete/Concrete.thy
--- a/thys/ConcurrentGC/concrete/Concrete.thy
+++ b/thys/ConcurrentGC/concrete/Concrete.thy
@@ -1,77 +1,79 @@
 (*<*)
 (*
  * Copyright 2015, NICTA
  *
  * This software may be distributed and modified according to the terms of
  * the BSD 2-Clause license. Note that NO WARRANTY is provided.
  * See "LICENSE_BSD2.txt" for details.
  *
  * @TAG(NICTA_BSD)
  *)
 
 theory Concrete
 imports
   Concrete_heap
 begin
 
+declare subst_all [simp del] [[simproc del: defined_all]]
+
 (*>*)
 text\<open>\<close>
 
 context gc_system
 begin
 
 abbreviation sys_init_state :: concrete_local_state where
   "sys_init_state \<equiv>
      undefined\<lparr> fA := initial_mark
               , fM := initial_mark
               , heap := sys_init_heap
               , handshake_pending := \<langle>False\<rangle>
               , handshake_type := ht_GetRoots
               , mem_lock := None
               , mem_write_buffers := \<langle>[]\<rangle>
               , phase := ph_Idle
               , W := {}
               , ghost_honorary_grey := {}
               , ghost_handshake_in_sync := \<langle>True\<rangle>
               , ghost_handshake_phase := hp_IdleMarkSweep \<rparr>"
 
 abbreviation gc_init_state :: concrete_local_state where
   "gc_init_state \<equiv>
      undefined\<lparr> fM := initial_mark
               , fA := initial_mark
               , phase := ph_Idle
               , W := {}
               , ghost_honorary_grey := {} \<rparr>"
 
 primrec lookup :: "('k \<times> 'v) list \<Rightarrow> 'v \<Rightarrow> 'k \<Rightarrow> 'v" where
   "lookup [] v0 k = v0"
 | "lookup (kv # kvs) v0 k = (if fst kv = k then snd kv else lookup kvs v0 k)"
 
 abbreviation muts_init_states :: "(mut \<times> concrete_local_state) list" where
   "muts_init_states \<equiv> [ (0, mut_init_state0), (1, mut_init_state1), (2, mut_init_state2) ]"
 
 abbreviation init_state :: clsts where
   "init_state \<equiv> \<lambda>p. case p of
               gc \<Rightarrow> gc_init_state
             | sys \<Rightarrow> sys_init_state
             | mutator m \<Rightarrow> lookup muts_init_states mut_common_init_state m"
 
 lemma
   "gc_system_init init_state"
 (*<*)
 apply (clarsimp simp: gc_system_init_def
                       gc_initial_state_def
                       mut_initial_state_def
                       sys_initial_state_def)
 apply (auto simp: ran_def)
 apply (auto simp: valid_refs_def)
 apply (erule rtranclp.cases; auto simp: ran_def split: if_splits obj_at_splits)+
 done
 (*>*)
 text\<open>\<close>
 
 end
 (*<*)
 
 end
 (*>*)