(******************************************************************************
 * Orca: A Functional Correctness Verifier for Imperative Programs
 *       Based on Isabelle/UTP
 *
 * Copyright (c) 2016-2018 Virginia Tech, USA
 *               2016-2018 Technische Universität München, Germany
 *               2016-2018 University of York, UK
 *               2016-2018 Université Paris-Saclay, Univ. Paris-Sud, France
 *
 * This software may be distributed and modified according to the terms of
 * the GNU Lesser General Public License version 3.0 or any later version.
 * Note that NO WARRANTY is provided.
 *
 * See CONTRIBUTORS, LICENSE and CITATION files for details.
 ******************************************************************************)

theory utp_heap_scratch
imports   "../../../Isabelle-UTP/utp/utp"
          "../../../Isabelle-UTP/theories/utp_designs"
          "../../AlgebraicLaws/Algebraic_Laws_aux"
begin
subsection {*UTP heap alphabet*}

text {*
*}

alphabet ('hval, 'haddr) hp_vars = des_vars +
  heap_raw:: "'haddr \<rightharpoonup> 'hval"

declare hp_vars.splits [alpha_splits]

subsubsection {*Alphabet proofs*}
text {*
  The two locale interpretations below are a technicality to improve automatic
  proof support via the predicate and relational tactics. This is to enable the
  (re-)interpretation of state spaces to remove any occurrences of lens types
  after the proof tactics @{method pred_simp} and @{method rel_simp}, or any
  of their derivatives have been applied. Eventually, it would be desirable to
  automate both interpretations as part of a custom outer command for defining
  alphabets.
*}

interpretation cp_hp:
  lens_interp "\<lambda> (ok, r) . (ok, heap_raw\<^sub>v r, more r)"
  apply (unfold_locales)
  apply (rule injI)
  apply (clarsimp)
  done

interpretation cp_hp_rel: lens_interp "\<lambda>(ok, ok', r, r').
  (ok, ok', heap_raw\<^sub>v r, heap_raw\<^sub>v r', more r, more r')"
  apply (unfold_locales)
  apply (rule injI)
  apply (clarsimp)
  done

subsubsection {*Type lifting*}

type_synonym  ('hval, 'haddr, '\<alpha>) cphp = "('hval, 'haddr, '\<alpha>) hp_vars_scheme des"
type_synonym ('hval, 'haddr, '\<alpha>,'\<beta>) rel_cphp  = "(('hval, 'haddr,'\<alpha>) cphp, ('hval, 'haddr,'\<beta>) cphp) rel"
type_synonym ('hval, 'haddr, '\<alpha>) hrel_cphp  = "(('hval, 'haddr, '\<alpha>) cphp) hrel"

subsubsection {*Syntactic type setup*}

translations
  (type) "('hval, 'haddr, '\<alpha>) cphp" <= (type) " ('hval, 'haddr, '\<alpha>) hp_vars_scheme des"
  (type) "('hval, 'haddr, '\<alpha>) cphp" <= (type) "('hval, 'haddr, '\<alpha>) hp_vars_ext des"
  (type) "('hval, 'haddr, '\<alpha>,'\<beta>) rel_cphp" <=
         (type) "(('hval, 'haddr,'\<alpha>) cphp, (_, _,'\<beta>) cphp) rel"

notation hp_vars_child_lens\<^sub>a ("\<Sigma>\<^sub>h\<^sub>p")
notation hp_vars_child_lens ("\<Sigma>\<^sub>H\<^sub>P")

syntax
  "_svid_st_alpha"  :: "svid" ("\<Sigma>\<^sub>H\<^sub>P")
  "_svid_st_a"  :: "svid" ("\<Sigma>\<^sub>h\<^sub>p")
translations
  "_svid_st_alpha" => "CONST hp_vars_child_lens"
   "_svid_st_a" => "CONST hp_vars_child_lens\<^sub>a"

syntax
  "_top_abr" :: "logic" ("\<top>\<^sub>H\<^sub>P")
  "_bot_abr" :: "logic" ("\<bottom>\<^sub>H\<^sub>P")

translations
  "\<top>\<^sub>H\<^sub>P" => "(CONST not_upred (CONST utp_expr.var (CONST ivar CONST ok)))"
  "\<bottom>\<^sub>H\<^sub>P" => "true"

subsection {*Substitution lift and drop*}

abbreviation lift_rel_usubst_cpa ("\<lceil>_\<rceil>\<^sub>S\<^sub>H\<^sub>P")
where "\<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>H\<^sub>P \<equiv> \<sigma> \<oplus>\<^sub>s (\<Sigma>\<^sub>H\<^sub>P \<times>\<^sub>L \<Sigma>\<^sub>H\<^sub>P)"

abbreviation lift_usubst_cpa ("\<lceil>_\<rceil>\<^sub>s\<^sub>H\<^sub>P")
where "\<lceil>\<sigma>\<rceil>\<^sub>s\<^sub>H\<^sub>P \<equiv> \<lceil>\<lceil>\<sigma>\<rceil>\<^sub>s\<rceil>\<^sub>S\<^sub>H\<^sub>P"

abbreviation drop_cpa_rel_usubst ("\<lfloor>_\<rfloor>\<^sub>S\<^sub>H\<^sub>P")
where "\<lfloor>\<sigma>\<rfloor>\<^sub>S\<^sub>H\<^sub>P \<equiv> \<sigma> \<restriction>\<^sub>s (\<Sigma>\<^sub>H\<^sub>P \<times>\<^sub>L \<Sigma>\<^sub>H\<^sub>P)"

abbreviation drop_cpa_usubst ("\<lfloor>_\<rfloor>\<^sub>s\<^sub>H\<^sub>P")
where "\<lfloor>\<sigma>\<rfloor>\<^sub>s\<^sub>H\<^sub>P \<equiv> \<lfloor>\<lfloor>\<sigma>\<rfloor>\<^sub>S\<^sub>H\<^sub>P\<rfloor>\<^sub>s"

subsection {*UTP-Relations lift and drop*}

abbreviation lift_rel_uexpr_cpa ("\<lceil>_\<rceil>\<^sub>H\<^sub>P")
where "\<lceil>P\<rceil>\<^sub>H\<^sub>P \<equiv> P \<oplus>\<^sub>p (\<Sigma>\<^sub>H\<^sub>P \<times>\<^sub>L \<Sigma>\<^sub>H\<^sub>P)"

abbreviation lift_pre_uexpr_cpa ("\<lceil>_\<rceil>\<^sub>H\<^sub>P\<^sub><")
where "\<lceil>p\<rceil>\<^sub>H\<^sub>P\<^sub>< \<equiv> \<lceil>\<lceil>p\<rceil>\<^sub><\<rceil>\<^sub>H\<^sub>P"

abbreviation lift_post_uexpr_cpa ("\<lceil>_\<rceil>\<^sub>H\<^sub>P\<^sub>>")
where "\<lceil>p\<rceil>\<^sub>H\<^sub>P\<^sub>> \<equiv> \<lceil>\<lceil>p\<rceil>\<^sub>>\<rceil>\<^sub>H\<^sub>P"

abbreviation drop_cpa_rel_uexpr ("\<lfloor>_\<rfloor>\<^sub>H\<^sub>P")
where "\<lfloor>P\<rfloor>\<^sub>H\<^sub>P \<equiv> P \<restriction>\<^sub>p (\<Sigma>\<^sub>H\<^sub>P \<times>\<^sub>L \<Sigma>\<^sub>H\<^sub>P)"

abbreviation drop_cpa_pre_uexpr ("\<lfloor>_\<rfloor>\<^sub><\<^sub>H\<^sub>P")
where "\<lfloor>P\<rfloor>\<^sub><\<^sub>H\<^sub>P \<equiv> \<lfloor>\<lfloor>P\<rfloor>\<^sub>H\<^sub>P\<rfloor>\<^sub><"

abbreviation drop_cpa_post_uexpr ("\<lfloor>_\<rfloor>\<^sub>>\<^sub>H\<^sub>P")
where "\<lfloor>P\<rfloor>\<^sub>>\<^sub>H\<^sub>P \<equiv> \<lfloor>\<lfloor>P\<rfloor>\<^sub>H\<^sub>P\<rfloor>\<^sub>>"

subsection{*Healthiness conditions*}

subsection{*Control flow statements*}
text {**}
subsection{*Loops*}
subsection{*Experiments*}
term "map_lens k"

term "&heap_raw"
term "fun_upd f 0 (Some 1)"
term "(trop fun_upd (&heap_raw) \<guillemotleft>add::nat\<guillemotright> (uop Some \<guillemotleft>v::int\<guillemotright>))"
term "\<lbrakk>trop fun_upd (&heap_raw) \<guillemotleft>add\<guillemotright> (uop Some \<guillemotleft>v\<guillemotright>)\<rbrakk>\<^sub>e s add = Some v"

lemma "(trop fun_upd (&heap_raw) \<guillemotleft>add::nat\<guillemotright> (uop Some \<guillemotleft>v::int\<guillemotright>)) = mem \<Longrightarrow>
      \<exists>s. \<lbrakk>mem\<rbrakk>\<^sub>e s add =  Some v"
  apply rel_simp
  apply (auto  split: if_splits)
  done
term "store ptr v = (trop fun_upd (&heap_raw) ptr (uop Some v))"
 term "(trop fun_upd (&heap_raw) ptr (uop Some v))"

term "restricted_load ptr = utp_expr.var (map_lens ptr ;\<^sub>L heap_raw)"
term "uop (\<lambda>ptr. get\<^bsub>map_lens ptr ;\<^sub>L heap_raw\<^esub>)"

term "load ptru = (\<lambda>ptr \<bullet> utp_expr.var (map_lens ptr ;\<^sub>L heap_raw))(ptru)\<^sub>a"
term "\<lambda>ptru. (\<lambda>ptr \<bullet> utp_expr.var (map_lens ptr ;\<^sub>L heap_raw))(ptru)\<^sub>a"

datatype block =  available| freed
term "(utp_expr.var (map_lens ptr ;\<^sub>L heap_raw))"
term "get\<^bsub>(heap_raw)\<^esub> s"
term "&heap_raw"
term "ulambda"
lift_definition ulambda_rev :: "('a \<Rightarrow> 'b, '\<alpha>) uexpr \<Rightarrow> ('a \<Rightarrow> ('b, '\<alpha>) uexpr)"
is "\<lambda> f x A. f A x" .
term "ulambda_rev (utp_expr.var (map_lens ptr ;\<^sub>L heap_raw))"

term "uop (ulambda_rev (&heap_raw)) p "
term "((&heap_raw) s)"
term "(&heap_raw)"
term "utp_expr.var ( map_lens ptr ;\<^sub>L heap_raw)"
term "(map_lens ptr ;\<^sub>L heap_raw)"
find_consts  "('a \<Rightarrow> 'b, 'c) uexpr \<Rightarrow> ('a \<Rightarrow> ('b, 'c) uexpr) "
term "\<lambda>x\<bullet> \<guillemotleft>(x::int)\<guillemotright>"
datatype ('n,'a) Ptr = pt:ptr | nm: Numeral (selctn:'n)
find_theorems name:".Ptr."
term "ptr"
term "pt"
term "\<lparr> lens_get = (\<lambda>s. None),
        lens_put = (\<lambda>s v. ptr) \<rparr>"

term " (case s of Numeral n \<Rightarrow> Some (Numeral v) | _ \<Rightarrow> None)"
term "Numeral "
term "\<lparr> lens_get = (\<lambda>s. (case s of Numeral n \<Rightarrow> Some n | _ \<Rightarrow> None)),
        lens_put = (\<lambda>s v. Numeral (the v)) \<rparr>"
term "\<lparr>lens_get = the, lens_put = \<lambda>s. Some\<rparr>"

 term "path P ;\<^sub>L the\<^sub>L ;\<^sub>L indx B"
 term "path P ;\<^sub>L
       \<lparr>lens_get = the, lens_put = \<lambda>_. Some\<rparr> ;\<^sub>L
       indx B"

term "\<lambda>(N) v . undefined"
term "Pair s s"
term "\<lambda>(s, s') v . undefined"
end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

theory AbstractSeparation_SD
imports
  AbstractSeparationHelpers_SD
  "Sep_Algebra.Map_Extra"
  "DSpec.Types_D"
begin

datatype cdl_component_id = Fields | Slot nat
type_synonym cdl_component_ids = "cdl_component_id set"

translations
  (type) "cdl_component_ids" <=(type) "cdl_component_id set"

(* The cdl_component are the pieces of capDL objects that we are interested in our lifted heap.
 * These components are either objects without capabilities or capabilities.
 *)
datatype cdl_component = CDL_Object cdl_object | CDL_Cap "cdl_cap option"

(* The state for separation logic is an option map
 * from (obj_id,component) to sep_entities
 *)
type_synonym sep_state_heap = "(cdl_object_id \<times> cdl_component_id) \<Rightarrow> cdl_component option"
type_synonym sep_state_irq_map = "cdl_irq \<Rightarrow> cdl_object_id option"

translations
  (type) "sep_state_heap" <=(type) "32 word \<times> cdl_component_id \<Rightarrow> cdl_component option"

(* Our lifted state contains sep_entities and the IRQ table.
 *)
datatype sep_state =
  SepState "(cdl_object_id \<times> cdl_component_id) \<Rightarrow> cdl_component option"
           "cdl_irq \<Rightarrow> cdl_object_id option"

(* Functions to get the object heap and the irq table from the sep_state. *)
primrec sep_heap :: "sep_state \<Rightarrow> sep_state_heap"
where "sep_heap (SepState heap irqs) = heap"

primrec sep_irq_node :: "sep_state \<Rightarrow> sep_state_irq_map"
where "sep_irq_node (SepState heap irqs) = irqs"

(* Adding states adds the separation entity heap and the IRQ table.
 *)
definition
  sep_state_add :: "sep_state \<Rightarrow> sep_state \<Rightarrow> sep_state"
where
  "sep_state_add state_a state_b \<equiv>
  SepState ((sep_heap state_a) ++ (sep_heap state_b))
           ((sep_irq_node state_a) ++ sep_irq_node state_b)"

(* State are disjoint the separation entity heaps and the IRQ tables are dijoint.
 *)
definition
  sep_state_disj :: "sep_state \<Rightarrow> sep_state \<Rightarrow> bool"
where
  "sep_state_disj state_a state_b \<equiv>
   (sep_heap state_a) \<bottom> (sep_heap state_b) \<and>
   (sep_irq_node state_a) \<bottom> (sep_irq_node state_b)"

lemma sep_state_add_comm:
  "sep_state_disj x y \<Longrightarrow> sep_state_add x y = sep_state_add y x"
  by (fastforce simp: sep_state_add_def sep_state_disj_def intro!:map_add_com)

(*********************************************)
(* Definition of separation logic for capDL. *)
(*********************************************)

instantiation "sep_state" :: zero
begin
  definition "0 \<equiv> SepState (\<lambda>p. None) Map.empty"
  instance ..
end

instantiation "sep_state" :: stronger_sep_algebra
begin

definition "(##) \<equiv> sep_state_disj"
definition "(+) \<equiv> sep_state_add"

(************************************************
 * The proof that this is a separation algebra. *
 ************************************************)

instance
  apply standard
(* x ## 0 *)
       apply (simp add: sep_disj_sep_state_def sep_state_disj_def zero_sep_state_def)
(* x ## y \<Longrightarrow> y ## x *)
      apply (clarsimp simp: sep_disj_sep_state_def sep_state_disj_def Let_unfold
                            map_disj_com Int_commute)
(* x + 0 = x *)
     apply (simp add: plus_sep_state_def sep_state_add_def zero_sep_state_def)
     apply (case_tac x,simp)
(* x ## y \<Longrightarrow> x + y = y + x *)
    apply (clarsimp simp: plus_sep_state_def sep_disj_sep_state_def)
    apply (erule sep_state_add_comm)
(* (x + y) + z = x + (y + z) *)
   apply (simp add: plus_sep_state_def sep_state_add_def)+
(* x ## y + z = (x ## y \<and> x ## z) *)
   apply (clarsimp simp: sep_disj_sep_state_def)
   apply (auto simp: map_disj_def sep_state_disj_def)
  done
end

(*************************************************************
 * The proof that this is a cancellative separation algebra. *
 *************************************************************)

instantiation "sep_state" :: cancellative_sep_algebra
begin

instance
  apply (standard; simp add: sep_disj_sep_state_def sep_state_disj_def zero_sep_state_def
                   plus_sep_state_def sep_state_add_def)
  apply (metis map_add_subsumed1 map_le_refl sep_heap.simps sep_irq_node.simps sep_state.exhaust)
  by (metis map_add_left_eq sep_heap.simps sep_irq_node.simps sep_state.exhaust)
end

end


(*  Title:      HOL/Auth/n_germanSimp_lemma_inv__54_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_germanSimp Protocol Case Study*}

theory n_germanSimp_lemma_inv__54_on_rules imports n_germanSimp_lemma_on_inv__54
begin
section{*All lemmas on causal relation between inv__54*}
lemma lemma_inv__54_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__54  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__0 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__1 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_StoreVsinv__54) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqSVsinv__54) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__0 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqE__part__0Vsinv__54) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__1 N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqE__part__1Vsinv__54) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__0Vsinv__54) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__1Vsinv__54) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvAckVsinv__54) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvInvAckVsinv__54) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntSVsinv__54) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntEVsinv__54) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntSVsinv__54) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntEVsinv__54) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


(*
 * Copyright 2014, General Dynamics C4 Systems
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

(*
The main architecture independent data types and type definitions in
the abstract model.
*)

chapter "Basic Data Structures"

theory Structures_A
imports
  Arch_Structs_A
  "ExecSpec.MachineExports"
begin

context begin interpretation Arch .

requalify_types
  aobject_type
  arch_cap
  vm_rights
  arch_kernel_obj
  arch_state
  arch_tcb
  aa_type

requalify_consts
  acap_rights
  acap_rights_update
  arch_kobj_size
  arch_obj_size
  aobj_ref
  asid_high_bits
  asid_low_bits
  arch_is_frame_type
  badge_bits
  default_arch_tcb
  arch_tcb_context_get
  arch_tcb_context_set
  arch_tcb_set_registers
  arch_tcb_get_registers
  cte_level_bits
  tcb_bits
  endpoint_bits
  ntfn_bits
  aa_type
  untyped_min_bits
  untyped_max_bits
  msg_label_bits
end

text \<open>
  User mode can request these objects to be created by retype:
\<close>
datatype apiobject_type =
    Untyped
  | TCBObject
  | EndpointObject
  | NotificationObject
  | CapTableObject
  | ArchObject aobject_type

definition
  is_frame_type :: "apiobject_type \<Rightarrow> bool"
where
  "is_frame_type obj \<equiv> case obj of
        ArchObject aobj \<Rightarrow> arch_is_frame_type aobj
      | _ \<Rightarrow> False"

text \<open>These allow more informative type signatures for IPC operations.\<close>
type_synonym badge = data
type_synonym msg_label = data
type_synonym message = data

text \<open>This type models refences to capability slots. The first element
  of the tuple points to the object the capability is contained in. The second
  element is the index of the slot inside a slot-containing object. The default
  slot-containing object is a cnode, thus the name @{text cnode_index}.
\<close>
type_synonym cnode_index = "bool list"
type_synonym cslot_ptr = "obj_ref \<times> cnode_index"

text \<open>Capabilities. Capabilities represent explicit authority to perform some
action and are required for all system calls. Capabilities to Endpoint,
Notification, Thread and CNode objects allow manipulation of standard kernel
objects. Untyped capabilities allow the creation and removal of kernel objects
from a memory region. Reply capabilities allow sending a one-off message to
a thread waiting for a reply. IRQHandler and IRQControl caps allow a user to
configure the way interrupts on one or all IRQs are handled. Capabilities to
architecture-specific facilities are provided through the @{text arch_cap} type.
Null capabilities are the contents of empty capability slots; they confer no
authority and can be freely replaced. Zombie capabilities are stored when
the deletion of CNode and Thread objects is partially completed; they confer no
authority but cannot be replaced until the deletion is finished.
\<close>

datatype cap
         = NullCap
         | UntypedCap bool obj_ref nat nat
           \<comment> \<open>device flag, pointer, size in bits (i.e. @{text "size = 2^bits"}) and freeIndex (i.e. @{text "freeRef = obj_ref + (freeIndex * 2^4)"})\<close>
         | EndpointCap obj_ref badge cap_rights
         | NotificationCap obj_ref badge cap_rights
         | ReplyCap obj_ref bool cap_rights
         | CNodeCap obj_ref nat "bool list"
           \<comment> \<open>CNode ptr, number of bits translated, guard\<close>
         | ThreadCap obj_ref
         | DomainCap
         | IRQControlCap
         | IRQHandlerCap irq
         | Zombie obj_ref "nat option" nat
           \<comment> \<open>@{text "cnode ptr * nat + tcb or cspace ptr"}\<close>
         | ArchObjectCap (the_arch_cap: arch_cap)

lemmas cap_cases =
  cap.induct[where cap=cap and P="\<lambda>cap'. cap' = cap \<longrightarrow> P cap'" for cap P, simplified, rule_format]

lemmas cap_cases_asm =
cap.induct[where cap=cap and P="\<lambda>cap'. cap = cap' \<longrightarrow> P cap' \<longrightarrow> R" for P R cap,
  simplified, rule_format, rotated -1]

text \<open>The CNode object is an array of capability slots. The domain of the
function will always be the set of boolean lists of some specific length.
Empty slots contain a Null capability.
\<close>
type_synonym cnode_contents = "cnode_index \<Rightarrow> cap option"

text \<open>Various access functions for the cap type are defined for
convenience.\<close>
definition
  the_cnode_cap :: "cap \<Rightarrow> obj_ref \<times> nat \<times> bool list" where
  "the_cnode_cap cap \<equiv>
  case cap of
    CNodeCap oref bits guard \<Rightarrow> (oref, bits, guard)"

primrec (nonexhaustive)
  cap_ep_badge :: "cap \<Rightarrow> badge"
where
  "cap_ep_badge (EndpointCap _ badge _) = badge"
| "cap_ep_badge (NotificationCap _ badge _) = badge"

primrec (nonexhaustive)
  cap_ep_ptr :: "cap \<Rightarrow> badge"
where
  "cap_ep_ptr (EndpointCap obj_ref _ _) = obj_ref"
| "cap_ep_ptr (NotificationCap obj_ref _ _) = obj_ref"

definition
  bits_of :: "cap \<Rightarrow> nat" where
  "bits_of cap \<equiv> case cap of
    UntypedCap _ _ bits _ \<Rightarrow> bits
  | CNodeCap _ radix_bits _ \<Rightarrow> radix_bits"

definition
  free_index_of :: "cap \<Rightarrow> nat" where
  "free_index_of cap \<equiv> case cap of
    UntypedCap _ _ _ free_index \<Rightarrow> free_index"

definition
  is_reply_cap :: "cap \<Rightarrow> bool" where
  "is_reply_cap cap \<equiv> case cap of ReplyCap _ m _ \<Rightarrow> \<not> m | _ \<Rightarrow> False"
definition
  is_master_reply_cap :: "cap \<Rightarrow> bool" where
  "is_master_reply_cap cap \<equiv> case cap of ReplyCap _ m _ \<Rightarrow> m | _ \<Rightarrow> False"
definition
  is_zombie :: "cap \<Rightarrow> bool" where
  "is_zombie cap \<equiv> case cap of Zombie _ _ _ \<Rightarrow> True | _ \<Rightarrow> False"
definition
  is_arch_cap :: "cap \<Rightarrow> bool" where
  "is_arch_cap cap \<equiv> case cap of ArchObjectCap _ \<Rightarrow> True | _ \<Rightarrow> False"

context
notes [[function_internals =true]]
begin

fun is_cnode_cap :: "cap \<Rightarrow> bool"
where
  "is_cnode_cap (CNodeCap _ _ _) = True"
| "is_cnode_cap _                = False"

fun is_thread_cap :: "cap \<Rightarrow> bool"
where
  "is_thread_cap (ThreadCap _) = True"
| "is_thread_cap _             = False"

fun is_domain_cap :: "cap \<Rightarrow> bool"
where
  "is_domain_cap DomainCap = True"
| "is_domain_cap _ = False"

fun is_untyped_cap :: "cap \<Rightarrow> bool"
where
  "is_untyped_cap (UntypedCap _ _ _ _) = True"
| "is_untyped_cap _                  = False"

fun is_ep_cap :: "cap \<Rightarrow> bool"
where
  "is_ep_cap (EndpointCap _ _ _) = True"
| "is_ep_cap _                   = False"

fun is_ntfn_cap :: "cap \<Rightarrow> bool"
where
  "is_ntfn_cap (NotificationCap _ _ _) = True"
| "is_ntfn_cap _                        = False"

primrec (nonexhaustive)
  cap_rights :: "cap \<Rightarrow> cap_rights"
where
  "cap_rights (EndpointCap _ _ cr) = cr"
| "cap_rights (NotificationCap _ _ cr) = cr"
| "cap_rights (ReplyCap _ _ cr) = cr"
| "cap_rights (ArchObjectCap acap) = acap_rights acap"
end

text \<open>Various update functions for cap data common to various kinds of
cap are defined here.\<close>
definition
  cap_rights_update :: "cap_rights \<Rightarrow> cap \<Rightarrow> cap" where
  "cap_rights_update cr' cap \<equiv>
   case cap of
     EndpointCap oref badge cr \<Rightarrow> EndpointCap oref badge cr'
   | NotificationCap oref badge cr
     \<Rightarrow> NotificationCap oref badge (cr' - {AllowGrant, AllowGrantReply})
   | ReplyCap t m cr \<Rightarrow> ReplyCap t m (cr' - {AllowRead, AllowGrantReply} \<union> {AllowWrite})
   | ArchObjectCap acap \<Rightarrow> ArchObjectCap (acap_rights_update cr' acap)
   | _ \<Rightarrow> cap"

definition
  badge_update :: "badge \<Rightarrow> cap \<Rightarrow> cap" where
  "badge_update data cap \<equiv>
   case cap of
     EndpointCap oref badge cr \<Rightarrow> EndpointCap oref (data && mask badge_bits) cr
   | NotificationCap oref badge cr \<Rightarrow> NotificationCap oref (data && mask badge_bits) cr
   | _ \<Rightarrow> cap"

definition
  mask_cap :: "cap_rights \<Rightarrow> cap \<Rightarrow> cap" where
  "mask_cap rights cap \<equiv> cap_rights_update (cap_rights cap \<inter> rights) cap"

section \<open>Message Info\<close>

text \<open>The message info is the first thing interpreted on a user system call
and determines the structure of the message the user thread is sending either to
another user or to a system service. It is also passed to user threads receiving
a message to indicate the structure of the message they have received. The
@{text mi_length} parameter is the number of data words in the body of the
message. The @{text mi_extra_caps} parameter is the number of caps to be passed
together with the message. The @{text mi_caps_unwrapped} parameter is a bitmask
allowing threads receiving a message to determine how extra capabilities were
transferred. The @{text mi_label} parameter is transferred directly from sender
to receiver as part of the message.
\<close>

datatype message_info =
  MI (mi_length: length_type)
     (mi_extra_caps: length_type)
     (mi_caps_unwrapped: data)
     (mi_label: msg_label)

text \<open>Message infos are encoded to or decoded from a data word.\<close>
primrec
  message_info_to_data :: "message_info \<Rightarrow> data"
where
  "message_info_to_data (MI len exc unw mlabel) =
   (let
        extra = exc << 7;
        unwrapped = unw << 9;
        label = mlabel << 12
    in
       label || extra || unwrapped || len)"

definition
  data_to_message_info :: "data \<Rightarrow> message_info"
where
  "data_to_message_info w \<equiv>
   MI (let v = w && mask 7 in if v > 120 then 120 else v)
      ((w >> 7) && mask 2)
      ((w >> 9) && mask 3)
      ((w >> 12) && mask msg_label_bits)"

section \<open>Kernel Objects\<close>

text \<open>Endpoints are synchronous points of communication for threads. At any
time an endpoint may contain a queue of threads waiting to send, a queue of
threads waiting to receive or be idle. Whenever threads would be waiting to
send and receive simultaneously messages are transferred immediately.
\<close>

datatype endpoint
           = IdleEP
           | SendEP "obj_ref list"
           | RecvEP "obj_ref list"

text \<open>Notifications are sets of binary semaphores (stored in the
\emph{badge word}). Unlike endpoints, threads may choose to block waiting to
receive, but not to send.\<close>

datatype ntfn
           = IdleNtfn
           | WaitingNtfn "obj_ref list"
           | ActiveNtfn badge

record notification =
  ntfn_obj :: ntfn
  ntfn_bound_tcb :: "obj_ref option"

definition
  default_ep :: endpoint where
  "default_ep \<equiv> IdleEP"

definition
  default_ntfn :: ntfn where
  "default_ntfn \<equiv> IdleNtfn"

definition
  default_notification :: notification where
  "default_notification \<equiv> \<lparr>
     ntfn_obj = default_ntfn,
     ntfn_bound_tcb = None \<rparr>"

text \<open>Thread Control Blocks are the in-kernel representation of a thread.

Threads which can execute are either in the Running state for normal execution,
in the Restart state if their last operation has not completed yet or in the
IdleThreadState for the unique system idle thread. Threads can also be blocked
waiting for any of the different kinds of system messages. The Inactive state
indicates that the TCB is not currently used by a running thread.

TCBs also contain some special-purpose capability slots. The CTable slot is a
capability to a CNode through which the thread accesses capabilities with which
to perform system calls. The VTable slot is a capability to a virtual address
space (an architecture-specific capability type) in which the thread runs. If
the thread has issued a Reply cap to another thread and is awaiting a reply,
that cap will have a "master" Reply cap as its parent in the Reply slot. The
Caller slot is used to initially store any Reply cap issued to this thread. The
IPCFrame slot stores a capability to a memory frame (an architecture-specific
capability type) through which messages will be sent and received.

If the thread has encountered a fault and is waiting to send it to its
supervisor the fault is stored in @{text tcb_fault}. The user register file is
stored in @{text tcb_context}, the pointer to the cap in the IPCFrame slot in
@{text tcb_ipc_buffer} and the identity of the Endpoint cap through which faults
are to be sent in @{text tcb_fault_handler}.
\<close>

record sender_payload =
 sender_badge           :: badge
 sender_can_grant       :: bool
 sender_can_grant_reply :: bool
 sender_is_call         :: bool

record receiver_payload =
 receiver_can_grant :: bool

datatype thread_state
  = Running
  | Inactive
  | Restart
  | BlockedOnReceive obj_ref receiver_payload
  | BlockedOnSend obj_ref sender_payload
  | BlockedOnReply
  | BlockedOnNotification obj_ref
  | IdleThreadState

type_synonym priority = word8

record tcb =
 tcb_ctable        :: cap
 tcb_vtable        :: cap
 tcb_reply         :: cap
 tcb_caller        :: cap
 tcb_ipcframe      :: cap
 tcb_state         :: thread_state
 tcb_fault_handler :: cap_ref
 tcb_ipc_buffer    :: vspace_ref
 tcb_fault         :: "fault option"
 tcb_bound_notification     :: "obj_ref option"
 tcb_mcpriority    :: priority
 tcb_arch          :: arch_tcb (* arch_tcb must have a field for user context *)

text \<open>Determines whether a thread in a given state may be scheduled.\<close>
primrec
  runnable :: "Structures_A.thread_state \<Rightarrow> bool"
where
  "runnable (Running)               = True"
| "runnable (Inactive)              = False"
| "runnable (Restart)               = True"
| "runnable (BlockedOnReceive x y)  = False"
| "runnable (BlockedOnSend x y)     = False"
| "runnable (BlockedOnNotification x) = False"
| "runnable (IdleThreadState)       = False"
| "runnable (BlockedOnReply)        = False"

definition
  default_tcb :: tcb where
  "default_tcb \<equiv> \<lparr>
      tcb_ctable   = NullCap,
      tcb_vtable   = NullCap,
      tcb_reply    = NullCap,
      tcb_caller   = NullCap,
      tcb_ipcframe = NullCap,
      tcb_state    = Inactive,
      tcb_fault_handler = to_bl (0::machine_word),
      tcb_ipc_buffer = 0,
      tcb_fault      = None,
      tcb_bound_notification  = None,
      tcb_mcpriority = minBound,
      tcb_arch       = default_arch_tcb\<rparr>"

text \<open>
All kernel objects are CNodes, TCBs, Endpoints, Notifications or architecture
specific.
\<close>
datatype kernel_object
         = CNode nat cnode_contents \<comment> \<open>size in bits, and contents\<close>
         | TCB tcb
         | Endpoint endpoint
         | Notification notification
         | ArchObj (the_arch_obj: arch_kernel_obj)

lemmas kernel_object_cases =
  kernel_object.induct[where kernel_object=x and P="\<lambda>x'. x = x' \<longrightarrow> P x'" for x P, simplified, rule_format]

lemmas kernel_object_cases_asm =
kernel_object.induct[where kernel_object=x and P="\<lambda>x'. x = x' \<longrightarrow> P x' \<longrightarrow> R" for P R x,
  simplified, rule_format, rotated -1]

definition aobj_of :: "kernel_object \<Rightarrow> arch_kernel_obj option"
  where
  "aobj_of ko \<equiv> case ko of ArchObj aobj \<Rightarrow> Some aobj | _ \<Rightarrow> None"

text \<open>Checks whether a cnode's contents are well-formed.\<close>

definition
  well_formed_cnode_n :: "nat \<Rightarrow> cnode_contents \<Rightarrow> bool" where
 "well_formed_cnode_n n \<equiv> \<lambda>cs. dom cs = {x. length x = n}"

primrec
  obj_bits :: "kernel_object \<Rightarrow> nat"
where
  "obj_bits (CNode sz cs) = cte_level_bits + sz"
| "obj_bits (TCB t) = tcb_bits"
| "obj_bits (Endpoint ep) = endpoint_bits"
| "obj_bits (Notification ntfn) = ntfn_bits"
| "obj_bits (ArchObj ao) = arch_kobj_size ao"

primrec (nonexhaustive)
  obj_size :: "cap \<Rightarrow> machine_word"
where
  "obj_size NullCap = 0"
| "obj_size (UntypedCap dev r bits f) = 1 << bits"
| "obj_size (EndpointCap r b R) = 1 << obj_bits (Endpoint undefined)"
| "obj_size (NotificationCap r b R) = 1 << obj_bits (Notification undefined)"
| "obj_size (CNodeCap r bits g) = 1 << (cte_level_bits + bits)"
| "obj_size (ThreadCap r) = 1 << obj_bits (TCB undefined)"
| "obj_size (Zombie r zb n) = (case zb of None \<Rightarrow> 1 << obj_bits (TCB undefined)
                                        | Some n \<Rightarrow> 1 << (cte_level_bits + n))"
| "obj_size (ArchObjectCap a) = 1 << arch_obj_size a"

text \<open>Object types:\<close>

datatype a_type =
    ATCB
  | AEndpoint
  | ANTFN
  | ACapTable nat
  | AGarbage nat \<comment> \<open>number of bytes of garbage\<close>
  | AArch aa_type

definition
  a_type :: "kernel_object \<Rightarrow> a_type"
where
 "a_type ob \<equiv> case ob of
           CNode sz cspace           \<Rightarrow> if well_formed_cnode_n sz cspace
                                        then ACapTable sz else AGarbage (cte_level_bits + sz)
         | TCB tcb                   \<Rightarrow> ATCB
         | Endpoint endpoint         \<Rightarrow> AEndpoint
         | Notification notification \<Rightarrow> ANTFN
         | ArchObj ao                \<Rightarrow> AArch (aa_type ao)"

section \<open>Kernel State\<close>

text \<open>The kernel's heap is a partial function containing kernel objects.\<close>
type_synonym kheap = "obj_ref \<Rightarrow> kernel_object option"

text \<open>
Capabilities are created either by cloning an existing capability or by creating
a subordinate capability from it. This results in a capability derivation tree
or CDT. The kernel provides a Revoke operation which deletes all capabilities
derived from one particular capability. To support this, the kernel stores the
CDT explicitly. It is here stored as a tree, a partial mapping from
capability slots to parent capability slots.
\<close>
type_synonym cdt = "cslot_ptr \<Rightarrow> cslot_ptr option"

datatype irq_state =
   IRQInactive
 | IRQSignal
 | IRQTimer
 | IRQReserved

text \<open>The kernel state includes a heap, a capability derivation tree
(CDT), a bitmap used to determine if a capability is the original
capability to that object, a pointer to the current thread, a pointer
to the system idle thread, the state of the underlying machine,
per-irq pointers to cnodes (each containing one notification through which
interrupts are delivered), an array recording which
interrupts are used for which purpose, and the state of the
architecture-specific kernel module.

Note: for each irq, @{text "interrupt_irq_node irq"} points to a cnode which
can contain the notification cap through which interrupts are delivered. In
C, this all lives in a single array. In the abstract spec though, to prove
security, we can't have a single object accessible by everyone. Hence the need
to separate irq handlers.
\<close>
record abstract_state =
  kheap              :: kheap
  cdt                :: cdt
  is_original_cap    :: "cslot_ptr \<Rightarrow> bool"
  cur_thread         :: obj_ref
  idle_thread        :: obj_ref
  machine_state      :: machine_state
  interrupt_irq_node :: "irq \<Rightarrow> obj_ref"
  interrupt_states   :: "irq \<Rightarrow> irq_state"
  arch_state         :: arch_state

text \<open>The following record extends the abstract kernel state with extra
state of type @{typ "'a"}. The specification operates over states of
this extended type. By choosing an appropriate concrete type for @{typ "'a"}
we may obtain different \emph{instantiations} of the kernel specifications
at differing levels of abstraction. See \autoref{c:ext-spec} for further
information.
\<close>
record 'a state = abstract_state + exst :: 'a

section \<open>Helper functions\<close>

text \<open>This wrapper lifts monadic operations on the underlying machine state to
monadic operations on the kernel state.\<close>
definition
  do_machine_op :: "(machine_state, 'a) nondet_monad \<Rightarrow> ('z state, 'a) nondet_monad"
where
 "do_machine_op mop \<equiv> do
    ms \<leftarrow> gets machine_state;
    (r, ms') \<leftarrow> select_f (mop ms);
    modify (\<lambda>state. state \<lparr> machine_state := ms' \<rparr>);
    return r
  od"

text \<open>This function generates the cnode indices used when addressing the
capability slots within a TCB.
\<close>
definition
  tcb_cnode_index :: "nat \<Rightarrow> cnode_index" where
  "tcb_cnode_index n \<equiv> to_bl (of_nat n :: 3 word)"

text \<open>Zombie capabilities store the bit size of the CNode cap they were
created from or None if they were created from a TCB cap. This function
decodes the bit-length of cnode indices into the relevant kernel objects.
\<close>
definition
  zombie_cte_bits :: "nat option \<Rightarrow> nat" where
 "zombie_cte_bits N \<equiv> case N of Some n \<Rightarrow> n | None \<Rightarrow> 3"

lemma zombie_cte_bits_simps[simp]:
 "zombie_cte_bits (Some n) = n"
 "zombie_cte_bits None     = 3"
  by (simp add: zombie_cte_bits_def)+

text \<open>The first capability slot of the relevant kernel object.\<close>
primrec (nonexhaustive)
  first_cslot_of :: "cap \<Rightarrow> cslot_ptr"
where
  "first_cslot_of (ThreadCap oref) = (oref, tcb_cnode_index 0)"
| "first_cslot_of (CNodeCap oref bits g) = (oref, replicate bits False)"
| "first_cslot_of (Zombie oref bits n) = (oref, replicate (zombie_cte_bits bits) False)"

text \<open>The set of all objects referenced by a capability.\<close>
primrec
  obj_refs :: "cap \<Rightarrow> obj_ref set"
where
  "obj_refs NullCap = {}"
| "obj_refs (ReplyCap r m cr) = {}"
| "obj_refs IRQControlCap = {}"
| "obj_refs (IRQHandlerCap irq) = {}"
| "obj_refs (UntypedCap dev r s f) = {}"
| "obj_refs (CNodeCap r bits guard) = {r}"
| "obj_refs (EndpointCap r b cr) = {r}"
| "obj_refs (NotificationCap r b cr) = {r}"
| "obj_refs (ThreadCap r) = {r}"
| "obj_refs DomainCap = {}"
| "obj_refs (Zombie ptr b n) = {ptr}"
| "obj_refs (ArchObjectCap x) = set_option (aobj_ref x)"

text \<open>
  The partial definition below is sometimes easier to work with.
  It also provides cases for UntypedCap and ReplyCap which are not
  true object references in the sense of the other caps.
\<close>
primrec (nonexhaustive)
  obj_ref_of :: "cap \<Rightarrow> obj_ref"
where
  "obj_ref_of (UntypedCap dev r s f) = r"
| "obj_ref_of (ReplyCap r m cr) = r"
| "obj_ref_of (CNodeCap r bits guard) = r"
| "obj_ref_of (EndpointCap r b cr) = r"
| "obj_ref_of (NotificationCap r b cr) = r"
| "obj_ref_of (ThreadCap r) = r"
| "obj_ref_of (Zombie ptr b n) = ptr"
| "obj_ref_of (ArchObjectCap x) = the (aobj_ref x)"

primrec (nonexhaustive)
  cap_bits_untyped :: "cap \<Rightarrow> nat"
where
  "cap_bits_untyped (UntypedCap dev r s f) = s"

definition tcb_cnode_map :: "tcb \<Rightarrow> cnode_index \<Rightarrow> cap option"
  where
  "tcb_cnode_map tcb \<equiv>
   [tcb_cnode_index 0 \<mapsto> tcb_ctable tcb,
    tcb_cnode_index 1 \<mapsto> tcb_vtable tcb,
    tcb_cnode_index 2 \<mapsto> tcb_reply tcb,
    tcb_cnode_index 3 \<mapsto> tcb_caller tcb,
    tcb_cnode_index 4 \<mapsto> tcb_ipcframe tcb]"

definition cap_of :: "kernel_object \<Rightarrow> cnode_index \<Rightarrow> cap option"
  where
  "cap_of kobj \<equiv> case kobj of CNode _ cs \<Rightarrow> cs | TCB tcb \<Rightarrow> tcb_cnode_map tcb | _ \<Rightarrow> Map.empty"

text \<open>The set of all caps contained in a kernel object.\<close>

definition
  caps_of :: "kernel_object \<Rightarrow> cap set" where
  "caps_of kobj \<equiv> ran (cap_of kobj)"

section "Cap transfers"

record captransfer =
  ct_receive_root :: cap_ref
  ct_receive_index :: cap_ref
  ct_receive_depth :: data

text \<open>A thread's IPC buffer capability must be to a page that is capable of
containing the IPC buffer without the end of the buffer spilling into another
page.\<close>
definition cap_transfer_data_size :: nat
  where
  "cap_transfer_data_size \<equiv> 3"

definition msg_max_length :: nat
  where
  "msg_max_length \<equiv> 120"

definition msg_max_extra_caps :: nat
  where
  "msg_max_extra_caps \<equiv> 3"

definition max_ipc_length :: nat
  where
  "max_ipc_length \<equiv> cap_transfer_data_size + msg_max_length + msg_max_extra_caps + 2"

definition msg_align_bits :: nat
  where
  "msg_align_bits \<equiv> word_size_bits + (LEAST n. max_ipc_length \<le> 2 ^ n)"

lemma msg_align_bits':
  "msg_align_bits = word_size_bits + 7"
proof -
  have "(LEAST n. (cap_transfer_data_size + msg_max_length + msg_max_extra_caps + 2) \<le> 2 ^ n) = 7"
  proof (rule Least_equality)
    show "(cap_transfer_data_size + msg_max_length + msg_max_extra_caps + 2)  \<le> 2 ^ 7"
      by (simp add: cap_transfer_data_size_def msg_max_length_def msg_max_extra_caps_def)
  next
    fix y
    assume "(cap_transfer_data_size + msg_max_length + msg_max_extra_caps + 2) \<le> 2 ^ y"
    hence "(2 :: nat) ^ 7 \<le> 2 ^ y"
      by (simp add: cap_transfer_data_size_def msg_max_length_def msg_max_extra_caps_def)
    thus "7 \<le> y"
      by (rule power_le_imp_le_exp [rotated], simp)
  qed
  thus ?thesis unfolding msg_align_bits_def max_ipc_length_def by simp
qed

end


theory Wasm_Interpreter_Printing_Pure imports "../Wasm_Interpreter_Properties" Wasm_Type_Abs_Printing "HOL-Library.Code_Target_Nat" (* "Native_Word.Code_Target_Bits_Int" *) begin

axiomatization where
  mem_grow_impl_is[code]: "mem_grow_impl m n = Some (mem_grow m n)"

definition "run = run_v (2^63) 300"

code_printing
  constant host_apply_impl \<rightharpoonup> (OCaml) "ImplWrapper.host'_apply'_impl"

declare Rep_bytes_inverse[code abstype]
declare Rep_mem_inverse[code abstype]

declare write_bytes.rep_eq[code abstract]
and read_bytes.rep_eq[code abstract]
and mem_append.rep_eq[code abstract]

lemma bytes_takefill_rep_eq[code abstract]:
  "Rep_bytes (bytes_takefill b n bs) = takefill b n (Rep_bytes bs)"
  using bytes_takefill.rep_eq Rep_uint8_inverse
  by simp

lemma bytes_replicate_rep_eq[code abstract]:
  "Rep_bytes (bytes_replicate n b) = replicate n b"
  using bytes_replicate.rep_eq Rep_uint8_inverse
  by simp

export_code open run in OCaml

end


(*  Title:      HOL/Auth/n_german_lemma_inv__13_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_german Protocol Case Study*}

theory n_german_lemma_inv__13_on_rules imports n_german_lemma_on_inv__13
begin
section{*All lemmas on causal relation between inv__13*}
lemma lemma_inv__13_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv1 p__Inv2. p__Inv1\<le>N\<and>p__Inv2\<le>N\<and>p__Inv1~=p__Inv2\<and>f=inv__13  p__Inv1 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_StoreVsinv__13) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqSVsinv__13) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqE__part__0Vsinv__13) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqE__part__1Vsinv__13) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqSVsinv__13) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqE N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqEVsinv__13) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__0Vsinv__13) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__1Vsinv__13) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvAckVsinv__13) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvInvAckVsinv__13) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntSVsinv__13) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntEVsinv__13) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntSVsinv__13) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntEVsinv__13) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


theory Kernel_Execution

imports Memory_Model

begin

lemma [simp]:
  "con_set S (s\<lparr>heap := hp ,  incon_set := IS, global_set := GS\<rparr>) =  con_set S (s\<lparr>incon_set := IS\<rparr>) "
  by (clarsimp simp: con_set_def)

lemma [simp]:
  "kernel_data_area (s\<lparr>heap := hp', global_set := GS\<rparr>) = kernel_data_area (s\<lparr>heap := hp'\<rparr>)"
  by (clarsimp simp: kernel_data_area_def kernel_data_def ptable_footprint_def)

lemma [simp]:
  "kernel_data (s\<lparr>heap := hp', global_set := GS\<rparr>)  = kernel_data (s\<lparr>heap := hp'\<rparr>) "
  by (clarsimp simp: kernel_data_def ptable_footprint_def)

lemma [simp]:
  "kernel_mappings (s\<lparr>heap := hp', global_set := GS\<rparr>)  = kernel_mappings (s\<lparr>heap := hp'\<rparr>) "
  by (clarsimp simp: kernel_mappings_def global_mappings_def global_mappings'_def hptable_eq_def)

 lemma [simp]:
  "kernel_safe (s\<lparr>heap := hp',  global_set := GS \<rparr>) =
         kernel_safe (s\<lparr>heap := hp' \<rparr>) "
   by (clarsimp simp: kernel_safe_def vas_of_current_state_mapped_to_global_mappings_of_all_processes_def)

 lemma [simp]:
  "ptrace_set V (s\<lparr>heap := hp',  global_set := GS \<rparr>) =
         ptrace_set V (s\<lparr>heap := hp' \<rparr>) "
   by (clarsimp simp: ptrace_set_def)

 lemma [simp]:
  "root_map  (s\<lparr>heap := hp',  global_set := GS \<rparr>) =
         root_map  (s\<lparr>heap := hp' \<rparr>) "
 by (clarsimp simp: root_map_def  map_of_set_def  root_set_def)

lemma root_map_rootsD:
  "root_map s r = Some a \<Longrightarrow> r \<in> roots s"
  by (simp add: roots_def')

lemma kernel_region_offset':
  " mmu_layout s \<and> mode s = Kernel   \<Longrightarrow>
        \<forall>va\<in>kernel_safe s.  ptable_lift' (heap s) (root s) va =
      Some (Addr (addr_val va) r- global_offset)"
  by (clarsimp simp: mmu_layout_def dest!: root_map_rootsD)

lemma mmu_layout_ptable_comp':
  "\<lbrakk> mmu_layout s; p \<notin> kernel_data_area s \<rbrakk> \<Longrightarrow>
        incon_comp (asid s) (asid s) (heap s) (heap s(p \<mapsto> v)) (root s) (root s) = {}"
  apply (simp add: incon_comp_def ptable_comp_def)
  apply (subgoal_tac "root s \<in> roots s")
   apply (simp add: mmu_layout_pt_walk_pair')
  by (clarsimp simp: mmu_layout_def rootsI)

lemma global_mappings_decode_mmu:
  "\<lbrakk>mmu_layout s ; mode s = Kernel  ; va \<in> kernel_safe s\<rbrakk> \<Longrightarrow>
         \<exists>p perm. decode_pde (the ((heap s)
          (root s r+ (vaddr_pd_index (addr_val va) << 2)))) =  SectionPDE p perm"
  apply (clarsimp simp: kernel_safe_def vas_mapped_by_global_mappings_def
                         kernel_mappings_def global_mappings_def global_mappings'_def  mmu_layout_def dest!: root_map_rootsD)
  apply (drule_tac x = "root s" in bspec)
   apply clarsimp
  apply clarsimp
  apply (drule_tac x = "x" in spec)
  by (clarsimp simp: get_pde'_def decode_heap_pde'_def)

lemma global_high_ptable:
  "\<lbrakk> mmu_layout s ; mode s = Kernel ; Addr vp \<in> (kernel_safe s) ;
        x \<in> ptable_trace' (heap s) (root s) (Addr vp)\<rbrakk>
           \<Longrightarrow> x \<in> high_ptable (root s)"
  apply (frule_tac va = "Addr vp" in global_mappings_decode_mmu ; clarsimp )
  apply (clarsimp simp: ptable_trace'_def Let_def)
  apply (clarsimp simp: mmu_layout_def kernel_safe_def vas_mapped_by_global_mappings_def
  vas_of_current_state_mapped_to_global_mappings_of_all_processes_def dest!: root_map_rootsD)
  apply (subgoal_tac "xa = root s r+ (vaddr_pd_index vp << 2)")
   apply (rule_tac x = "root s" in bexI)
    apply (clarsimp simp: pd_idx_offset_def)
   apply clarsimp
  by (clarsimp simp: ptable_trace'_def)

lemma global_high_ptable':
  "\<lbrakk> mmu_layout s ; mode s = Kernel ; Addr vp \<in> (kernel_safe s) \<rbrakk> \<Longrightarrow>
        \<forall>x\<in>ptable_trace' (heap s) (root s) (Addr vp).
           x \<in> high_ptable (root s)"
   by (clarsimp simp: global_high_ptable)

lemma  kernel_safe_region_ptable_trace'' [simp]:
  " \<lbrakk> mmu_layout s ; mode s = Kernel ; Addr vp' \<in> kernel_safe s;
     vp \<in> kernel_safe s\<rbrakk> \<Longrightarrow>
     Addr (vp' - global_offset) \<notin> ptable_trace' (heap s) (root s) vp"
  apply (frule_tac va = vp in  global_mappings_decode_mmu)
    apply (clarsimp simp: mmu_layout_def)
   apply clarsimp
  apply (clarsimp simp:  mmu_layout_def ptable_trace'_def kernel_safe_def Let_def
      vas_mapped_by_global_mappings_def
        vas_of_current_state_mapped_to_global_mappings_of_all_processes_def
        pd_idx_offset_def dest!: root_map_rootsD)
  done

lemma mmu_layout_pt_comp_heap_same[simp]:
  "\<lbrakk> mmu_layout s; p \<notin> kernel_data_area s ; r \<in> roots s\<rbrakk>
       \<Longrightarrow> ptable_comp (snd (ptable_snapshot s a)) (pt_walk_pair a (heap s) r) =
         ptable_comp (snd (ptable_snapshot s a)) (pt_walk_pair a (heap s(p \<mapsto> v)) r)"
  apply (subgoal_tac "pt_walk_pair a (heap s(p \<mapsto> v)) r = pt_walk_pair a (heap s) r")
   apply clarsimp
  by (rule mmu_layout_pt_walk_pair'; simp)

lemma mmu_layout_global_heap_upd:
  "\<lbrakk>mmu_layout s; p \<notin> kernel_data_area s\<rbrakk>
         \<Longrightarrow> global_entries (ran (pt_walk (asid s) (heap s(p \<mapsto> v)) (root s))) = global_entries (ran (pt_walk (asid s) (heap s) (root s)))"
  apply (subgoal_tac "pt_walk (asid s) (heap s(p \<mapsto> v)) (root s) = pt_walk (asid s)  (heap s) (root s)")
   apply (clarsimp)
  apply (subst mmu_layout_pt_walk'; simp?)
  apply (clarsimp simp: mmu_layout_def roots_def)
  using rootsI roots_def by blast

lemma mmu_layout_global_set_subset':
  "\<lbrakk>mmu_layout s ; rt \<in> roots s \<rbrakk> \<Longrightarrow>   (\<Union>x\<in>global_entries (ran (pt_walk a (heap s) rt)). range_of x) =
           {va::vaddr. rt r+ pd_idx_offset (addr_val va) \<in> high_ptable rt}"
  apply safe
   apply (rename_tac va e)
   apply (subgoal_tac "global (heap s) rt va \<and> (\<exists>e. pt_walk a (heap s) rt va = Some e)")
    apply (clarsimp simp: mmu_layout_def kernel_mappings_def global_mappings_def global_mappings'_def)
    apply (drule_tac x = rt in bspec, simp, clarsimp)
    apply (drule_tac x = "addr_val va" in spec, drule_tac x = "addr_val va" in spec)
    apply (case_tac " rt r+ pd_idx_offset (addr_val va) \<in> high_ptable rt"; clarsimp)
    apply (clarsimp simp: global_def non_global_def is_fault_def pt_walk_def map_opt_def pdc_walk_def  pte_tlb_entry_def
      split: option.splits pde.splits pte.splits)
   apply (subgoal_tac "\<exists>v'. e = the (pt_walk a (heap s) rt v') \<and>(\<exists>e. pt_walk a (heap s) rt v' = Some e)")
    prefer 2
    apply (clarsimp simp:  global_entries_def ran_def is_fault_def)
    apply force
   apply clarsimp
   apply (subgoal_tac "(\<exists>e. pt_walk a (heap s) rt v' = Some e)")
    prefer 2
    apply (clarsimp simp: global_entries_def  ran_def)
   apply (subgoal_tac "pt_walk a (heap s) rt v' = pt_walk a (heap s) rt va")
    apply clarsimp
    apply (subgoal_tac "asid_of (the (pt_walk a (heap s) rt va)) = None")
     prefer 2
     apply (clarsimp simp: global_entries_def)
    apply (clarsimp simp: mmu_layout_def kernel_mappings_def global_mappings_def global_mappings'_def)
    apply (drule_tac x = rt in bspec, simp, clarsimp)
    apply (drule_tac x = "addr_val va" in spec, drule_tac x = "addr_val va" in spec)
    apply (case_tac " rt r+ pd_idx_offset (addr_val va) \<in> high_ptable rt"; clarsimp)
     apply (clarsimp simp: global_def non_global_def is_fault_def pt_walk_def map_opt_def pdc_walk_def  pte_tlb_entry_def
      split: option.splits pde.splits pte.splits)
    apply (clarsimp simp: global_def non_global_def is_fault_def pt_walk_def map_opt_def pdc_walk_def  global_entries_def tag_conv_def
      pte_tlb_entry_def to_tlb_flags_def split: option.splits pde.splits pte.splits)
   apply (rule va_entry_set_pt_palk_same', simp add: is_fault_def, simp)
  apply clarsimp
  apply (rename_tac va)
  apply (subgoal_tac "global (heap s) rt va \<and> \<not>is_fault (pt_walk a (heap s) rt va)")
   apply (rule_tac x = "the (pt_walk a (heap s) rt va)" in bexI, clarsimp)
    apply (simp add: pt_walk'_pt_walk [symmetric])
    apply (frule asid_va_entry_range_pt_entry, simp)
   apply (subgoal_tac "asid_of (the (pt_walk a (heap s) rt va)) = None")
    apply (clarsimp simp: global_entries_def is_fault_def ran_def) apply force
   apply (clarsimp simp: global_def  is_fault_def pt_walk_def map_opt_def pdc_walk_def  pte_tlb_entry_def tag_conv_def to_tlb_flags_def
      split: option.splits pde.splits pte.splits)
  apply (clarsimp simp: mmu_layout_def kernel_mappings_def global_mappings_def global_mappings'_def)
  apply (drule_tac x = rt in bspec, simp, clarsimp)
  apply (drule_tac x = "addr_val va" in spec, drule_tac x = "addr_val va" in spec)
  by (clarsimp simp: global_def non_global_def is_fault_def pt_walk_def map_opt_def pdc_walk_def  pte_tlb_entry_def
      split: option.splits pde.splits pte.splits)

lemma mmu_layout_global_set_subset:
  "mmu_layout s \<Longrightarrow>   (\<Union>x\<in>global_entries (ran (pt_walk (asid s) (heap s) (root s))). range_of x) = global_set s "
  apply (frule_tac rt = "root s"  and a = "asid s" in mmu_layout_global_set_subset')
  using mmu_layout_def rootsI apply force
  by (clarsimp simp: mmu_layout_def  global_set_eq_def)

lemma kernel_safe_assignment:
  "\<Turnstile> \<lbrace>\<lambda>s. mmu_layout s \<and> mode s = Kernel \<and> safe_set (kernel_safe s) s \<and>
           asids_consistent {} s \<and>
           aval lval s = Some vp \<and> aval rval s = Some v \<and>
           Addr vp \<in> (kernel_safe s) \<and> k_phy_ad vp \<notin> kernel_data_area s \<rbrace>
        lval ::= rval
      \<lbrace>\<lambda>s. mmu_layout s \<and> mode s = Kernel \<and> safe_set (kernel_safe s) s \<and>
           asids_consistent {} s \<and> heap s (k_phy_ad vp) = Some v\<rbrace>"
  apply (vcgm vcg: weak_pre_write')
  apply (rule conjI)
   apply (clarsimp simp: asids_consistent_def safe_set_def con_set_def)
  apply (subgoal_tac " ptable_lift' (heap s) (root s) (Addr vp) = Some (Addr vp r-  global_offset)")
   prefer 2
   apply (clarsimp simp: kernel_region_offset')
  apply (clarsimp simp: k_phy_ad_def mmu_layout_ptable_comp' mmu_layout_upd')
  apply (rule conjI)
   apply (clarsimp simp: mmu_layout_global_heap_upd)
   apply (frule_tac mmu_layout_global_set_subset, simp)
   apply (clarsimp simp: k_phy_ad_def mmu_layout_ptable_comp' mmu_layout_upd')
  apply (rule conjI)
   apply (subgoal_tac  "kernel_safe (s\<lparr> heap := heap s(Addr (vp - global_offset) \<mapsto> v)\<rparr>) =
                        kernel_safe s")
    apply (clarsimp simp: safe_set_def safe_memory_def con_set_def)
    apply (drule_tac x = va in bspec; clarsimp)
    apply (rule_tac x = p in exI)
    apply (subgoal_tac "ptable_lift' (heap s) (root s) va =
                      ptable_lift' (heap s(Addr (vp -  global_offset) \<mapsto> v)) (root s) va")
     apply (rule conjI, clarsimp)
     apply (subgoal_tac  "ptrace_set (kernel_safe s) (s\<lparr> heap := heap s(Addr (vp - global_offset) \<mapsto> v)\<rparr>) =
                           ptrace_set (kernel_safe s) s", clarsimp)
     prefer 3
     apply (frule_tac vp = vp in global_high_ptable', clarsimp, clarsimp)
     apply (clarsimp simp: kernel_safe_def  vas_of_current_state_mapped_to_global_mappings_of_all_processes_def)
     apply (rule_tac x = "root s" in bexI, force)
     apply (clarsimp simp: mmu_layout_def dest!: root_map_rootsD)
    prefer 2 apply (rule pt_table_lift_trace_upd', clarsimp)
   apply (clarsimp simp: ptrace_set_def)
   apply safe
    apply (rule_tac a = xa in UN_I, clarsimp)
    prefer 2 apply (rule_tac a = xa in UN_I, clarsimp)
    apply (subgoal_tac "ptable_trace' (heap s(Addr (vp - global_offset) \<mapsto> v)) (root s) xa =
                       ptable_trace' (heap s) (root s) xa", clarsimp)
    prefer 2
    apply (subgoal_tac "ptable_trace' (heap s(Addr (vp - global_offset) \<mapsto> v)) (root s) xa =
                       ptable_trace' (heap s) (root s) xa" , clarsimp)
    apply (rule pt_trace_upd, clarsimp)
   apply (subgoal_tac "ptable_trace' (heap s(Addr (vp - global_offset) \<mapsto> v)) (root s) xa =
                      ptable_trace' (heap s) (root s) xa" , clarsimp)
   apply (rule pt_trace_upd, clarsimp)
  apply (frule_tac mmu_layout_global_set_subset)
  apply (subgoal_tac "(s\<lparr>heap := heap s(Addr (vp - global_offset) \<mapsto> v),
                   global_set := global_set s \<union> (\<Union>x\<in>global_entries (ran (pt_walk (asid s) (heap s(Addr (vp - global_offset) \<mapsto> v)) (root s))). range_of x)\<rparr>) =
   s\<lparr>heap := heap s(Addr (vp - global_offset) \<mapsto> v)\<rparr>")
   apply simp
   apply (clarsimp simp: asids_consistent_def)
   apply (rule)
    apply clarsimp
    apply (subgoal_tac "pt_walk_pair a (heap s(Addr (vp - global_offset) \<mapsto> v)) r = pt_walk_pair a (heap s) r")
     apply force
    apply (rule mmu_layout_pt_walk_pair', simp, simp, simp add: roots_def)
  using root_map_rootsD roots_def apply force
   apply clarsimp
   apply (subgoal_tac "pt_walk_pair a (heap s(Addr (vp - global_offset) \<mapsto> v)) r = pt_walk_pair a (heap s) r")
    apply force
   apply (rule mmu_layout_pt_walk_pair'; simp add: roots_def)
  apply (subgoal_tac "pt_walk (asid s) (heap s(Addr (vp - global_offset) \<mapsto> v)) (root s) = pt_walk (asid s) (heap s) (root s)")
   apply clarsimp
  apply (rule mmu_layout_pt_walk'; simp add: roots_def)
  using mmu_layout_def rootsI roots_def by auto

end