342 lines
14 KiB
Plaintext
342 lines
14 KiB
Plaintext
(*
|
|
* Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
|
|
*
|
|
* SPDX-License-Identifier: BSD-2-Clause
|
|
*)
|
|
|
|
theory L2Opt
|
|
imports L2Defs L2Peephole
|
|
begin
|
|
|
|
(* Flow-sensitive simplification rules for L2 programs. *)
|
|
named_theorems L2flow
|
|
|
|
(*
|
|
* The monads "A" and "B" are equivalent under precondition "P".
|
|
* Additionally, under this precondition, they always leave the
|
|
* postcondition "Q" (normally) or "E" (if an exception occurs).
|
|
*)
|
|
definition
|
|
"monad_equiv P A B Q E \<equiv> (\<forall>s. P s \<longrightarrow> A s = B s) \<and> \<lbrace> P \<rbrace> A \<lbrace> Q \<rbrace>, \<lbrace> E \<rbrace>"
|
|
|
|
lemma monad_equivI [intro]:
|
|
"\<lbrakk> \<And>s. P s \<Longrightarrow> A s = B s; \<lbrace> P \<rbrace> A \<lbrace> Q \<rbrace>, \<lbrace> E \<rbrace> \<rbrakk> \<Longrightarrow> monad_equiv P A B Q E"
|
|
apply (clarsimp simp: monad_equiv_def)
|
|
done
|
|
|
|
lemma monad_equiv_eqI [intro]:
|
|
"\<lbrakk> \<lbrace> P \<rbrace> A \<lbrace> Q \<rbrace>, \<lbrace> E \<rbrace> \<rbrakk> \<Longrightarrow> monad_equiv P A A Q E"
|
|
apply (clarsimp simp: monad_equiv_def)
|
|
done
|
|
|
|
lemma monad_equiv_eq:
|
|
"monad_equiv (\<lambda>_. True) A B X Y \<Longrightarrow> A = B"
|
|
apply (rule ext)
|
|
apply (clarsimp simp: monad_equiv_def)
|
|
done
|
|
|
|
lemma monad_equiv_triv [L2flow]:
|
|
"monad_equiv P A A (\<lambda>_ _. \<exists>s. P s) (\<lambda>_ _. \<exists>s. P s)"
|
|
apply rule
|
|
apply wp
|
|
apply force
|
|
done
|
|
|
|
lemma monad_equiv_symmetric:
|
|
"monad_equiv P A B X Y = monad_equiv P B A X Y"
|
|
apply (clarsimp simp: monad_equiv_def validE_def2 Ball_def split: sum.splits)
|
|
apply force
|
|
done
|
|
|
|
lemma monad_equivD: "\<lbrakk> monad_equiv P A B R E; P s \<rbrakk> \<Longrightarrow> A s = B s"
|
|
apply (clarsimp simp: monad_equiv_def)
|
|
done
|
|
|
|
(*
|
|
* Show that under condition "P", the values "A" and "B" are equal.
|
|
*
|
|
* We use this to simplify expressions inside our monads in a (somewhat)
|
|
* controlled fashion.
|
|
*)
|
|
definition "simp_expr P A B \<equiv> P \<longrightarrow> A = B"
|
|
|
|
lemma simp_expr_triv: "simp_expr P A A"
|
|
apply (clarsimp simp: simp_expr_def)
|
|
done
|
|
|
|
lemma simp_expr_P_cong:
|
|
"\<lbrakk> P = P' \<rbrakk> \<Longrightarrow> simp_expr P A B = simp_expr P' A B"
|
|
apply (clarsimp simp: simp_expr_def)
|
|
done
|
|
|
|
lemma simp_expr_rhs_cong [cong]:
|
|
"\<lbrakk> P = P'; P' \<Longrightarrow> B = B' \<rbrakk> \<Longrightarrow> simp_expr P A B = simp_expr P' A B'"
|
|
apply (clarsimp simp: simp_expr_def simp_implies_def)
|
|
done
|
|
|
|
lemma simp_expr_weaken:
|
|
"\<lbrakk> simp_expr P A B; Q \<Longrightarrow> P \<rbrakk> \<Longrightarrow> simp_expr Q A B"
|
|
apply (clarsimp simp: simp_expr_def)
|
|
done
|
|
|
|
(*
|
|
* Monad simplification rules.
|
|
*
|
|
* When solving "monad_equiv P A B R E", the l2_opt tactics assume that P is concrete;
|
|
* to ensure this, monad_equiv rules should result in R being instantiated.
|
|
* See e.g. monad_equiv_unreachable where we have to constrain the rule.
|
|
*)
|
|
|
|
lemma monad_equiv_gets [L2flow]:
|
|
"simp_expr True v v' \<Longrightarrow> monad_equiv P (L2_gets (\<lambda>s. v s) n) (L2_gets (\<lambda>s. v' s) n)
|
|
(\<lambda>r s. P s \<and> r = v' s) (\<lambda>_ _. False)"
|
|
apply rule
|
|
apply (clarsimp simp: L2_defs simp_expr_def)+
|
|
apply wpsimp
|
|
done
|
|
|
|
lemma monad_equiv_throw [L2flow]:
|
|
"simp_expr True v v' \<Longrightarrow>
|
|
monad_equiv P (L2_throw v n) (L2_throw v' n) (\<lambda>_ _. False) (\<lambda>r s. P s \<and> r = v')"
|
|
apply (clarsimp simp: monad_equiv_def L2_defs simp_expr_def)
|
|
apply wp
|
|
apply force
|
|
done
|
|
|
|
lemma monad_equiv_guard:
|
|
"\<lbrakk> \<And>s. simp_expr (P s) (G s) (G' s) \<rbrakk> \<Longrightarrow>
|
|
monad_equiv P (L2_guard (\<lambda>s. G s)) (L2_guard (\<lambda>s. G' s)) (\<lambda>r s. P s \<and> G' s \<and> r = ()) (\<lambda>_ _. False)"
|
|
apply (clarsimp simp: monad_equiv_def L2_defs simp_expr_def)
|
|
apply rule
|
|
apply (clarsimp simp: liftE_def guard_def bind_def in_return snd_return)
|
|
apply wp
|
|
apply force
|
|
done
|
|
|
|
(* We use this weaker form of guard simplification to prevent bound
|
|
* variables being expanded inside of guard statements. *)
|
|
lemma monad_equiv_guard' [L2flow]:
|
|
"\<lbrakk> \<And>s. simp_expr True (G s) (G' s) \<rbrakk> \<Longrightarrow>
|
|
monad_equiv P (L2_guard (\<lambda>s. G s)) (L2_guard (\<lambda>s. G' s)) (\<lambda>r s. P s \<and> G' s \<and> r = ()) (\<lambda>_ _. False)"
|
|
apply (rule monad_equiv_guard)
|
|
apply (rule simp_expr_weaken)
|
|
apply assumption
|
|
apply simp
|
|
done
|
|
|
|
lemma monad_equiv_guard_False [L2flow]:
|
|
"\<lbrakk> \<And>s. simp_expr (P s) False (G s) \<rbrakk>
|
|
\<Longrightarrow> monad_equiv P (L2_guard G) (L2_fail) (\<lambda>_ _. False) (\<lambda>_ _. False)"
|
|
apply (monad_eq simp: L2_defs monad_equiv_def simp_expr_def validE_def2)
|
|
done
|
|
|
|
lemma monad_equiv_guard_True [L2flow]:
|
|
"\<lbrakk> \<And>s. simp_expr (P s) True (G s) \<rbrakk>
|
|
\<Longrightarrow> monad_equiv P (L2_guard G) L2_skip (\<lambda>r s. P s \<and> r = ()) (\<lambda>_ _. False)"
|
|
apply (auto simp: L2_defs simp_expr_def guard_def liftE_def return_def returnOk_def bind_def validE_def valid_def)
|
|
done
|
|
|
|
lemma monad_equiv_guard_conj [L2flow]:
|
|
"\<lbrakk> monad_equiv P (L2_guard G1) G1' R1 E1;
|
|
monad_equiv (\<lambda>s. R1 () s) (L2_guard G2) G2' R2 E2 \<rbrakk> \<Longrightarrow>
|
|
monad_equiv P (L2_guard (\<lambda>s. G1 s \<and> G2 s)) (L2_seq G1' (\<lambda>_. G2')) (\<lambda>r s. R2 () s) (\<lambda>_ _. False)"
|
|
apply (subst (asm) (1 2) monad_equiv_symmetric)
|
|
apply (subst monad_equiv_symmetric)
|
|
apply rule
|
|
apply (monad_eq simp: L2_defs monad_equiv_def validE_def2 Bex_def Ball_def split: sum.splits)
|
|
apply fast
|
|
apply (monad_eq simp: monad_equiv_def L2_defs validE_def2 Ball_def split: sum.splits)
|
|
apply fast
|
|
done
|
|
|
|
lemma monad_equiv_unknown [L2flow]:
|
|
"monad_equiv P (L2_unknown name) (L2_unknown name) (\<lambda>r s. P s) (\<lambda>_ _. False)"
|
|
apply (clarsimp simp: monad_equiv_def L2_defs)
|
|
apply wp
|
|
apply force
|
|
done
|
|
|
|
lemma monad_equiv_modify [L2flow]:
|
|
"\<lbrakk> \<And>s. simp_expr True (m s) (m' s) \<rbrakk> \<Longrightarrow>
|
|
monad_equiv P (L2_modify (\<lambda>s. m s)) (L2_modify (\<lambda>s. m' s)) (\<lambda>r s'. \<exists>s. P s \<and> m' s = s' \<and> r = ()) (\<lambda>_ _. False)"
|
|
apply rule
|
|
apply (clarsimp simp: L2_defs simp_expr_def liftE_def modify_def put_def get_def bind_def)
|
|
apply (clarsimp simp: L2_defs simp_expr_def)
|
|
apply wp
|
|
apply force
|
|
done
|
|
|
|
lemma monad_equiv_spec [L2flow]:
|
|
"\<lbrakk> \<And>s s'. simp_expr True ((s, s') \<in> S) (S' s s') \<rbrakk> \<Longrightarrow>
|
|
monad_equiv P (L2_spec S) (L2_spec ({(s, s'). S' s s'})) (\<lambda>r s. \<exists>s. P s) (\<lambda>_ _. False)"
|
|
apply rule
|
|
apply (clarsimp simp: L2_defs simp_expr_def liftE_def spec_def bind_def)
|
|
apply (clarsimp simp: L2_defs)
|
|
apply wp
|
|
apply force
|
|
done
|
|
|
|
lemma monad_equiv_fail [L2flow]:
|
|
"monad_equiv P L2_fail L2_fail (\<lambda>_ _. False) (\<lambda>_ _. False)"
|
|
apply (clarsimp simp: monad_equiv_def L2_defs)
|
|
done
|
|
|
|
lemma monad_equiv_condition [L2flow]:
|
|
"\<lbrakk> \<And>s. simp_expr True (C s) (C' s);
|
|
monad_equiv (\<lambda>s. P s \<and> C' s) L L' QL EL;
|
|
monad_equiv (\<lambda>s. P s \<and> \<not> C' s) R R' QR ER \<rbrakk> \<Longrightarrow>
|
|
monad_equiv P (L2_condition (\<lambda>s. C s) L R) (L2_condition (\<lambda>s. C' s) L' R')
|
|
(\<lambda>r s. \<exists>s. P s) \<comment> \<open>Deliberately weak to avoid exponential growth.\<close>
|
|
(\<lambda>r s. \<exists>s. P s)"
|
|
apply rule
|
|
apply (monad_eq simp: L2_defs monad_equiv_def simp_expr_def split: condition_splits)
|
|
apply (monad_eq simp: L2_defs monad_equiv_def validE_def2 split: condition_splits sum.splits)
|
|
apply force
|
|
done
|
|
|
|
lemma monad_equiv_condition_True [L2flow]:
|
|
"\<lbrakk> \<And>s. simp_expr (P s) (C s) True;
|
|
monad_equiv P L L' QL EL \<rbrakk> \<Longrightarrow>
|
|
monad_equiv P (L2_condition C L R) L' QL EL"
|
|
unfolding L2_defs condition_def
|
|
apply (monad_eq simp: simp_expr_def monad_equiv_def validE_def2 Ball_def split: sum.splits)
|
|
done
|
|
|
|
lemma monad_equiv_condition_False [L2flow]:
|
|
"\<lbrakk> \<And>s. simp_expr (P s) (C s) False;
|
|
monad_equiv P R R' QR ER \<rbrakk> \<Longrightarrow>
|
|
monad_equiv P (L2_condition C L R) R' QR ER"
|
|
unfolding L2_defs condition_def
|
|
apply (monad_eq simp: simp_expr_def monad_equiv_def validE_def2 Ball_def split: sum.splits)
|
|
done
|
|
|
|
(* C-parser sometimes generates boolean expressions like
|
|
if P then (if P then 1 else 0) else Q
|
|
This simplifies the branches. *)
|
|
lemma monad_equiv_gets_if [L2flow]:
|
|
"\<lbrakk> \<And>s. simp_expr (P s) True (b s) \<rbrakk> \<Longrightarrow>
|
|
monad_equiv P (L2_gets (\<lambda>s. if (b s) then L else R) f)
|
|
(L2_gets (\<lambda>s. L) f) (%r s. P s) (\<lambda>r s. False)"
|
|
"\<lbrakk> \<And>s. simp_expr (P s) False (b s) \<rbrakk> \<Longrightarrow>
|
|
monad_equiv P (L2_gets (\<lambda>s. if (b s) then L else R) f)
|
|
(L2_gets (\<lambda>s. R) f) (%r s. P s) (\<lambda>r s. False)"
|
|
apply (monad_eq simp: L2_defs simp_expr_def monad_equiv_def
|
|
validE_def valid_def split: sum.splits)+
|
|
done
|
|
|
|
lemma monad_equiv_seq [L2flow]:
|
|
"\<lbrakk> monad_equiv P A A' Q E;
|
|
\<And>x. monad_equiv (Q x) (B x) (B' x) (R x) (E2 x) \<rbrakk> \<Longrightarrow>
|
|
monad_equiv P (L2_seq A (\<lambda>x. B x)) (L2_seq A' (\<lambda>x. B' x)) (\<lambda>r s. \<exists>r'. R r' r s) (\<lambda>r s. \<exists>s. P s)"
|
|
apply rule
|
|
apply (clarsimp simp: monad_equiv_def L2_defs simp_expr_def)
|
|
apply (rule bindE_apply_cong)
|
|
apply simp
|
|
apply (clarsimp simp: validE_def valid_def)
|
|
apply force
|
|
apply (clarsimp simp: monad_equiv_def L2_defs
|
|
validE_def valid_def in_bindE simp_expr_def split: sum.splits)
|
|
apply (erule allE, erule (1) impE)+
|
|
apply fastforce
|
|
done
|
|
|
|
lemma monad_equiv_catch [L2flow]:
|
|
"\<lbrakk> monad_equiv P A A' Q E;
|
|
\<And>x. monad_equiv (E x) (B x) (B' x) (Q' x) (E2 x) \<rbrakk> \<Longrightarrow>
|
|
monad_equiv P (L2_catch A (\<lambda>x. B x)) (L2_catch A' (\<lambda>x. B' x)) (\<lambda>r s. \<exists>s. P s) (\<lambda>r s. \<exists>r'. E2 r' r s)"
|
|
apply rule
|
|
apply atomize
|
|
apply (clarsimp simp: simp_expr_def L2_defs monad_equiv_def)
|
|
apply (erule allE, erule impE, assumption)
|
|
apply (clarsimp simp: validE_def2 split: sum.splits)
|
|
apply (erule allE, erule impE, assumption)
|
|
apply (rule monad_state_eqI)
|
|
apply (clarsimp simp: in_handleE')
|
|
apply force
|
|
apply (clarsimp simp: in_handleE')
|
|
apply force
|
|
apply (fastforce simp: snd_handleE')
|
|
apply (clarsimp simp: monad_equiv_def L2_defs
|
|
validE_def valid_def simp_expr_def in_handleE' split: sum.splits)
|
|
apply (erule allE, erule (1) impE)+
|
|
apply fastforce
|
|
done
|
|
|
|
lemma monad_equiv_cong:
|
|
"\<lbrakk> \<And>s. P s = P' s;
|
|
\<And>s. P s \<Longrightarrow> A s = A' s;
|
|
\<And>s. P s \<Longrightarrow> B s = B' s;
|
|
\<And>s s' r. P s \<Longrightarrow> Q r s' = Q' r s';
|
|
\<And>s s' r. P s \<Longrightarrow> R r s' = R' r s' \<rbrakk> \<Longrightarrow>
|
|
monad_equiv P A B Q R = monad_equiv P' A' B' Q' R'"
|
|
apply atomize
|
|
apply (clarsimp simp: monad_equiv_def validE_def valid_def split: sum.splits)
|
|
apply (rule iffI)
|
|
apply clarsimp
|
|
apply fastforce
|
|
apply clarsimp
|
|
apply fastforce
|
|
done
|
|
|
|
lemma monad_equiv_while [L2flow]:
|
|
assumes cond_simp: "\<And>s r. simp_expr True (c r s) (c' r s)"
|
|
assumes body_equiv: "\<And>r. monad_equiv (\<lambda>s. (\<exists>s'. P s') \<and> c' r s) (B r) (B' r) (Q r) (E r)"
|
|
assumes init_simp: "\<And>s r. simp_expr True x x'"
|
|
shows "monad_equiv P (L2_while (\<lambda>r s. c r s) B x n) (L2_while (\<lambda>r s. c' r s) B' x' n) (\<lambda>r s. \<not> c' r s \<and> (\<exists>x. P x)) (\<lambda>r s. \<exists>x. E x r s)"
|
|
apply (insert cond_simp [unfolded simp_expr_def] init_simp [unfolded simp_expr_def])
|
|
apply rule
|
|
apply (clarsimp simp: L2_while_def)
|
|
apply (rule whileLoopE_cong [THEN fun_cong, THEN fun_cong])
|
|
apply force
|
|
apply (cut_tac r=r in body_equiv)
|
|
apply (clarsimp simp: monad_equiv_def)
|
|
apply (erule allE, erule impE, auto)[1]
|
|
apply simp
|
|
apply (clarsimp simp: L2_while_def)
|
|
apply (rule validE_whileLoopE [where I="\<lambda>r s. \<exists>s. P s"])
|
|
apply force
|
|
apply (cut_tac r=r in body_equiv)
|
|
apply (clarsimp simp: validE_def valid_def monad_equiv_def split: sum.splits)
|
|
apply blast
|
|
apply simp
|
|
done
|
|
|
|
lemma monad_equiv_recguard [L2flow]:
|
|
"\<lbrakk> monad_equiv P B B' Q E \<rbrakk> \<Longrightarrow>
|
|
monad_equiv P (L2_recguard a B) (L2_recguard a B') Q E"
|
|
apply rule
|
|
apply (clarsimp simp: L2_recguard_def monad_equiv_def valid_def validE_def
|
|
split: sum.splits condition_splits)
|
|
apply (clarsimp simp: L2_recguard_def monad_equiv_def valid_def validE_def in_fail
|
|
split: sum.splits condition_splits)
|
|
done
|
|
|
|
lemma monad_equiv_unreachable' [L2flow]:
|
|
"monad_equiv (\<lambda>_. False) L (L2_gets (\<lambda>_. undefined) [''L2Opt_internal_var'']) Q R"
|
|
by (simp add: monad_equiv_def)
|
|
|
|
(* avoid leaving schematic Q in goal *)
|
|
lemma monad_equiv_unreachable [L2flow]:
|
|
"monad_equiv (\<lambda>_. False) L (L2_gets (\<lambda>_. undefined) [''L2Opt_internal_var'']) (\<lambda>_ _. False) R"
|
|
by (rule monad_equiv_unreachable')
|
|
|
|
lemma monad_equiv_split [L2flow]:
|
|
"\<lbrakk> \<And>a b. monad_equiv (P (a, b)) (X a b) (Y a b) (Q a b) (E a b) \<rbrakk> \<Longrightarrow>
|
|
monad_equiv (P x) (case x of (a, b) \<Rightarrow> X a b) (case x of (a, b) \<Rightarrow> Y a b)
|
|
(case x of (a, b) \<Rightarrow> Q a b) (case x of (a, b) \<Rightarrow> E a b)"
|
|
apply (clarsimp simp: monad_equiv_def validE_def valid_def split_def)
|
|
done
|
|
|
|
lemma simp_expr_solve_constant: "\<lbrakk> A \<Longrightarrow> B = C \<rbrakk> \<Longrightarrow> simp_expr A B C"
|
|
by (clarsimp simp: simp_expr_def)
|
|
|
|
lemma monad_equiv_weaken_pre':
|
|
"\<lbrakk> \<And>s. P' s \<Longrightarrow> P s; monad_equiv P L R Q E \<rbrakk> \<Longrightarrow> monad_equiv P' L R Q E"
|
|
by (fastforce simp: monad_equiv_def validE_def valid_def)
|
|
|
|
lemma monad_equiv_weaken_pre'':
|
|
"\<lbrakk> P' \<equiv> P; monad_equiv P L R Q E \<rbrakk> \<Longrightarrow> monad_equiv P' L R Q E"
|
|
by (fastforce simp: monad_equiv_def validE_def valid_def)
|
|
|
|
end
|