(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory CommonOpsLemmas

imports
  "CommonOps"
begin

lemma fold_all_htd_updates':
  "ptr_retyp (p :: ('a :: c_type) ptr)
    = all_htd_updates TYPE('a) 1 (ptr_val p) 1"
  "(if P then (f :: heap_typ_desc \<Rightarrow> heap_typ_desc) else g) s
    = (if P then f s else g s)"
  "\<lbrakk> n < 2 ^ word_bits \<rbrakk> \<Longrightarrow>
    ptr_retyps n p = all_htd_updates TYPE('a) 1 (ptr_val p) (of_nat n)"
  "\<lbrakk> n < 2 ^ word_bits \<rbrakk> \<Longrightarrow>
    ptr_retyps (2 ^ n) p = all_htd_updates TYPE('a) 3 (ptr_val p) (of_nat n)"
  "n < 2 ^ word_bits \<Longrightarrow> typ_clear_region x n = all_htd_updates TYPE(machine_word) 0 x (of_nat n)"
  "n < 2 ^ word_bits \<Longrightarrow> typ_region_bytes x n = all_htd_updates TYPE(machine_word) 2 x (of_nat n)"
  "\<lbrakk> n < 2 ^ word_bits \<rbrakk> \<Longrightarrow>
    ptr_arr_retyps n p = all_htd_updates TYPE('a) 4 (ptr_val p) (of_nat n)"
  "\<lbrakk> n < 2 ^ word_bits \<rbrakk> \<Longrightarrow>
    ptr_arr_retyps (2 ^ n) p = all_htd_updates TYPE('a) 5 (ptr_val p) (of_nat n)"
  by (simp_all add: all_htd_updates_def fun_eq_iff word_bits_conv take_bit_nat_eq_self unat_of_nat)

lemma upcast_unat_less_2p_length:
    "is_up UCAST('a :: len \<rightarrow> 'b :: len) \<Longrightarrow> unat (x :: 'a word) < 2 ^ LENGTH('b)"
  by (simp add: is_up unat_pow_le_intro)

(* FIXME: this is a hack that happens to work on all arches. Use arch split. *)
lemma is_up_u32_word_size: "is_up UCAST(32 \<rightarrow> machine_word_len)"
  by (clarsimp simp add: is_up_def source_size target_size)

lemma is_up_i32_word_size: "is_up UCAST(32 signed \<rightarrow> machine_word_len)"
  by (clarsimp simp add: is_up_def source_size target_size)

(* This proof is a bit convoluted so that it happens to work with word_bits = 32 and 64 *)
lemma unat_word32_less_2p_word_bits: "unat (x :: 32 word) < 2 ^ word_bits"
  unfolding word_bits_def by (rule upcast_unat_less_2p_length, rule is_up_u32_word_size)

lemma unat_sword32_less_2p_word_bits: "unat (x :: 32 signed word) < 2 ^ word_bits"
  by (rule upcast_unat_less_2p_length[OF is_up_i32_word_size, simplified word_bits_def[symmetric]])

lemmas fold_all_htd_updates_intermediate
    = fold_all_htd_updates'
      fold_all_htd_updates'(3-)[OF unat_less_2p_word_bits]
      fold_all_htd_updates'(3-)[OF unat_word32_less_2p_word_bits]
      fold_all_htd_updates'(3-)[OF unat_sword32_less_2p_word_bits]

lemmas fold_all_htd_updates = fold_all_htd_updates_intermediate[simplified word_bits_conv]

lemma signed_div_range_check:
  assumes len: "size a > 1"
  shows
  "(sint a sdiv sint b = sint (a sdiv b))
    = (a \<noteq> (- (2 ^ (size a - 1))) \<or> b \<noteq> -1)"
proof -
  have sints: "(sint (1 :: 'a word)) = 1"
       "(sint (-1 :: 'a word)) = -1"
       "(sint (0 :: 'a word)) = 0"
    using len
    apply (simp_all add: word_size)
    done
  have abs_sint_gt_1:
    "b \<noteq> 0 \<and> b \<noteq> 1 \<and> b \<noteq> -1 \<Longrightarrow> abs (sint b) > 1"
    apply (fold word_sint.Rep_inject,
        simp only: sints abs_if split: if_split)
    apply arith
    done
  have mag: "(a \<noteq> (- (2 ^ (size a - 1))) \<or> (b \<noteq> -1 \<and> b \<noteq> 1))
    \<Longrightarrow> abs (abs (sint a) div abs (sint b)) < 2 ^ (size a - 1)"
    using word_sint.Rep_inject[where x=a and y="- (2 ^ (size a - 1))"]
          word_sint.Rep_inject[where x=b and y=1]
    apply (simp add: word_size sint_int_min sints)
    apply (simp add: nonneg_mod_div)
    apply (cases "b = 0")
     apply simp
    apply (erule impCE)
     apply (rule order_le_less_trans, rule zdiv_le_dividend, simp_all)
     apply (cut_tac x=a in sint_range')
     apply (clarsimp simp add: abs_if word_size)
    apply (cases "a = 0", simp_all)
    apply (rule order_less_le_trans, rule int_div_less_self, simp_all)
     apply (rule abs_sint_gt_1, simp)
    apply (cut_tac x=a in sint_range')
    apply (clarsimp simp add: abs_if word_size)
    done
  note sint_of_int_eq[simp] signed_take_bit_int_eq_self[simp]
  show ?thesis using mag len
    apply (cases "b = 1")
     apply (case_tac "size a", simp_all)[1]
     apply (case_tac nat, simp_all add: sint_word_ariths word_size)[1]
    apply (simp add: sdiv_int_def sdiv_word_def del: of_int_mult)
    apply (simp add: sbintrunc_eq_in_range range_sbintrunc sgn_if)
    apply (safe, simp_all add: word_size sint_int_min sint_int_max_plus_1;
           simp add: sint_word_ariths)
    done
qed

lemma ptr_add_assertion_uintD:
  "ptr_add_assertion ptr (uint (x :: ('a :: len) word)) strong htd
    \<longrightarrow> (x = 0 \<or> array_assertion ptr (if strong then unat (x + 1) else unat x) htd)"
  by (auto simp: unat_plus_if_size intro: array_assertion_shrink_right)

lemma sint_uint_sless_0_if:
  "sint x = (if x <s 0 then - uint (- x) else uint (x :: ('a :: len) word))"
  apply (simp add: word_sint_msb_eq word_sless_alt
                   word_size uint_word_ariths)
  apply (clarsimp simp: zmod_zminus1_eq_if uint_0_iff)
  done

lemma ptr_add_assertion_sintD:
  "ptr_add_assertion ptr (sint (x :: ('a :: len) word)) strong htd
    \<longrightarrow> (x = 0 \<or> (x <s 0 \<and> array_assertion (ptr +\<^sub>p sint x)
            (unat (- x)) htd)
        \<or> (x \<noteq> 0 \<and> \<not> x <s 0 \<and> array_assertion ptr (if strong then unat (x + 1) else unat x) htd))"
  apply (simp add: ptr_add_assertion_def word_sless_alt
                   sint_uint_sless_0_if[THEN arg_cong[where f="\<lambda>x. - x"]]
                   sint_uint_sless_0_if[THEN arg_cong[where f=nat]]
                   unat_plus_if_size)
  apply (simp add: array_assertion_shrink_right)
  apply (auto simp: linorder_not_less)
  done

\<comment> \<open>
  Some lemmas used by both SimplExport and ProveGraphRefine.
\<close>

lemmas sdiv_word_max_ineq = sdiv_word_max[folded zle_diff1_eq, simplified]

lemmas signed_mult_eq_checks_all =
  signed_mult_eq_checks_double_size[where 'a="32" and 'b="64", simplified]
  signed_mult_eq_checks_double_size[where 'a="32 signed" and 'b="64 signed", simplified]
  signed_mult_eq_checks_double_size[where 'a="64" and 'b="128", simplified]
  signed_mult_eq_checks_double_size[where 'a="64 signed" and 'b="128 signed", simplified]

lemmas signed_arith_ineq_checks_to_eq_all =
  signed_arith_ineq_checks_to_eq[where 'a="32"]
  signed_arith_ineq_checks_to_eq[where 'a="32", simplified word_size, simplified]
  signed_arith_ineq_checks_to_eq[where 'a="32 signed"]
  signed_arith_ineq_checks_to_eq[where 'a="32 signed", simplified word_size, simplified]
  signed_arith_ineq_checks_to_eq[where 'a="64"]
  signed_arith_ineq_checks_to_eq[where 'a="64", simplified word_size, simplified]
  signed_arith_ineq_checks_to_eq[where 'a="64 signed"]
  signed_arith_ineq_checks_to_eq[where 'a="64 signed", simplified word_size, simplified]

lemmas signed_div_range_check_all =
  signed_div_range_check[where 'a="32", simplified word_size, simplified]
  signed_div_range_check[where 'a="32 signed", simplified word_size, simplified]
  signed_div_range_check[where 'a="64", simplified word_size, simplified]
  signed_div_range_check[where 'a="64 signed", simplified word_size, simplified]

lemma word32_31_less:
  "31 < len_of TYPE (32 signed)" "31 > (0 :: nat)"
  "31 < len_of TYPE (32)" "31 > (0 :: nat)"
  by auto

lemma word64_31_less:
  "31 < len_of TYPE (64 signed)" "31 > (0 :: nat)"
  "31 < len_of TYPE (64)" "31 > (0 :: nat)"
  by auto

lemmas signed_shift_guard_to_word_all =
  signed_shift_guard_to_word[OF word32_31_less(1-2)]
  signed_shift_guard_to_word[OF word32_31_less(3-4)]
  signed_shift_guard_to_word[OF word64_31_less(1-2)]
  signed_shift_guard_to_word[OF word64_31_less(3-4)]

lemmas guard_arith_simps =
  neg_le_iff_le
  signed_arith_eq_checks_to_ord
  signed_arith_ineq_checks_to_eq_all
  signed_div_range_check_all
  signed_mult_eq_checks_all
  signed_shift_guard_to_word_all
  sdiv_word_min[THEN eqTrueI] sdiv_word_max_ineq

(* FIXME: move to word lib *)
lemma small_downcasts:
  "unat (x :: 'a :: len word) < 2 ^ LENGTH('b :: len) \<Longrightarrow> unat (UCAST('a \<rightarrow> 'b) x) = unat x"
  apply (case_tac "LENGTH('a) \<le> LENGTH('b)", simp add: unat_ucast_up_simp)
  apply (simp add: unat_ucast unat_less_power)
  done

(* FIXME: move to word lib *)
lemma less_shift_makes_shift_cast_safe:
  "y < (a :: 'a :: len word) >> unat (x :: 'b :: len word) \<Longrightarrow>
  unat (UCAST('b \<rightarrow> 'a) x) = unat x"
  apply (prop_tac "unat x < LENGTH('a)")
   apply (rotate_tac)
   apply (erule contrapos_pp; simp add: not_less)
   apply (prop_tac "a >> unat x = 0")
    apply (rule shiftr_eq_0; simp)
   apply simp
  apply (subst small_downcasts)
  apply (meson le_less_trans n_less_equal_power_2 nat_less_le)
  apply simp
  done

lemmas less_shift_makes_shift_cast_safe_arg_cong =
  arg_cong[where f="f w" for f w, OF less_shift_makes_shift_cast_safe]

\<comment> \<open>
  @{thm less_shift_makes_shift_cast_safe} allows us to
  remove the `ucast` in `unat (ucast x)`, but this loses potentially important
  type information. These rules act as "lenses" to make sure we only modify
  the relevant ucasts (the ones that show up in the guards of translated
  nontrivial shifts).
\<close>
lemmas less_shift_targeted_cast_convs =
  less_shift_makes_shift_cast_safe_arg_cong[where f=shiftr]
  less_shift_makes_shift_cast_safe_arg_cong[where f="(^)"]

end


(*
Copyright 2018

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
*)
theory HTriple
  imports U_exec
begin

datatype ACode =
  Block nat \<open>64 word\<close> nat
| Seq ACode ACode (infixr ";" 70)
| ITE state_pred ACode ACode ("IF _ THEN _ ELSE _ FI")
| ACode_WHILE state_pred  ACode ("WHILE _ DO _ OD")
| CASES "(state_pred \<times> ACode) list"
| CALL ACode (* maybe update to \<open>64 word\<close> ACode eventually to merge the call inst block with the actual call *)
| Skip

context exec_code
begin

inductive while_semantics where
  "\<not> B \<sigma> \<Longrightarrow> while_semantics B body \<sigma> \<sigma>"
| "B \<sigma> \<Longrightarrow> body \<sigma> \<sigma>'' \<Longrightarrow> while_semantics B body \<sigma>'' \<sigma>' \<Longrightarrow> while_semantics B body \<sigma> \<sigma>'"

fun exec_acode :: "ACode \<Rightarrow> state \<Rightarrow> state \<Rightarrow> bool" where
  "exec_acode (Block si end ii) \<sigma> \<sigma>' = (\<sigma>' = exec_block si end ii \<sigma>)"
| "exec_acode (a;b) \<sigma> \<sigma>'' = (\<exists>\<sigma>'. exec_acode a \<sigma> \<sigma>' \<and> exec_acode b \<sigma>' \<sigma>'')"
| "exec_acode (IF f THEN a ELSE b FI) \<sigma> \<sigma>' = (
  if f \<sigma> then
    exec_acode a \<sigma> \<sigma>'
  else
    exec_acode b \<sigma> \<sigma>'
  )"
| "exec_acode (WHILE B DO b OD) \<sigma> \<sigma>' = while_semantics B (exec_acode b) \<sigma> \<sigma>'"
| "exec_acode (CASES x) \<sigma> \<sigma>' = (\<exists> (P,a) \<in> list.set x . P \<sigma> \<and> exec_acode a \<sigma> \<sigma>')"
| "exec_acode (CALL f) \<sigma> \<sigma>' = exec_acode f \<sigma> \<sigma>'"
| "exec_acode Skip \<sigma> \<sigma>' = (\<sigma>' = \<sigma>)"

definition usage :: "(64 word \<times> nat) set \<Rightarrow> state \<Rightarrow> state \<Rightarrow> bool"
  where "usage regions \<sigma> \<sigma>' \<equiv> \<forall>a. no_block_overflow (a, 1) \<and> (\<forall>r\<in>regions. (a, 1) \<bowtie> r) \<and> (\<forall>r\<in>regions. \<not> (a, 1) \<sqsubseteq> r) \<longrightarrow> (\<sigma>' \<turnstile> *[a,1]) = (\<sigma> \<turnstile> *[a,1]::8 word)"

definition block_usage :: "(state \<Rightarrow> (nat \<times> 64 word \<times> nat) set) \<Rightarrow> state \<Rightarrow> state \<Rightarrow> bool"
  where "block_usage regions \<sigma> \<sigma>' \<equiv> \<forall>a. no_block_overflow (a, 1) \<and> (\<forall>r\<in>regions \<sigma>. (a, 1) \<bowtie> snd r) \<and> (\<forall>r\<in>regions \<sigma>. \<not> (a, 1) \<sqsubseteq> snd r) \<longrightarrow> (\<sigma>' \<turnstile> *[a,1]) = (\<sigma> \<turnstile> *[a,1]::8 word)"

definition HTriple_for_memory_preservation :: "state_pred \<Rightarrow> ACode \<Rightarrow> state_pred \<Rightarrow> (64 word \<times> nat) set \<Rightarrow> bool" ("{{_}} _{{_;_}}") where
  "HTriple_for_memory_preservation P a Q M \<equiv> \<forall>\<sigma> \<sigma>'. P \<sigma> \<and> exec_acode a \<sigma> \<sigma>' \<longrightarrow> Q \<sigma>' \<and> usage M \<sigma> \<sigma>'"

text \<open>
  Let @{term f} be a function body.
  A black-box Hoare triple indicates that the memory usage of @{term f} has been verified and is
  represented by memory predicate @{term M\<^sub>f}.
  In order to composably reuse that verification effort, @{term f} is considered black-box.
  The precondition @{term P} represents the state right after the assembly instruction CALL.
  That precondition may contain terms that reason over memory of the caller, e.g., [a,8] == RBP,
  where [a,8] denotes some part of the stack frame of the caller.
  Such terms are not in the pre-/postcondition of the called function.
  However, they must be proven to be preserved by the function call.
  That proof is based on the memory usage of @{term f}.

  A proof over @{term f} can thus be reused, if:
  \<^enum> there exists a Hoare triple over @{term f}.
  \<^enum> preconditon @{term P} can be separated into two parts, one that is relevant to the called
    function, one that is irrelevant to the called function
  \<^enum> the irrelevant part is preserved by @{term f}, and this can be proven based on the memory
    predicate @{term M\<^sub>f}
  \<^enum> the postcondition of @{term f} combined with the irrelevant part of the precondition of
    @{term f} implies the postcondition @{term Q}
\<close>

definition HTriple_blackbox :: "state_pred \<Rightarrow> ACode \<Rightarrow> state_pred \<Rightarrow> (64 word \<times> nat) set \<Rightarrow> bool" ("{{_}} \<box>_ {{_;_}}")
  where "HTriple_blackbox P f Q M\<^sub>f \<equiv> \<exists> P\<^sub>f Q\<^sub>f P\<^sub>s\<^sub>e\<^sub>p .
            ({{P\<^sub>f}} f {{Q\<^sub>f;M\<^sub>f}})                        \<comment> \<open>1.\<close>
          \<and> (\<turnstile> P \<longmapsto> P\<^sub>f && P\<^sub>s\<^sub>e\<^sub>p)                        \<comment> \<open>2.\<close>
          \<and> (\<forall>s s'. usage M\<^sub>f s s' \<and> P\<^sub>s\<^sub>e\<^sub>p s \<longrightarrow> P\<^sub>s\<^sub>e\<^sub>p s') \<comment> \<open>3.\<close>
          \<and> (\<turnstile> Q\<^sub>f && P\<^sub>s\<^sub>e\<^sub>p \<longmapsto> Q)"                       \<comment> \<open>4.\<close>

text \<open>To introduce a Hoare triple for a basic block, it must be shown that:
\<^enum> for any state satisfying the precondition, executing the block produces a memory predicate
  @{term mp} whose state satisfies postcondition Q
\<^enum> the memory usage of the block wrt to the initial state is given by @{term mp}, but may need to be
  translated by @{term t} if the predicate contains state-sensitive terms. Often @{term t} is equal
  to @{term id}.
\<close>

lemma HTriple_I:
  assumes "\<And>\<sigma>. P \<sigma> \<Longrightarrow> exec_block si a i \<sigma> \<triangleq> t \<sigma> \<and> Q (t \<sigma>) \<and> block_usage regions \<sigma> (t \<sigma>)"
      and "M = {r. \<exists>\<sigma>. P \<sigma> \<and> r \<in> snd ` regions \<sigma>}"
  shows "{{P}} Block si a i {{Q;M}}"
  apply (simp add: HTriple_for_memory_preservation_def)
  apply (rule allI)
  subgoal for \<sigma>
    using assms(1)[of \<sigma>] assms(2-)
    unfolding block_usage_def usage_def eq_def
    by (auto simp add: pred_logic) (metis (no_types, hide_lams) image_eqI no_block_overflow.cases)
  done

lemma HTriple_seq:
  assumes "{{P}} a {{Q;M\<^sub>1}}"
    and "{{Q}} b {{R;M\<^sub>2}}"
    and "M = M\<^sub>1 \<union> M\<^sub>2"
  shows "{{P}} a;b {{R;M}}"
  unfolding HTriple_for_memory_preservation_def
  apply auto
  subgoal for s s' s''
    using assms(1)[unfolded HTriple_for_memory_preservation_def, THEN spec, THEN spec, of s s'']
      assms(2)[unfolded HTriple_for_memory_preservation_def, THEN spec, THEN spec, of s'' s']
      assms(3)
    by simp
  subgoal for s s' s''
    using assms(1)[unfolded HTriple_for_memory_preservation_def, THEN spec, THEN spec, of s s'']
      assms(2)[unfolded HTriple_for_memory_preservation_def, THEN spec, THEN spec, of s'' s']
      assms(3)
    by (auto simp add: usage_def)
  done

lemma HTriple_ite:
  assumes "{{P && f}} a {{Q\<^sub>1;M\<^sub>1}}"
      and "{{P && !f}} b {{Q\<^sub>2;M\<^sub>2}}"
      and "Q = (Q\<^sub>1 || Q\<^sub>2)"
      and "M\<^sub>3 = M\<^sub>1 \<union> M\<^sub>2"
    shows "{{P}} IF f THEN a ELSE b FI {{Q;M\<^sub>3}}"
  using assms
  unfolding HTriple_for_memory_preservation_def
  apply (auto simp add: pred_logic)
  subgoal for s s'
    using assms(1)[unfolded HTriple_for_memory_preservation_def, THEN spec, THEN spec, of s s']
      assms(2)[unfolded HTriple_for_memory_preservation_def, THEN spec, THEN spec, of s s']
    by (simp add: usage_def)
  subgoal for s s'
    using assms(1)[unfolded HTriple_for_memory_preservation_def,THEN spec,THEN spec,of s s']
      assms(2)[unfolded HTriple_for_memory_preservation_def,THEN spec,THEN spec,of s s']
      assms(3-)
    by (simp add: usage_def)
  done

lemma HTriple_while:
  assumes "{{I && B}} b {{I';M}}"
      and "\<turnstile> I' \<longmapsto> I"
    shows "{{I}} WHILE B DO b OD {{I && !B;M}}"
proof-
  {
    fix s s' :: state
    fix body :: "state \<Rightarrow> state \<Rightarrow> bool"
    assume "while_semantics B body s s'"
       and "\<forall> s s' . body s s' \<and> I s \<and> B s \<longrightarrow> I' s' \<and> usage M s s'"
       and "I s"
    hence "I s' \<and> \<not>B s' \<and> usage M s s'"
    proof(induct rule: while_semantics.induct)
      case (1 B \<sigma> body)
      thus ?case
        by (auto simp add: usage_def)
    next
      case (2 B \<sigma> body \<sigma>'' \<sigma>')
      thus ?case
        using assms(2)
        by (auto simp add: usage_def pred_logic)
    qed
  }
  note 1 = this
  have 2: "\<forall> s s' . exec_acode b s s' \<and> I s \<and> B s \<longrightarrow> I' s' \<and> usage M s s'"
    using assms(1)
    by (auto simp add: pred_logic HTriple_for_memory_preservation_def)
  note 3 = 1[OF _ 2]
  thus ?thesis
    by (auto simp add: pred_logic HTriple_for_memory_preservation_def)
qed

lemma HTriple_cases1:
  assumes "{{fst x}} snd x {{Q;M}}"
    shows "{{P}} CASES [x] {{Q;M}}"
  using assms
  by (auto simp add: HTriple_for_memory_preservation_def usage_def)

lemma HTriple_cases2:
  assumes "{{fst x\<^sub>0}} snd x\<^sub>0 {{Q\<^sub>0;M\<^sub>0}}"
      and "{{fst x\<^sub>1}} snd x\<^sub>1 {{Q\<^sub>1;M\<^sub>1}}"
      and "Q = (Q\<^sub>0 || Q\<^sub>1)"
      and "M = M\<^sub>0 \<union> M\<^sub>1"
    shows "{{P}} CASES [x\<^sub>0,x\<^sub>1] {{Q;M}}"
  using assms
  by (auto simp add: HTriple_for_memory_preservation_def usage_def)

lemma HTriple_cases3:
  assumes "{{fst x\<^sub>0}} snd x\<^sub>0 {{Q\<^sub>0;M\<^sub>0}}"
      and "{{fst x\<^sub>1}} snd x\<^sub>1 {{Q\<^sub>1;M\<^sub>1}}"
      and "{{fst x\<^sub>2}} snd x\<^sub>2 {{Q\<^sub>2;M\<^sub>2}}"
      and "Q = (Q\<^sub>0 || Q\<^sub>1 || Q\<^sub>2)"
      and "M = \<Union> {M\<^sub>0 ,M\<^sub>1, M\<^sub>2}"
    shows "{{P}} CASES [x\<^sub>0,x\<^sub>1,x\<^sub>2] {{Q;M}}"
  using assms
  by (auto simp add: HTriple_for_memory_preservation_def usage_def)

lemma HTriple_cases4:
  assumes "{{fst x\<^sub>0}} snd x\<^sub>0 {{Q\<^sub>0;M\<^sub>0}}"
      and "{{fst x\<^sub>1}} snd x\<^sub>1 {{Q\<^sub>1;M\<^sub>1}}"
      and "{{fst x\<^sub>2}} snd x\<^sub>2 {{Q\<^sub>2;M\<^sub>2}}"
      and "{{fst x\<^sub>3}} snd x\<^sub>3 {{Q\<^sub>3;M\<^sub>3}}"
      and "Q = (Q\<^sub>0 || Q\<^sub>1 || Q\<^sub>2 || Q\<^sub>3)"
      and "M = \<Union> {M\<^sub>0, M\<^sub>1, M\<^sub>2, M\<^sub>3}"
    shows "{{P}} CASES [x\<^sub>0,x\<^sub>1,x\<^sub>2,x\<^sub>3] {{Q;M}}"
  using assms
  by (auto simp add: HTriple_for_memory_preservation_def usage_def)

lemma HTriple_cases5:
  assumes "{{fst x\<^sub>0}} snd x\<^sub>0 {{Q\<^sub>0;M\<^sub>0}}"
      and "{{fst x\<^sub>1}} snd x\<^sub>1 {{Q\<^sub>1;M\<^sub>1}}"
      and "{{fst x\<^sub>2}} snd x\<^sub>2 {{Q\<^sub>2;M\<^sub>2}}"
      and "{{fst x\<^sub>3}} snd x\<^sub>3 {{Q\<^sub>3;M\<^sub>3}}"
      and "{{fst x\<^sub>4}} snd x\<^sub>4 {{Q\<^sub>4;M\<^sub>4}}"
      and "Q = (Q\<^sub>0 || Q\<^sub>1 || Q\<^sub>2 || Q\<^sub>3 || Q\<^sub>4)"
      and "M = \<Union> {M\<^sub>0, M\<^sub>1, M\<^sub>2, M\<^sub>3, M\<^sub>4}"
    shows "{{P}} CASES [x\<^sub>0,x\<^sub>1,x\<^sub>2,x\<^sub>3,x\<^sub>4] {{Q;M}}"
  using assms
  by (auto simp add: HTriple_for_memory_preservation_def usage_def)

lemma HTriple_cases6:
  assumes "{{fst x\<^sub>0}} snd x\<^sub>0 {{Q\<^sub>0;M\<^sub>0}}"
      and "{{fst x\<^sub>1}} snd x\<^sub>1 {{Q\<^sub>1;M\<^sub>1}}"
      and "{{fst x\<^sub>2}} snd x\<^sub>2 {{Q\<^sub>2;M\<^sub>2}}"
      and "{{fst x\<^sub>3}} snd x\<^sub>3 {{Q\<^sub>3;M\<^sub>3}}"
      and "{{fst x\<^sub>4}} snd x\<^sub>4 {{Q\<^sub>4;M\<^sub>4}}"
      and "{{fst x\<^sub>5}} snd x\<^sub>5 {{Q\<^sub>5;M\<^sub>5}}"
      and "Q = (Q\<^sub>0 || Q\<^sub>1 || Q\<^sub>2 || Q\<^sub>3 || Q\<^sub>4 || Q\<^sub>5)"
      and "M = \<Union> {M\<^sub>0, M\<^sub>1, M\<^sub>2, M\<^sub>3, M\<^sub>4, M\<^sub>5}"
    shows "{{P}} CASES [x\<^sub>0,x\<^sub>1,x\<^sub>2,x\<^sub>3,x\<^sub>4,x\<^sub>5] {{Q;M}}"
  using assms
  by (auto simp add: HTriple_for_memory_preservation_def usage_def)

lemma HTriple_skip:
  assumes "M = {}"
      and "Q = P"
    shows "{{P}} Skip {{Q;M}}"
  using assms
  unfolding HTriple_for_memory_preservation_def
  by (auto simp add: usage_def pred_logic)

lemma HTriple_weaken:
  assumes \<open>\<turnstile> P' \<longmapsto> P\<close>
      and \<open>{{P}} b {{Q;M}}\<close>
    shows \<open>{{P'}} b {{Q;M}}\<close>
  using assms
  unfolding HTriple_for_memory_preservation_def
  by (auto simp add: pred_logic)

lemma HTriple_strengthen:
  assumes \<open>\<turnstile> Q \<longmapsto> Q'\<close>
      and \<open>{{P}} b {{Q;M}}\<close>
    shows \<open>{{P}} b {{Q';M}}\<close>
  using assms
  unfolding HTriple_for_memory_preservation_def
  by (auto simp add: pred_logic)

lemma HTriple_blackbox:
  assumes \<open>{{P}} \<box>f {{Q;M\<^sub>f}}\<close>
    shows \<open>{{P}} CALL f {{Q;M\<^sub>f}}\<close>
proof -
  from assms(1) obtain P\<^sub>f Q\<^sub>f P\<^sub>s\<^sub>e\<^sub>p where
          0: \<open>{{P\<^sub>f}} f {{Q\<^sub>f;M\<^sub>f}}\<close>
          and 1: "\<turnstile> P \<longmapsto> P\<^sub>f && P\<^sub>s\<^sub>e\<^sub>p"
          and 2: "\<forall>s s'. usage M\<^sub>f s s' \<and> P\<^sub>s\<^sub>e\<^sub>p s \<longrightarrow> P\<^sub>s\<^sub>e\<^sub>p s'"
          and 3: "\<turnstile> Q\<^sub>f && P\<^sub>s\<^sub>e\<^sub>p \<longmapsto> Q"
    unfolding HTriple_blackbox_def
    by auto
  thus ?thesis
    unfolding HTriple_for_memory_preservation_def
    by (simp add: pred_logic) blast
qed

text \<open>
  For each called function, a black-box Hoare triple is assumed. If the called function is within
  the same binary, this lemma can be used to discharge that assumption.
\<close>
lemma Htriple_blackbox_I:
  assumes \<open>{{P\<^sub>f}} f {{Q\<^sub>f;M\<^sub>f}}\<close>
      and \<open>\<turnstile> P \<longmapsto> P\<^sub>f && P\<^sub>s\<^sub>e\<^sub>p\<close>
      and \<open>\<forall>s s'. usage M\<^sub>f s s' \<and> P\<^sub>s\<^sub>e\<^sub>p s \<longrightarrow> P\<^sub>s\<^sub>e\<^sub>p s'\<close>
      and \<open>\<turnstile> Q\<^sub>f && P\<^sub>s\<^sub>e\<^sub>p \<longmapsto> Q\<close>
    shows \<open>{{P}} \<box>f {{Q;M\<^sub>f}}\<close>
  using assms
  by (auto simp add: HTriple_blackbox_def)

lemmas htriples = HTriple_I HTriple_seq HTriple_ite HTriple_blackbox HTriple_cases1 HTriple_cases2
  HTriple_cases3 HTriple_cases4 HTriple_cases5 HTriple_cases6 HTriple_skip

end

end


(*  Title:      JinjaThreads/BV/Effect.thy
    Author:     Gerwin Klein, Andreas Lochbihler
*)

header {* \isaheader{Effect of Instructions on the State Type} *}

theory Effect
imports
  JVM_SemiType
  "../JVM/JVMExceptions"
begin

locale jvm_method = prog +
  fixes mxs :: nat
  fixes mxl\<^sub>0 :: nat
  fixes Ts :: "ty list"
  fixes T\<^sub>r :: ty
  fixes "is" :: "'addr instr list"
  fixes xt :: ex_table

  fixes mxl :: nat
  defines mxl_def: "mxl \<equiv> 1+size Ts+mxl\<^sub>0"

text {* Program counter of successor instructions: *}
primrec succs :: "'addr instr \<Rightarrow> ty\<^sub>i \<Rightarrow> pc \<Rightarrow> pc list"
where
  "succs (Load idx) \<tau> pc     = [pc+1]"
| "succs (Store idx) \<tau> pc    = [pc+1]"
| "succs (Push v) \<tau> pc       = [pc+1]"
| "succs (Getfield F C) \<tau> pc = [pc+1]"
| "succs (Putfield F C) \<tau> pc = [pc+1]"
| "succs (New C) \<tau> pc        = [pc+1]"
| "succs (NewArray T) \<tau> pc   = [pc+1]"
| "succs ALoad \<tau> pc          = (if (fst \<tau>)!1 = NT then [] else [pc+1])"
| "succs AStore \<tau> pc         = (if (fst \<tau>)!2 = NT then [] else [pc+1])"
| "succs ALength \<tau> pc        = (if (fst \<tau>)!0 = NT then [] else [pc+1])"
| "succs (Checkcast C) \<tau> pc  = [pc+1]"
| "succs (Instanceof T) \<tau> pc  = [pc+1]"
| "succs Pop \<tau> pc            = [pc+1]"
| "succs Dup \<tau> pc            = [pc+1]"
| "succs Swap \<tau> pc           = [pc+1]"
| "succs (BinOpInstr b) \<tau> pc = [pc+1]"
| succs_IfFalse:
  "succs (IfFalse b) \<tau> pc    = [pc+1, nat (int pc + b)]"
| succs_Goto:
  "succs (Goto b) \<tau> pc       = [nat (int pc + b)]"
| succs_Return:
  "succs Return \<tau> pc         = []"
| succs_Invoke:
  "succs (Invoke M n) \<tau> pc   = (if (fst \<tau>)!n = NT then [] else [pc+1])"
| succs_Throw:
  "succs ThrowExc \<tau> pc          = []"
| "succs MEnter \<tau> pc         = (if (fst \<tau>)!0 = NT then [] else [pc+1])"
| "succs MExit \<tau> pc          = (if (fst \<tau>)!0 = NT then [] else [pc+1])"

text "Effect of instruction on the state type:"

fun eff\<^sub>i :: "'addr instr \<times> 'm prog \<times> ty\<^sub>i \<Rightarrow> ty\<^sub>i"
where
  eff\<^sub>i_Load:
  "eff\<^sub>i (Load n,  P, (ST, LT))          = (ok_val (LT ! n) # ST, LT)"

| eff\<^sub>i_Store:
  "eff\<^sub>i (Store n, P, (T#ST, LT))        = (ST, LT[n:= OK T])"

| eff\<^sub>i_Push:
  "eff\<^sub>i (Push v, P, (ST, LT))             = (the (typeof v) # ST, LT)"

| eff\<^sub>i_Getfield:
  "eff\<^sub>i (Getfield F C, P, (T#ST, LT))    = (fst (snd (field P C F)) # ST, LT)"

| eff\<^sub>i_Putfield:
  "eff\<^sub>i (Putfield F C, P, (T\<^sub>1#T\<^sub>2#ST, LT)) = (ST,LT)"

| eff\<^sub>i_New:
  "eff\<^sub>i (New C, P, (ST,LT))               = (Class C # ST, LT)"

| eff\<^sub>i_NewArray:
  "eff\<^sub>i (NewArray Ty, P, (T#ST,LT))       = (Ty\<lfloor>\<rceil> # ST,LT)"

| eff\<^sub>i_ALoad:
  "eff\<^sub>i (ALoad, P, (T1#T2#ST,LT))       = (the_Array T2# ST,LT)"

| eff\<^sub>i_AStore:
  "eff\<^sub>i (AStore, P, (T1#T2#T3#ST,LT))  = (ST,LT)"

| eff\<^sub>i_ALength:
  "eff\<^sub>i (ALength, P, (T1#ST,LT))  = (Integer#ST,LT)"

| eff\<^sub>i_Checkcast:
  "eff\<^sub>i (Checkcast Ty, P, (T#ST,LT))       = (Ty # ST,LT)"

| eff\<^sub>i_Instanceof:
  "eff\<^sub>i (Instanceof Ty, P, (T#ST,LT))       = (Boolean # ST,LT)"

| eff\<^sub>i_Pop:
  "eff\<^sub>i (Pop, P, (T#ST,LT))               = (ST,LT)"

| eff\<^sub>i_Dup:
  "eff\<^sub>i (Dup, P, (T#ST,LT))               = (T#T#ST,LT)"

| eff\<^sub>i_Swap:
  "eff\<^sub>i (Swap, P, (T1#T2#ST,LT))               = (T2#T1#ST,LT)"

| eff\<^sub>i_BinOpInstr:
  "eff\<^sub>i (BinOpInstr bop, P, (T2#T1#ST,LT)) = ((THE T. P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T)#ST, LT)"

| eff\<^sub>i_IfFalse:
  "eff\<^sub>i (IfFalse b, P, (T\<^sub>1#ST,LT))        = (ST,LT)"

| eff\<^sub>i_Invoke:
  "eff\<^sub>i (Invoke M n, P, (ST,LT))          =
  (let U = fst (snd (snd (method P (the (class_type_of' (ST ! n))) M)))
   in (U # drop (n+1) ST, LT))"

| eff\<^sub>i_Goto:
  "eff\<^sub>i (Goto n, P, s)                    = s"

| eff\<^sub>i_MEnter:
  "eff\<^sub>i (MEnter, P, (T1#ST,LT))           = (ST,LT)"

| eff\<^sub>i_MExit:
  "eff\<^sub>i (MExit, P, (T1#ST,LT))            = (ST,LT)"

fun is_relevant_class :: "'addr instr \<Rightarrow> 'm prog \<Rightarrow> cname \<Rightarrow> bool"
where
  rel_Getfield:
  "is_relevant_class (Getfield F D) = (\<lambda>P C. P \<turnstile> NullPointer \<preceq>\<^sup>* C)"
| rel_Putfield:
  "is_relevant_class (Putfield F D) = (\<lambda>P C. P \<turnstile> NullPointer \<preceq>\<^sup>* C)"
| rel_Checcast:
  "is_relevant_class (Checkcast T)  = (\<lambda>P C. P \<turnstile> ClassCast \<preceq>\<^sup>* C)"
| rel_New:
  "is_relevant_class (New D)        = (\<lambda>P C. P \<turnstile> OutOfMemory \<preceq>\<^sup>* C)"
| rel_Throw:
  "is_relevant_class ThrowExc       = (\<lambda>P C. True)"
| rel_Invoke:
  "is_relevant_class (Invoke M n)   = (\<lambda>P C. True)"
| rel_NewArray:
  "is_relevant_class (NewArray T)   = (\<lambda>P C. (P \<turnstile> OutOfMemory \<preceq>\<^sup>* C) \<or> (P \<turnstile> NegativeArraySize \<preceq>\<^sup>* C))"
| rel_ALoad:
  "is_relevant_class ALoad          = (\<lambda>P C. P \<turnstile> ArrayIndexOutOfBounds \<preceq>\<^sup>* C \<or> P \<turnstile> NullPointer \<preceq>\<^sup>* C)"
| rel_AStore:
  "is_relevant_class AStore         = (\<lambda>P C. P \<turnstile> ArrayIndexOutOfBounds \<preceq>\<^sup>* C \<or> P \<turnstile> ArrayStore \<preceq>\<^sup>* C \<or> P \<turnstile> NullPointer \<preceq>\<^sup>* C)"
| rel_ALength:
  "is_relevant_class ALength        = (\<lambda>P C. P \<turnstile> NullPointer \<preceq>\<^sup>* C)"
| rel_MEnter:
  "is_relevant_class MEnter         = (\<lambda>P C. P \<turnstile> IllegalMonitorState \<preceq>\<^sup>* C \<or> P \<turnstile> NullPointer \<preceq>\<^sup>* C)"
| rel_MExit:
  "is_relevant_class MExit          = (\<lambda>P C. P \<turnstile> IllegalMonitorState \<preceq>\<^sup>* C \<or> P \<turnstile> NullPointer \<preceq>\<^sup>* C)"
| rel_BinOp:
  "is_relevant_class (BinOpInstr bop) = binop_relevant_class bop"
| rel_default:
  "is_relevant_class i              = (\<lambda>P C. False)"

definition is_relevant_entry :: "'m prog \<Rightarrow> 'addr instr \<Rightarrow> pc \<Rightarrow> ex_entry \<Rightarrow> bool"
where
  "is_relevant_entry P i pc e \<equiv>
   let (f,t,C,h,d) = e
   in (case C of None \<Rightarrow> True | \<lfloor>C'\<rfloor> \<Rightarrow> is_relevant_class i P C') \<and> pc \<in> {f..<t}"

definition relevant_entries :: "'m prog \<Rightarrow> 'addr instr \<Rightarrow> pc \<Rightarrow> ex_table \<Rightarrow> ex_table"
where
  "relevant_entries P i pc \<equiv> filter (is_relevant_entry P i pc)"

definition xcpt_eff :: "'addr instr \<Rightarrow> 'm prog \<Rightarrow> pc \<Rightarrow> ty\<^sub>i \<Rightarrow> ex_table \<Rightarrow> (pc \<times> ty\<^sub>i') list"
where
  "xcpt_eff i P pc \<tau> et \<equiv> let (ST,LT) = \<tau> in
  map (\<lambda>(f,t,C,h,d). (h, Some ((case C of None \<Rightarrow> Class Throwable | Some C' \<Rightarrow> Class C')#drop (size ST - d) ST, LT))) (relevant_entries P i pc et)"

definition norm_eff :: "'addr instr \<Rightarrow> 'm prog \<Rightarrow> nat \<Rightarrow> ty\<^sub>i \<Rightarrow> (pc \<times> ty\<^sub>i') list"
where "norm_eff i P pc \<tau> \<equiv> map (\<lambda>pc'. (pc',Some (eff\<^sub>i (i,P,\<tau>)))) (succs i \<tau> pc)"

definition eff :: "'addr instr \<Rightarrow> 'm prog \<Rightarrow> pc \<Rightarrow> ex_table \<Rightarrow> ty\<^sub>i' \<Rightarrow> (pc \<times> ty\<^sub>i') list"
where
  "eff i P pc et t \<equiv>
  case t of
    None \<Rightarrow> []
  | Some \<tau> \<Rightarrow> (norm_eff i P pc \<tau>) @ (xcpt_eff i P pc \<tau> et)"

lemma eff_Some:
  "eff i P pc xt (Some \<tau>) = norm_eff i P pc \<tau> @ xcpt_eff i P pc \<tau> xt"
by (simp add: eff_def)

(* FIXME: getfield, \<exists>T D. P \<turnstile> C sees F:T in D \<and> .. *)

text "Conditions under which eff is applicable:"

fun app\<^sub>i :: "'addr instr \<times> 'm prog \<times> pc \<times> nat \<times> ty \<times> ty\<^sub>i \<Rightarrow> bool"
where
  app\<^sub>i_Load:
  "app\<^sub>i (Load n, P, pc, mxs, T\<^sub>r, (ST,LT)) =
    (n < length LT \<and> LT ! n \<noteq> Err \<and> length ST < mxs)"
| app\<^sub>i_Store:
  "app\<^sub>i (Store n, P, pc, mxs, T\<^sub>r, (T#ST, LT)) =
    (n < length LT)"
| app\<^sub>i_Push:
  "app\<^sub>i (Push v, P, pc, mxs, T\<^sub>r, (ST,LT)) =
    (length ST < mxs \<and> typeof v \<noteq> None)"
| app\<^sub>i_Getfield:
  "app\<^sub>i (Getfield F C, P, pc, mxs, T\<^sub>r, (T#ST, LT)) =
    (\<exists>T\<^sub>f fm. P \<turnstile> C sees F:T\<^sub>f (fm) in C \<and> P \<turnstile> T \<le> Class C)"
| app\<^sub>i_Putfield:
  "app\<^sub>i (Putfield F C, P, pc, mxs, T\<^sub>r, (T\<^sub>1#T\<^sub>2#ST, LT)) =
    (\<exists>T\<^sub>f fm. P \<turnstile> C sees F:T\<^sub>f (fm) in C \<and> P \<turnstile> T\<^sub>2 \<le> (Class C) \<and> P \<turnstile> T\<^sub>1 \<le> T\<^sub>f)"
| app\<^sub>i_New:
  "app\<^sub>i (New C, P, pc, mxs, T\<^sub>r, (ST,LT)) =
    (is_class P C \<and> length ST < mxs)"
| app\<^sub>i_NewArray:
  "app\<^sub>i (NewArray Ty, P, pc, mxs, T\<^sub>r, (Integer#ST,LT)) =
    is_type P (Ty\<lfloor>\<rceil>)"
|  app\<^sub>i_ALoad:
  "app\<^sub>i (ALoad, P, pc, mxs, T\<^sub>r, (T1#T2#ST,LT)) =
    (T1 = Integer \<and> (T2 \<noteq> NT \<longrightarrow> (\<exists>Ty. T2 = Ty\<lfloor>\<rceil>)))"
| app\<^sub>i_AStore:
  "app\<^sub>i (AStore, P, pc, mxs, T\<^sub>r, (T1#T2#T3#ST,LT)) =
    (T2 = Integer \<and> (T3 \<noteq> NT \<longrightarrow> (\<exists>Ty. T3 = Ty\<lfloor>\<rceil>)))"
| app\<^sub>i_ALength:
  "app\<^sub>i (ALength, P, pc, mxs, T\<^sub>r, (T1#ST,LT)) =
    (T1 = NT \<or> (\<exists>Ty. T1 = Ty\<lfloor>\<rceil>))"
| app\<^sub>i_Checkcast:
  "app\<^sub>i (Checkcast Ty, P, pc, mxs, T\<^sub>r, (T#ST,LT)) =
    (is_type P Ty)"
| app\<^sub>i_Instanceof:
  "app\<^sub>i (Instanceof Ty, P, pc, mxs, T\<^sub>r, (T#ST,LT)) =
    (is_type P Ty \<and> is_refT T)"
| app\<^sub>i_Pop:
  "app\<^sub>i (Pop, P, pc, mxs, T\<^sub>r, (T#ST,LT)) =
    True"
| app\<^sub>i_Dup:
  "app\<^sub>i (Dup, P, pc, mxs, T\<^sub>r, (T#ST,LT)) =
    (Suc (length ST) < mxs)"
| app\<^sub>i_Swap:
  "app\<^sub>i (Swap, P, pc, mxs, T\<^sub>r, (T1#T2#ST,LT)) = True"
| app\<^sub>i_BinOpInstr:
  "app\<^sub>i (BinOpInstr bop, P, pc, mxs, T\<^sub>r, (T2#T1#ST,LT)) = (\<exists>T. P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T)"
| app\<^sub>i_IfFalse:
  "app\<^sub>i (IfFalse b, P, pc, mxs, T\<^sub>r, (Boolean#ST,LT)) =
    (0 \<le> int pc + b)"
| app\<^sub>i_Goto:
  "app\<^sub>i (Goto b, P, pc, mxs, T\<^sub>r, s) =  (0 \<le> int pc + b)"
| app\<^sub>i_Return:
  "app\<^sub>i (Return, P, pc, mxs, T\<^sub>r, (T#ST,LT)) = (P \<turnstile> T \<le> T\<^sub>r)"
| app\<^sub>i_Throw:
  "app\<^sub>i (ThrowExc, P, pc, mxs, T\<^sub>r, (T#ST,LT)) =
    (T = NT \<or> (\<exists>C. T = Class C \<and> P \<turnstile> C \<preceq>\<^sup>* Throwable))"
| app\<^sub>i_Invoke:
  "app\<^sub>i (Invoke M n, P, pc, mxs, T\<^sub>r, (ST,LT)) =
    (n < length ST \<and>
    (ST!n \<noteq> NT \<longrightarrow>
      (\<exists>C D Ts T m. class_type_of' (ST ! n) = \<lfloor>C\<rfloor> \<and> P \<turnstile> C sees M:Ts \<rightarrow> T = m in D \<and> P \<turnstile> rev (take n ST) [\<le>] Ts)))"
| app\<^sub>i_MEnter:
  "app\<^sub>i (MEnter,P, pc,mxs,T\<^sub>r,(T#ST,LT)) = (is_refT T)"
| app\<^sub>i_MExit:
  "app\<^sub>i (MExit,P, pc,mxs,T\<^sub>r,(T#ST,LT)) = (is_refT T)"
| app\<^sub>i_default:
  "app\<^sub>i (i,P, pc,mxs,T\<^sub>r,s) = False"

definition xcpt_app :: "'addr instr \<Rightarrow> 'm prog \<Rightarrow> pc \<Rightarrow> nat \<Rightarrow> ex_table \<Rightarrow> ty\<^sub>i \<Rightarrow> bool"
where
  "xcpt_app i P pc mxs xt \<tau> \<equiv> \<forall>(f,t,C,h,d) \<in> set (relevant_entries P i pc xt). (case C of None \<Rightarrow> True | Some C' \<Rightarrow> is_class P C') \<and> d \<le> size (fst \<tau>) \<and> d < mxs"

definition app :: "'addr instr \<Rightarrow> 'm prog \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ex_table \<Rightarrow> ty\<^sub>i' \<Rightarrow> bool"
where
  "app i P mxs T\<^sub>r pc mpc xt t \<equiv> case t of None \<Rightarrow> True | Some \<tau> \<Rightarrow>
  app\<^sub>i (i,P,pc,mxs,T\<^sub>r,\<tau>) \<and> xcpt_app i P pc mxs xt \<tau> \<and>
  (\<forall>(pc',\<tau>') \<in> set (eff i P pc xt t). pc' < mpc)"

lemma app_Some:
  "app i P mxs T\<^sub>r pc mpc xt (Some \<tau>) =
  (app\<^sub>i (i,P,pc,mxs,T\<^sub>r,\<tau>) \<and> xcpt_app i P pc mxs xt \<tau> \<and>
  (\<forall>(pc',s') \<in> set (eff i P pc xt (Some \<tau>)). pc' < mpc))"
by (simp add: app_def)

locale eff = jvm_method +
  fixes eff\<^sub>i and app\<^sub>i and eff and app
  fixes norm_eff and xcpt_app and xcpt_eff

  fixes mpc
  defines "mpc \<equiv> size is"

  defines "eff\<^sub>i i \<tau> \<equiv> Effect.eff\<^sub>i (i,P,\<tau>)"
  notes eff\<^sub>i_simps [simp] = Effect.eff\<^sub>i.simps [where P = P, folded eff\<^sub>i_def]

  defines "app\<^sub>i i pc \<tau> \<equiv> Effect.app\<^sub>i (i, P, pc, mxs, T\<^sub>r, \<tau>)"
  notes app\<^sub>i_simps [simp] = Effect.app\<^sub>i.simps [where P=P and mxs=mxs and T\<^sub>r=T\<^sub>r, folded app\<^sub>i_def]

  defines "xcpt_eff i pc \<tau> \<equiv> Effect.xcpt_eff i P pc \<tau> xt"
  notes xcpt_eff = Effect.xcpt_eff_def [of _ P _ _ xt, folded xcpt_eff_def]

  defines "norm_eff i pc \<tau> \<equiv> Effect.norm_eff i P pc \<tau>"
  notes norm_eff = Effect.norm_eff_def [of _ P, folded norm_eff_def eff\<^sub>i_def]

  defines "eff i pc \<equiv> Effect.eff i P pc xt"
  notes eff = Effect.eff_def [of _ P  _ xt, folded eff_def norm_eff_def xcpt_eff_def]

  defines "xcpt_app i pc \<tau> \<equiv> Effect.xcpt_app i P pc mxs xt \<tau>"
  notes xcpt_app = Effect.xcpt_app_def [of _ P _ mxs xt, folded xcpt_app_def]

  defines "app i pc \<equiv> Effect.app i P mxs T\<^sub>r pc mpc xt"
  notes app = Effect.app_def [of _ P mxs T\<^sub>r _ mpc xt, folded app_def xcpt_app_def app\<^sub>i_def eff_def]

lemma length_cases2:
  assumes "\<And>LT. P ([],LT)"
  assumes "\<And>l ST LT. P (l#ST,LT)"
  shows "P s"
  by (cases s, cases "fst s") (auto intro!: assms)

lemma length_cases3:
  assumes "\<And>LT. P ([],LT)"
  assumes "\<And>l LT. P ([l],LT)"
  assumes "\<And>l ST LT. P (l#ST,LT)"
  shows "P s"
(*<*)
proof -
  obtain xs LT where s: "s = (xs,LT)" by (cases s)
  show ?thesis
  proof (cases xs)
    case Nil thus ?thesis using s assms by (simp)
  next
    fix l xs' assume "xs = l#xs'"
    thus ?thesis using s assms by (simp)
  qed
qed
(*>*)

lemma length_cases4:
  assumes "\<And>LT. P ([],LT)"
  assumes "\<And>l LT. P ([l],LT)"
  assumes "\<And>l l' LT. P ([l,l'],LT)"
  assumes "\<And>l l' ST LT. P (l#l'#ST,LT)"
  shows "P s"
(*<*)
proof -
  obtain xs LT where s: "s = (xs,LT)" by (cases s)
  show ?thesis
  proof (cases xs)
    case Nil thus ?thesis using s assms by (simp)
  next
    fix l xs' assume xs: "xs = l#xs'"
    thus ?thesis
    proof (cases xs')
      case Nil thus ?thesis using s assms xs by (simp)
    next
      fix l' ST assume xs': "xs' = l'#ST"
      thus ?thesis using s assms xs xs' by (simp)
    qed
  qed
qed
(*>*)

text {*
\medskip
simp rules for @{term app}
*}
lemma appNone[simp]: "app i P mxs T\<^sub>r pc mpc et None = True"
  by (simp add: app_def)

lemma appLoad[simp]:
"app\<^sub>i (Load idx, P, T\<^sub>r, mxs, pc, s) = (\<exists>ST LT. s = (ST,LT) \<and> idx < length LT \<and> LT!idx \<noteq> Err \<and> length ST < mxs)"
  by (cases s, simp)

lemma appStore[simp]:
"app\<^sub>i (Store idx,P,pc,mxs,T\<^sub>r,s) = (\<exists>ts ST LT. s = (ts#ST,LT) \<and> idx < length LT)"
  by (rule length_cases2, auto)

lemma appPush[simp]:
"app\<^sub>i (Push v,P,pc,mxs,T\<^sub>r,s) =
 (\<exists>ST LT. s = (ST,LT) \<and> length ST < mxs \<and> typeof v \<noteq> None)"
  by (cases s, simp)

lemma appGetField[simp]:
"app\<^sub>i (Getfield F C,P,pc,mxs,T\<^sub>r,s) =
 (\<exists> oT vT ST LT fm. s = (oT#ST, LT) \<and>
  P \<turnstile> C sees F:vT (fm) in C \<and> P \<turnstile> oT \<le> (Class C))"
  by (rule length_cases2 [of _ s]) auto

lemma appPutField[simp]:
"app\<^sub>i (Putfield F C,P,pc,mxs,T\<^sub>r,s) =
 (\<exists> vT vT' oT ST LT fm. s = (vT#oT#ST, LT) \<and>
  P \<turnstile> C sees F:vT' (fm) in C \<and> P \<turnstile> oT \<le> (Class C) \<and> P \<turnstile> vT \<le> vT')"
  by (rule length_cases4 [of _ s], auto)

lemma appNew[simp]:
  "app\<^sub>i (New C,P,pc,mxs,T\<^sub>r,s) =
  (\<exists>ST LT. s=(ST,LT) \<and> is_class P C \<and> length ST < mxs)"
  by (cases s, simp)

lemma appNewArray[simp]:
  "app\<^sub>i (NewArray Ty,P,pc,mxs,T\<^sub>r,s) =
  (\<exists>ST LT. s=(Integer#ST,LT) \<and> is_type P (Ty\<lfloor>\<rceil>))"
  by (cases s, simp, cases "fst s", simp)(cases "hd (fst s)", auto)

lemma appALoad[simp]:
  "app\<^sub>i (ALoad,P,pc,mxs,T\<^sub>r,s) =
  (\<exists>T ST LT. s=(Integer#T#ST,LT) \<and> (T \<noteq> NT \<longrightarrow> (\<exists>T'.  T = T'\<lfloor>\<rceil>)))"
proof -
  obtain ST LT where [simp]: "s = (ST, LT)" by (cases s)
  have "ST = [] \<or> (\<exists>T. ST = [T]) \<or> (\<exists>T\<^sub>1 T\<^sub>2 ST'. ST = T\<^sub>1#T\<^sub>2#ST')"
    by (cases ST, auto, case_tac list, auto)
  moreover
  { assume "ST = []" hence ?thesis by simp }
  moreover
  { fix T assume "ST = [T]" hence ?thesis by (cases T, auto) }
  moreover
  { fix T\<^sub>1 T\<^sub>2 ST' assume "ST = T\<^sub>1#T\<^sub>2#ST'"
    hence ?thesis by (cases T\<^sub>1, auto)
  }
  ultimately show ?thesis by blast
qed

lemma appAStore[simp]:
  "app\<^sub>i (AStore,P,pc,mxs,T\<^sub>r,s) =
  (\<exists>T U ST LT. s=(T#Integer#U#ST,LT) \<and> (U \<noteq> NT \<longrightarrow> (\<exists>T'. U = T'\<lfloor>\<rceil>)))"
proof -
  obtain ST LT where [simp]: "s = (ST, LT)" by (cases s)
  have "ST = [] \<or> (\<exists>T. ST = [T]) \<or> (\<exists>T\<^sub>1 T\<^sub>2. ST = [T\<^sub>1, T\<^sub>2]) \<or> (\<exists>T1 T2 T3 ST'. ST = T1 # T2 # T3 # ST')"
    by (cases ST, auto, case_tac list, auto, case_tac lista, auto)
  moreover
  { assume "ST = []" hence ?thesis by simp }
  moreover
  { fix T assume "ST = [T]" hence ?thesis by(simp) }
  moreover
  { fix T1 T2 assume "ST = [T1, T2]" hence ?thesis by simp }
  moreover
  { fix T1 T2 T3 ST' assume "ST = T1 # T2 # T3 # ST'" hence ?thesis by(cases T2, auto) }
  ultimately show ?thesis by blast
qed

lemma appALength[simp]:
  "app\<^sub>i (ALength,P,pc,mxs,T\<^sub>r,s) =
  (\<exists>T ST LT. s=(T#ST,LT) \<and> (T \<noteq> NT \<longrightarrow> (\<exists>T'.  T = T'\<lfloor>\<rceil>)))"
  by (cases s, cases "fst s", simp add: app_def) (cases "hd (fst s)", auto)

lemma appInstanceof[simp]:
  "app\<^sub>i (Instanceof Ty,P,pc,mxs,T\<^sub>r,s) =
  (\<exists>T ST LT. s = (T#ST,LT) \<and> is_type P Ty \<and> is_refT T)"
  by (cases s, cases "fst s", simp add: app_def) (cases "hd (fst s)", auto)

lemma app\<^sub>iPop[simp]:
"app\<^sub>i (Pop,P,pc,mxs,T\<^sub>r,s) = (\<exists>ts ST LT. s = (ts#ST,LT))"
  by (rule length_cases2, auto)

lemma appDup[simp]:
"app\<^sub>i (Dup,P,pc,mxs,T\<^sub>r,s) =
 (\<exists>T ST LT. s = (T#ST,LT) \<and> Suc (length ST) < mxs)"
by (cases s, cases "fst s", simp_all)

lemma app\<^sub>iSwap[simp]:
"app\<^sub>i (Swap,P,pc,mxs,T\<^sub>r,s) = (\<exists>T1 T2 ST LT. s = (T1#T2#ST,LT))"
by(rule length_cases4) auto

lemma appBinOp[simp]:
"app\<^sub>i (BinOpInstr bop,P,pc,mxs,T\<^sub>r,s) = (\<exists>T1 T2 ST LT T. s = (T2 # T1 # ST, LT) \<and> P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T)"
proof -
  obtain ST LT where [simp]: "s = (ST,LT)" by (cases s)
  have "ST = [] \<or> (\<exists>T. ST = [T]) \<or> (\<exists>T\<^sub>1 T\<^sub>2 ST'. ST = T\<^sub>1#T\<^sub>2#ST')"
    by (cases ST, auto, case_tac list, auto)
  moreover
  { assume "ST = []" hence ?thesis by simp }
  moreover
  { fix T assume "ST = [T]" hence ?thesis by (cases T, auto) }
  moreover
  { fix T\<^sub>1 T\<^sub>2 ST' assume "ST = T\<^sub>1#T\<^sub>2#ST'"
    hence ?thesis by simp
  }
  ultimately show ?thesis by blast
qed

lemma appIfFalse [simp]:
"app\<^sub>i (IfFalse b,P,pc,mxs,T\<^sub>r,s) =
  (\<exists>ST LT. s = (Boolean#ST,LT) \<and> 0 \<le> int pc + b)"
  apply (rule length_cases2)
  apply simp
  apply (case_tac l)
  apply auto
  done

lemma appReturn[simp]:
"app\<^sub>i (Return,P,pc,mxs,T\<^sub>r,s) = (\<exists>T ST LT. s = (T#ST,LT) \<and> P \<turnstile> T \<le> T\<^sub>r)"
  by (rule length_cases2, auto)

lemma appThrow[simp]:
  "app\<^sub>i (ThrowExc,P,pc,mxs,T\<^sub>r,s) = (\<exists>T ST LT. s=(T#ST,LT) \<and> (T = NT \<or> (\<exists>C. T = Class C \<and> P \<turnstile> C \<preceq>\<^sup>* Throwable)))"
  by (rule length_cases2, auto)

lemma appMEnter[simp]:
  "app\<^sub>i (MEnter,P,pc,mxs,T\<^sub>r,s) = (\<exists>T ST LT. s=(T#ST,LT) \<and> is_refT T)"
  by (rule length_cases2, auto)

lemma appMExit[simp]:
  "app\<^sub>i (MExit,P,pc,mxs,T\<^sub>r,s) = (\<exists>T ST LT. s=(T#ST,LT) \<and> is_refT T)"
  by (rule length_cases2, auto)

lemma effNone:
  "(pc', s') \<in> set (eff i P pc et None) \<Longrightarrow> s' = None"
  by (auto simp add: eff_def xcpt_eff_def norm_eff_def)

lemma relevant_entries_append [simp]:
  "relevant_entries P i pc (xt @ xt') = relevant_entries P i pc xt @ relevant_entries P i pc xt'"
  by (unfold relevant_entries_def) simp

lemma xcpt_app_append [iff]:
  "xcpt_app i P pc mxs (xt@xt') \<tau> = (xcpt_app i P pc mxs xt \<tau> \<and> xcpt_app i P pc mxs xt' \<tau>)"
unfolding xcpt_app_def by force

lemma xcpt_eff_append [simp]:
  "xcpt_eff i P pc \<tau> (xt@xt') = xcpt_eff i P pc \<tau> xt @ xcpt_eff i P pc \<tau> xt'"
 by (unfold xcpt_eff_def, cases \<tau>) simp

lemma app_append [simp]:
  "app i P pc T mxs mpc (xt@xt') \<tau> = (app i P pc T mxs mpc xt \<tau> \<and> app i P pc T mxs mpc xt' \<tau>)"
  by (unfold app_def eff_def) auto

subsection {* Code generator setup *}

declare list_all2_Nil [code]
declare list_all2_Cons [code]

lemma eff\<^sub>i_BinOpInstr_code:
  "eff\<^sub>i (BinOpInstr bop, P, (T2#T1#ST,LT)) = (Predicate.the (WTrt_binop_i_i_i_i_o P T1 bop T2) # ST, LT)"
by(simp add: the_WTrt_binop_code)

lemmas eff\<^sub>i_code[code] =
  eff\<^sub>i_Load eff\<^sub>i_Store eff\<^sub>i_Push eff\<^sub>i_Getfield eff\<^sub>i_Putfield eff\<^sub>i_New eff\<^sub>i_NewArray eff\<^sub>i_ALoad
  eff\<^sub>i_AStore eff\<^sub>i_ALength eff\<^sub>i_Checkcast eff\<^sub>i_Instanceof eff\<^sub>i_Pop eff\<^sub>i_Dup eff\<^sub>i_Swap eff\<^sub>i_BinOpInstr_code
  eff\<^sub>i_IfFalse eff\<^sub>i_Invoke eff\<^sub>i_Goto eff\<^sub>i_MEnter eff\<^sub>i_MExit

lemma app\<^sub>i_Getfield_code:
  "app\<^sub>i (Getfield F C, P, pc, mxs, T\<^sub>r, (T#ST, LT)) \<longleftrightarrow>
  Predicate.holds (Predicate.bind (sees_field_i_i_i_o_o_i P C F C) (\<lambda>T. Predicate.single ())) \<and> P \<turnstile> T \<le> Class C"
apply(clarsimp simp add: Predicate.bind_def Predicate.single_def holds_eq eval_sees_field_i_i_i_o_i_conv)
done

lemma app\<^sub>i_Putfield_code:
  "app\<^sub>i (Putfield F C, P, pc, mxs, T\<^sub>r, (T\<^sub>1#T\<^sub>2#ST, LT)) \<longleftrightarrow>
   P \<turnstile> T\<^sub>2 \<le> (Class C) \<and>
   Predicate.holds (Predicate.bind (sees_field_i_i_i_o_o_i P C F C) (\<lambda>(T, fm). if P \<turnstile> T\<^sub>1 \<le> T then Predicate.single () else bot))"
by (auto simp add: holds_eq eval_sees_field_i_i_i_o_i_conv split: if_splits)

lemma app\<^sub>i_ALoad_code:
  "app\<^sub>i (ALoad, P, pc, mxs, T\<^sub>r, (T1#T2#ST,LT)) =
   (T1 = Integer \<and> (case T2 of Ty\<lfloor>\<rceil> \<Rightarrow> True | NT \<Rightarrow> True | _ \<Rightarrow> False))"
by(simp add: split: ty.split)

lemma app\<^sub>i_AStore_code:
  "app\<^sub>i (AStore, P, pc, mxs, T\<^sub>r, (T1#T2#T3#ST,LT)) =
  (T2 = Integer \<and> (case T3 of Ty\<lfloor>\<rceil> \<Rightarrow> True | NT \<Rightarrow> True | _ \<Rightarrow> False))"
by(simp add: split: ty.split)

lemma app\<^sub>i_ALength_code:
  "app\<^sub>i (ALength, P, pc, mxs, T\<^sub>r, (T1#ST,LT)) =
   (case T1 of Ty\<lfloor>\<rceil> \<Rightarrow> True | NT \<Rightarrow> True | _ \<Rightarrow> False)"
by(simp add: split: ty.split)

lemma app\<^sub>i_BinOpInstr_code:
  "app\<^sub>i (BinOpInstr bop, P, pc, mxs, T\<^sub>r, (T2#T1#ST,LT)) =
   Predicate.holds (Predicate.bind (WTrt_binop_i_i_i_i_o P T1 bop T2) (\<lambda>T. Predicate.single ()))"
by (auto simp add: holds_eq eval_WTrt_binop_i_i_i_i_o)

lemma app\<^sub>i_Invoke_code:
  "app\<^sub>i (Invoke M n, P, pc, mxs, T\<^sub>r, (ST,LT)) =
  (n < length ST \<and>
  (ST!n \<noteq> NT \<longrightarrow>
     (case class_type_of' (ST ! n) of Some C \<Rightarrow>
         Predicate.holds (Predicate.bind (Method_i_i_i_o_o_o_o P C M)
                                          (\<lambda>(Ts, _). if P \<turnstile> rev (take n ST) [\<le>] Ts then Predicate.single () else bot))
      | _ \<Rightarrow> False)))"
proof -
  have bind_Ex: "\<And>P f. Predicate.bind P f = Predicate.Pred (\<lambda>x. (\<exists>y. Predicate.eval P y \<and> Predicate.eval (f y) x))"
    by (rule pred_eqI) auto
  thus ?thesis
    by (auto simp add: bind_Ex Predicate.single_def holds_eq eval_Method_i_i_i_o_o_o_o_conv split: ty.split)
qed

lemma app\<^sub>i_Throw_code:
  "app\<^sub>i (ThrowExc, P, pc, mxs, T\<^sub>r, (T#ST,LT)) =
  (case T of NT \<Rightarrow> True | Class C \<Rightarrow> P \<turnstile> C \<preceq>\<^sup>* Throwable | _ \<Rightarrow> False)"
by(simp split: ty.split)

lemmas app\<^sub>i_code [code] =
  app\<^sub>i_Load app\<^sub>i_Store app\<^sub>i_Push
  app\<^sub>i_Getfield_code app\<^sub>i_Putfield_code
  app\<^sub>i_New app\<^sub>i_NewArray
  app\<^sub>i_ALoad_code app\<^sub>i_AStore_code app\<^sub>i_ALength_code
  app\<^sub>i_Checkcast app\<^sub>i_Instanceof
  app\<^sub>i_Pop app\<^sub>i_Dup app\<^sub>i_Swap app\<^sub>i_BinOpInstr_code app\<^sub>i_IfFalse app\<^sub>i_Goto
  app\<^sub>i_Return app\<^sub>i_Throw_code app\<^sub>i_Invoke_code app\<^sub>i_MEnter app\<^sub>i_MExit
  app\<^sub>i_default

end