254 lines
9.0 KiB
Plaintext
254 lines
9.0 KiB
Plaintext
(*
|
|
* Copyright 2014, NICTA
|
|
*
|
|
* This software may be distributed and modified according to the terms of
|
|
* the BSD 2-Clause license. Note that NO WARRANTY is provided.
|
|
* See "LICENSE_BSD2.txt" for details.
|
|
*
|
|
* @TAG(NICTA_BSD)
|
|
*)
|
|
|
|
(*
|
|
* Peep-hole optimisations for applied to L2.
|
|
*)
|
|
|
|
theory L2Peephole
|
|
imports L2Defs
|
|
begin
|
|
|
|
lemma L2_seq_skip [L2opt]:
|
|
"L2_seq (L2_gets (\<lambda>_. ()) n) X = (X ())"
|
|
"L2_seq Y (\<lambda>_. (L2_gets (\<lambda>_. ()) n)) = Y"
|
|
apply (clarsimp simp: L2_seq_def L2_gets_def returnOk_liftE[symmetric])+
|
|
done
|
|
|
|
lemma L2_seq_L2_gets [L2opt]: "L2_seq X (\<lambda>x. L2_gets (\<lambda>_. x) n) = X"
|
|
apply (clarsimp simp: L2_defs cong: bindE_cong)
|
|
apply (fold returnOk_liftE)
|
|
apply simp
|
|
done
|
|
|
|
lemma L2_seq_assoc [L2opt]:
|
|
"L2_seq (L2_seq A (\<lambda>x. B x)) C = L2_seq A (\<lambda>x. L2_seq (B x) C)"
|
|
apply (clarsimp simp: L2_seq_def bindE_assoc)
|
|
done
|
|
|
|
lemma L2_trim_after_throw [L2opt]:
|
|
"L2_seq (L2_throw x n) Z = (L2_throw x n)"
|
|
apply (clarsimp simp: L2_seq_def L2_throw_def)
|
|
done
|
|
|
|
lemma L2_guard_true [L2opt]: "\<lbrakk> \<And>s. P s \<rbrakk> \<Longrightarrow> L2_guard P = L2_gets (\<lambda>_. ()) [''ret'']"
|
|
apply (monad_eq simp: L2_defs)
|
|
done
|
|
|
|
lemma L2_guard_false [L2opt]: "\<lbrakk> \<And>s. \<not> P s \<rbrakk> \<Longrightarrow> L2_guard P = L2_fail"
|
|
apply (monad_eq simp: L2_defs)
|
|
done
|
|
|
|
lemma L2_spec_empty [L2opt]:
|
|
(* FIXME: do we need both? *)
|
|
"L2_spec {} = L2_fail"
|
|
"\<lbrakk> \<And>s t. \<not> C s t \<rbrakk> \<Longrightarrow> L2_spec {(s, t). C s t} = L2_fail"
|
|
by (monad_eq simp: L2_defs)+
|
|
|
|
lemma L2_unknown_bind [L2opt]:
|
|
"(\<And>a b. f a = f b) \<Longrightarrow> (L2_seq (L2_unknown name) f) = f undefined"
|
|
apply (atomize)
|
|
apply (subst (asm) all_comm)
|
|
apply (erule allE [where x=undefined])
|
|
apply (rule ext)
|
|
apply (clarsimp simp: L2_seq_def L2_unknown_def)
|
|
apply (clarsimp simp: liftE_def select_def bindE_def)
|
|
apply (clarsimp simp: NonDetMonad.lift_def bind_def)
|
|
apply (clarsimp simp: NonDetMonad.bind_def split_def)
|
|
apply (rule prod_eqI)
|
|
apply (rule set_eqI)
|
|
apply (clarsimp)
|
|
apply (rule iffI)
|
|
apply clarsimp
|
|
apply metis
|
|
apply force
|
|
apply (clarsimp simp: image_def)
|
|
apply (rule iffI)
|
|
apply (clarsimp simp: prod_eq_iff)
|
|
apply metis
|
|
apply force
|
|
done
|
|
|
|
lemma L2_guard_cong:
|
|
"\<lbrakk> P = P'; \<And>s. P s \<Longrightarrow> X s = X' s \<rbrakk> \<Longrightarrow> L2_seq (L2_guard P) (\<lambda>_. X) = L2_seq (L2_guard P') (\<lambda>_. X')"
|
|
apply (rule ext)
|
|
apply (atomize)
|
|
apply (erule_tac x=x in allE)
|
|
apply (monad_eq simp: L2_defs Bex_def)
|
|
done
|
|
|
|
lemma L2_condition_true [L2opt]: "\<lbrakk> \<And>s. C s \<rbrakk> \<Longrightarrow> L2_condition C A B = A"
|
|
apply (clarsimp simp: L2_condition_def condition_def)
|
|
done
|
|
|
|
lemma L2_condition_false [L2opt]: "\<lbrakk> \<And>s. \<not> C s \<rbrakk> \<Longrightarrow> L2_condition C A B = B"
|
|
apply (clarsimp simp: L2_condition_def condition_def)
|
|
done
|
|
|
|
lemma L2_condition_same [L2opt]: "L2_condition C A A = A"
|
|
apply (clarsimp simp: L2_defs condition_def)
|
|
done
|
|
|
|
lemma L2_fail_seq [L2opt]: "L2_seq L2_fail X = L2_fail"
|
|
apply (clarsimp simp: L2_seq_def L2_fail_def)
|
|
done
|
|
|
|
lemma L2_fail_propagates [L2opt]:
|
|
"L2_seq (L2_gets V n) (\<lambda>_. L2_fail) = L2_fail"
|
|
"L2_seq (L2_modify M) (\<lambda>_. L2_fail) = L2_fail"
|
|
"L2_seq (L2_spec S) (\<lambda>_. L2_fail) = L2_fail"
|
|
"L2_seq (L2_guard G) (\<lambda>_. L2_fail) = L2_fail"
|
|
"L2_seq (L2_unknown name) (\<lambda>_. L2_fail) = L2_fail"
|
|
"L2_seq L2_fail (\<lambda>_. L2_fail) = L2_fail"
|
|
apply (unfold L2_defs)
|
|
apply (auto intro!: bindE_fail_propagates empty_fail_bindE
|
|
no_throw_bindE [where B="\<top>"] hoare_TrueI simp: empty_fail_error_bits)
|
|
done
|
|
|
|
lemma L2_condition_distrib:
|
|
"L2_seq (L2_condition C L R) X = L2_condition C (L2_seq L X) (L2_seq R X)"
|
|
apply (unfold L2_defs)
|
|
apply (rule ext)
|
|
apply (clarsimp split: condition_splits)
|
|
apply (rule conjI)
|
|
apply (clarsimp simp: condition_def cong: bindE_apply_cong)
|
|
apply (clarsimp simp: condition_def cong: bindE_apply_cong)
|
|
done
|
|
|
|
lemmas L2_fail_propagate_condition [L2opt] = L2_condition_distrib [where X="\<lambda>_. L2_fail"]
|
|
|
|
lemma L2_fail_propagate_catch [L2opt]:
|
|
"(L2_seq (L2_catch L R) (\<lambda>_. L2_fail)) = (L2_catch (L2_seq L (\<lambda>_. L2_fail)) (\<lambda>e. L2_seq (R e) (\<lambda>_. L2_fail)))"
|
|
apply (unfold L2_defs)
|
|
apply (clarsimp simp: bindE_def)
|
|
apply (clarsimp simp: handleE'_def handleE_def)
|
|
apply (clarsimp simp: bind_assoc)
|
|
apply (rule arg_cong [where f="NonDetMonad.bind L"])
|
|
apply (rule ext)+
|
|
apply (clarsimp split: sum.splits)
|
|
apply (clarsimp simp: throwError_def)
|
|
done
|
|
|
|
lemma L2_condition_fail_lhs [L2opt]:
|
|
"L2_condition C L2_fail A = L2_seq (L2_guard (\<lambda>s. \<not> C s)) (\<lambda>_. A)"
|
|
apply (rule ext)
|
|
apply (clarsimp simp: L2_guard_def L2_fail_def guard_def get_def
|
|
L2_seq_def bindE_def bind_def fail_def liftE_def2 L2_condition_def
|
|
split: condition_splits)
|
|
done
|
|
|
|
lemma L2_condition_fail_rhs [L2opt]:
|
|
"L2_condition C A L2_fail = L2_seq (L2_guard (\<lambda>s. C s)) (\<lambda>_. A)"
|
|
apply (rule ext)
|
|
apply (clarsimp simp: L2_guard_def L2_fail_def guard_def get_def
|
|
L2_seq_def bindE_def bind_def fail_def liftE_def2 L2_condition_def
|
|
split: condition_splits)
|
|
done
|
|
|
|
lemma L2_catch_fail [L2opt]: "L2_catch L2_fail A = L2_fail"
|
|
apply (clarsimp simp: L2_catch_def L2_fail_def handleE'_def)
|
|
done
|
|
|
|
lemma L2_while_fail [L2opt]: "L2_while C (\<lambda>_. L2_fail) i n = (L2_seq (L2_guard (\<lambda>s. \<not> C i s)) (\<lambda>_. L2_gets (\<lambda>s. i) n))"
|
|
apply (rule ext)+
|
|
apply (clarsimp simp: L2_defs)
|
|
apply (subst whileLoopE_unroll)
|
|
apply (clarsimp split: condition_splits)
|
|
apply (monad_eq)
|
|
done
|
|
|
|
lemma L2_returncall_trivial [L2opt]:
|
|
"\<lbrakk> \<And>s v. f v s = v \<rbrakk> \<Longrightarrow> L2_returncall x f = L2_call x"
|
|
apply (rule ext)+
|
|
apply (monad_eq simp: L2_defs L2_call_def)
|
|
done
|
|
|
|
(*
|
|
* Trim "L2_gets" commands where the value is never actually used.
|
|
*
|
|
* This would be nice to apply automatically, but in practice causes
|
|
* everything to slow down significantly.
|
|
*)
|
|
lemma L2_gets_unused:
|
|
"\<lbrakk> \<And>x y s. B x s = B y s \<rbrakk> \<Longrightarrow> L2_seq (L2_gets A n) B = (B undefined)"
|
|
by (fastforce simp: L2_defs bindE_def simpler_gets_def bind_def lift_def split_def liftE_def2)
|
|
|
|
lemma L2_gets_bind:
|
|
"L2_seq (L2_gets (\<lambda>_. x :: 'var_type) n) f = f x"
|
|
by (monad_eq simp: L2corres_def corresXF_def L2_defs Bex_def)
|
|
|
|
lemma split_seq_assoc [L2opt]:
|
|
"(\<lambda>x. L2_seq (case x of (a, b) \<Rightarrow> B a b) (G x)) = (\<lambda>x. case x of (a, b) \<Rightarrow> (L2_seq (B a b) (G x)))"
|
|
by (rule ext) clarsimp
|
|
|
|
lemma L2_while_infinite [L2opt]:
|
|
"L2_while (\<lambda>i s. C s) (\<lambda>x. L2_gets (\<lambda>s. B s x) n') i n
|
|
= (L2_seq (L2_guard (\<lambda>s. \<not> C s)) (\<lambda>_. L2_gets (\<lambda>_. i) n))"
|
|
apply (clarsimp simp: L2_defs whileLoopE_def)
|
|
apply (rule ext)
|
|
apply (case_tac "C x")
|
|
apply (rule whileLoop_rule_strong)
|
|
apply (rule valid_whileLoop [where I="\<lambda>r s. C s \<and> (\<exists>x. r = Inr x)"])
|
|
apply simp
|
|
apply (monad_eq simp: valid_def)
|
|
apply monad_eq
|
|
apply monad_eq
|
|
apply (rule snd_whileLoop [where I="\<lambda>r s. True"])
|
|
apply monad_eq
|
|
apply monad_eq
|
|
apply (monad_eq simp: exs_valid_def split: sum.splits)
|
|
apply monad_eq
|
|
apply (subst whileLoop_unroll)
|
|
apply monad_eq
|
|
done
|
|
|
|
(*
|
|
* We are happy to collapse away automatically generated constructs.
|
|
*
|
|
* In particular, anything of type "c_exntype" (which is used to track
|
|
* what the current exception represents at the C level) is
|
|
* autogenerated, and hence can be collapsed.
|
|
*)
|
|
lemmas L2_gets_bind_c_exntype [L2opt] = L2_gets_bind [where 'var_type=c_exntype]
|
|
lemmas L2_gets_bind_unit [L2opt] = L2_gets_bind [where 'var_type=unit]
|
|
|
|
declare L2_voidcall_def [L2opt]
|
|
declare L2_modifycall_def [L2opt]
|
|
declare ucast_id [L2opt]
|
|
declare scast_id [L2opt]
|
|
|
|
(* Other misc lemmas. *)
|
|
declare singleton_iff [L2opt]
|
|
|
|
(* Optimising "if" structres. *)
|
|
|
|
lemma L2_gets_L2_seq_if_P_1_0 [L2opt]:
|
|
"L2_seq (L2_gets (\<lambda>s. if P s then 1 else 0) n) (\<lambda>x. Q x)
|
|
= (L2_seq (L2_gets P n) (\<lambda>x. Q (if x then 1 else 0)))"
|
|
apply (clarsimp simp: L2_defs)
|
|
apply (rule monad_eqI)
|
|
apply (clarsimp simp: L2_defs in_liftE in_gets in_bindE)
|
|
apply (clarsimp simp: L2_defs in_liftE in_gets in_bindE)
|
|
apply (clarsimp simp: L2_defs in_liftE snd_liftE snd_gets snd_bindE Bex_def in_gets)
|
|
done
|
|
|
|
(* Join up guards, so that we can potentially solve some just by using
|
|
* HOL.conj_cong. We will split them out again during the polish phase. *)
|
|
|
|
lemma L2_guard_join_simple [L2opt]: "L2_seq (L2_guard A) (\<lambda>_. L2_guard B) = L2_guard (\<lambda>s. A s \<and> B s)"
|
|
by (monad_eq simp: L2_defs')
|
|
|
|
lemma L2_guard_join_nested [L2opt]:
|
|
"L2_seq (L2_guard A) (\<lambda>_. L2_seq (L2_guard B) (\<lambda>_. C))
|
|
= L2_seq (L2_guard (\<lambda>s. A s \<and> B s)) (\<lambda>_. C)"
|
|
by (monad_eq simp: L2_defs')
|
|
|
|
end
|