├── .gitignore ├── CONTRIBUTORS ├── LICENSE ├── README.md ├── WebAssembly ├── OCaml_Printing.thy ├── PowerSum.thy ├── ROOT ├── Wasm.thy ├── Wasm_Ast.thy ├── Wasm_Axioms.thy ├── Wasm_Base_Defs.thy ├── Wasm_Checker.thy ├── Wasm_Checker_Printing.thy ├── Wasm_Checker_Properties.thy ├── Wasm_Checker_Types.thy ├── Wasm_Countable.thy ├── Wasm_Instantiation.thy ├── Wasm_Instantiation_Printing.thy ├── Wasm_Instantiation_Properties.thy ├── Wasm_Instantiation_Properties_Aux.thy ├── Wasm_Interpreter.thy ├── Wasm_Interpreter_Printing.thy ├── Wasm_Interpreter_Properties.thy ├── Wasm_Module.thy ├── Wasm_Module_Checker.thy ├── Wasm_Native_Word_Entry.thy ├── Wasm_Printing.thy ├── Wasm_Properties.thy ├── Wasm_Properties_Aux.thy ├── Wasm_Soundness.thy ├── Wasm_Type_Abs.thy ├── Wasm_Type_Printing.thy ├── Wasm_Type_Word.thy └── code │ ├── .keep │ └── WasmRef_Isa.ocaml └── libs ├── Misc_Generic_Lemmas.thy └── More_More_Word.thy /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | -------------------------------------------------------------------------------- /CONTRIBUTORS: -------------------------------------------------------------------------------- 1 | Conrad Watt 2 | 3 | Martin Desharnais 4 | Florian Märkl 5 | Maja Trela 6 | Peter Lammich 7 | Antanas Kalkauskas 8 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2021 Conrad Watt and CONTRIBUTORS 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are met: 5 | 6 | Redistributions of source code must retain the above copyright notice, this 7 | list of conditions and the following disclaimer. Redistributions in binary form 8 | must reproduce the above copyright notice, this list of conditions and the 9 | following disclaimer in the documentation and/or other materials provided with 10 | the distribution. 11 | 12 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 13 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 14 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 15 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 16 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 17 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 18 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 19 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 20 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 21 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # WasmCert-Isabelle 2 | 3 | A mechanisation of Wasm in Isabelle. BSD-2 licensed - see LICENSE for details and copyright. 4 | 5 | An updated version of the mechanisation from "Mechanising and Verifying the WebAssembly Specification" (C. Watt, CPP 2018). 6 | 7 | The type soundness statement and proof can be found in WebAssembly/Wasm_Soundness.thy. 8 | 9 | ## Building 10 | 11 | Currently this repository contains only free-standing Isabelle/HOL files, which have been updated for use with Isabelle2024. The extracted OCaml executable definitions can be found in the code subdirectory, but are currently not fully functional. For a working interpreter build, see one of the interpreter branches. 12 | -------------------------------------------------------------------------------- /WebAssembly/OCaml_Printing.thy: -------------------------------------------------------------------------------- 1 | theory OCaml_Printing imports Main begin 2 | 3 | (* OCaml-specific hacks follow... *) 4 | 5 | lemma [code]: "pred_option P None = True" 6 | using Option.option.pred_inject(1) 7 | by auto 8 | 9 | lemmas[code] = Option.option.pred_inject(2) 10 | 11 | definition "failwith_nth n \ []!n" 12 | 13 | declare [[code abort: failwith_nth]] 14 | 15 | lemma nth_emp[code]: "nth [] n = failwith_nth n" 16 | unfolding failwith_nth_def .. 17 | 18 | (* The model uses a naive list-based memory *) 19 | (* The list can get very large, so relevant functions must be tail-recursive *) 20 | 21 | primrec replicate_tr :: "nat \ 'a \ 'a list \ 'a list" where 22 | "replicate_tr 0 x acc = acc" 23 | | "replicate_tr (Suc n) x acc = replicate_tr n x (x # acc)" 24 | 25 | lemma[code]: "replicate n x = replicate_tr n x []" 26 | proof - 27 | have "\acc. (replicate n x)@acc = replicate_tr n x acc" 28 | apply (induction n) 29 | apply simp_all 30 | apply (metis replicate_app_Cons_same) 31 | done 32 | thus ?thesis 33 | by (metis self_append_conv) 34 | qed 35 | 36 | (* n.b. `rev` is tail-recursive when extracted to OCaml *) 37 | 38 | fun take_tr:: "nat \ 'a list \ 'a list \ 'a list" where 39 | "take_tr n [] acc_r = rev acc_r" 40 | | "take_tr n (x # xs) acc_r = 41 | (case n of 42 | 0 \ (rev acc_r) 43 | | Suc n' \ take_tr n' xs (x # acc_r))" 44 | 45 | lemma[code]: "take n xs = take_tr n xs []" 46 | proof - 47 | { fix acc_r :: "'a list" 48 | 49 | have "take_tr n xs acc_r = (rev acc_r)@(take n xs)" 50 | proof (induction n xs acc_r arbitrary: acc_r rule: take_tr.induct) 51 | case (2 n x xs acc_r) 52 | thus ?case 53 | apply (cases n) 54 | apply auto 55 | done 56 | qed simp_all 57 | } 58 | thus ?thesis 59 | by simp 60 | qed 61 | 62 | fun app_rev_tr:: "'a list \ 'a list \ 'a list" where 63 | "app_rev_tr [] ys = ys" 64 | | "app_rev_tr (x#xs) ys = app_rev_tr xs (x#ys)" 65 | 66 | lemma append_app_rev_tr: 67 | "app_rev_tr xs ys = append (rev xs) ys" 68 | by (induction xs ys arbitrary: ys rule: app_rev_tr.induct) simp_all 69 | 70 | end -------------------------------------------------------------------------------- /WebAssembly/PowerSum.thy: -------------------------------------------------------------------------------- 1 | theory PowerSum 2 | imports Main 3 | begin 4 | 5 | section\Lemmas about Sums of Powers divided by their Base\ 6 | 7 | text\ 8 | The following lemmas speak about cases like 9 | \(\n\A. b ^ n) div b\ 10 | where @{term "(div)"} is integer division. 11 | 12 | This is useful for example when for bit-shifting a number 13 | \X\ with binary representation \x\<^sub>0 x\<^sub>1 x\<^sub>2 \\ such that \X = x\<^sub>0 * 2^0 + x\<^sub>1 * 2^1 + x\<^sub>2 * 2^2 + \\ 14 | we can say that 15 | \X >> 1 = (x\<^sub>0 * 2^0 + x\<^sub>1 * 2^1 + x\<^sub>2 * 2^2 + \) div 2 = x\<^sub>1 * 2^0 + x\<^sub>2 * 2^1 + \\ 16 | so in this case: 17 | 1. Filter out the summand where the exponent is 0 18 | 2. Subtract 1 from all remaining exponents 19 | \ 20 | 21 | text\ 22 | This is the generalization of step 1 above, filter out any summand that has no effect on the 23 | result after dividing by the base. 24 | \ 25 | lemma power_sum_div_filter: 26 | fixes A :: "'a set" and b :: int 27 | assumes "card (Set.filter (\n. f n = 0) A) \ 1" "finite A" "b > 1" 28 | shows "(\n\A. b ^ f n) div b = (\n\Set.filter (\n. f n \ 0) A. b ^ f n) div b" 29 | proof - 30 | have *: "(\n\A. b ^ f n) = 31 | (\n\Set.filter (\n. f n \ 0) A. b ^ f n) 32 | + (\n\Set.filter (\n. f n = 0) A. b ^ f n)" 33 | apply (subst sum.union_disjoint[of "Set.filter (\n. f n \ 0) A" "Set.filter (\n. f n = 0) A", THEN sym]) 34 | using assms apply auto[3] 35 | apply (rule arg_cong[where f="sum (\n. b ^ f n)"]) unfolding Set.filter_def by auto 36 | hence "(\n\A. b ^ f n) div b = 37 | (\n\Set.filter (\n. f n \ 0) A. b ^ f n) div b 38 | + (\n\Set.filter (\n. f n = 0) A. b ^ f n) div b" 39 | apply (subst *) 40 | apply (rule div_plus_div_distrib_dvd_left) 41 | apply (rule dvd_sum) 42 | by simp 43 | moreover have "(\n\Set.filter (\n. f n = 0) A. b ^ f n) div b = 0" 44 | proof (cases "Set.filter (\n. f n = 0) A = {}") 45 | case False 46 | hence "0 < card (Set.filter (\n. f n = 0) A)" 47 | apply (subst card_gt_0_iff) using \finite A\ by simp 48 | hence "is_singleton (Set.filter (\n. f n = 0) A)" 49 | unfolding is_singleton_def apply (subst card_1_singleton_iff[THEN sym]) 50 | using \card _ \ 1\ using False by simp 51 | then obtain x where x: "Set.filter (\n. f n = 0) A = {x}" by (rule is_singletonE) 52 | hence 0: "f x = 0" by auto 53 | then show ?thesis unfolding x using \b > 1\ by simp 54 | qed simp 55 | ultimately show ?thesis by presburger 56 | qed 57 | 58 | text\ 59 | Step 2, when there are no summands remaining where the exponent is 0, 60 | one can subtract 1 from all remaining exponents to resolve the division. 61 | \ 62 | lemma power_sum_div_n0: 63 | fixes A :: "'a set" and b :: int 64 | assumes n0: "\n. n \ A \ f n \ 0" and "b \ 0" 65 | shows "(\n\A. b ^ f n) div b = (\n\A. b ^ (f n - 1))" 66 | proof - 67 | have *: "(\n\A. b ^ f n) = b * (\n\A. b ^ (f n - 1))" 68 | apply (subst sum_distrib_left) 69 | apply (subst power_eq_if) 70 | apply (rule sum.cong) 71 | apply standard 72 | using n0 by fastforce 73 | show ?thesis unfolding * using \b \ 0\ by simp 74 | qed 75 | 76 | text\Both steps combined\ 77 | lemma power_sum_div: 78 | fixes A :: "'a set" and b :: int 79 | assumes "card (Set.filter (\n. f n = 0) A) \ 1" "finite A" "b > 1" 80 | shows "(\n\A. b ^ f n) div b = (\n\Set.filter (\n. f n \ 0) A. b ^ (f n - 1))" 81 | apply (subst power_sum_div_filter[OF assms]) 82 | apply (rule power_sum_div_n0) 83 | using \b > 1\ by auto 84 | 85 | text\Example usage for bit shifts\ 86 | lemma "(\n = 0..n = 1.. {a \ {0.. 0} = {a \ {1..n = 0..n\?A. ?b ^ (?f n)) div 2" 95 | unfolding Set.filter_def by (subst sum.inter_filter[symmetric]) auto 96 | also have "\ = (\n\Set.filter (\n. ?f n \ 0) ?A. ?b ^ (?f n - 1))" 97 | apply (rule power_sum_div) 98 | apply (rule order.trans[where b="card (Set.filter (\n. n = 0) {0.. = (\n = 1.. bool" ("_ \ _ : _" 60) where 5 | \ \\num ops\\ 6 | const:"\ \ [C v] :([] _> [(typeof v)])" 7 | | unop:"unop_t_num_agree op t \ \ \ [Unop t op] : ([T_num t] _> [T_num t])" 8 | | binop:"binop_t_num_agree op t \ \ \ [Binop t op] : ([T_num t,T_num t] _> [T_num t])" 9 | | testop:"is_int_t_num t \ \ \ [Testop t _] : ([T_num t] _> [T_num T_i32])" 10 | | relop:"relop_t_num_agree op t \ \ \ [Relop t op] : ([T_num t,T_num t] _> [T_num T_i32])" 11 | \ \\vector ops\\ 12 | | unop_vec:"\ \ [Unop_vec op] : ([T_vec T_v128] _> [T_vec T_v128])" 13 | | binop_vec:"\binop_vec_wf op\ \ \ \ [Binop_vec op] : ([T_vec T_v128, T_vec T_v128] _> [T_vec T_v128])" 14 | | ternop_vec:"\ \ [Ternop_vec op] : ([T_vec T_v128, T_vec T_v128, T_vec T_v128] _> [T_vec T_v128])" 15 | | test_vec:"\ \ [Test_vec op] : ([T_vec T_v128] _> [T_num T_i32])" 16 | | shift_vec:"\ \ [Shift_vec op] : ([T_vec T_v128, T_num T_i32] _> [T_vec T_v128])" 17 | | splat_vec:"\ \ [Splat_vec sv] : ([T_num (vec_lane_t sv)] _> [T_vec T_v128])" 18 | | extract_vec:"\i < vec_num sv; sx = U \ vec_length sv \ 2\ \ \ \ [Extract_vec sv sx i] : ([T_vec T_v128] _> [T_num (vec_lane_t sv)])" 19 | | replace_vec:"i < vec_num sv \ \ \ [Replace_vec sv i] : ([T_vec T_v128, T_num (vec_lane_t sv)] _> [T_vec T_v128])" 20 | \ \\convert\\ 21 | | convert:"\(t1 \ t2); (sat_sx = None) = ((is_float_t_num t1 \ is_float_t_num t2) \ (is_int_t_num t1 \ is_int_t_num t2 \ (t_num_length t1 < t_num_length t2)))\ \ \ \ [Cvtop t1 Convert t2 sat_sx] : ([T_num t2] _> [T_num t1])" 22 | \ \\reinterpret\\ 23 | | reinterpret:"\(t1 \ t2); t_num_length t1 = t_num_length t2\ \ \ \ [Cvtop t1 Reinterpret t2 None] : ([T_num t2] _> [T_num t1])" 24 | \ \\unreachable, nop, drop, select\\ 25 | | unreachable:"\ \ [Unreachable] : (ts _> ts')" 26 | | nop:"\ \ [Nop] : ([] _> [])" 27 | | drop:"\ \ [Drop] : ([t] _> [])" 28 | | select:"\ \ [Select] : ([t,t,T_num T_i32] _> [t])" 29 | \ \\block\\ 30 | | block:"\tb_tf_t \ tb = Some (tn _> tm); \\label := ([tm] @ (label \))\ \ es : (tn _> tm)\ \ \ \ [Block tb es] : (tn _> tm)" 31 | \ \\loop\\ 32 | | loop:"\tb_tf_t \ tb = Some (tn _> tm); \\label := ([tn] @ (label \))\ \ es : (tn _> tm)\ \ \ \ [Loop tb es] : (tn _> tm)" 33 | \ \\if then else\\ 34 | | if_wasm:"\tb_tf_t \ tb = Some (tn _> tm); \\label := ([tm] @ (label \))\ \ es1 : (tn _> tm); \\label := ([tm] @ (label \))\ \ es2 : (tn _> tm)\ \ \ \ [If tb es1 es2] : (tn @ [T_num T_i32] _> tm)" 35 | \ \\br\\ 36 | | br:"\i < length(label \); (label \)!i = ts\ \ \ \ [Br i] : (t1s @ ts _> t2s)" 37 | \ \\br_if\\ 38 | | br_if:"\i < length(label \); (label \)!i = ts\ \ \ \ [Br_if i] : (ts @ [T_num T_i32] _> ts)" 39 | \ \\br_table\\ 40 | | br_table:"\list_all (\i. i < length(label \) \ (label \)!i = ts) (is@[i])\ \ \ \ [Br_table is i] : (t1s @ ts @ [T_num T_i32] _> t2s)" 41 | \ \\return\\ 42 | | return:"\(return \) = Some ts\ \ \ \ [Return] : (t1s @ ts _> t2s)" 43 | \ \\call\\ 44 | | call:"\i < length(func_t \); (func_t \)!i = tf\ \ \ \ [Call i] : tf" 45 | \ \\call_indirect\\ 46 | | call_indirect:"\i < length(types_t \); (types_t \)!i = (t1s _> t2s); length (table \) \ 1\ \ \ \ [Call_indirect i] : (t1s @ [T_num T_i32] _> t2s)" 47 | \ \\get_local\\ 48 | | get_local:"\i < length(local \); (local \)!i = t\ \ \ \ [Get_local i] : ([] _> [t])" 49 | \ \\set_local\\ 50 | | set_local:"\i < length(local \); (local \)!i = t\ \ \ \ [Set_local i] : ([t] _> [])" 51 | \ \\tee_local\\ 52 | | tee_local:"\i < length(local \); (local \)!i = t\ \ \ \ [Tee_local i] : ([t] _> [t])" 53 | \ \\get_global\\ 54 | | get_global:"\i < length(global \); tg_t ((global \)!i) = t\ \ \ \ [Get_global i] : ([] _> [t])" 55 | \ \\set_global\\ 56 | | set_global:"\i < length(global \); tg_t ((global \)!i) = t; is_mut ((global \)!i)\ \ \ \ [Set_global i] : ([t] _> [])" 57 | \ \\load\\ 58 | | load:"\length (memory \) \ 1; load_store_t_bounds a (option_projl tp_sx) t\ \ \ \ [Load t tp_sx a off] : ([T_num T_i32] _> [T_num t])" 59 | \ \\store\\ 60 | | store:"\length (memory \) \ 1; load_store_t_bounds a tp t\ \ \ \ [Store t tp a off] : ([T_num T_i32,T_num t] _> [])" 61 | \ \\load_vec\\ 62 | | load_vec:"\length (memory \) \ 1; load_vec_t_bounds lvop a\ \ \ \ [Load_vec lvop a off] : ([T_num T_i32] _> [T_vec T_v128])" 63 | \ \\load_lane_vec\\ 64 | | load_lane_vec:"\length (memory \) \ 1; i < vec_i_num svi \ 2^a \ (vec_i_length svi)\ \ \ \ [Load_lane_vec svi i a off] : ([T_num T_i32, T_vec T_v128] _> [T_vec T_v128])" 65 | \ \\store_vec\\ 66 | | store_vec:"\length (memory \) \ 1; store_vec_t_bounds svop a\ \ \ \ [Store_vec svop a off] : ([T_num T_i32,T_vec T_v128] _> [])" 67 | \ \\current_memory\\ 68 | | current_memory:"length (memory \) \ 1 \ \ \ [Current_memory] : ([] _> [T_num T_i32])" 69 | \ \\Grow_memory\\ 70 | | grow_memory:"length (memory \) \ 1 \ \ \ [Grow_memory] : ([T_num T_i32] _> [T_num T_i32])" 71 | \ \\empty program\\ 72 | | empty:"\ \ [] : ([] _> [])" 73 | \ \\composition\\ 74 | | composition:"\\ \ es : (t1s _> t2s); \ \ [e] : (t2s _> t3s)\ \ \ \ es @ [e] : (t1s _> t3s)" 75 | \ \\weakening\\ 76 | | weakening:"\ \ es : (t1s _> t2s) \ \ \ es : (ts @ t1s _> ts @ t2s)" 77 | 78 | definition "glob_typing g tg = (tg_mut tg = g_mut g \ tg_t tg = typeof (g_val g))" 79 | 80 | definition "globi_agree gs n g = (n < length gs \ glob_typing (gs!n) g)" 81 | 82 | definition "limits_compat lt1 lt2 = 83 | ((l_min lt1) \ (l_min lt2) \ 84 | pred_option (\lt2_the. (case (l_max lt1) of 85 | Some lt1_the \ (lt1_the \ lt2_the) 86 | | None \ False)) (l_max lt2))" 87 | 88 | definition "tab_typing t tt = (limits_compat \l_min=(tab_size t),l_max=(tab_max t)\ tt)" 89 | 90 | definition "tabi_agree ts n tab_t = 91 | ((n < length ts) \ (tab_typing (ts!n) tab_t))" 92 | 93 | definition "mem_typing m mt = (limits_compat \l_min=(mem_size m),l_max=(mem_max m)\ mt)" 94 | 95 | definition "memi_agree ms n mem_t = 96 | ((n < length ms) \ mem_typing (ms!n) mem_t)" 97 | 98 | definition "funci_agree fs n f = (n < length fs \ (cl_type (fs!n)) = f)" 99 | 100 | inductive inst_typing :: "[s, inst, t_context] \ bool" where 101 | "\list_all2 (funci_agree (funcs s)) fs tfs; 102 | list_all2 (globi_agree (globs s)) gs tgs; 103 | list_all2 (tabi_agree (tabs s)) tbs tabs_t; 104 | list_all2 (memi_agree (mems s)) ms mems_t\ 105 | \ inst_typing s \types = ts, funcs = fs, tabs = tbs, mems = ms, globs = gs\ 106 | \types_t = ts, func_t = tfs, global = tgs, table = tabs_t, memory = mems_t, local = [], label = [], return = None\" 107 | 108 | inductive frame_typing :: "[s, f, t_context] \ bool" where 109 | "\tvs = map typeof (f_locs f); inst_typing s (f_inst f) \\ \ frame_typing s f (\\local := tvs\)" 110 | 111 | inductive cl_typing :: "[s, cl, tf] \ bool" where 112 | "\inst_typing s i \; tf = (t1s _> t2s); \\local := t1s @ ts, label := ([t2s] @ (label \)), return := Some t2s\ \ es : ([] _> t2s)\ \ cl_typing s (Func_native i tf ts es) (t1s _> t2s)" 113 | | "cl_typing s (Func_host tf h) tf" 114 | 115 | (* lifting the b_e_typing relation to the administrative operators *) 116 | inductive e_typing :: "[s, t_context, e list, tf] \ bool" ("_\_ \ _ : _" 60) 117 | and l_typing :: "[s, (t list) option, f, e list, t list] \ bool" ("_\_ \' _;_ : _" 60) where 118 | (* section: e_typing *) 119 | (* lifting *) 120 | "\ \ b_es : tf \ \\\ \ $*b_es : tf" 121 | (* composition *) 122 | | "\\\\ \ es : (t1s _> t2s); \\\ \ [e] : (t2s _> t3s)\ \ \\\ \ es @ [e] : (t1s _> t3s)" 123 | (* weakening *) 124 | | "\\\ \ es : (t1s _> t2s) \\\\ \ es : (ts @ t1s _> ts @ t2s)" 125 | (* trap *) 126 | | "\\\ \ [Trap] : tf" 127 | (* frame *) 128 | | "\\\Some ts \ f;es : ts; length ts = n\ \ \\\ \ [Frame n f es] : ([] _> ts)" 129 | (* invoke *) 130 | | "\i < length (funcs \); cl_type ((funcs \)!i) = tf\ \ \\\ \ [Invoke i] : tf" 131 | (* label *) 132 | | "\\\\ \ e0s : (ts _> t2s); \\\\label := ([ts] @ (label \))\ \ es : ([] _> t2s); length ts = n\ \ \\\ \ [Label n e0s es] : ([] _> t2s)" 133 | (* Init_mem (instantiation) *) 134 | | "\length (memory \) \ 1\ \ \\\ \ [Init_mem n bs] : ([] _> [])" 135 | (* Init_tab (instantiation) *) 136 | | "\length (table \) \ 1; list_all (\ti. ti < length (funcs \)) tis\ \ \\\ \ [Init_tab n tis] : ([] _> [])" 137 | (* section: l_typing *) 138 | | "\frame_typing \ f \; \\\\return := rs\ \ es : ([] _> ts)\ \ \\rs \ f;es : ts" 139 | 140 | definition "tab_agree s tab = 141 | ((list_all (\i_opt. (case i_opt of None \ True | Some i \ i < length (funcs s))) (fst tab)) \ 142 | pred_option (\max. (tab_size tab) \ max) (tab_max tab))" 143 | 144 | inductive store_typing :: "s \ bool" where 145 | "\list_all (\cl. \tf. cl_typing s cl tf) (funcs s); 146 | list_all (tab_agree s) (tabs s); 147 | list_all mem_agree (mems s) 148 | \ \ store_typing s" 149 | 150 | inductive config_typing :: "[s, f, e list, t list] \ bool" ("\ _;_;_ : _" 60) where 151 | "\store_typing s; s\None \ f;es : ts\ \ \ s;f;es : ts" 152 | 153 | (* REDUCTION RELATION *) 154 | 155 | inductive reduce_simple :: "[e list, e list] \ bool" ("\_\ \ \_\" 60) where 156 | \ \\unary ops\\ 157 | unop:"\[$C\<^sub>n v, $(Unop t op)]\ \ \[$C\<^sub>n (app_unop op v)]\" 158 | \ \\binary ops\\ 159 | | binop_Some:"\app_binop op v1 v2 = (Some v)\ \ \[$C\<^sub>n v1, $C\<^sub>n v2, $(Binop t op)]\ \ \[$C\<^sub>n v]\" 160 | | binop_None:"\app_binop op v1 v2 = None\ \ \[$C\<^sub>n v1, $C\<^sub>n v2, $(Binop t op)]\ \ \[Trap]\" 161 | \ \\testops\\ 162 | | testop:"\[$C\<^sub>n v, $(Testop t op)]\ \ \[$C\<^sub>n (app_testop op v)]\" 163 | \ \\relops\\ 164 | | relop:"\[$C\<^sub>n v1, $C\<^sub>n v2, $(Relop t op)]\ \ \[$C\<^sub>n (app_relop op v1 v2)]\" 165 | \ \\convert\\ 166 | | convert_Some:"\(typeof_num v) = t1; cvt t2 sat_sx v = (Some v')\ \ \[$(C\<^sub>n v), $(Cvtop t2 Convert t1 sat_sx)]\ \ \[$(C\<^sub>n v')]\" 167 | | convert_None:"\(typeof_num v) = t1; cvt t2 sat_sx v = None\ \ \[$(C\<^sub>n v), $(Cvtop t2 Convert t1 sat_sx)]\ \ \[Trap]\" 168 | \ \\reinterpret\\ 169 | | reinterpret:"(typeof_num v) = t1 \ \[$(C\<^sub>n v), $(Cvtop t2 Reinterpret t1 None)]\ \ \[$(C\<^sub>n (wasm_reinterpret t2 v))]\" 170 | \ \\unary vector ops\\ 171 | | unop_vec:"\[$C\<^sub>v v, $(Unop_vec op)]\ \ \[$C\<^sub>v (app_unop_vec op v)]\" 172 | \ \\binary vector ops\\ 173 | | binop_vec_Some:"\app_binop_vec op v1 v2 = Some v\ \ \[$C\<^sub>v v1, $C\<^sub>v v2, $(Binop_vec op)]\ \ \[$C\<^sub>v v]\" 174 | | binop_vec_None:"\app_binop_vec op v1 v2 = None\ \ \[$C\<^sub>v v1, $C\<^sub>v v2, $(Binop_vec op)]\ \ \[Trap]\" 175 | \ \\ternary vector ops\\ 176 | | ternop_vec:"\[$C\<^sub>v v1, $C\<^sub>v v2, $C\<^sub>v v3, $(Ternop_vec op)]\ \ \[$C\<^sub>v (app_ternop_vec op v1 v2 v3)]\" 177 | \ \\test vector ops\\ 178 | | test_vec:"\[$C\<^sub>v v, $(Test_vec op)]\ \ \[$C\<^sub>n (ConstInt32 (app_test_vec op v))]\" 179 | \ \\shift vector ops\\ 180 | | shift_vec:"\[$C\<^sub>v v, $C\<^sub>n (ConstInt32 n), $(Shift_vec op)]\ \ \[$C\<^sub>v (app_shift_vec op v n)]\" 181 | \ \\splat vector ops\\ 182 | | splat_vec:"\[$C\<^sub>n v, $(Splat_vec sv)]\ \ \[$C\<^sub>v (app_splat_vec sv v)]\" 183 | \ \\extract vector ops\\ 184 | | extract_vec:"\[$C\<^sub>v v, $(Extract_vec sv sx i)]\ \ \[$C\<^sub>n (app_extract_vec sv sx i v)]\" 185 | \ \\replace vector ops\\ 186 | | replace_vec:"\[$C\<^sub>v v, $C\<^sub>n vn, $(Replace_vec sv i)]\ \ \[$C\<^sub>v (app_replace_vec sv i v vn)]\" 187 | \ \\unreachable\\ 188 | | unreachable:"\[$ Unreachable]\ \ \[Trap]\" 189 | \ \\nop\\ 190 | | nop:"\[$ Nop]\ \ \[]\" 191 | \ \\drop\\ 192 | | drop:"\[$(C v), ($ Drop)]\ \ \[]\" 193 | \ \\select\\ 194 | | select_false:"int_eq n 0 \ \[$(C v1), $(C v2), $C\<^sub>n (ConstInt32 n), ($ Select)]\ \ \[$(C v2)]\" 195 | | select_true:"int_ne n 0 \ \[$(C v1), $(C v2), $C\<^sub>n (ConstInt32 n), ($ Select)]\ \ \[$(C v1)]\" 196 | \ \\if\\ 197 | | if_false:"int_eq n 0 \ \[$C\<^sub>n (ConstInt32 n), $(If tb e1s e2s)]\ \ \[$(Block tb e2s)]\" 198 | | if_true:"int_ne n 0 \ \[$C\<^sub>n (ConstInt32 n), $(If tb e1s e2s)]\ \ \[$(Block tb e1s)]\" 199 | \ \\label\\ 200 | | label_const:"\[Label n es ($C* vs)]\ \ \($C* vs)\" 201 | | label_trap:"\[Label n es [Trap]]\ \ \[Trap]\" 202 | \ \\br\\ 203 | | br:"\length vs = n; Lfilled i lholed (($C* vs) @ [$(Br i)]) LI\ \ \[Label n es LI]\ \ \($C* vs) @ es\" 204 | \ \\br_if\\ 205 | | br_if_false:"int_eq n 0 \ \[$C\<^sub>n (ConstInt32 n), $(Br_if i)]\ \ \[]\" 206 | | br_if_true:"int_ne n 0 \ \[$C\<^sub>n (ConstInt32 n), $(Br_if i)]\ \ \[$(Br i)]\" 207 | \ \\br_table\\ 208 | | br_table:"\length is > (nat_of_int c)\ \ \[$C\<^sub>n (ConstInt32 c), $(Br_table is i)]\ \ \[$(Br (is!(nat_of_int c)))]\" 209 | | br_table_length:"\length is \ (nat_of_int c)\ \ \[$C\<^sub>n (ConstInt32 c), $(Br_table is i)]\ \ \[$(Br i)]\" 210 | \ \\local\\ 211 | | local_const:"\[Frame n f ($C* vs)]\ \ \($C* vs)\" 212 | | local_trap:"\[Frame n f [Trap]]\ \ \[Trap]\" 213 | \ \\return\\ 214 | | return:"\length vs = n; Lfilled j lholed (($C* vs) @ [$Return]) es\ \ \[Frame n f es]\ \ \($C* vs)\" 215 | \ \\tee_local\\ 216 | | tee_local:"\[$C v, $(Tee_local i)]\ \ \[$C v, $C v, $(Set_local i)]\" 217 | | trap:"\es \ [Trap]; Lfilled 0 lholed [Trap] es\ \ \es\ \ \[Trap]\" 218 | 219 | (* full reduction rule *) 220 | inductive reduce :: "[s, f, e list, s, f, e list] \ bool" ("\_;_;_\ \ \_;_;_\" 60) where 221 | \ \\lifting basic reduction\\ 222 | basic:"\e\ \ \e'\ \ \s;f;e\ \ \s;f;e'\" 223 | \ \\call\\ 224 | | call:"\s;f;[$(Call j)]\ \ \s;f;[Invoke (sfunc_ind (f_inst f) j)]\" 225 | \ \\call_indirect\\ 226 | | call_indirect_Some:"\(f_inst f) = i; stab s i (nat_of_int c) = Some i_cl; stypes i j = tf; cl_type (funcs s!i_cl) = tf\ \ \s;f;[$C\<^sub>n (ConstInt32 c), $(Call_indirect j)]\ \ \s;f;[Invoke i_cl]\" 227 | | call_indirect_None:"\(f_inst f) = i; (stab s i (nat_of_int c) = Some i_cl \ stypes i j \ cl_type (funcs s!i_cl)) \ stab s i (nat_of_int c) = None\ \ \s;f;[$C\<^sub>n (ConstInt32 c), $(Call_indirect j)]\ \ \s;f;[Trap]\" 228 | \ \\invoke\\ 229 | | invoke_native:"\(funcs s!i_cl) = Func_native j (t1s _> t2s) ts es; ves = ($C* vcs); length vcs = n; length ts = k; length t1s = n; length t2s = m; (n_zeros ts = zs) \ \ \s;f;ves @ [Invoke i_cl]\ \ \s;f;[Frame m \ f_locs = vcs@zs, f_inst = j \ [(Label m [] ($*es))]]\" 230 | | invoke_host_Some:"\(funcs s!i_cl) = Func_host (t1s _> t2s) h; ves = ($C* vcs); length vcs = n; length t1s = n; length t2s = m; host_apply s (t1s _> t2s) h vcs hs (Some (s', vcs'))\ \ \s;f;ves @ [Invoke i_cl]\ \ \s';f;($C* vcs')\" 231 | | invoke_host_None:"\(funcs s!i_cl) = Func_host (t1s _> t2s) h; ves = ($C* vcs); length vcs = n; length t1s = n; length t2s = m\ \ \s;f;ves @ [Invoke i_cl]\ \ \s;f;[Trap]\" 232 | \ \\get_local\\ 233 | | get_local:"\length vi = j; f_locs f = (vi @ [v] @ vs)\ \ \s;f;[$(Get_local j)]\ \ \s;f;[$(C v)]\" 234 | \ \\set_local\\ 235 | | set_local:"\length vi = j\ \ \s;\ f_locs = (vi @ [v] @ vs), f_inst = i \;[$(C v'), $(Set_local j)]\ \ \s;\ f_locs = (vi @ [v'] @ vs), f_inst = i \;[]\" 236 | \ \\get_global\\ 237 | | get_global:"\s;f;[$(Get_global j)]\ \ \s;f;[$ C(sglob_val s (f_inst f) j)]\" 238 | \ \\set_global\\ 239 | | set_global:"supdate_glob s (f_inst f) j v = s' \ \s;f;[$(C v), $(Set_global j)]\ \ \s';f;[]\" 240 | \ \\load\\ 241 | | load_Some:"\smem_ind (f_inst f) = Some j; ((mems s)!j) = m; load m (nat_of_int k) off (t_num_length t) = Some bs\ \ \s;f;[$C\<^sub>n (ConstInt32 k), $(Load t None a off)]\ \ \s;f;[$C\<^sub>n (wasm_deserialise_num bs t)]\" 242 | | load_None:"\smem_ind (f_inst f) = Some j; ((mems s)!j) = m; load m (nat_of_int k) off (t_num_length t) = None\ \ \s;f;[$C\<^sub>n (ConstInt32 k), $(Load t None a off)]\ \ \s;f;[Trap]\" 243 | \ \\load packed\\ 244 | | load_packed_Some:"\smem_ind (f_inst f) = Some j; ((mems s)!j) = m; load_packed sx m (nat_of_int k) off (tp_num_length tp) (t_num_length t) = Some bs\ \ \s;f;[$C\<^sub>n (ConstInt32 k), $(Load t (Some (tp, sx)) a off)]\ \ \s;f;[$C\<^sub>n (wasm_deserialise_num bs t)]\" 245 | | load_packed_None:"\smem_ind (f_inst f) = Some j; ((mems s)!j) = m; load_packed sx m (nat_of_int k) off (tp_num_length tp) (t_num_length t) = None\ \ \s;f;[$C\<^sub>n (ConstInt32 k), $(Load t (Some (tp, sx)) a off)]\ \ \s;f;[Trap]\" 246 | \ \\store\\ 247 | | store_Some:"\(typeof_num v) = t; smem_ind (f_inst f) = Some j; ((mems s)!j) = m; store m (nat_of_int k) off (bits_num v) (t_num_length t) = Some mem'\ \ \s;f;[$C\<^sub>n (ConstInt32 k), $C\<^sub>n v, $(Store t None a off)]\ \ \s\mems:= ((mems s)[j := mem'])\;f;[]\" 248 | | store_None:"\(typeof_num v) = t; smem_ind (f_inst f) = Some j; ((mems s)!j) = m; store m (nat_of_int k) off (bits_num v) (t_num_length t) = None\ \ \s;f;[$C\<^sub>n (ConstInt32 k), $C\<^sub>n v, $(Store t None a off)]\ \ \s;f;[Trap]\" 249 | \ \\store packed\\ (* take only (tp_length tp) lower order bytes *) 250 | | store_packed_Some:"\(typeof_num v) = t; smem_ind (f_inst f) = Some j; ((mems s)!j) = m; store_packed m (nat_of_int k) off (bits_num v) (tp_num_length tp) = Some mem'\ \ \s;f;[$C\<^sub>n (ConstInt32 k), $C\<^sub>n v, $(Store t (Some tp) a off)]\ \ \s\mems:= ((mems s)[j := mem'])\;f;[]\" 251 | | store_packed_None:"\(typeof_num v) = t; smem_ind (f_inst f) = Some j; ((mems s)!j) = m; store_packed m (nat_of_int k) off (bits_num v) (tp_num_length tp) = None\ \ \s;f;[$C\<^sub>n (ConstInt32 k), $C\<^sub>n v, $(Store t (Some tp) a off)]\ \ \s;f;[Trap]\" 252 | \ \\load vector\\ 253 | | load_vec_Some:"\smem_ind (f_inst f) = Some j; ((mems s)!j) = m; load_vec lv m (nat_of_int k) off = Some bs\ \ \s;f;[$C\<^sub>n (ConstInt32 k), $(Load_vec lv a off)]\ \ \s;f;[$C\<^sub>v (ConstVec128 (deserialise_v128 bs))]\" 254 | | load_vec_None:"\smem_ind (f_inst f) = Some j; ((mems s)!j) = m; load_vec lv m (nat_of_int k) off = None\ \ \s;f;[$C\<^sub>n (ConstInt32 k), $(Load_vec lv a off)]\ \ \s;f;[Trap]\" 255 | \ \\load lane vector\\ 256 | | load_lane_vec_Some:"\smem_ind (f_inst f) = Some j; ((mems s)!j) = m; load m (nat_of_int k) off (vec_i_length svi) = Some bs\ \ \s;f;[$C\<^sub>n (ConstInt32 k), $C\<^sub>v (ConstVec128 v), $(Load_lane_vec svi i a off)]\ \ \s;f;[$C\<^sub>v (ConstVec128 (insert_lane_vec svi i bs v))]\" 257 | | load_lane_vec_None:"\smem_ind (f_inst f) = Some j; ((mems s)!j) = m; load m (nat_of_int k) off (vec_i_length svi) = None\ \ \s;f;[$C\<^sub>n (ConstInt32 k), $C\<^sub>v (ConstVec128 v), $(Load_lane_vec svi i a off)]\ \ \s;f;[Trap]\" 258 | \ \\store vector\\ 259 | | store_vec_Some:"\smem_ind (f_inst f) = Some j; ((mems s)!j) = m; (store_serialise_vec sv v) = bs; store m (nat_of_int k) off bs (length bs) = Some mem'\ \ \s;f;[$C\<^sub>n (ConstInt32 k), $C\<^sub>v (ConstVec128 v), $(Store_vec sv a off)]\ \ \s\mems:= ((mems s)[j := mem'])\;f;[]\" 260 | | store_vec_None:"\smem_ind (f_inst f) = Some j; ((mems s)!j) = m; (store_serialise_vec sv v) = bs; store m (nat_of_int k) off bs (length bs) = None\ \ \s;f;[$C\<^sub>n (ConstInt32 k), $C\<^sub>v (ConstVec128 v), $(Store_vec sv a off)]\ \ \s;f;[Trap]\" 261 | \ \\current_memory\\ 262 | | current_memory:"\smem_ind (f_inst f) = Some j; ((mems s)!j) = m; mem_size m = n\ \ \s;f;[ $(Current_memory)]\ \ \s;f;[$C\<^sub>n (ConstInt32 (int_of_nat n))]\" 263 | \ \\grow_memory\\ 264 | | grow_memory:"\smem_ind (f_inst f) = Some j; ((mems s)!j) = m; mem_size m = n; mem_grow m (nat_of_int c) = Some mem'\ \ \s;f;[$C\<^sub>n (ConstInt32 c), $(Grow_memory)]\ \ \s\mems:= ((mems s)[j := mem'])\;f;[$C\<^sub>n (ConstInt32 (int_of_nat n))]\" 265 | \ \\grow_memory fail\\ 266 | | grow_memory_fail:"\smem_ind (f_inst f) = Some j; ((mems s)!j) = m; mem_size m = n\ \ \s;f;[$C\<^sub>n (ConstInt32 c),$(Grow_memory)]\ \ \s;f;[$C\<^sub>n (ConstInt32 int32_minus_one)]\" 267 | \ \\block\\ 268 | | block:"\length vs = n; tb_tf (f_inst f) tb = (t1s _> t2s); length t1s = n; length t2s = m\ \ \s;f;($C* vs) @ [$(Block tb es)]\ \ \s;f;[Label m [] (($C* vs) @ ($* es))]\" 269 | \ \\loop\\ 270 | | loop:"\length vs = n; tb_tf (f_inst f) tb = (t1s _> t2s); length t1s = n; length t2s = m\ \ \s;f;($C* vs) @ [$(Loop tb es)]\ \ \s;f;[Label n [$(Loop tb es)] (($C* vs) @ ($* es))]\" 271 | (* The bad ones *) 272 | \ \\inductive label reduction\\ 273 | | label:"\\s;f;es\ \ \s';f';es'\; Lfilled k lholed es les; Lfilled k lholed es' les'\ \ \s;f;les\ \ \s';f';les'\" 274 | \ \\inductive local reduction\\ 275 | | local:"\\s;f;es\ \ \s';f';es'\\ \ \s;f0;[Frame n f es]\ \ \s';f0;[Frame n f' es']\" 276 | (* instantiation helpers *) 277 | | init_mem_Some:"\smem_ind (f_inst f) = Some j; ((mems s)!j) = m; store m n 0 bs (length bs) = Some mem'\ \ \s;f;[Init_mem n bs]\ \ \s\mems:= ((mems s)[j := mem'])\;f;[]\" 278 | | init_mem_None:"\smem_ind (f_inst f) = Some j; ((mems s)!j) = m; store m n 0 bs (length bs) = None\ \ \s;f;[Init_mem n bs]\ \ \s;f;[Trap]\" 279 | | init_tab_Some:"\stab_ind (f_inst f) = Some j; ((tabs s)!j) = t; store_tab t n icls = Some tab'\ \ \s;f;[Init_tab n icls]\ \ \s\tabs:= ((tabs s)[j := tab'])\;f;[]\" 280 | | init_tab_None:"\stab_ind (f_inst f) = Some j; ((tabs s)!j) = t; store_tab t n icls = None\ \ \s;f;[Init_tab n icls]\ \ \s;f;[Trap]\" 281 | 282 | definition reduce_trans where 283 | "reduce_trans \ (\(s,f,es) (s',f',es'). \s;f;es\ \ \s';f';es'\)^**" 284 | 285 | definition reduce_irrtrans where 286 | "reduce_irrtrans \ (\(s,f,es) (s',f',es'). \s;f;es\ \ \s';f';es'\)^++" 287 | 288 | lemma reduce_irrtrans_trans:"reduce_irrtrans a b \ reduce_trans a b" 289 | unfolding reduce_irrtrans_def reduce_trans_def 290 | by simp 291 | 292 | type_synonym v_stack = "v list" 293 | 294 | abbreviation v_stack_to_es :: " v_stack \ e list" 295 | where "v_stack_to_es v \ $C* (rev v)" 296 | 297 | 298 | definition "computes cfg s' vs \ \f'. reduce_trans cfg (s', f', v_stack_to_es vs)" 299 | 300 | definition "traps cfg s' \ \f'. reduce_trans cfg (s',f',[Trap])" 301 | 302 | definition "empty_frame \ \f_locs = [],f_inst = \ types = [], funcs = [], tabs = [], mems = [], globs = []\\" 303 | 304 | definition "invoke_config s vargs i \ (s, empty_frame, ($C* vargs) @ [Invoke i])" 305 | 306 | end 307 | -------------------------------------------------------------------------------- /WebAssembly/Wasm_Ast.thy: -------------------------------------------------------------------------------- 1 | section \WebAssembly Core AST\ 2 | 3 | theory Wasm_Ast 4 | imports 5 | Main 6 | "HOL-Library.Word" 7 | "Word_Lib.Reversed_Bit_Lists" 8 | "Native_Word.Uint8" 9 | begin 10 | 11 | type_synonym \ \immediate\ 12 | i = nat 13 | type_synonym \ \static offset\ 14 | off = nat 15 | type_synonym \ \alignment exponent\ 16 | a = nat 17 | 18 | \ \primitive types\ 19 | typedef i32 = "UNIV :: (32 word) set" .. 20 | typedef i64 = "UNIV :: (64 word) set" .. 21 | 22 | typedef f32 = "UNIV :: (32 word) set" .. 23 | typedef f64 = "UNIV :: (64 word) set" .. 24 | typedef v128 = "UNIV :: (128 word) set" .. 25 | 26 | (*typedecl f32 27 | typedecl f64 28 | typedecl v128 29 | *) 30 | 31 | setup_lifting type_definition_i32 32 | declare Quotient_i32[transfer_rule] 33 | setup_lifting type_definition_i64 34 | declare Quotient_i64[transfer_rule] 35 | 36 | \ \memory\ 37 | type_synonym byte = uint8 38 | 39 | definition "msb_byte = (msb::byte \ bool)" 40 | definition "zero_byte = (0::byte)" 41 | definition "negone_byte = (-1::byte)" 42 | 43 | definition "nat_of_byte = nat_of_uint8" 44 | definition "byte_of_nat = uint8_of_nat" 45 | 46 | type_synonym bytes = "byte list" 47 | 48 | definition bytes_takefill :: "byte \ nat \ bytes \ bytes" where 49 | "bytes_takefill = (\(a::byte) n as. takefill a n as)" 50 | 51 | definition bytes_replicate :: "nat \ byte \ bytes" where 52 | "bytes_replicate = (\n (b::byte). replicate n b)" 53 | 54 | definition msbyte :: "bytes \ byte" where 55 | "msbyte bs = last (bs)" 56 | 57 | record limit_t = 58 | l_min :: nat 59 | l_max :: "nat option" 60 | 61 | free_constructors case_limit_t_ext for limit_t_ext 62 | using limit_t.cases_scheme 63 | by blast+ 64 | 65 | type_synonym tab_t = \ \table type\ 66 | "limit_t" 67 | 68 | type_synonym mem_t = \ \memory type\ 69 | "limit_t" 70 | 71 | definition Ki64 :: "nat" where 72 | "Ki64 = 65536" 73 | 74 | typedef mem_rep = "UNIV :: (byte list) set" .. 75 | setup_lifting type_definition_mem_rep 76 | declare Quotient_mem_rep[transfer_rule] 77 | 78 | type_synonym mem = "(mem_rep \ nat option)" 79 | 80 | lift_definition mem_rep_mk :: "nat \ mem_rep" is "(\n. (bytes_replicate (n * Ki64) zero_byte))" . 81 | definition mem_mk :: "limit_t \ mem" where 82 | "mem_mk lim = (mem_rep_mk (l_min lim), l_max lim)" 83 | 84 | lift_definition mem_rep_byte_at :: "mem_rep \ nat \ byte" is "(\m n. m!n)::(byte list) \ nat \ byte" . 85 | definition byte_at :: "mem \ nat \ byte" where 86 | "byte_at m n = mem_rep_byte_at (fst m) n" 87 | 88 | lift_definition mem_rep_length :: "mem_rep \ nat" is "(\m. length m)" . 89 | definition mem_length :: "mem \ nat" where 90 | "mem_length m = mem_rep_length (fst m)" 91 | 92 | definition mem_max :: "mem \ nat option" where 93 | "mem_max m = snd m" 94 | 95 | lift_definition mem_rep_read_bytes :: "mem_rep \ nat \ nat \ bytes" is "(\m n l. (take l (drop n m))::(byte list))" . 96 | definition read_bytes :: "mem \ nat \ nat \ bytes" where 97 | "read_bytes m n l = mem_rep_read_bytes (fst m) n l" 98 | 99 | lift_definition mem_rep_write_bytes :: "mem_rep \ nat \ bytes \ mem_rep" is "(\m n bs. ((take n m) @ bs @ (drop (n + length bs) m)) :: byte list)" . 100 | definition write_bytes :: "mem \ nat \ bytes \ mem" where 101 | "write_bytes m n bs = (mem_rep_write_bytes (fst m) n bs, snd m)" 102 | 103 | lift_definition mem_rep_append :: "mem_rep \ nat \ byte \ mem_rep" is "(\m n b. (append m (replicate n b))::byte list)" . 104 | definition mem_append :: "mem \ nat \ byte \ mem" where 105 | "mem_append m n b = (mem_rep_append (fst m) n b, snd m)" 106 | 107 | lemma take_drop_map: 108 | assumes "ind+n \ length bs" 109 | shows "(take n (drop ind bs)) = (map ((!) bs) [ind.. mem_length m" 120 | shows "read_bytes m ind n = (map (\k. byte_at m k) [ind.. \host\ 127 | typedecl host 128 | typedecl host_state 129 | 130 | datatype \ \numeric types\ 131 | t_num = T_i32 | T_i64 | T_f32 | T_f64 132 | 133 | (* 1.1: vector operators *) 134 | datatype \ \vector types\ 135 | t_vec = T_v128 136 | 137 | datatype \ \value types\ 138 | t = T_num t_num | T_vec t_vec 139 | 140 | datatype \ \packed numeric types\ 141 | tp_num = Tp_i8 | Tp_i16 | Tp_i32 142 | 143 | datatype \ \packed vector types\ 144 | tp_vec = Tp_v8_8 | Tp_v16_4 | Tp_v32_2 145 | 146 | datatype \ \mutability\ 147 | mut = T_immut | T_mut 148 | 149 | record tg = \ \global types\ 150 | tg_mut :: mut 151 | tg_t :: t 152 | 153 | free_constructors case_tg_ext for tg_ext 154 | using tg.cases_scheme 155 | by blast+ 156 | 157 | datatype \ \function types\ 158 | tf = Tf (dom: "t list") (ran: "t list") ("_ '_> _" 60) 159 | hide_const (open) tf.dom tf.ran 160 | 161 | datatype \ \block types\ 162 | tb = Tbf i | Tbv "t option" 163 | 164 | (* TYPING *) 165 | record t_context = 166 | types_t :: "tf list" 167 | func_t :: "tf list" 168 | global :: "tg list" 169 | table :: "tab_t list" 170 | memory :: "mem_t list" 171 | local :: "t list" 172 | label :: "(t list) list" 173 | return :: "(t list) option" 174 | 175 | datatype \ \numeric values\ 176 | v_num = ConstInt32 i32 177 | | ConstInt64 i64 178 | | ConstFloat32 f32 179 | | ConstFloat64 f64 180 | 181 | datatype \ \vector values\ 182 | v_vec = ConstVec128 v128 183 | 184 | datatype \ \values\ 185 | v = V_num v_num | V_vec v_vec 186 | 187 | datatype 188 | sx = S | U 189 | 190 | datatype 191 | sat = Sat | Nonsat 192 | 193 | (* numeric ops *) 194 | 195 | datatype 196 | unop_i = Clz | Ctz | Popcnt 197 | 198 | datatype 199 | unop_f = Neg | Abs | Ceil | Floor | Trunc | Nearest | Sqrt 200 | 201 | datatype 202 | unop = Unop_i unop_i | Unop_f unop_f 203 | (* 1.1: sign-extension operators *) 204 | | Extend_s tp_num 205 | 206 | datatype 207 | binop_i = Add | Sub | Mul | Div sx | Rem sx | And | Or | Xor | Shl | Shr sx | Rotl | Rotr 208 | 209 | datatype 210 | binop_f = Addf | Subf | Mulf | Divf | Min | Max | Copysign 211 | 212 | datatype 213 | binop = Binop_i binop_i | Binop_f binop_f 214 | 215 | datatype 216 | testop = Eqz 217 | 218 | datatype 219 | relop_i = Eq | Ne | Lt sx | Gt sx | Le sx | Ge sx 220 | 221 | datatype 222 | relop_f = Eqf | Nef | Ltf | Gtf | Lef | Gef 223 | 224 | datatype 225 | relop = Relop_i relop_i | Relop_f relop_f 226 | 227 | datatype 228 | cvtop = Convert | Reinterpret 229 | 230 | (* 1.1: vector ops *) 231 | 232 | datatype shape_vec_i = I8_16 | I16_8 | I32_4 | I64_2 233 | 234 | datatype shape_vec_f = F32_4 | F64_2 235 | 236 | datatype shape_vec = Svi shape_vec_i | Svf shape_vec_f 237 | 238 | datatype 239 | loadop_vec = 240 | Load_128 241 | | Load_packed_vec tp_vec sx 242 | | Load_32_zero 243 | | Load_64_zero 244 | | Load_splat shape_vec_i 245 | 246 | datatype 247 | storeop_vec = 248 | Store_128 249 | | Store_lane shape_vec_i i 250 | 251 | 252 | consts unop_vec_carrier :: "nat set" 253 | specification (unop_vec_carrier) 254 | unop_vec_finite[simp]: "finite unop_vec_carrier" 255 | unop_vec_ne: "unop_vec_carrier \ {}" 256 | by blast 257 | 258 | typedef unop_vec = "unop_vec_carrier" using unop_vec_ne by blast 259 | 260 | lemma range_unop_vec[simp]: "range Rep_unop_vec = unop_vec_carrier" 261 | apply (auto) 262 | apply (simp add: Rep_unop_vec) 263 | by (metis Rep_unop_vec_cases rangeI) 264 | 265 | instance unop_vec :: finite 266 | apply standard 267 | apply (rule finite_imageD[where f=Rep_unop_vec]) 268 | apply (auto) 269 | by (meson Rep_unop_vec_inject inj_onI) 270 | 271 | 272 | 273 | consts binop_vec_carrier :: "nat set" 274 | specification (binop_vec_carrier) 275 | binop_vec_finite[simp]: "finite binop_vec_carrier" 276 | binop_vec_ne: "binop_vec_carrier \ {}" 277 | by blast 278 | 279 | typedef binop_vec = "binop_vec_carrier" using binop_vec_ne by blast 280 | 281 | lemma range_binop_vec[simp]: "range Rep_binop_vec = binop_vec_carrier" 282 | apply (auto) 283 | apply (simp add: Rep_binop_vec) 284 | by (metis Rep_binop_vec_cases rangeI) 285 | 286 | instance binop_vec :: finite 287 | apply standard 288 | apply (rule finite_imageD[where f=Rep_binop_vec]) 289 | apply (auto) 290 | by (meson Rep_binop_vec_inject inj_onI) 291 | 292 | 293 | consts ternop_vec_carrier :: "nat set" 294 | specification (ternop_vec_carrier) 295 | ternop_vec_finite[simp]: "finite ternop_vec_carrier" 296 | ternop_vec_ne: "ternop_vec_carrier \ {}" 297 | by blast 298 | 299 | typedef ternop_vec = "ternop_vec_carrier" using ternop_vec_ne by blast 300 | 301 | lemma range_ternop_vec[simp]: "range Rep_ternop_vec = ternop_vec_carrier" 302 | apply (auto) 303 | apply (simp add: Rep_ternop_vec) 304 | by (metis Rep_ternop_vec_cases rangeI) 305 | 306 | instance ternop_vec :: finite 307 | apply standard 308 | apply (rule finite_imageD[where f=Rep_ternop_vec]) 309 | apply (auto) 310 | by (meson Rep_ternop_vec_inject inj_onI) 311 | 312 | 313 | 314 | consts testop_vec_carrier :: "nat set" 315 | specification (testop_vec_carrier) 316 | testop_vec_finite[simp]: "finite testop_vec_carrier" 317 | testop_vec_ne: "testop_vec_carrier \ {}" 318 | by blast 319 | 320 | typedef testop_vec = "testop_vec_carrier" using testop_vec_ne by blast 321 | 322 | lemma range_testop_vec[simp]: "range Rep_testop_vec = testop_vec_carrier" 323 | apply (auto) 324 | apply (simp add: Rep_testop_vec) 325 | by (metis Rep_testop_vec_cases rangeI) 326 | 327 | instance testop_vec :: finite 328 | apply standard 329 | apply (rule finite_imageD[where f=Rep_testop_vec]) 330 | apply (auto) 331 | by (meson Rep_testop_vec_inject inj_onI) 332 | 333 | 334 | consts shiftop_vec_carrier :: "nat set" 335 | specification (shiftop_vec_carrier) 336 | shiftop_vec_finite[simp]: "finite shiftop_vec_carrier" 337 | shiftop_vec_ne: "shiftop_vec_carrier \ {}" 338 | by blast 339 | 340 | typedef shiftop_vec = "shiftop_vec_carrier" using shiftop_vec_ne by blast 341 | 342 | lemma range_shiftop_vec[simp]: "range Rep_shiftop_vec = shiftop_vec_carrier" 343 | apply (auto) 344 | apply (simp add: Rep_shiftop_vec) 345 | by (metis Rep_shiftop_vec_cases rangeI) 346 | 347 | instance shiftop_vec :: finite 348 | apply standard 349 | apply (rule finite_imageD[where f=Rep_shiftop_vec]) 350 | apply (auto) 351 | by (meson Rep_shiftop_vec_inject inj_onI) 352 | 353 | 354 | datatype \ \basic instructions\ 355 | b_e = 356 | Unreachable 357 | | Nop 358 | | Drop 359 | | Select 360 | | Block tb "b_e list" 361 | | Loop tb "b_e list" 362 | | If tb "b_e list" "b_e list" 363 | | Br i 364 | | Br_if i 365 | | Br_table "i list" i 366 | | Return 367 | | Call i 368 | | Call_indirect i 369 | | Get_local i 370 | | Set_local i 371 | | Tee_local i 372 | | Get_global i 373 | | Set_global i 374 | | Load t_num "(tp_num \ sx) option" a off 375 | | Store t_num "tp_num option" a off 376 | | Load_vec loadop_vec a off 377 | | Load_lane_vec shape_vec_i i a off 378 | | Store_vec storeop_vec a off 379 | | Current_memory 380 | | Grow_memory 381 | | EConst v ("C _" 60) 382 | | Unop t_num unop 383 | | Binop t_num binop 384 | | Testop t_num testop 385 | | Relop t_num relop 386 | | Cvtop t_num cvtop t_num "(sat \ sx) option" 387 | | Unop_vec unop_vec 388 | | Binop_vec binop_vec 389 | | Ternop_vec ternop_vec 390 | | Test_vec testop_vec 391 | | Shift_vec shiftop_vec 392 | | Splat_vec shape_vec 393 | | Extract_vec shape_vec sx i 394 | | Replace_vec shape_vec i 395 | 396 | abbreviation "C\<^sub>n x \ C (V_num x)" 397 | abbreviation "C\<^sub>v x \ C (V_vec x)" 398 | 399 | record inst = \ \instances\ 400 | types :: "tf list" 401 | funcs :: "i list" 402 | tabs :: "i list" 403 | mems :: "i list" 404 | globs :: "i list" 405 | 406 | datatype cl = \ \function closures\ 407 | Func_native inst tf "t list" "b_e list" 408 | | Func_host tf host 409 | 410 | type_synonym tabinst = "(i option) list \ nat option" 411 | 412 | abbreviation "tab_size (t::tabinst) \ length (fst t)" 413 | abbreviation "tab_max (t::tabinst) \ snd t" 414 | 415 | record global = 416 | g_mut :: mut 417 | g_val :: v 418 | 419 | record s = \ \store\ 420 | funcs :: "cl list" 421 | tabs :: "tabinst list" 422 | mems :: "mem list" 423 | globs :: "global list" 424 | 425 | record f = \ \frame\ 426 | f_locs :: "v list" 427 | f_inst :: inst 428 | 429 | datatype e = \ \administrative instruction\ 430 | Basic b_e ("$_" 60) 431 | | Trap 432 | | Invoke i 433 | | Label nat "e list" "e list" 434 | | Frame nat f "e list" 435 | (* only used by instantiation *) 436 | | Init_mem nat "byte list" 437 | | Init_tab nat "i list" 438 | 439 | datatype Lholed = 440 | \ \L0 = v* [] e*\ 441 | LBase "v list" "e list" 442 | \ \L(i+1) = v* (label n {e* } Li) e*\ 443 | | LRec "v list" nat "e list" Lholed "e list" 444 | 445 | end 446 | -------------------------------------------------------------------------------- /WebAssembly/Wasm_Axioms.thy: -------------------------------------------------------------------------------- 1 | section \Host Properties\ 2 | 3 | theory Wasm_Axioms imports Wasm begin 4 | 5 | lemma old_mem_size_def: 6 | shows "mem_size m = length (Rep_mem_rep (fst m)) div Ki64" 7 | unfolding mem_size_def mem_rep_length_def mem_length_def 8 | by (simp split: prod.splits) 9 | 10 | (* these were originally axioms, but memory now has a concrete representation in the model *) 11 | lemma mem_grow_size: 12 | assumes "mem_grow m n = Some m'" 13 | shows "(mem_size m + n) = mem_size m'" 14 | using assms Abs_mem_rep_inverse 15 | unfolding mem_grow_def old_mem_size_def mem_append_def mem_rep_append_def bytes_replicate_def 16 | by (auto simp add: Ki64_def Let_def split: prod.splits if_splits) 17 | 18 | lemma mem_grow_max1: 19 | assumes "mem_grow m n = Some m'" 20 | shows "mem_max m = mem_max m'" 21 | using assms Abs_mem_rep_inverse 22 | unfolding mem_grow_def mem_max_def mem_append_def 23 | by (auto simp add: Ki64_def Let_def split: prod.splits if_splits) 24 | 25 | lemma mem_grow_max2: 26 | assumes "mem_grow m n = Some m'" 27 | shows "pred_option ((\) (mem_size m')) (mem_max m')" 28 | using assms Abs_mem_rep_inverse 29 | unfolding mem_grow_def mem_max_def mem_append_def 30 | by (auto simp add: assms mem_grow_size Let_def split: prod.splits if_splits) 31 | 32 | lemma mem_grow_length: 33 | assumes "mem_grow m n = Some m'" 34 | shows "(mem_length m + (n * Ki64)) = mem_length m'" 35 | using assms Abs_mem_rep_inverse 36 | bytes_replicate_def mem_rep_append.rep_eq mem_rep_length.rep_eq 37 | unfolding mem_grow_def mem_length_def old_mem_size_def mem_rep_append_def mem_append_def bytes_replicate_def 38 | by (auto simp add: Let_def split: prod.splits if_splits) 39 | 40 | lemma mem_grow_byte_at_m: 41 | assumes "k < mem_length m" 42 | "(mem_grow m n) = Some m'" 43 | shows "byte_at m' k = byte_at m k" 44 | using assms 45 | unfolding mem_rep_byte_at.rep_eq mem_length_def mem_rep_length.rep_eq mem_grow_def 46 | mem_rep_append.rep_eq mem_append_def mem_rep_append_def mem_size_def byte_at_def 47 | by (auto simp add: Abs_mem_rep_inverse nth_append Let_def split: prod.splits if_splits) 48 | 49 | lemma mem_grow_byte_at_m_n: 50 | assumes "k \ mem_length m" 51 | "(mem_grow m n) = Some m'" 52 | "k < mem_length m'" 53 | shows "byte_at m' k = (zero_byte::byte)" 54 | using assms 55 | unfolding mem_rep_byte_at.rep_eq mem_length_def mem_rep_length.rep_eq mem_grow_def 56 | mem_rep_append.rep_eq mem_append_def mem_rep_append_def mem_size_def byte_at_def 57 | by (auto simp add: Abs_mem_rep_inverse nth_append Let_def split: prod.splits if_splits) 58 | 59 | lemma load_size: 60 | "(load m n off l = None) = (mem_length m < (off + n + l))" 61 | unfolding load_def 62 | by (cases "n + off + l \ mem_length m") auto 63 | 64 | lemma load_packed_size: 65 | "(load_packed sx m n off lp l = None) = (mem_length m < (off + n + lp))" 66 | using load_size 67 | unfolding load_packed_def 68 | by (cases "n + off + l \ mem_length m") auto 69 | 70 | lemma store_size1: 71 | "(store m n off v l = None) = (mem_length m < (off + n + l))" 72 | unfolding store_def 73 | by (cases "n + off + l \ mem_length m") auto 74 | 75 | lemma store_size: 76 | assumes "(store m n off v l = Some m')" 77 | shows "mem_size m = mem_size m'" 78 | using assms Abs_mem_rep_inverse mem_rep_length.rep_eq 79 | unfolding store_def mem_rep_write_bytes_def write_bytes_def 80 | bytes_takefill_def 81 | apply (cases "n + off + l \ mem_length m") 82 | apply(auto simp add: old_mem_size_def mem_length_def split: prod.splits) 83 | done 84 | 85 | lemma store_max: 86 | assumes "(store m n off v l = Some m')" 87 | shows "mem_max m = mem_max m'" 88 | using assms Abs_mem_rep_inverse 89 | unfolding store_def mem_max_def write_bytes_def 90 | by (auto split: if_splits prod.splits) 91 | 92 | lemma store_length: 93 | assumes "(store m n off v l = Some m')" 94 | shows "mem_length m = mem_length m'" 95 | using assms Abs_mem_rep_inverse mem_rep_length.rep_eq 96 | unfolding store_def mem_rep_write_bytes_def write_bytes_def 97 | bytes_takefill_def 98 | apply (cases "n + off + l \ mem_length m") 99 | apply(auto simp add: old_mem_size_def mem_length_def split: prod.splits) 100 | done 101 | 102 | lemma store_packed_size1: 103 | "(store_packed m n off v l = None) = (mem_length m < (off + n + l))" 104 | using store_size1 105 | unfolding store_packed_def 106 | by simp 107 | 108 | lemma store_packed_size: 109 | assumes "(store_packed m n off v l = Some m')" 110 | shows "mem_size m = mem_size m'" 111 | using assms store_size 112 | unfolding store_packed_def 113 | by simp 114 | 115 | lemma store_packed_max: 116 | assumes "(store_packed m n off v l = Some m')" 117 | shows "mem_max m = mem_max m'" 118 | using assms store_max 119 | unfolding store_packed_def 120 | by simp 121 | 122 | lemma store_tab_size: 123 | assumes "(store_tab t n icls = Some t')" 124 | shows "tab_size t = tab_size t'" 125 | using assms 126 | unfolding store_tab_def 127 | by (fastforce split: if_splits) 128 | 129 | lemma store_tab_max: 130 | assumes "(store_tab t n icls = Some t')" 131 | shows "tab_max t = tab_max t'" 132 | using assms 133 | unfolding store_tab_def 134 | by (fastforce split: if_splits) 135 | 136 | lemma wasm_deserialise_num_type:"typeof_num (wasm_deserialise_num bs t) = t" 137 | unfolding wasm_deserialise_num_def typeof_num_def 138 | by (simp split: t_num.splits) 139 | 140 | axiomatization where 141 | host_apply_preserve_store1:"host_apply s (t1s _> t2s) f vs hs (Some (s', vs')) \ store_extension s s'" 142 | and host_apply_preserve_store2:"host_apply s (t1s _> t2s) f vs hs (Some (s', vs')) \ store_typing s \ store_typing s'" 143 | and host_apply_respect_type:"list_all2 (\t v. typeof v = t) t1s vs \ host_apply s (t1s _> t2s) f vs hs (Some (s', vs')) \ list_all2 (\t v. typeof v = t) t2s vs'" 144 | 145 | lemma host_apply_preserve_store: 146 | assumes "host_apply s (t1s _> t2s) f vs hs (Some (s', vs'))" 147 | "store_typing s" 148 | shows "store_extension s s' \ store_typing s'" 149 | using assms host_apply_preserve_store1 host_apply_preserve_store2 150 | by blast 151 | 152 | end -------------------------------------------------------------------------------- /WebAssembly/Wasm_Checker.thy: -------------------------------------------------------------------------------- 1 | section \Executable Type Checker\ 2 | 3 | theory Wasm_Checker imports Wasm_Checker_Types begin 4 | 5 | fun convert_cond :: "t_num \ t_num \ (sat \ sx) option \ bool" where 6 | "convert_cond t1 t2 sat_sx = ((t1 \ t2) \ (sat_sx = None) = ((is_float_t_num t1 \ is_float_t_num t2) 7 | \ (is_int_t_num t1 \ is_int_t_num t2 \ (t_num_length t1 < t_num_length t2))))" 8 | 9 | fun same_lab_h :: "nat list \ (t list) list \ t list \ (t list) option" where 10 | "same_lab_h [] _ ts = Some ts" 11 | | "same_lab_h (i#is) lab_c ts = (if i \ length lab_c 12 | then None 13 | else (if lab_c!i = ts 14 | then same_lab_h is lab_c (lab_c!i) 15 | else None))" 16 | 17 | fun same_lab :: "nat list \ (t list) list \ (t list) option" where 18 | "same_lab [] lab_c = None" 19 | | "same_lab (i#is) lab_c = (if i \ length lab_c 20 | then None 21 | else same_lab_h is lab_c (lab_c!i))" 22 | 23 | lemma same_lab_h_conv_list_all: 24 | assumes "same_lab_h ils ls ts' = Some ts" 25 | shows "list_all (\i. i < length ls \ ls!i = ts) ils \ ts' = ts" 26 | using assms 27 | proof(induction ils) 28 | case (Cons a ils) 29 | thus ?case 30 | apply (simp,safe) 31 | apply (metis not_less option.distinct(1))+ 32 | done 33 | qed simp 34 | 35 | lemma same_lab_conv_list_all: 36 | assumes "same_lab ils ls = Some ts" 37 | shows "list_all (\i. i < length ls \ ls!i = ts) ils" 38 | using assms 39 | proof (induction rule: same_lab.induct) 40 | case (2 i "is" lab_c) 41 | thus ?case 42 | using same_lab_h_conv_list_all 43 | by (metis (mono_tags, lifting) list_all_simps(1) not_less option.distinct(1) same_lab.simps(2)) 44 | qed simp 45 | 46 | lemma list_all_conv_same_lab_h: 47 | assumes "list_all (\i. i < length ls \ ls!i = ts) ils" 48 | shows "same_lab_h ils ls ts = Some ts" 49 | using assms 50 | by (induction ils, simp_all) 51 | 52 | lemma list_all_conv_same_lab: 53 | assumes "list_all (\i. i < length ls \ls!i = ts) (is@[i])" 54 | shows "same_lab (is@[i]) ls = Some ts" 55 | using assms 56 | proof (induction "(is@[i])") 57 | case (Cons a x) 58 | thus ?case 59 | using list_all_conv_same_lab_h[OF Cons(3)] 60 | by (metis option.distinct(1) same_lab.simps(2) same_lab_h.simps(2)) 61 | qed auto 62 | 63 | fun b_e_type_checker :: "t_context \ b_e list \ tf \ bool" 64 | and check :: "t_context \ b_e list \ checker_type \ checker_type" 65 | and check_single :: "t_context \ b_e \ checker_type \ checker_type" where 66 | check_top:"b_e_type_checker \ es (tn _> tm) = c_types_agree (check \ es (Type tn)) tm" 67 | | check_iter:"check \ es ts = (case es of 68 | [] \ ts 69 | | (e#es) \ (case ts of 70 | Bot \ Bot 71 | | _ \ check \ es (check_single \ e ts)))" 72 | (* 73 | foldl (\ ts e. (case ts of Bot \ Bot | _ \ check_single \ e ts)) es 74 | 75 | 76 | 77 | primrec foldl :: "('b \ 'a \ 'b) \ 'b \ 'a list \ 'b" where 78 | foldl_Nil: "foldl f a [] = a" | 79 | foldl_Cons: "foldl f a (x # xs) = foldl f (f a x) xs" 80 | *) 81 | (* num ops *) 82 | | check_const:"check_single \ (C v) ts = type_update ts [] (Type [typeof v])" 83 | | check_unop:"check_single \ (Unop t op) ts = (if unop_t_num_agree op t 84 | then type_update ts [TSome (T_num t)] (Type [T_num t]) 85 | else Bot)" 86 | | check_binop:"check_single \ (Binop t op) ts = (if binop_t_num_agree op t 87 | then type_update ts [TSome (T_num t), TSome (T_num t)] (Type [T_num t]) 88 | else Bot)" 89 | | check_testop:"check_single \ (Testop t _) ts = (if is_int_t_num t 90 | then type_update ts [TSome (T_num t)] (Type [T_num T_i32]) 91 | else Bot)" 92 | | check_relop:"check_single \ (Relop t op) ts = (if relop_t_num_agree op t 93 | then type_update ts [TSome (T_num t), TSome (T_num t)] (Type [T_num T_i32]) 94 | else Bot)" 95 | (* vector ops *) 96 | | check_unop_vec:"check_single \ (Unop_vec op) ts = (type_update ts [TSome (T_vec T_v128)] (Type [T_vec T_v128]))" 97 | | check_binop_vec:"check_single \ (Binop_vec op) ts = (if binop_vec_wf op 98 | then type_update ts [TSome (T_vec T_v128), TSome (T_vec T_v128)] (Type [T_vec T_v128]) 99 | else Bot)" 100 | | check_ternop_vec:"check_single \ (Ternop_vec op) ts = (type_update ts [TSome (T_vec T_v128), TSome (T_vec T_v128), TSome (T_vec T_v128)] (Type [T_vec T_v128]))" 101 | | check_test_vec:"check_single \ (Test_vec op) ts = (type_update ts [TSome (T_vec T_v128)] (Type [T_num T_i32]))" 102 | | check_shift_vec:"check_single \ (Shift_vec op) ts = (type_update ts [TSome (T_vec T_v128), TSome (T_num T_i32)] (Type [T_vec T_v128]))" 103 | | check_splat_vec:"check_single \ (Splat_vec sv) ts = (type_update ts [TSome (T_num (vec_lane_t sv))] (Type [T_vec T_v128]))" 104 | | check_extract_vec:"check_single \ (Extract_vec sv sx i) ts = (if i < vec_num sv \ (sx = U \ vec_length sv \ 2) 105 | then type_update ts [TSome (T_vec T_v128)] (Type [T_num (vec_lane_t sv)]) 106 | else Bot)" 107 | | check_replace_vec:"check_single \ (Replace_vec sv i) ts = (if i < vec_num sv 108 | then type_update ts [TSome (T_vec T_v128), TSome (T_num (vec_lane_t sv))] (Type [T_vec T_v128]) 109 | else Bot)" 110 | (* convert *) 111 | | check_convert:"check_single \ (Cvtop t1 Convert t2 sat_sx) ts = (if (convert_cond t1 t2 sat_sx) 112 | then type_update ts [TSome (T_num t2)] (Type [T_num t1]) 113 | else Bot)" 114 | (* reinterpret *) 115 | | check_reinterpret:"check_single \ (Cvtop t1 Reinterpret t2 sx) ts = (if ((t1 \ t2) \ t_num_length t1 = t_num_length t2 \ sx = None) 116 | then type_update ts [TSome (T_num t2)] (Type [T_num t1]) 117 | else Bot)" 118 | (* unreachable, nop, drop, select *) 119 | | check_unreachable:"check_single \ (Unreachable) ts = type_update ts [] (TopType [])" 120 | | check_nop:"check_single \ (Nop) ts = ts" 121 | | check_drop:"check_single \ (Drop) ts = type_update ts [TAny] (Type [])" 122 | | check_select:"check_single \ (Select) ts = type_update_select ts" 123 | (* block *) 124 | | check_block:"check_single \ (Block tb es) ts = (case tb_tf_t \ tb of 125 | Some (tn _> tm) \ 126 | (if (b_e_type_checker (\\label := ([tm] @ (label \))\) es (tn _> tm)) 127 | then type_update ts (to_ct_list tn) (Type tm) 128 | else Bot) 129 | | None \ Bot)" 130 | (* loop *) 131 | | check_loop:"check_single \ (Loop tb es) ts = (case tb_tf_t \ tb of 132 | Some (tn _> tm) \ 133 | (if (b_e_type_checker (\\label := ([tn] @ (label \))\) es (tn _> tm)) 134 | then type_update ts (to_ct_list tn) (Type tm) 135 | else Bot) 136 | | None \ Bot)" 137 | (* if *) 138 | | check_if:"check_single \ (If tb es1 es2) ts = (case tb_tf_t \ tb of 139 | Some (tn _> tm) \ (if (b_e_type_checker (\\label := ([tm] @ (label \))\) es1 (tn _> tm) 140 | \ b_e_type_checker (\\label := ([tm] @ (label \))\) es2 (tn _> tm)) 141 | then type_update ts (to_ct_list (tn@[T_num T_i32])) (Type tm) 142 | else Bot) 143 | | None => Bot)" 144 | (* br *) 145 | | check_br:"check_single \ (Br i) ts = (if i < length (label \) 146 | then type_update ts (to_ct_list ((label \)!i)) (TopType []) 147 | else Bot)" 148 | (* br_if *) 149 | | check_br_if:"check_single \ (Br_if i) ts = (if i < length (label \) 150 | then type_update ts (to_ct_list ((label \)!i @ [T_num T_i32])) (Type ((label \)!i)) 151 | else Bot)" 152 | (* br_table *) 153 | | check_br_table:"check_single \ (Br_table is i) ts = (case (same_lab (is@[i]) (label \)) of 154 | None \ Bot 155 | | Some tls \ type_update ts (to_ct_list (tls @ [T_num T_i32])) (TopType []))" 156 | (* return *) 157 | | check_return:"check_single \ (Return) ts = (case (return \) of 158 | None \ Bot 159 | | Some tls \ type_update ts (to_ct_list tls) (TopType []))" 160 | (* call *) 161 | | check_call:"check_single \ (Call i) ts = (if i < length (func_t \) 162 | then (case ((func_t \)!i) of 163 | (tn _> tm) \ type_update ts (to_ct_list tn) (Type tm)) 164 | else Bot)" 165 | (* call_indirect *) 166 | | check_call_indirect:"check_single \ (Call_indirect i) ts = (if length (table \) \ 1 \ i < length (types_t \) 167 | then (case ((types_t \)!i) of 168 | (tn _> tm) \ type_update ts (to_ct_list (tn@[T_num T_i32])) (Type tm)) 169 | else Bot)" 170 | (* get_local *) 171 | | check_get_local:"check_single \ (Get_local i) ts = (if i < length (local \) 172 | then type_update ts [] (Type [(local \)!i]) 173 | else Bot)" 174 | (* set_local *) 175 | | check_set_local:"check_single \ (Set_local i) ts = (if i < length (local \) 176 | then type_update ts [TSome ((local \)!i)] (Type []) 177 | else Bot)" 178 | (* tee_local *) 179 | | check_tee_local:"check_single \ (Tee_local i) ts = (if i < length (local \) 180 | then type_update ts [TSome ((local \)!i)] (Type [(local \)!i]) 181 | else Bot)" 182 | (* get_global *) 183 | | check_get_global:"check_single \ (Get_global i) ts = (if i < length (global \) 184 | then type_update ts [] (Type [tg_t ((global \)!i)]) 185 | else Bot)" 186 | (* set_global *) 187 | | check_set_global:"check_single \ (Set_global i) ts = (if i < length (global \) \ is_mut (global \ ! i) 188 | then type_update ts [TSome (tg_t ((global \)!i))] (Type []) 189 | else Bot)" 190 | (* load *) 191 | | check_load:"check_single \ (Load t tp_sx a off) ts = (if length (memory \) \ 1 \ load_store_t_bounds a (option_projl tp_sx) t 192 | then type_update ts [TSome (T_num T_i32)] (Type [T_num t]) 193 | else Bot)" 194 | (* store *) 195 | | check_store:"check_single \ (Store t tp a off) ts = (if length (memory \) \ 1 \ load_store_t_bounds a tp t 196 | then type_update ts [TSome (T_num T_i32),TSome (T_num t)] (Type []) 197 | else Bot)" 198 | (* load_vec *) 199 | | check_load_vec:"check_single \ (Load_vec lv a off) ts = (if length (memory \) \ 1 \ load_vec_t_bounds lv a 200 | then type_update ts [TSome (T_num T_i32)] (Type [T_vec T_v128]) 201 | else Bot)" 202 | (* load_lane_vec *) 203 | | check_load_lane_vec:"check_single \ (Load_lane_vec svi i a off) ts = (if length (memory \) \ 1 \ (i < vec_i_num svi \ 2^a \ (vec_i_length svi)) 204 | then type_update ts [TSome (T_num T_i32), TSome (T_vec T_v128)] (Type [T_vec T_v128]) 205 | else Bot)" 206 | (* store_vec *) 207 | | check_store_vec:"check_single \ (Store_vec sv a off) ts = (if length (memory \) \ 1 \ store_vec_t_bounds sv a 208 | then type_update ts [TSome (T_num T_i32),TSome (T_vec T_v128)] (Type []) 209 | else Bot)" 210 | (* current_memory *) 211 | | check_current_memory:"check_single \ Current_memory ts = (if length (memory \) \ 1 212 | then type_update ts [] (Type [T_num T_i32]) 213 | else Bot)" 214 | (* grow_memory *) 215 | | check_grow_memory:"check_single \ Grow_memory ts = (if length (memory \) \ 1 216 | then type_update ts [TSome (T_num T_i32)] (Type [T_num T_i32]) 217 | else Bot)" 218 | 219 | end 220 | -------------------------------------------------------------------------------- /WebAssembly/Wasm_Checker_Printing.thy: -------------------------------------------------------------------------------- 1 | theory Wasm_Checker_Printing imports Wasm_Checker begin 2 | 3 | definition "typing = b_e_type_checker" 4 | 5 | end -------------------------------------------------------------------------------- /WebAssembly/Wasm_Countable.thy: -------------------------------------------------------------------------------- 1 | theory Wasm_Countable imports Wasm_Base_Defs "HOL-Library.Countable" begin 2 | 3 | instance t_num :: countable 4 | by countable_datatype 5 | 6 | instance t_vec :: countable 7 | by countable_datatype 8 | 9 | instance t :: countable 10 | by countable_datatype 11 | 12 | instance tf :: countable 13 | by countable_datatype 14 | 15 | instance tb :: countable 16 | by countable_datatype 17 | 18 | instance inst_ext :: (countable) countable 19 | proof(rule countable_classI[of "\i. to_nat (types i, inst.funcs i, inst.tabs i, inst.mems i, inst.globs i, inst.more i)"]) 20 | qed auto 21 | 22 | instance tp_num :: countable 23 | by countable_datatype 24 | 25 | instance tp_vec :: countable 26 | by countable_datatype 27 | 28 | instance sx :: countable 29 | by countable_datatype 30 | 31 | instance sat :: countable 32 | by countable_datatype 33 | 34 | instance i32 :: countable 35 | proof(rule countable_classI[of "\n::i32. nat_of_int n"]) 36 | qed (simp add: Rep_i32_inject nat_of_int_i32.rep_eq) 37 | 38 | instance i64 :: countable 39 | proof(rule countable_classI[of "\n::i64. nat_of_int n"]) 40 | qed (simp add: Rep_i64_inject nat_of_int_i64.rep_eq) 41 | 42 | instance f32 :: countable 43 | proof(rule countable_classI[of "unat o Rep_f32"]) 44 | qed (simp add: Rep_f32_inject) 45 | 46 | instance f64 :: countable 47 | proof(rule countable_classI[of "unat o Rep_f64"]) 48 | qed (simp add: Rep_f64_inject) 49 | 50 | instance v128 :: countable 51 | proof(rule countable_classI[of "unat o Rep_v128"]) 52 | qed (simp add: Rep_v128_inject) 53 | 54 | instance v_num :: countable 55 | by countable_datatype 56 | 57 | instance v_vec :: countable 58 | by countable_datatype 59 | 60 | instance v :: countable 61 | by countable_datatype 62 | 63 | instance unop_i :: countable 64 | by countable_datatype 65 | 66 | instance unop_f :: countable 67 | by countable_datatype 68 | 69 | instance unop :: countable 70 | by countable_datatype 71 | 72 | instance binop_i :: countable 73 | by countable_datatype 74 | 75 | instance binop_f :: countable 76 | by countable_datatype 77 | 78 | instance binop :: countable 79 | by countable_datatype 80 | 81 | instance testop :: countable 82 | by countable_datatype 83 | 84 | instance relop_i :: countable 85 | by countable_datatype 86 | 87 | instance relop_f :: countable 88 | by countable_datatype 89 | 90 | instance relop :: countable 91 | by countable_datatype 92 | 93 | instance cvtop :: countable 94 | by countable_datatype 95 | 96 | instance shape_vec_i :: countable 97 | by countable_datatype 98 | 99 | instance shape_vec_f :: countable 100 | by countable_datatype 101 | 102 | instance shape_vec :: countable 103 | by countable_datatype 104 | 105 | instance unop_vec :: countable .. 106 | 107 | instance binop_vec :: countable .. 108 | 109 | instance ternop_vec :: countable .. 110 | 111 | instance testop_vec :: countable .. 112 | 113 | instance shiftop_vec :: countable .. 114 | 115 | instance loadop_vec :: countable 116 | by countable_datatype 117 | 118 | instance storeop_vec :: countable 119 | by countable_datatype 120 | 121 | instance b_e :: countable 122 | by countable_datatype 123 | 124 | axiomatization where 125 | host_countable: "OFCLASS(host, countable_class)" 126 | 127 | instance host :: countable 128 | by (rule host_countable) 129 | 130 | instance cl :: countable 131 | by countable_datatype 132 | 133 | instance uint8 :: countable 134 | proof(rule countable_classI[of "\n::byte. nat_of_byte n"]) 135 | qed (simp add: Rep_uint8_inject nat_of_byte_def nat_of_uint8.rep_eq) 136 | 137 | instance mem_rep :: countable 138 | proof(rule countable_classI[of "\m::mem_rep. to_nat (Rep_mem_rep m)"]) 139 | qed (simp add: Rep_mem_rep_inject) 140 | 141 | instance mut :: countable 142 | by countable_datatype 143 | 144 | instance global_ext :: (countable) countable 145 | proof(rule countable_classI[of "\g. to_nat (g_mut g, g_val g, global.more g)"]) 146 | qed simp 147 | 148 | instance s_ext :: (countable) countable 149 | proof (rule countable_classI[of "\s. to_nat (funcs s, tabs s, mems s, globs s, s.more s)"]) 150 | qed simp 151 | 152 | instance limit_t_ext :: (countable) countable 153 | proof (rule countable_classI[of "\i. to_nat (l_min i, l_max i, limit_t.more i)"]) 154 | qed simp 155 | 156 | instance tg_ext :: (countable) countable 157 | proof (rule countable_classI[of "\i. to_nat (tg_mut i, tg_t i, tg.more i)"]) 158 | qed simp 159 | 160 | end -------------------------------------------------------------------------------- /WebAssembly/Wasm_Instantiation_Printing.thy: -------------------------------------------------------------------------------- 1 | theory Wasm_Instantiation_Printing imports Wasm_Instantiation begin 2 | 3 | code_pred (modes: i \ i \ i \ bool as external_checker) external_typing. 4 | 5 | end -------------------------------------------------------------------------------- /WebAssembly/Wasm_Instantiation_Properties.thy: -------------------------------------------------------------------------------- 1 | theory Wasm_Instantiation_Properties 2 | imports Wasm_Instantiation Wasm_Properties Wasm_Instantiation_Properties_Aux 3 | begin 4 | 5 | lemma ex_list_all2: 6 | assumes "\x \ set xs. \y. P x y" 7 | shows "\ys. list_all2 P xs ys" 8 | proof - 9 | have "list_all2 P xs (map (\x. SOME y. P x y) xs)" 10 | unfolding list.rel_map(2) using assms 11 | by (simp add: list.rel_refl_strong someI_ex) 12 | then show ?thesis by (rule exI) 13 | qed 14 | 15 | lemma list_all2_in_set: 16 | assumes "x\set xs" "list_all2 f xs ys" 17 | shows "\y. f x y \ y\set ys" 18 | using list_all2_iff[of f xs ys] assms 19 | by simp (metis case_prodD in_set_impl_in_set_zip1 set_zip_rightD) 20 | 21 | lemma list_all2_forget: 22 | assumes "list_all2 P xs ys" 23 | shows "list_all (\x. \y. P x y) xs" 24 | using assms 25 | by (metis Ball_set list_all2_in_set) 26 | 27 | lemma limits_compat_refl:"limits_compat l l" 28 | unfolding limits_compat_def by(simp add: pred_option_def) 29 | 30 | lemma tab_typing_exists:"\tt. tab_typing t tt" 31 | using limits_compat_refl tab_typing_def 32 | by (metis limit_t.select_convs(1,2) limits_compat_def) 33 | 34 | lemma mem_typing_exists:"\mt. mem_typing m mt" 35 | using limits_compat_refl mem_typing_def 36 | by (metis limit_t.select_convs(1,2) limits_compat_def) 37 | 38 | lemma glob_typing_exists:"\gt. glob_typing g gt" 39 | unfolding glob_typing_def typeof_def 40 | by (metis tg.select_convs(1,2)) 41 | 42 | lemma instantiation_external_typing: 43 | assumes "alloc_module s m v_imps g_inits (s1, inst, v_exps)" 44 | "inst_typing s' inst \" 45 | "list_all2 (\exp. module_export_typing \ (E_desc exp)) (m_exports m) t_exps" 46 | shows "\tes. list_all2 (\v_exp te. external_typing s' (E_desc v_exp) te) v_exps tes" 47 | proof - 48 | have 1:"map E_desc v_exps = map (\m_exp. export_get_v_ext inst (E_desc m_exp)) (m_exports m)" 49 | using assms(1) unfolding alloc_module.simps by auto 50 | { 51 | have funci_agree_s':"list_all2 (funci_agree (funcs s')) (inst.funcs inst) (func_t \)" 52 | using assms(2) inst_typing.simps by auto 53 | 54 | fix i 55 | assume "Ext_func i \ set (map E_desc v_exps)" 56 | then obtain j where "Ext_func j \ set (map E_desc (m_exports m))" 57 | "i = inst.funcs inst ! j" 58 | unfolding 1 export_get_v_ext_def 59 | by(simp add: image_iff split:v_ext.splits, metis v_ext.exhaust) 60 | then have "j < length (inst.funcs inst)" 61 | using list_all2_forget[OF assms(3)] funci_agree_s' 62 | unfolding list_all2_conv_all_nth module_export_typing.simps list_all_iff by fastforce 63 | moreover have "list_all (\x. x < length (funcs s')) (inst.funcs inst)" 64 | using funci_agree_s' unfolding funci_agree_def 65 | by (simp add: list_all2_conv_all_nth list_all_length) 66 | ultimately have "i < length (funcs s')" using \i = inst.funcs inst ! j\ 67 | unfolding list_all_length by auto 68 | then have "\ tf. external_typing s' (Ext_func i) tf" 69 | unfolding external_typing.simps by auto 70 | } 71 | moreover { 72 | have tabi_agree_s':"list_all2 (tabi_agree (tabs s')) (inst.tabs inst) (table \)" 73 | using assms(2) inst_typing.simps by auto 74 | 75 | fix i 76 | assume "Ext_tab i \ set (map E_desc v_exps)" 77 | then obtain j where "Ext_tab j \ set (map E_desc (m_exports m))" 78 | "i = inst.tabs inst ! j" 79 | unfolding 1 export_get_v_ext_def 80 | by(simp add: image_iff split:v_ext.splits, metis v_ext.exhaust) 81 | then have "j < length (inst.tabs inst)" 82 | using list_all2_forget[OF assms(3)] tabi_agree_s' 83 | unfolding list_all2_conv_all_nth module_export_typing.simps list_all_iff by fastforce 84 | moreover have "list_all (\x. x < length (tabs s')) (inst.tabs inst)" 85 | using tabi_agree_s' unfolding tabi_agree_def 86 | by (simp add: list_all2_conv_all_nth list_all_length) 87 | ultimately have "i < length (tabs s')" using \i = inst.tabs inst ! j\ 88 | unfolding list_all_length by auto 89 | then have "\ tt. external_typing s' (Ext_tab i) tt" 90 | unfolding external_typing.simps by (simp add: tab_typing_exists) 91 | } 92 | moreover { 93 | have memi_agree_s':"list_all2 (memi_agree (mems s')) (inst.mems inst) (memory \)" 94 | using assms(2) inst_typing.simps by auto 95 | 96 | fix i 97 | assume "Ext_mem i \ set (map E_desc v_exps)" 98 | then obtain j where "Ext_mem j \ set (map E_desc (m_exports m))" 99 | "i = inst.mems inst ! j" 100 | unfolding 1 export_get_v_ext_def 101 | by(simp add: image_iff split:v_ext.splits, metis v_ext.exhaust) 102 | then have "j < length (inst.mems inst)" 103 | using list_all2_forget[OF assms(3)] memi_agree_s' 104 | unfolding list_all2_conv_all_nth module_export_typing.simps list_all_iff by fastforce 105 | moreover have "list_all (\x. x < length (mems s')) (inst.mems inst)" 106 | using memi_agree_s' unfolding memi_agree_def 107 | by (simp add: list_all2_conv_all_nth list_all_length) 108 | ultimately have "i < length (mems s')" using \i = inst.mems inst ! j\ 109 | unfolding list_all_length by auto 110 | then have "\ tm. external_typing s' (Ext_mem i) tm" 111 | unfolding external_typing.simps by (simp add: mem_typing_exists) 112 | } 113 | moreover { 114 | have globi_agree_s':"list_all2 (globi_agree (globs s')) (inst.globs inst) (global \)" 115 | using assms(2) inst_typing.simps by auto 116 | 117 | fix i 118 | assume "Ext_glob i \ set (map E_desc v_exps)" 119 | then obtain j where "Ext_glob j \ set (map E_desc (m_exports m))" 120 | "i = inst.globs inst ! j" 121 | unfolding 1 export_get_v_ext_def 122 | by(simp add: image_iff split:v_ext.splits, metis v_ext.exhaust) 123 | then have "j < length (inst.globs inst)" 124 | using list_all2_forget[OF assms(3)] globi_agree_s' 125 | unfolding list_all2_conv_all_nth module_export_typing.simps list_all_iff by fastforce 126 | moreover have "list_all (\x. x < length (globs s')) (inst.globs inst)" 127 | using globi_agree_s' unfolding globi_agree_def 128 | by (simp add: list_all2_conv_all_nth list_all_length) 129 | ultimately have "i < length (globs s')" using \i = inst.globs inst ! j\ 130 | unfolding list_all_length by auto 131 | then have "\ tg. external_typing s' (Ext_glob i) tg" 132 | unfolding external_typing.simps by(simp add: glob_typing_exists) 133 | } 134 | ultimately have "\ext. ext \ set (map E_desc v_exps) \ \ te. external_typing s' ext te" 135 | using v_ext.exhaust by metis 136 | then show ?thesis by (simp add: ex_list_all2) 137 | qed 138 | 139 | theorem instantiation_sound: 140 | assumes "store_typing s" 141 | "(instantiate s m v_imps ((s', inst, v_exps), init_es))" 142 | shows "store_typing s'" 143 | "\\. (inst_typing s' inst \ \ (s'\\ \ init_es : ([] _> [])))" 144 | "\tes. list_all2 (\v_exp te. external_typing s' (E_desc v_exp) te) v_exps tes" 145 | "store_extension s s'" 146 | proof - 147 | obtain t_imps t_exps g_inits f e_offs d_offs start e_init_tabs e_init_mems where 148 | "module_typing m t_imps t_exps" 149 | and s_ext_typing:"list_all2 (external_typing s) v_imps t_imps" 150 | and s_alloc_module:"alloc_module s m v_imps g_inits (s', inst, v_exps)" 151 | and f_def:"f = \ f_locs = [], f_inst = inst \" 152 | and g_inits_def: 153 | "list_all2 (\g v. reduce_trans (s',f,$*(g_init g)) (s',f,[$C v])) (m_globs m) g_inits" 154 | and "list_all2 (\e c. reduce_trans (s',f,$*(e_off e)) (s',f,[$C\<^sub>n (ConstInt32 c)])) (m_elem m) e_offs" 155 | "list_all2 (\d c. reduce_trans (s',f,$*(d_off d)) (s',f,[$C\<^sub>n (ConstInt32 c)])) (m_data m) d_offs" 156 | and s_element_in_bounds: 157 | "list_all2 (\e_off e. ((nat_of_int e_off) + (length (e_init e))) \ length (fst ((tabs s')!((inst.tabs inst)!(e_tab e))))) e_offs (m_elem m)" 158 | and s_data_in_bounds: 159 | "list_all2 (\d_off d. ((nat_of_int d_off) + (length (d_init d))) \ mem_length ((mems s')!((inst.mems inst)!(d_data d)))) d_offs (m_data m)" 160 | and s_start:"(case (m_start m) of None \ [] | Some i_s \ [Invoke ((inst.funcs inst)!i_s)]) = start" 161 | and s_init_tabs:"List.map2 (\n e. Init_tab n (map (\i. (inst.funcs inst)!i) (e_init e))) (map nat_of_int e_offs) (m_elem m) = e_init_tabs" 162 | and s_init_mems:"List.map2 (\n d. Init_mem n (d_init d)) (map nat_of_int d_offs) (m_data m) = e_init_mems" 163 | and init_es_is:"init_es = e_init_tabs@e_init_mems@start" 164 | using assms(2) instantiate.simps by auto 165 | 166 | show "store_extension s s'" 167 | using alloc_module_preserve_store_extension s_alloc_module 168 | by auto 169 | 170 | obtain \ \' fts gts 171 | where c_is:"list_all2 (module_func_typing \) (m_funcs m) fts" 172 | "list_all (module_tab_typing) (m_tabs m)" 173 | "list_all (module_elem_typing \) (m_elem m)" 174 | "list_all (module_data_typing \) (m_data m)" 175 | "list_all2 (\exp. module_export_typing \ (E_desc exp)) (m_exports m) t_exps" 176 | "pred_option (module_start_typing \) (m_start m)" 177 | "\ = \types_t=(m_types m), 178 | func_t=ext_t_funcs t_imps @ fts, 179 | global=ext_t_globs t_imps @ gts, 180 | table=ext_t_tabs t_imps @ (m_tabs m), 181 | memory=ext_t_mems t_imps @ (m_mems m), 182 | local=[], label=[], return=None\" 183 | "list_all2 (module_glob_typing \') (m_globs m) gts" 184 | "\' = \types_t=[], func_t=[], global=ext_t_globs t_imps, table=[], memory=[], 185 | local=[], label=[], return=None\" 186 | "list_all (module_mem_typing) (m_mems m)" 187 | using \module_typing m t_imps t_exps\ module_typing.simps 188 | by auto 189 | 190 | obtain fs ts ms gs where s'_is: 191 | "funcs s' = funcs s @ fs" 192 | "tabs s' = tabs s @ ts" 193 | "mems s' = mems s @ ms" 194 | "globs s' = globs s @ gs" 195 | using alloc_module_ext_arb[OF s_alloc_module] 196 | by metis 197 | 198 | have ts_alloc:"ts = alloc_tabs_simple (m_tabs m)" 199 | using alloc_module_tabs_form[OF s_alloc_module s'_is(2)] by simp 200 | have ms_alloc:"ms = alloc_mems_simple (m_mems m)" 201 | using alloc_module_mems_form[OF s_alloc_module s'_is(3)] by simp 202 | 203 | have tabi_agree_s1:"list_all2 (tabi_agree (tabs s')) (inst.tabs inst) (table \)" 204 | proof - 205 | define allocd_tabs where "allocd_tabs = snd (alloc_tabs s (m_tabs m))" 206 | then have "inst.tabs inst = (ext_tabs v_imps)@allocd_tabs" 207 | using alloc_module_allocated_form(2)[OF s_alloc_module] 208 | by (metis prod.collapse) 209 | moreover have "list_all2 (tabi_agree (tabs s')) (ext_tabs v_imps) (ext_t_tabs t_imps)" 210 | proof - 211 | have "list_all2 (tabi_agree (tabs s)) (ext_tabs v_imps) (ext_t_tabs t_imps)" 212 | using ext_typing_imp_tabi_agree[OF s_ext_typing] by - 213 | then show ?thesis 214 | unfolding tabi_agree_def s'_is(2) 215 | by (simp add: list_all2_mono nth_append) 216 | qed 217 | moreover have "list_all2 (tabi_agree (tabs s')) allocd_tabs (m_tabs m)" 218 | proof - 219 | have "length ts = length (m_tabs m)" using ts_alloc by auto 220 | then have allocd_interval:"allocd_tabs = [length (tabs s) ..< (length (tabs s) + length ts)]" 221 | using allocd_tabs_def alloc_tabs_range surjective_pairing by metis 222 | 223 | have "list_all2 tab_typing ts (m_tabs m)" 224 | unfolding ts_alloc alloc_tab_simple_def tab_typing_def list.rel_map(1) limits_compat_def 225 | by(simp add:list_all2_refl pred_option_def) 226 | 227 | then have "list_all2 (tabi_agree (tabs s@ts)) allocd_tabs (m_tabs m)" 228 | unfolding tabi_agree_def allocd_interval 229 | by (simp add: list_all2_conv_all_nth) 230 | then show ?thesis using s'_is(2) by auto 231 | qed 232 | ultimately show ?thesis 233 | using c_is by (simp add: list_all2_appendI) 234 | qed 235 | 236 | 237 | have memi_agree_s1:"list_all2 (memi_agree (mems s')) (inst.mems inst) (memory \)" 238 | proof - 239 | define allocd_mems where "allocd_mems = snd (alloc_mems s (m_mems m))" 240 | then have "inst.mems inst = (ext_mems v_imps)@allocd_mems" 241 | using alloc_module_allocated_form(3)[OF s_alloc_module] 242 | by (metis prod.collapse) 243 | moreover have "list_all2 (memi_agree (mems s')) (ext_mems v_imps) (ext_t_mems t_imps)" 244 | proof - 245 | have "list_all2 (memi_agree (mems s)) (ext_mems v_imps) (ext_t_mems t_imps)" 246 | using ext_typing_imp_memi_agree[OF s_ext_typing] by - 247 | then show ?thesis 248 | unfolding memi_agree_def s'_is(3) 249 | by (simp add: list_all2_mono nth_append) 250 | qed 251 | moreover have "list_all2 (memi_agree (mems s')) allocd_mems (m_mems m)" 252 | proof - 253 | have "length ms = length (m_mems m)" using ms_alloc by auto 254 | then have allocd_interval:"allocd_mems = [length (mems s) ..< (length (mems s) + length ms)]" 255 | using allocd_mems_def alloc_mems_range surjective_pairing by metis 256 | 257 | have "list_all2 mem_typing ms (m_mems m)" 258 | unfolding ms_alloc alloc_mem_simple_def mem_typing_def list.rel_map(1) limits_compat_def 259 | mem_mk_def mem_rep_mk_def mem_size_def mem_length_def mem_rep_length_def bytes_replicate_def 260 | mem_max_def 261 | by(rule list_all2_refl, simp add: pred_option_def mem_rep.Abs_mem_rep_inverse Ki64_def) 262 | 263 | then have "list_all2 (memi_agree (mems s@ms)) allocd_mems (m_mems m)" 264 | unfolding memi_agree_def allocd_interval 265 | by (simp add: list_all2_conv_all_nth) 266 | then show ?thesis using s'_is(3) by auto 267 | qed 268 | ultimately show ?thesis 269 | using c_is by(simp add: list_all2_appendI) 270 | qed 271 | 272 | have "types inst = types_t \" 273 | proof - 274 | have "types inst = m_types m" using s_alloc_module unfolding alloc_module.simps 275 | by(auto) 276 | also have "... = types_t \" using c_is by auto 277 | finally show ?thesis by - 278 | qed 279 | moreover have funci_agree_s':"list_all2 (funci_agree (funcs s')) (inst.funcs inst) (func_t \)" 280 | proof - 281 | define allocd_funcs where "allocd_funcs = snd (alloc_funcs s (m_funcs m) inst)" 282 | then have "inst.funcs inst = (ext_funcs v_imps)@allocd_funcs" 283 | using s_alloc_module unfolding alloc_module.simps by auto 284 | moreover have "list_all2 (funci_agree (funcs s')) (ext_funcs v_imps) (ext_t_funcs t_imps)" 285 | proof - 286 | have "list_all2 (funci_agree (funcs s)) (ext_funcs v_imps) (ext_t_funcs t_imps)" 287 | using ext_typing_imp_funci_agree[OF s_ext_typing] by - 288 | 289 | then show ?thesis unfolding funci_agree_def \funcs s' =funcs s @ fs\ 290 | by (simp add: list_all2_mono nth_append) 291 | qed 292 | moreover have "list_all2 (funci_agree (funcs s')) allocd_funcs fts" 293 | proof - 294 | have fs_alloc:"fs = alloc_funcs_simple (m_funcs m) inst" 295 | using alloc_module_funcs_form[OF s_alloc_module s'_is(1)] by - 296 | then have "length fs = length (m_funcs m)" by auto 297 | then have allocd_interval:"allocd_funcs = [length (funcs s) ..< (length (funcs s) + length fs)]" 298 | using allocd_funcs_def alloc_funcs_range surjective_pairing by metis 299 | 300 | have "list_all2 (\f i. cl_type f = (types inst)!(fst i)) fs (m_funcs m)" 301 | unfolding cl_type_def alloc_func_simple_def fs_alloc list.rel_map(1) 302 | by(simp add: list_all2_refl split:prod.splits) 303 | 304 | moreover 305 | have "(\x y. 306 | module_func_typing \ x y \ 307 | fst x < length (types_t \) \ types_t \ ! fst x = y)" 308 | unfolding module_func_typing.simps 309 | by fastforce 310 | hence "list_all2 (\f ft. (fst f) < length (types_t \)\ (types_t \)!(fst f) = ft) 311 | (m_funcs m) fts" 312 | using list_all2_mono[OF c_is(1)] 313 | by simp 314 | 315 | ultimately have "list_all2 (\f ft. cl_type f = ft) fs fts" using \types inst = types_t \\ 316 | list_all2_trans[where as=fs and bs="(m_funcs m)" and cs=fts] 317 | by (metis (mono_tags, lifting)) 318 | 319 | then have "list_all2 (funci_agree (funcs s@fs)) allocd_funcs fts" 320 | unfolding funci_agree_def allocd_interval 321 | by (simp add: list_all2_conv_all_nth) 322 | then show ?thesis using \funcs s' = funcs s @ fs\ by auto 323 | qed 324 | ultimately show ?thesis using c_is by (simp add: list_all2_appendI) 325 | qed 326 | 327 | 328 | moreover have tabi_agree_s':"list_all2 (tabi_agree (tabs s')) (inst.tabs inst) (table \)" 329 | using tabi_agree_store_extension 330 | list_all2_mono[OF tabi_agree_s1] 331 | by blast 332 | moreover have memi_agree_s':"list_all2 (memi_agree (mems s')) (inst.mems inst) (memory \)" 333 | using memi_agree_store_extension 334 | list_all2_mono[OF memi_agree_s1] 335 | by blast 336 | 337 | 338 | moreover have globi_agree_s':"list_all2 (globi_agree (globs s')) (inst.globs inst) (global \)" 339 | proof - 340 | define allocd_globs where "allocd_globs = snd (alloc_globs s (m_globs m) g_inits)" 341 | then have "inst.globs inst = (ext_globs v_imps)@allocd_globs" 342 | using alloc_module_allocated_form(4)[OF s_alloc_module] 343 | by (metis prod.collapse) 344 | moreover have "list_all2 (globi_agree (globs s')) (ext_globs v_imps) (ext_t_globs t_imps)" 345 | proof - 346 | have "list_all2 (globi_agree (globs s)) (ext_globs v_imps) (ext_t_globs t_imps)" 347 | using ext_typing_imp_globi_agree[OF s_ext_typing] by - 348 | 349 | then show ?thesis unfolding globi_agree_def \globs s' = globs s @ gs\ 350 | by (simp add: list_all2_mono nth_append) 351 | qed 352 | moreover have "list_all2 (globi_agree (globs s')) allocd_globs gts" 353 | proof - 354 | have zip_agree:"length (m_globs m) = length g_inits" 355 | using g_inits_def unfolding list_all2_conv_all_nth by simp 356 | have gs_alloc:"gs = alloc_globs_simple (m_globs m) g_inits" 357 | using alloc_module_globs_form[OF s_alloc_module s'_is(4)] 358 | by simp 359 | then have "length gs = length (m_globs m)" using \length (m_globs m) = length g_inits\ 360 | by auto 361 | then have allocd_interval:"allocd_globs = [length (globs s) ..< (length (globs s) + length gs)]" 362 | using allocd_globs_def alloc_globs_range surjective_pairing \length (m_globs m) = length g_inits\ 363 | by (metis min.idem) 364 | 365 | have "list_all2 (\g gt. gt = g_type g) (m_globs m) gts" 366 | unfolding module_glob_typing.simps 367 | by (metis (mono_tags, lifting) c_is(8) list_all2_mono module_glob_typing_equiv_module_glob_type_checker) 368 | then have "gts = map g_type (m_globs m)" 369 | unfolding list_all2_conv_all_nth 370 | by (metis map_intro_length) 371 | 372 | have "map tg_t gts = map typeof g_inits" (*from typing preservation*) 373 | proof - 374 | { 375 | fix g v 376 | assume assm:"(g, v) \ set (zip (m_globs m) g_inits)" 377 | 378 | have 1:"const_exprs \' (g_init g)" using c_is(8) zip_agree assm 379 | unfolding module_glob_typing.simps list_all2_conv_all_nth 380 | by (metis in_set_conv_nth module_glob.select_convs(2) set_zip_leftD) 381 | have 2:"\' \ g_init g : ([] _> [tg_t (g_type g)])" using c_is(8) zip_agree assm 382 | unfolding module_glob_typing.simps list_all2_conv_all_nth 383 | by (metis in_set_conv_nth module_glob.select_convs(1,2) set_zip_leftD) 384 | have 3:"reduce_trans (s',f,$*(g_init g)) (s',f,[$C v])" 385 | using g_inits_def assm zip_agree unfolding list_all2_conv_all_nth in_set_conv_nth 386 | by fastforce 387 | have 4:"global \' = ext_t_globs t_imps" unfolding c_is(9) by simp 388 | 389 | have "tg_t (g_type g) = typeof v" 390 | using const_exprs_reduce_trans[OF 1 2 3 4 391 | list_all2_external_typing_glob_alloc[OF s_ext_typing] s'_is(4)] 392 | \inst.globs inst = (ext_globs v_imps)@allocd_globs\ f_def by force 393 | } 394 | then have "list_all2 (\g g_init. tg_t (g_type g) = typeof g_init) (m_globs m) g_inits" 395 | using \length (m_globs m) = length g_inits\ unfolding list_all2_conv_all_nth 396 | (*todo: I have no idea why gs gets involved but whatever*) 397 | by (metis \length gs = length (m_globs m)\ gs_alloc length_map nth_mem nth_zip) 398 | 399 | then show ?thesis unfolding \gts = map g_type (m_globs m)\ list_all2_conv_all_nth 400 | by (simp add: map_intro_length) 401 | qed 402 | 403 | moreover have "map g_val gs = g_inits" 404 | unfolding gs_alloc alloc_glob_simple_def using \length (m_globs m) = length g_inits\ 405 | by(simp add:comp_def prod.case_eq_if) 406 | 407 | ultimately have "list_all2 (\g gt. typeof (g_val g) = tg_t gt) gs gts" 408 | using length_map nth_map unfolding list_all2_conv_all_nth 409 | by metis 410 | 411 | moreover have "list_all2 (\g gt. g_mut g = tg_mut gt) gs gts" 412 | unfolding \gts = map g_type (m_globs m)\ list_all2_map2 413 | gs_alloc list_all2_map1 alloc_glob_simple_def list_all2_conv_all_nth 414 | using \length (m_globs m) = length g_inits\ 415 | by(simp add:prod.case_eq_if) 416 | 417 | ultimately have "list_all2 glob_typing gs gts" unfolding glob_typing_def 418 | by (simp add: list_all2_conv_all_nth) 419 | then have "list_all2 (globi_agree (globs s@gs)) allocd_globs gts" 420 | unfolding globi_agree_def allocd_interval 421 | by (simp add: list_all2_conv_all_nth) 422 | then show ?thesis using \globs s' = globs s @ gs\ by auto 423 | qed 424 | ultimately show ?thesis using c_is by (simp add: list_all2_appendI) 425 | qed 426 | moreover have "local \ = [] \ label \ = [] \ return \ = None" using c_is by auto 427 | ultimately have s'_inst_t:"inst_typing s' inst \" using inst_typing.simps 428 | by (metis (full_types) inst.surjective old.unit.exhaust t_context.surjective) 429 | 430 | 431 | have "length (inst.mems inst) = length (memory \)" using memi_agree_s1 432 | unfolding list_all2_conv_all_nth by simp 433 | 434 | 435 | show "store_typing s'" 436 | proof - 437 | have 1:"list_all (\cl. \tf. cl_typing s' cl tf) (funcs s')" 438 | proof - 439 | have "list_all (\cl. \tf. cl_typing s cl tf) (funcs s)" 440 | using store_typing_imp_cl_typing[OF assms(1)] unfolding list_all_length by blast 441 | then have "list_all (\cl. \tf. cl_typing s' cl tf) (funcs s)" 442 | using cl_typing_store_extension_inv[OF \store_extension s s'\] 443 | unfolding list_all_length by blast 444 | 445 | moreover have "list_all (\cl. \tf. cl_typing s' cl tf) fs" 446 | proof - 447 | { 448 | fix f 449 | assume "f\set fs" 450 | then obtain i_t loc_ts b_es where 1: 451 | "f = Func_native inst ((types inst)!i_t) loc_ts b_es" 452 | "(i_t, loc_ts, b_es) \ set (m_funcs m)" 453 | unfolding alloc_module_funcs_form[OF s_alloc_module s'_is(1)] 454 | alloc_func_simple_def by fastforce 455 | obtain tn tm where 2: 456 | "i_t < length (types_t \)" 457 | "(types_t \)!i_t = (tn _> tm)" 458 | "\\local := tn @ loc_ts, label := ([tm] @ (label \)), return := Some tm\ \ b_es : ([] _> tm)" 459 | using list_all2_in_set[OF 1(2) c_is(1)] 460 | unfolding module_func_typing.simps by auto 461 | have 3:"(types_t \)!i_t = (types inst)!i_t" 462 | using store_typing_imp_types_eq[OF \inst_typing s' inst \\ 2(1)] by - 463 | 464 | have "cl_typing s' f (tn _> tm)" 465 | using cl_typing.intros(1)[OF \inst_typing s' inst \\ 2(2) 2(3)] 466 | unfolding 1(1) 3 by - 467 | then have "\tf. cl_typing s' f tf" by auto 468 | } 469 | then show ?thesis by (simp add: list_all_iff) 470 | qed 471 | ultimately show ?thesis using \funcs s' = funcs s @ fs\ 472 | by (metis list_all_append) 473 | qed 474 | have 2:"list_all (tab_agree s') (tabs s')" 475 | proof - 476 | have 1:"list_all (\i. i< length (funcs s')) (inst.funcs inst)" 477 | using funci_agree_s' s'_is(1) unfolding funci_agree_def 478 | by (simp add: list_all2_conv_all_nth list_all_length) 479 | { 480 | fix e 481 | assume "e \ set (m_elem m)" 482 | then have "module_elem_typing \ e" using \list_all (module_elem_typing \) (m_elem m)\ 483 | by (metis list_all_iff) 484 | then have "list_all (\i. i < length (func_t \)) (e_init e)" 485 | unfolding module_elem_typing.simps by auto 486 | then have "list_all (\i. i < length (inst.funcs inst)) (e_init e)" 487 | using \list_all2 (funci_agree (funcs s')) (inst.funcs inst) (func_t \)\ 488 | list_all2_conv_all_nth 489 | by (simp add: list_all2_conv_all_nth) 490 | then have "list_all (\i. (inst.funcs inst)!i < length (s.funcs s')) (e_init e)" using 1 491 | by (metis list_all_length) 492 | } 493 | then have 1:"list_all (element_funcs_in_bounds s' inst) (m_elem m)" by (metis list_all_iff) 494 | 495 | have 2:"list_all2 (element_in_bounds s' inst) (map nat_of_int e_offs) (m_elem m)" 496 | proof - 497 | have "list_all (\i. i < length (tabs s')) (inst.tabs inst)" 498 | using tabi_agree_s1 unfolding tabi_agree_def 499 | by (simp add: less_imp_le_nat list_all2_conv_all_nth list_all_length) 500 | moreover have "list_all (\e. e_tab e < length (inst.tabs inst)) (m_elem m)" 501 | using tabi_agree_s1 c_is(3) 502 | unfolding list_all2_conv_all_nth module_elem_typing.simps list_all_length 503 | by auto 504 | ultimately show ?thesis using s_element_in_bounds 505 | unfolding element_in_bounds_def list_all2_conv_all_nth list_all_length 506 | by auto 507 | qed 508 | have "list_all (tab_agree s) (tabs s)" using assms(1) unfolding store_typing.simps by auto 509 | then have "list_all (tab_agree s') (tabs s)" 510 | using tab_agree_store_extension_inv[OF \store_extension s s'\] 511 | by (simp add: list_all_length) 512 | moreover have "list_all (tab_agree s') ts" 513 | using \list_all (module_tab_typing) (m_tabs m)\ 514 | unfolding ts_alloc alloc_tab_simple_def tab_agree_def list.pred_map(1) comp_def 515 | limit_typing.simps 516 | by(simp add:list.pred_set, auto) 517 | ultimately show "list_all (tab_agree s') (tabs s')" 518 | using s'_is(2) 519 | by simp 520 | qed 521 | have 3:"list_all mem_agree (mems s')" 522 | proof - 523 | have "list_all2 (data_in_bounds s' inst) (map nat_of_int d_offs) (m_data m)" 524 | proof - 525 | have "list_all (\i. i < length (mems s')) (inst.mems inst)" 526 | using list_all2_forget[OF memi_agree_s1] list.pred_mono_strong unfolding memi_agree_def 527 | by fastforce 528 | moreover have "list_all (\d. d_data d < length (inst.mems inst)) (m_data m)" 529 | using c_is(4) unfolding \length (inst.mems inst) = length (memory \)\ 530 | module_data_typing.simps list_all_length by auto 531 | ultimately show ?thesis using s_data_in_bounds unfolding data_in_bounds_def 532 | Let_def list.rel_map(1) list_all2_conv_all_nth list_all_length by(simp) 533 | qed 534 | then have 1:"list_all2 (data_in_bounds s' inst) (map nat_of_int d_offs) (m_data m)" 535 | unfolding data_in_bounds_def 536 | by auto 537 | 538 | have "list_all mem_agree (mems s)" using assms(1) unfolding store_typing.simps by auto 539 | moreover have "list_all mem_agree ms" 540 | using \list_all (module_mem_typing) (m_mems m)\ 541 | unfolding ms_alloc alloc_mem_simple_def limit_typing.simps list.pred_map(1) comp_def 542 | mem_mk_def mem_rep_mk_def 543 | by(simp add:list.pred_set bytes_replicate_def 544 | mem_size_def mem_length_def mem_rep_length.abs_eq Ki64_def mem_max_def, fastforce) 545 | 546 | ultimately show "list_all mem_agree (mems s')" 547 | unfolding s'_is(3) 548 | by simp 549 | qed 550 | show ?thesis 551 | using 1 2 3 store_typing.intros 552 | by blast 553 | qed 554 | 555 | show "\tes. list_all2 (\v_exp te. external_typing s' (E_desc v_exp) te) v_exps tes" 556 | using instantiation_external_typing[OF s_alloc_module \inst_typing s' inst \\ c_is(5)] by - 557 | 558 | 559 | show "\\. (inst_typing s' inst \ \ (s'\\ \ init_es : ([] _> [])))" 560 | proof - 561 | have "s'\\ \ (case (m_start m) of None \ [] | Some i_s \ [Invoke ((inst.funcs inst)!i_s)]) : ([] _> [])" 562 | proof (cases "m_start m") 563 | case None 564 | thus ?thesis 565 | by (simp add: e_type_empty) 566 | next 567 | case (Some a) 568 | have a_type:"a < length (inst.funcs inst)" 569 | "(func_t \)!a = ([] _> [])" using c_is(6) Some funci_agree_s' 570 | unfolding module_start_typing.simps list_all2_conv_all_nth by simp_all 571 | then have "inst.funcs inst ! a < length (funcs s')" using list_all2_forget[OF funci_agree_s'] 572 | unfolding funci_agree_def list_all_length by simp 573 | moreover have "cl_type ((funcs s')!(inst.funcs inst ! a)) = ([] _> [])" 574 | using a_type(1,2) c_is(7) 575 | by (metis funci_agree_def funci_agree_s' list_all2_conv_all_nth) 576 | ultimately show ?thesis 577 | using e_typing_l_typing.intros(6) Some 578 | by simp 579 | qed 580 | moreover have "s'\\ \ e_init_tabs : ([] _> [])" 581 | proof - 582 | have "length e_offs = length (m_elem m)" 583 | using s_element_in_bounds list_all2_lengthD 584 | by auto 585 | thus ?thesis 586 | using c_is(3) s_init_tabs 587 | proof (induction "m_elem m" arbitrary: e_offs e_init_tabs m rule: list.induct) 588 | case Nil 589 | thus ?case 590 | by (simp add: e_type_empty) 591 | next 592 | case (Cons a x) 593 | obtain e_off e_offs' where 594 | e_off_is:"e_off#e_offs' = e_offs" "length e_offs' = length x" 595 | using Cons(3) Cons(2)[symmetric] 596 | by (metis length_Suc_conv) 597 | then obtain e_init_tab e_init_tabs' where 598 | e_init_tab_is:"e_init_tab#e_init_tabs' = e_init_tabs" 599 | "length x = length e_init_tabs'" 600 | "(Init_tab (nat_of_int e_off) (map (\i. (inst.funcs inst)!i) (e_init a))) = e_init_tab" 601 | "map2 (\x y. Init_tab x (map (\i. (inst.funcs inst)!i) (e_init y))) (map nat_of_int e_offs') x = e_init_tabs'" 602 | using Cons(5) Cons(2)[symmetric] 603 | by fastforce 604 | have "(module_elem_typing \ a)" 605 | using Cons(2,4) 606 | by (metis list_all_simps(1)) 607 | hence len_tab_c:"length (table \) > 0" 608 | "list_all (\ti. ti < length (s.funcs s')) (map (\i. (inst.funcs inst)!i) (e_init a))" 609 | using c_is(7) funci_agree_s' inst_typing_func_length s'_inst_t 610 | unfolding funci_agree_def list_all2_conv_all_nth list_all_length module_elem_typing.simps 611 | by fastforce+ 612 | hence "s'\\ \ [e_init_tab] : ([] _> [])" 613 | using e_init_tab_is(3) e_typing_l_typing.intros(9) len_tab_c(1) 614 | by (metis le_refl less_one nat_less_le nat_neq_iff) 615 | moreover 616 | have "s'\\ \ e_init_tabs' : ([] _> [])" 617 | using Cons(1)[of "\m_types=[], m_funcs=[],m_tabs=[], m_mems=[], m_globs=[], m_elem=x, m_data=[],m_start=None,m_imports=[],m_exports=[]\" "e_offs'" "e_init_tabs'"] 618 | Cons(2,3,4) e_off_is e_init_tab_is 619 | by simp (metis list_all_simps(1)) 620 | ultimately 621 | show ?case 622 | using e_init_tab_is(1) e_type_comp_conc 623 | by fastforce 624 | qed 625 | qed 626 | moreover have "s'\\ \ e_init_mems : ([] _> [])" 627 | proof - 628 | have "length d_offs = length (m_data m)" 629 | using s_data_in_bounds list_all2_lengthD 630 | by auto 631 | thus ?thesis 632 | using c_is(4) s_init_mems 633 | proof (induction "m_data m" arbitrary: d_offs e_init_mems m rule: list.induct) 634 | case Nil 635 | thus ?case 636 | by (simp add: e_type_empty) 637 | next 638 | case (Cons a x) 639 | obtain d_off d_offs' where 640 | e_off_is:"d_off#d_offs' = d_offs" "length d_offs' = length x" 641 | using Cons(3) Cons(2)[symmetric] 642 | by (metis length_Suc_conv) 643 | then obtain e_init_mem e_init_mems' where 644 | e_init_mem_is:"e_init_mem#e_init_mems' = e_init_mems" 645 | "length x = length e_init_mems'" 646 | "(Init_mem (nat_of_int d_off) (d_init a)) = e_init_mem" 647 | "map2 (\x y. Init_mem x (d_init y)) (map nat_of_int d_offs') x = e_init_mems'" 648 | using Cons(5) Cons(2)[symmetric] 649 | by fastforce 650 | have "(module_data_typing \ a)" 651 | using Cons(2,4) 652 | by (metis list_all_simps(1)) 653 | hence len_tab_c:"length (memory \) > 0" 654 | unfolding module_data_typing.simps 655 | by auto 656 | hence "s'\\ \ [e_init_mem] : ([] _> [])" 657 | using e_init_mem_is(3) e_typing_l_typing.intros(8) 658 | by (metis le_refl less_one nat_less_le nat_neq_iff) 659 | moreover 660 | have "s'\\ \ e_init_mems' : ([] _> [])" 661 | using Cons(1)[of "\m_types=[], m_funcs=[],m_tabs=[], m_mems=[], m_globs=[], m_elem=[], m_data=x,m_start=None,m_imports=[],m_exports=[]\" "d_offs'" "e_init_mems'"] 662 | Cons(2,3,4) e_off_is e_init_mem_is 663 | by simp (metis list_all_simps(1)) 664 | ultimately 665 | show ?case 666 | using e_init_mem_is(1) e_type_comp_conc 667 | by fastforce 668 | qed 669 | qed 670 | ultimately have "(s'\\ \ init_es : ([] _> []))" 671 | using e_type_comp_conc init_es_is s_start 672 | by fastforce 673 | thus ?thesis 674 | using s'_inst_t 675 | by auto 676 | qed 677 | qed 678 | 679 | 680 | theorem run_instantiate_sound: 681 | assumes "run_instantiate n d (s,inst,es) = (s',RValue vs)" 682 | shows "computes (instantiate_config s inst es) s' vs" 683 | using assms 684 | by (auto 685 | simp: instantiate_config_def computes_def 686 | dest!: run_iter_sound 687 | split: prod.splits config.splits) 688 | 689 | theorem run_instantiate_sound_trap: 690 | assumes "run_instantiate n d (s,inst,es) = (s',RTrap str)" 691 | shows "traps (instantiate_config s inst es) s'" 692 | using assms 693 | by (auto 694 | simp: instantiate_config_def traps_def 695 | dest!: run_iter_sound 696 | split: prod.splits config.splits) 697 | 698 | 699 | 700 | (* TODO: Delete all those simp-lemmas, right after defs (best: change fun to definition! )*) 701 | lemmas [simp del] = run_invoke_v.simps 702 | lemmas [simp del] = interp_instantiate.simps run_instantiate.simps 703 | 704 | lemma interp_instantiate_init_sound: 705 | assumes "interp_instantiate_init s m v_imps = (s', RI_res inst exps es)" 706 | shows "\sh esh. 707 | instantiate s m v_imps ((sh, inst, exps), esh) 708 | \ es = [] 709 | \ computes (instantiate_config sh inst esh) s' [] 710 | " 711 | using assms 712 | unfolding interp_instantiate_init_def 713 | by (auto 0 4 714 | split: prod.splits res_inst.splits res.splits list.splits config.splits 715 | dest!: run_instantiate_sound 716 | simp: instantiate_equiv_interp_instantiate[symmetric] 717 | ) 718 | 719 | (* 720 | lemma interp_instantiate_init_sound_traps: 721 | assumes "interp_instantiate_init s m v_imps = (s', RI_trap str)" 722 | shows "\sh esh. 723 | instantiate s m v_imps ((sh, inst, exps), esh) \ This could fail, too! 724 | \ es = [] 725 | \ traps (instantiate_config sh inst esh) s' 726 | " 727 | using assms 728 | unfolding interp_instantiate_init_def 729 | apply (auto 0 4 730 | split: prod.splits res_inst.splits res.splits list.splits config.splits 731 | dest!: run_instantiate_sound_trap 732 | simp: instantiate_equiv_interp_instantiate[symmetric] 733 | ) 734 | find_theorems interp_instantiate RI_trap 735 | (* TODO: Missing abstract characterization of trapping instantiation. 736 | There's only instantiate, which describes successful instantiation. 737 | *) 738 | oops 739 | *) 740 | 741 | (* TODO: Also write simplified check in definitions! *) 742 | lemma simplify_check_is_Ext_func: "(\exp. case E_desc exp of Ext_func i \ True | _ \ False) = is_Ext_func o E_desc" 743 | by (auto simp: fun_eq_iff split: v_ext.splits) 744 | 745 | 746 | 747 | 748 | theorem run_fuzz'_sound: "run_fuzz' n d s m v_imps vs_opt = (s',RValue vs) \ 749 | run_fuzz_abs s m v_imps vs_opt s' vs" 750 | unfolding run_fuzz'_def run_fuzz_abs_def 751 | apply (auto 752 | split: prod.splits res_inst.splits option.splits v_ext.splits tf.splits 753 | simp: instantiate_equiv_interp_instantiate[symmetric] simplify_check_is_Ext_func find_finds_first 754 | simp: make_params_def Let_def 755 | dest!: interp_instantiate_init_sound run_invoke_v_sound' 756 | dest: is_first_elem_with_prop_propI 757 | ) 758 | apply fastforce+ 759 | done 760 | 761 | theorem run_fuzz_entry'_sound: "run_fuzz_entry' n m vs_opt = (s',RValue vs) \ run_fuzz_abs empty_store m [] vs_opt s' vs" 762 | by (auto simp: run_fuzz_entry'_def dest!: run_fuzz'_sound) 763 | 764 | 765 | 766 | end -------------------------------------------------------------------------------- /WebAssembly/Wasm_Instantiation_Properties_Aux.thy: -------------------------------------------------------------------------------- 1 | theory Wasm_Instantiation_Properties_Aux imports Wasm_Instantiation Wasm_Properties begin 2 | 3 | 4 | definition element_in_bounds where 5 | "element_in_bounds s inst e_ind e \ 6 | let i = inst.tabs inst ! e_tab e 7 | in i < length (tabs s) \ e_ind + length (e_init e) \ length (fst (tabs s ! i))" 8 | 9 | definition data_in_bounds where 10 | "data_in_bounds s inst d_ind d \ 11 | let i = inst.mems inst ! d_data d 12 | in i < length (mems s) \ d_ind + length (d_init d) \ mem_length (mems s ! i)" 13 | 14 | abbreviation "element_funcs_in_bounds s inst e 15 | \list_all (\i. (inst.funcs inst)!i < length (s.funcs s)) (e_init e)" 16 | 17 | lemma tab_extension_trans:"tab_extension a b \ tab_extension b c \ tab_extension a c" 18 | unfolding tab_extension_def by auto 19 | lemma mem_extension_trans:"mem_extension a b \ mem_extension b c \ mem_extension a c" 20 | unfolding mem_extension_def by auto 21 | 22 | (* while mathematically superfluous, this form makes the following lemmas easier to prove *) 23 | lemma store_extension_intros_with_refl: 24 | assumes "funcs s = funcs s' \ (\ fs. funcs s @ fs = funcs s')" 25 | "tabs s = tabs s' \ (\ t1 t2. t1 @ t2 = tabs s' \ list_all2 tab_extension (tabs s) t1)" 26 | "mems s = mems s' \ (\ m1 m2. m1 @ m2 = mems s' \ list_all2 mem_extension (mems s) m1)" 27 | "globs s = globs s' \ (\ g1 g2. g1 @ g2 = globs s' \ list_all2 global_extension (globs s) g1)" 28 | shows "store_extension s s'" 29 | proof - 30 | have funcs:"\ fs. funcs s @ fs = funcs s'" using assms(1) by auto 31 | have tabs: "\ t1 t2. t1 @ t2 = tabs s' \ list_all2 tab_extension (tabs s) t1" 32 | using assms(2) tab_extension_refl list_all2_refl by (metis append_Nil2) 33 | have mems: "\ m1 m2. m1 @ m2 = mems s' \ list_all2 mem_extension (mems s) m1" 34 | using assms(3) mem_extension_refl list_all2_refl by (metis append_Nil2) 35 | have globs: "\ g1 g2. g1 @ g2 = globs s' \ list_all2 global_extension (globs s) g1" 36 | using assms(4) global_extension_refl list_all2_refl by (metis append_Nil2) 37 | show ?thesis using funcs mems tabs globs unfolding store_extension.simps 38 | by (metis (full_types) unit.exhaust s.surjective) 39 | qed 40 | 41 | lemma alloc_module_preserve_store_extension: 42 | assumes "alloc_module s m imps gvs (s',inst,exps)" 43 | shows "store_extension s s'" 44 | using alloc_module_ext_arb[OF assms] 45 | store_extension_intros_with_refl list_all2_refl tab_extension_refl mem_extension_refl global_extension_refl 46 | by metis 47 | 48 | definition alloc_func_simple :: "module_func \ inst \ cl" where 49 | "alloc_func_simple m_f inst = 50 | (case m_f of (i_t, loc_ts, b_es) \ 51 | Func_native inst ((types inst)!i_t) loc_ts b_es)" 52 | 53 | lemma alloc_func_equiv:"fst (alloc_func s m_f i) = s\funcs := funcs s @ [alloc_func_simple m_f i]\" 54 | unfolding alloc_func_def alloc_func_simple_def by(simp split:prod.splits) 55 | 56 | definition alloc_tab_simple :: "tab_t \ tabinst" where 57 | "alloc_tab_simple m_t = (replicate (l_min m_t) None, (l_max m_t))" 58 | 59 | lemma alloc_tab_equiv:"fst (alloc_tab s m_t) = s\tabs := tabs s @ [alloc_tab_simple m_t]\" 60 | unfolding alloc_tab_def alloc_tab_simple_def by simp 61 | 62 | definition alloc_mem_simple :: "mem_t \ mem" where 63 | "alloc_mem_simple m_m = mem_mk m_m" 64 | 65 | lemma alloc_mem_equiv:"fst (alloc_mem s m_m) = s\mems := mems s @ [alloc_mem_simple m_m]\" 66 | unfolding alloc_mem_def alloc_mem_simple_def by simp 67 | 68 | definition alloc_glob_simple :: "(module_glob \ v) \ global" where 69 | "alloc_glob_simple m_g_v = 70 | (case m_g_v of (m_g, v) \ \g_mut=(tg_mut (module_glob.g_type m_g)), g_val=v\)" 71 | 72 | lemma alloc_glob_equiv:"fst (alloc_glob s m_g_v) = s\globs := globs s @ [alloc_glob_simple m_g_v]\" 73 | unfolding alloc_glob_def alloc_glob_simple_def by(simp split:prod.splits) 74 | 75 | abbreviation "alloc_funcs_simple m_fs i \ map (\m_f. alloc_func_simple m_f i) m_fs" 76 | 77 | lemma alloc_funcs_equiv:"fst (alloc_funcs s m_fs i) = s\funcs := funcs s @ alloc_funcs_simple m_fs i\" 78 | proof(induct m_fs arbitrary: s) 79 | case Nil 80 | then show ?case by auto 81 | next 82 | case (Cons a m_fs) 83 | have "fst (alloc_funcs s (a # m_fs) i) = fst (alloc_funcs (fst (alloc_func s a i)) m_fs i)" 84 | by(simp split:prod.splits) 85 | then show ?case unfolding alloc_func_equiv Cons by simp 86 | qed 87 | 88 | abbreviation "alloc_tabs_simple m_ts \ map alloc_tab_simple m_ts" 89 | 90 | lemma alloc_tabs_equiv:"fst (alloc_tabs s m_ts) = s\tabs := tabs s @ alloc_tabs_simple m_ts\" 91 | proof(induct m_ts arbitrary:s) 92 | case Nil 93 | then show ?case by auto 94 | next 95 | case (Cons a m_ts) 96 | have "fst (alloc_tabs s (a # m_ts)) = fst (alloc_tabs (fst (alloc_tab s a)) m_ts)" 97 | by(simp split:prod.splits) 98 | then show ?case unfolding alloc_tab_equiv Cons by simp 99 | qed 100 | 101 | abbreviation "alloc_mems_simple m_ms \ map alloc_mem_simple m_ms" 102 | 103 | lemma alloc_mems_equiv:"fst (alloc_mems s m_ms) = s\mems := mems s @ alloc_mems_simple m_ms\" 104 | proof(induct m_ms arbitrary:s) 105 | case Nil 106 | then show ?case by auto 107 | next 108 | case (Cons a m_ms) 109 | have "fst (alloc_mems s (a # m_ms)) = fst (alloc_mems (fst (alloc_mem s a)) m_ms)" 110 | by(simp split:prod.splits) 111 | then show ?case unfolding alloc_mem_equiv Cons by simp 112 | qed 113 | 114 | abbreviation "alloc_globs_simple m_gs vs \ map (\m_g_v. alloc_glob_simple m_g_v) (zip m_gs vs)" 115 | 116 | lemma alloc_globs_equiv: 117 | "fst (alloc_globs s m_gs vs) = s\globs := globs s @ alloc_globs_simple m_gs vs\" 118 | proof(induct "zip m_gs vs" arbitrary:s m_gs vs) 119 | case Nil 120 | then show ?case by auto 121 | next 122 | case (Cons a m_g_vs) 123 | have 1:"m_g_vs = zip (map fst m_g_vs) (map snd m_g_vs)" 124 | by (simp add: zip_map_fst_snd) 125 | have "fst (alloc_globs s (map fst (a#m_g_vs)) (map snd (a#m_g_vs))) 126 | = fst (alloc_globs (fst (alloc_glob s a)) (map fst m_g_vs) (map snd m_g_vs))" 127 | by(simp split:prod.splits) 128 | also have "... = s\globs := globs s @ alloc_globs_simple (map fst (a#m_g_vs)) (map snd (a#m_g_vs))\" 129 | unfolding alloc_glob_equiv Cons(1)[OF 1] by(simp) 130 | finally show ?case by(simp add: zip_map_fst_snd Cons(2)) 131 | qed 132 | 133 | lemma alloc_tabs_store_agnostic: 134 | assumes "tabs s1 = tabs s2" 135 | "(s1', i1) = alloc_tabs s1 (m_tabs m)" 136 | "(s2', i2) = alloc_tabs s2 (m_tabs m)" 137 | shows "tabs s1' = tabs s2' \ i1 = i2" 138 | using alloc_tabs_range(1) assms alloc_tabs_equiv 139 | by (metis (no_types, lifting) fst_conv s.select_convs(2) s.surjective s.update_convs(2)) 140 | 141 | lemma alloc_mems_store_agnostic: 142 | assumes "mems s1 = mems s2" 143 | "(s1', i1) = alloc_mems s1 (m_mems m)" 144 | "(s2', i2) = alloc_mems s2 (m_mems m)" 145 | shows "mems s1' = mems s2' \ i1 = i2" 146 | using alloc_mems_range(1) assms alloc_mems_equiv 147 | by (metis (no_types, lifting) fst_conv s.select_convs(3) s.surjective s.update_convs(3)) 148 | 149 | lemma alloc_globs_store_agnostic: 150 | assumes "globs s1 = globs s2" 151 | "(s1', i1) = alloc_globs s1 (m_globs m) gvs" 152 | "(s2', i2) = alloc_globs s2 (m_globs m) gvs" 153 | shows "globs s1' = globs s2' \ i1 = i2" 154 | using alloc_globs_range(1) assms alloc_globs_equiv 155 | by (metis (no_types, lifting)) 156 | 157 | 158 | lemma alloc_module_allocated_form: 159 | assumes "alloc_module s m imps gvs (s',inst,exps)" 160 | shows "alloc_funcs s (m_funcs m) inst = (ss,i_fs) 161 | \ funcs s' = funcs ss \ inst.funcs inst = (ext_funcs imps)@i_fs" 162 | "alloc_tabs s (m_tabs m) = (ss,i_ts) 163 | \ tabs s' = tabs ss \ inst.tabs inst = (ext_tabs imps)@i_ts" 164 | "alloc_mems s (m_mems m) = (ss,i_ms) 165 | \ mems s' = mems ss \ inst.mems inst = (ext_mems imps)@i_ms" 166 | "alloc_globs s (m_globs m) gvs = (ss,i_gs) 167 | \ globs s' = globs ss \ inst.globs inst = (ext_globs imps)@i_gs" 168 | proof - 169 | obtain s1 s2 s3 i_fs' i_ts' i_ms' i_gs' where 170 | inst:"inst = \types=(m_types m), 171 | funcs=(ext_funcs imps)@i_fs', 172 | tabs=(ext_tabs imps)@i_ts', 173 | mems=(ext_mems imps)@i_ms', 174 | globs=(ext_globs imps)@i_gs'\" 175 | and funcs:"alloc_funcs s (m_funcs m) inst = (s1,i_fs')" 176 | and tabs:"alloc_tabs s1 (m_tabs m) = (s2,i_ts')" 177 | and mems:"alloc_mems s2 (m_mems m) = (s3,i_ms')" 178 | and globs:"alloc_globs s3 (m_globs m) gvs = (s',i_gs')" 179 | using assms unfolding alloc_module.simps by auto 180 | 181 | show "alloc_funcs s (m_funcs m) inst = (ss,i_fs) 182 | \ funcs s' = funcs ss \ inst.funcs inst = (ext_funcs imps)@i_fs" 183 | using funcs alloc_tabs_range[OF tabs] 184 | alloc_mems_range[OF mems] alloc_globs_range[OF globs] inst by force 185 | 186 | show "alloc_tabs s (m_tabs m) = (ss,i_ts) 187 | \ tabs s' = tabs ss \ inst.tabs inst = (ext_tabs imps)@i_ts" 188 | using alloc_funcs_range[OF funcs] alloc_tabs_store_agnostic tabs 189 | alloc_mems_range[OF mems] alloc_globs_range[OF globs] inst 190 | by (metis inst.select_convs(3)) 191 | 192 | show "alloc_mems s (m_mems m) = (ss,i_ms) 193 | \ mems s' = mems ss \ inst.mems inst = (ext_mems imps)@i_ms" 194 | using alloc_funcs_range[OF funcs] alloc_tabs_range[OF tabs] alloc_mems_store_agnostic mems 195 | alloc_globs_range[OF globs] inst 196 | by (metis inst.select_convs(4)) 197 | 198 | show "alloc_globs s (m_globs m) gvs = (ss,i_gs) 199 | \ globs s' = globs ss \ inst.globs inst = (ext_globs imps)@i_gs" 200 | using alloc_funcs_range[OF funcs] alloc_tabs_range[OF tabs] alloc_mems_range[OF mems] 201 | alloc_globs_store_agnostic globs inst 202 | by (metis inst.select_convs(5)) 203 | qed 204 | 205 | 206 | 207 | lemma alloc_module_funcs_form: 208 | assumes "alloc_module s m v_imps g_inits (s', inst, v_exps)" 209 | "funcs s' = funcs s @ fs" 210 | shows "fs = alloc_funcs_simple (m_funcs m) inst" 211 | proof - 212 | define s_mid where s_mid_def:"s_mid = fst (alloc_funcs s (m_funcs m) inst)" 213 | then have "funcs s' = funcs s_mid" 214 | using alloc_module_allocated_form(1)[OF assms(1)] 215 | by (metis eq_fst_iff) 216 | then have "funcs s_mid = funcs s @ fs" using assms(2) by auto 217 | then show ?thesis using alloc_funcs_equiv s_mid_def by auto 218 | qed 219 | 220 | lemma alloc_module_tabs_form: 221 | assumes "alloc_module s m v_imps g_inits (s', inst, v_exps)" 222 | "tabs s' = tabs s @ ts" 223 | shows "ts = alloc_tabs_simple (m_tabs m)" 224 | proof - 225 | have "tabs s' = tabs (fst (alloc_tabs s (m_tabs m)))" 226 | using alloc_module_allocated_form(2)[OF assms(1)] 227 | by (metis eq_fst_iff) 228 | then show ?thesis using alloc_tabs_equiv assms(2) by auto 229 | qed 230 | 231 | lemma alloc_module_mems_form: 232 | assumes "alloc_module s m v_imps g_inits (s', inst, v_exps)" 233 | "mems s' = mems s @ ms" 234 | shows "ms = alloc_mems_simple (m_mems m)" 235 | proof - 236 | have "mems s' = mems (fst (alloc_mems s (m_mems m)))" 237 | using alloc_module_allocated_form(3)[OF assms(1)] 238 | by (metis eq_fst_iff) 239 | then show ?thesis using alloc_mems_equiv assms(2) by auto 240 | qed 241 | 242 | lemma alloc_module_globs_form: 243 | assumes "alloc_module s m v_imps g_inits (s', inst, v_exps)" 244 | "globs s' = globs s @ gs" 245 | shows "gs = alloc_globs_simple (m_globs m) g_inits" 246 | proof - 247 | have "globs s' = globs (fst (alloc_globs s (m_globs m) g_inits))" 248 | using alloc_module_allocated_form(4)[OF assms(1)] 249 | by (metis eq_fst_iff) 250 | then show ?thesis using alloc_globs_equiv assms(2) by auto 251 | qed 252 | 253 | lemma ext_typing_imp_helper: 254 | assumes "list_all2 (external_typing s) v_imps t_imps" 255 | "\v t. external_typing s v t \ (\v'. f v = Some v') \ (\e'. g t = Some e')" 256 | "\v t v' t'. external_typing s v t \ f v = Some v' \ g t = Some t' \ P v' t'" 257 | shows "list_all2 P (List.map_filter f v_imps) (List.map_filter g t_imps)" 258 | proof - 259 | { 260 | fix a 261 | have "list_all2 (external_typing s) (map fst a) (map snd a) 262 | \ list_all2 P (List.map_filter f (map fst a)) (List.map_filter g (map snd a))" 263 | proof(induct a) 264 | case Nil 265 | then show ?case by (simp add: map_filter_simps(2)) 266 | next 267 | case (Cons a1 a2) 268 | have 1:"list_all2 P (List.map_filter f (map fst a2)) (List.map_filter g (map snd a2))" 269 | using Cons by auto 270 | have 2:"external_typing s (fst a1) (snd a1)" using Cons(2) by auto 271 | show ?case 272 | proof(cases "\v'. f (fst a1) = Some v'") 273 | case True 274 | then obtain v' where v'_def:"f (fst a1) = Some v'" by auto 275 | then obtain t' where t'_def:"g (snd a1) = Some t'" using assms(2)[OF 2] 276 | by force 277 | have "P v' t'" using assms(3)[OF 2 v'_def t'_def] by - 278 | then show ?thesis using 1 v'_def t'_def by(simp add: List.map_filter_simps) 279 | next 280 | case False 281 | then have no_t':"g (snd a1) = None" using assms(2)[OF 2] by auto 282 | show ?thesis using False no_t' 1 by(simp add: List.map_filter_simps) 283 | qed 284 | qed 285 | } 286 | then show ?thesis using assms 287 | by (metis list.in_rel) 288 | qed 289 | 290 | lemma ext_typing_imp_funci_agree: 291 | assumes "list_all2 (external_typing s) v_imps t_imps" 292 | shows "list_all2 (funci_agree (funcs s)) (ext_funcs v_imps) (ext_t_funcs t_imps)" 293 | apply(rule ext_typing_imp_helper[OF assms]) 294 | apply(simp add: external_typing.simps) 295 | apply auto 296 | apply(simp split:v_ext.splits extern_t.splits add: external_typing.simps funci_agree_def) 297 | done 298 | 299 | lemma ext_typing_imp_globi_agree: 300 | assumes "list_all2 (external_typing s) v_imps t_imps" 301 | shows "list_all2 (globi_agree (globs s)) (ext_globs v_imps) (ext_t_globs t_imps)" 302 | apply(rule ext_typing_imp_helper[OF assms]) 303 | apply(simp add: external_typing.simps) 304 | apply auto 305 | apply(simp split:v_ext.splits extern_t.splits add: external_typing.simps globi_agree_def) 306 | done 307 | 308 | lemma ext_typing_imp_tabi_agree: 309 | assumes "list_all2 (external_typing s) v_imps t_imps" 310 | shows "list_all2 (tabi_agree (tabs s)) (ext_tabs v_imps) (ext_t_tabs t_imps)" 311 | apply(rule ext_typing_imp_helper[OF assms]) 312 | apply(simp add: external_typing.simps) 313 | apply auto 314 | apply(simp split:v_ext.splits extern_t.splits add: external_typing.simps tabi_agree_def) 315 | done 316 | 317 | lemma ext_typing_imp_memi_agree: 318 | assumes "list_all2 (external_typing s) v_imps t_imps" 319 | shows "list_all2 (memi_agree (mems s)) (ext_mems v_imps) (ext_t_mems t_imps)" 320 | apply(rule ext_typing_imp_helper[OF assms]) 321 | apply(simp add: external_typing.simps) 322 | apply auto 323 | apply(simp split:v_ext.splits extern_t.splits add: external_typing.simps memi_agree_def) 324 | done 325 | 326 | 327 | end -------------------------------------------------------------------------------- /WebAssembly/Wasm_Interpreter_Printing.thy: -------------------------------------------------------------------------------- 1 | theory Wasm_Interpreter_Printing imports "Wasm_Interpreter_Properties" begin 2 | 3 | definition "run = run_v (2^63) 300" 4 | 5 | definition "run_invoke = run_invoke_v (2^63) 300" 6 | 7 | (* host *) 8 | 9 | axiomatization 10 | Abs_host :: "((s \ v list) \ (s \ v list) option) \ host" and 11 | Rep_host :: "host \ ((s \ v list) \ (s \ v list) option)" 12 | where 13 | host_is[code abstype]: 14 | "Abs_host (Rep_host h) = h" 15 | and 16 | host_apply_impl_def[code] : 17 | "host_apply_impl s tf h vs = ((Rep_host h) (s,vs))" 18 | 19 | (* memory *) 20 | 21 | (* 22 | code_printing 23 | type_constructor byte \ (OCaml) "ImplWrapper.byte" 24 | 25 | code_printing 26 | constant msb_byte \ (OCaml) "ImplWrapper.msb'_byte" 27 | | constant zero_byte \ (OCaml) "ImplWrapper.zero'_byte" 28 | | constant negone_byte \ (OCaml) "ImplWrapper.negone'_byte" 29 | *) 30 | 31 | end -------------------------------------------------------------------------------- /WebAssembly/Wasm_Module.thy: -------------------------------------------------------------------------------- 1 | theory Wasm_Module imports Wasm begin 2 | 3 | record module_glob = 4 | g_type :: tg 5 | g_init :: "b_e list" 6 | 7 | record module_elem = 8 | e_tab :: i 9 | e_off :: "b_e list" 10 | e_init :: "i list" 11 | 12 | record module_data = 13 | d_data :: i 14 | d_off :: "b_e list" 15 | d_init :: "byte list" 16 | 17 | type_synonym module_func = \ \function\ 18 | "i \ t list \ b_e list" 19 | 20 | datatype imp_desc = 21 | Imp_func i 22 | | Imp_tab tab_t 23 | | Imp_mem mem_t 24 | | Imp_glob tg 25 | 26 | datatype v_ext = 27 | Ext_func (the_idx: i) 28 | | Ext_tab (the_idx: i) 29 | | Ext_mem (the_idx: i) 30 | | Ext_glob (the_idx: i) 31 | hide_const (open) v_ext.the_idx 32 | 33 | type_synonym exp_desc = v_ext 34 | 35 | record module_import = 36 | I_module :: String.literal 37 | I_name :: String.literal 38 | I_desc :: imp_desc 39 | 40 | record module_export = 41 | E_name :: String.literal 42 | E_desc :: exp_desc 43 | 44 | datatype extern_t = 45 | Te_func tf 46 | | Te_tab tab_t 47 | | Te_mem mem_t 48 | | Te_glob tg 49 | 50 | definition export_get_v_ext :: "inst \ exp_desc \ v_ext" where 51 | "export_get_v_ext inst exp = 52 | (case exp of 53 | Ext_func i \ Ext_func ((inst.funcs inst)!i) 54 | | Ext_tab i \ Ext_tab ((inst.tabs inst)!i) 55 | | Ext_mem i \ Ext_mem ((inst.mems inst)!i) 56 | | Ext_glob i \ Ext_glob ((inst.globs inst)!i))" 57 | 58 | abbreviation "ext_funcs \ List.map_filter (\x. case x of Ext_func i \ Some i | _ \ None)" 59 | abbreviation "ext_tabs \ List.map_filter (\x. case x of Ext_tab i \ Some i | _ \ None)" 60 | abbreviation "ext_mems \ List.map_filter (\x. case x of Ext_mem i \ Some i | _ \ None)" 61 | abbreviation "ext_globs \ List.map_filter (\x. case x of Ext_glob i \ Some i | _ \ None)" 62 | 63 | abbreviation "ext_t_funcs \ List.map_filter (\x. case x of Te_func tf \ Some tf | _ \ None)" 64 | abbreviation "ext_t_tabs \ List.map_filter (\x. case x of Te_tab t \ Some t | _ \ None)" 65 | abbreviation "ext_t_mems \ List.map_filter (\x. case x of Te_mem m \ Some m | _ \ None)" 66 | abbreviation "ext_t_globs \ List.map_filter (\x. case x of Te_glob g \ Some g | _ \ None)" 67 | 68 | inductive const_expr :: "t_context \ b_e \ bool" where \ \constant expression\ 69 | "const_expr \ (C v)" 70 | | "\k < length (global \); tg_mut ((global \)!k) = T_immut \ \ const_expr \ (Get_global k)" 71 | 72 | code_pred (modes: i \ i \ bool as const_expr_p) const_expr . 73 | 74 | abbreviation "const_exprs \ es \ list_all (const_expr \) es" 75 | 76 | inductive limit_typing :: "limit_t \ nat \ bool" where 77 | "\k \ 2^32; n \ k; pred_option (\m. m \ k) m_opt; pred_option (\m. n \ m) m_opt\ 78 | \ limit_typing \l_min = n, l_max = m_opt\ k" 79 | 80 | inductive module_func_typing :: "t_context \ module_func \ tf \ bool" where 81 | "\i < length (types_t \); 82 | (types_t \)!i = (tn _> tm); 83 | \\local := tn @ t_locs, label := ([tm] @ (label \)), return := Some tm\ \ b_es : ([] _> tm)\ 84 | \ module_func_typing \ (i, t_locs, b_es) (tn _> tm)" 85 | 86 | abbreviation "module_tab_typing t \ limit_typing t (2^32)" 87 | abbreviation "module_mem_typing t \ limit_typing t (2^16)" 88 | 89 | inductive module_glob_typing :: "t_context \ module_glob \ tg \ bool" where 90 | "\const_exprs \ es; \ \ es : ([] _> [tg_t tg])\ \ module_glob_typing \ \g_type=tg, g_init=es\ tg" 91 | 92 | inductive module_elem_typing :: "t_context \ module_elem \ bool" where 93 | "\t = 0; 94 | const_exprs \ es; 95 | \ \ es : ([] _> [T_num T_i32]); 96 | t < length (table \); 97 | list_all (\i. i < length (func_t \)) is\ \ module_elem_typing \ \e_tab=t, e_off=es, e_init=is\" 98 | 99 | inductive module_data_typing :: "t_context \ module_data \ bool" where 100 | "\d = 0; 101 | const_exprs \ es; 102 | \ \ es : ([] _> [T_num T_i32]); 103 | d < length (memory \)\ \ module_data_typing \ \d_data=d, d_off=es, d_init=bs\" 104 | 105 | inductive module_start_typing :: "t_context \ i \ bool" where 106 | "\i < length (func_t \); (func_t \)!i = ([] _> [])\ \ module_start_typing \ i" 107 | 108 | abbreviation "module_exports_distinct exps \ List.distinct (List.map E_name exps)" 109 | 110 | inductive module_import_typing :: "t_context \ imp_desc \ extern_t \ bool" where 111 | "\i < length (types_t \); (types_t \)!i = tf\ \ module_import_typing \ (Imp_func i) (Te_func tf)" 112 | | "\module_tab_typing tt\ \ module_import_typing \ (Imp_tab tt) (Te_tab tt)" 113 | | "\module_mem_typing mt\ \ module_import_typing \ (Imp_mem mt) (Te_mem mt)" 114 | | "module_import_typing \ (Imp_glob gt) (Te_glob gt)" 115 | 116 | inductive module_export_typing :: "t_context \ exp_desc \ extern_t \ bool" where 117 | "\i < length (func_t \); (func_t \)!i = tf\ \ module_export_typing \ (Ext_func i) (Te_func tf)" 118 | | "\i < length (table \); (table \)!i = tt\ \ module_export_typing \ (Ext_tab i) (Te_tab tt)" 119 | | "\i < length (memory \); (memory \)!i = mt\ \ module_export_typing \ (Ext_mem i) (Te_mem mt)" 120 | | "\i < length (global \); (global \)!i = gt\ \ module_export_typing \ (Ext_glob i) (Te_glob gt)" 121 | 122 | inductive external_typing :: "s \ v_ext \ extern_t \ bool" where 123 | "\i < length (funcs s); cl_type ((funcs s)!i) = tf\ \ external_typing s (Ext_func i) (Te_func tf)" 124 | | "\i < length (tabs s); tab_typing ((tabs s)!i) tt\ \ external_typing s (Ext_tab i) (Te_tab tt)" 125 | | "\i < length (mems s); mem_typing ((mems s)!i) mt\ \ external_typing s (Ext_mem i) (Te_mem mt)" 126 | | "\i < length (globs s); glob_typing ((globs s)!i) gt\ \ external_typing s (Ext_glob i) (Te_glob gt)" 127 | 128 | record m = \ \module\ 129 | m_types :: "tf list" 130 | m_funcs :: "module_func list" 131 | m_tabs :: "tab_t list" 132 | m_mems :: "mem_t list" 133 | m_globs :: "module_glob list" 134 | m_elem :: "module_elem list" 135 | m_data :: "module_data list" 136 | m_start :: "i option" 137 | m_imports :: "module_import list" 138 | m_exports :: "module_export list" 139 | 140 | inductive module_typing :: "m \ extern_t list \ extern_t list \ bool" where 141 | "\list_all2 (module_func_typing \) fs fts; 142 | list_all (module_tab_typing) ts; 143 | list_all (module_mem_typing) ms; 144 | list_all2 (module_glob_typing \') gs gts; 145 | list_all (module_elem_typing \) els; 146 | list_all (module_data_typing \) ds; 147 | pred_option (module_start_typing \) i_opt; 148 | module_exports_distinct exps; 149 | list_all2 (\imp. module_import_typing \ (I_desc imp)) imps impts; 150 | list_all2 (\exp. module_export_typing \ (E_desc exp)) exps expts; 151 | ifts = ext_t_funcs impts; 152 | its = ext_t_tabs impts; 153 | ims = ext_t_mems impts; 154 | igs = ext_t_globs impts; 155 | length (its@ts) \ 1; \ \\MVP restriction\\ 156 | length (ims@ms) \ 1; \ \\MVP restriction\\ 157 | \ = \types_t=tfs, func_t=ifts@fts, global=igs@gts, table=its@ts, memory=ims@ms, local=[], label=[], return=None\; 158 | \' = \types_t=[], func_t=[], global=igs, table=[], memory=[], local=[], label=[], return=None\\ 159 | \ module_typing \m_types = tfs, 160 | m_funcs = fs, 161 | m_tabs = ts, 162 | m_mems = ms, 163 | m_globs = gs, 164 | m_elem = els, 165 | m_data = ds, 166 | m_start = i_opt, 167 | m_imports = imps, 168 | m_exports = exps\ impts expts" 169 | 170 | end -------------------------------------------------------------------------------- /WebAssembly/Wasm_Module_Checker.thy: -------------------------------------------------------------------------------- 1 | theory Wasm_Module_Checker imports Wasm_Module Wasm_Checker_Properties begin 2 | 3 | code_pred (modes: i \ i \ bool as limit_type_checker_p) limit_typing . 4 | 5 | fun module_func_type_checker :: "t_context \ module_func \ bool" where 6 | "module_func_type_checker \ (i, t_locs, b_es) = 7 | ((i < length (types_t \)) \ 8 | (case (types_t \)!i of 9 | (tn _> tm) \ 10 | b_e_type_checker (\\local := tn @ t_locs, label := ([tm] @ (label \)), return := Some tm\) b_es ([] _> tm)))" 11 | 12 | lemma module_func_typing_equiv_module_func_type_checker: 13 | "module_func_typing \ m_f tf = (module_func_type_checker \ m_f \ 14 | ((types_t \)!(fst m_f) = tf))" 15 | apply (cases m_f) 16 | apply (auto simp add: module_func_typing.simps b_e_typing_equiv_b_e_type_checker split: tf.splits) 17 | done 18 | 19 | abbreviation "module_tab_type_checker \ module_tab_typing" 20 | abbreviation "module_mem_type_checker \ module_mem_typing" 21 | 22 | fun module_glob_type_checker :: "t_context \ module_glob \ bool" where 23 | "module_glob_type_checker \ \g_type=tg, g_init=es\ = 24 | (const_exprs \ es \ b_e_type_checker \ es ([] _> [tg_t tg]))" 25 | 26 | lemma module_glob_typing_equiv_module_glob_type_checker: 27 | "module_glob_typing \ m_g tg = (module_glob_type_checker \ m_g \ 28 | (module_glob.g_type m_g) = tg)" 29 | apply (cases m_g) 30 | apply (auto simp add: module_glob_typing.simps b_e_typing_equiv_b_e_type_checker) 31 | done 32 | 33 | fun module_elem_type_checker :: "t_context \ module_elem \ bool" where 34 | "module_elem_type_checker \ \e_tab=t, e_off=es, e_init=is\ = 35 | (t = 0 \ const_exprs \ es \ b_e_type_checker \ es ([] _> [T_num T_i32]) \ t < length (table \) \ list_all (\i. i < length (func_t \)) is)" 36 | 37 | lemma module_elem_typing_equiv_module_elem_type_checker: 38 | "module_elem_typing \ m_e = module_elem_type_checker \ m_e" 39 | apply (cases m_e) 40 | apply (auto simp add: module_elem_typing.simps b_e_typing_equiv_b_e_type_checker) 41 | done 42 | 43 | fun module_data_type_checker :: "t_context \ module_data \ bool" where 44 | "module_data_type_checker \ \d_data=d, d_off=es, d_init=bs\ = 45 | (d = 0 \ const_exprs \ es \ b_e_type_checker \ es ([] _> [T_num T_i32]) \ d < length (memory \))" 46 | 47 | lemma module_data_typing_equiv_module_data_type_checker: 48 | "module_data_typing \ m_e = module_data_type_checker \ m_e" 49 | apply (cases m_e) 50 | apply (auto simp add: module_data_typing.simps b_e_typing_equiv_b_e_type_checker) 51 | done 52 | 53 | code_pred (modes: i \ i \ bool as module_start_type_checker_p) module_start_typing . 54 | 55 | abbreviation "module_start_type_checker \ module_start_typing" 56 | 57 | fun module_import_typer :: "tf list \ imp_desc \ extern_t option" where 58 | "module_import_typer tfs (Imp_func i) = (if i < length tfs then Some (Te_func (tfs!i)) else None)" 59 | | "module_import_typer tfs (Imp_tab tt) = (if module_tab_typing tt then Some (Te_tab tt) else None)" 60 | | "module_import_typer tfs (Imp_mem mt) = (if module_mem_typing mt then Some (Te_mem mt) else None)" 61 | | "module_import_typer tfs (Imp_glob gt) = Some (Te_glob gt)" 62 | 63 | lemma module_import_typing_equiv_module_import_typer: 64 | "(module_import_typing \ imp e_t) = (module_import_typer (types_t \) imp = Some e_t)" 65 | apply (cases imp) 66 | apply (auto simp add: module_import_typing.simps) 67 | done 68 | 69 | fun module_export_typer :: "t_context \ exp_desc \ extern_t option" where 70 | "module_export_typer \ (Ext_func i) = (if i < length (func_t \) then Some (Te_func ((func_t \)!i)) else None)" 71 | | "module_export_typer \ (Ext_tab i) = (if i < length (table \) then Some (Te_tab ((table \)!i)) else None)" 72 | | "module_export_typer \ (Ext_mem i) = (if i < length (memory \) then Some (Te_mem ((memory \)!i)) else None)" 73 | | "module_export_typer \ (Ext_glob i) = (if i < length (global \) then Some (Te_glob ((global \)!i)) else None)" 74 | 75 | lemma module_export_typing_equiv_module_export_typer: 76 | "(module_export_typing \ exp e_t) = (module_export_typer \ exp = Some e_t)" 77 | apply (cases exp) 78 | apply (auto simp add: module_export_typing.simps) 79 | done 80 | 81 | abbreviation "module_imports_typer tfs imps \ List.those (List.map (\imp. module_import_typer tfs (I_desc imp)) imps)" 82 | abbreviation "module_exports_typer \ exps \ List.those (List.map (\exp. module_export_typer \ (E_desc exp)) exps)" 83 | 84 | lemma list_all2_module_imports_typer: 85 | "list_all2 (\imp. module_import_typing \ (I_desc imp)) imps impts = (module_imports_typer (types_t \) imps = Some impts)" 86 | proof (induction imps arbitrary:impts) 87 | case Nil 88 | thus ?case 89 | by auto 90 | next 91 | case (Cons imp imps) 92 | thus ?case 93 | proof (cases impts) 94 | case Nil 95 | thus ?thesis 96 | by (simp split: option.splits) 97 | next 98 | case (Cons impt impts') 99 | thus ?thesis 100 | using module_import_typing_equiv_module_import_typer[of \ "(I_desc imp)" impt] 101 | Cons.IH 102 | by (auto split: option.splits) 103 | qed 104 | qed 105 | 106 | lemma list_all2_module_exports_typer: 107 | "list_all2 (\exp. module_export_typing \ (E_desc exp)) exps expts = (module_exports_typer \ exps = Some expts)" 108 | proof (induction exps arbitrary:expts) 109 | case Nil 110 | thus ?case 111 | by auto 112 | next 113 | case (Cons exp exps) 114 | thus ?case 115 | proof (cases expts) 116 | case Nil 117 | thus ?thesis 118 | by (simp split: option.splits) 119 | next 120 | case (Cons expt expts') 121 | thus ?thesis 122 | using module_export_typing_equiv_module_export_typer[of \ "(E_desc exp)" expt] 123 | Cons.IH 124 | by (auto split: option.splits) 125 | qed 126 | qed 127 | 128 | definition gather_m_f_type :: "tf list \ module_func \ tf option" where 129 | "gather_m_f_type tfs m_f \ if (fst m_f < length tfs) then Some (tfs!(fst m_f)) else None" 130 | 131 | abbreviation gather_m_f_types :: "tf list \ module_func list \ (tf list) option" where 132 | "gather_m_f_types tfs m_fs \ List.those (List.map (gather_m_f_type tfs) m_fs)" 133 | 134 | lemma module_func_typing_imp_gather_m_f_type: 135 | assumes "module_func_typing \ fs ft" 136 | shows "gather_m_f_type (types_t \) fs = Some ft" 137 | using assms 138 | unfolding module_func_typing.simps gather_m_f_type_def 139 | by (auto split: if_splits) 140 | 141 | lemma module_func_typing_imp_gather_m_f_types: 142 | assumes "list_all2 (module_func_typing \) fs fts" 143 | shows "gather_m_f_types (types_t \) fs = Some fts" 144 | using assms 145 | proof (induction fs arbitrary: fts) 146 | case Nil 147 | thus ?case 148 | by auto 149 | next 150 | case (Cons a fs) 151 | thus ?case 152 | using module_func_typing_imp_gather_m_f_type 153 | unfolding list_all2_Cons1 154 | by fastforce 155 | qed 156 | 157 | lemma gather_m_f_types_length: 158 | assumes "gather_m_f_types (types_t \) fs = Some fts" 159 | shows "length fs = length fts" 160 | using assms 161 | proof (induction fs arbitrary: fts) 162 | case Nil 163 | thus ?case 164 | by simp 165 | next 166 | case (Cons a fs) 167 | thus ?case 168 | by (auto split: option.splits) 169 | qed 170 | 171 | lemma gather_m_f_type_imp_module_func_typing: 172 | assumes "gather_m_f_type (types_t \) f = Some ft" 173 | "module_func_type_checker \ f" 174 | shows "module_func_typing \ f ft" 175 | using assms 176 | unfolding gather_m_f_type_def 177 | by (simp add: module_func_typing_equiv_module_func_type_checker split: if_splits) 178 | 179 | lemma gather_m_f_types_imp_module_func_typing: 180 | assumes "gather_m_f_types (types_t \) fs = Some fts" 181 | "list_all (module_func_type_checker \) fs" 182 | shows "list_all2 (module_func_typing \) fs fts" 183 | using assms 184 | proof (induction fs arbitrary: fts) 185 | case Nil 186 | thus ?case 187 | by simp 188 | next 189 | case (Cons f fs') 190 | note outer_Cons = Cons 191 | show ?case 192 | proof (cases fts) 193 | case Nil 194 | thus ?thesis 195 | using Cons(2) 196 | by (simp split: option.splits) 197 | next 198 | case (Cons ft fts') 199 | thus ?thesis 200 | using outer_Cons gather_m_f_type_imp_module_func_typing 201 | by (auto split: option.splits) 202 | qed 203 | qed 204 | 205 | abbreviation gather_m_g_types :: "module_glob list \ tg list" where 206 | "gather_m_g_types \ map module_glob.g_type" 207 | 208 | fun module_type_checker :: "m \ (extern_t list \ extern_t list) option" where 209 | "module_type_checker \m_types = tfs, 210 | m_funcs = fs, 211 | m_tabs = ts, 212 | m_mems = ms, 213 | m_globs = gs, 214 | m_elem = els, 215 | m_data = ds, 216 | m_start = i_opt, 217 | m_imports = imps, 218 | m_exports = exps\ = 219 | (case (gather_m_f_types tfs fs, module_imports_typer tfs imps) of 220 | (Some fts, Some impts) \ 221 | let ifts = ext_t_funcs impts in 222 | let its = ext_t_tabs impts in 223 | let ims = ext_t_mems impts in 224 | let igs = ext_t_globs impts in 225 | let gts = gather_m_g_types gs in 226 | let \ = \types_t=tfs, func_t=ifts@fts, global=igs@gts, table=its@ts, memory=ims@ms, local=[], label=[], return=None\ in 227 | let \' = \types_t=[], func_t=[], global=igs, table=[], memory=[], local=[], label=[], return=None\ in 228 | if (list_all (module_func_type_checker \) fs \ 229 | list_all (module_tab_type_checker) ts \ 230 | list_all (module_mem_type_checker) ms \ 231 | list_all (module_glob_type_checker \') gs \ 232 | list_all (module_elem_type_checker \) els \ 233 | list_all (module_data_type_checker \) ds \ 234 | pred_option (module_start_type_checker \) i_opt \ 235 | module_exports_distinct exps \ 236 | length (its@ts) \ 1 \ \ \\MVP restriction\\ 237 | length (ims@ms) \ 1 \ \\MVP restriction\\) then 238 | case (module_exports_typer \ exps) of 239 | Some expts \ Some (impts, expts) 240 | | _ \ None 241 | else None 242 | | _ \ None 243 | )" 244 | 245 | lemma module_typing_imp_module_type_checker: 246 | assumes "module_typing m impts expts" 247 | shows "module_type_checker m = Some (impts, expts)" 248 | proof - 249 | obtain tfs fs ts ms gs els ds i_opt imps exps where m_def: 250 | "m =\m_types = tfs, 251 | m_funcs = fs, 252 | m_tabs = ts, 253 | m_mems = ms, 254 | m_globs = gs, 255 | m_elem = els, 256 | m_data = ds, 257 | m_start = i_opt, 258 | m_imports = imps, 259 | m_exports = exps\" 260 | using module_type_checker.cases 261 | by blast 262 | obtain \ \' fts gts ifts its ims igs where module_typing_is: 263 | "list_all2 (module_func_typing \) fs fts" 264 | "list_all (module_tab_typing) ts" 265 | "list_all (module_mem_typing) ms" 266 | "list_all2 (module_glob_typing \') gs gts" 267 | "list_all (module_elem_typing \) els" 268 | "list_all (module_data_typing \) ds" 269 | "pred_option (module_start_typing \) i_opt" 270 | "list_all2 (\imp. module_import_typing \ (I_desc imp)) imps impts" 271 | "list_all2 (\exp. module_export_typing \ (E_desc exp)) exps expts" 272 | "ifts = ext_t_funcs impts" 273 | "its = ext_t_tabs impts" 274 | "ims = ext_t_mems impts" 275 | "igs = ext_t_globs impts" 276 | "module_exports_distinct exps" 277 | "length (its@ts) \ 1" 278 | "length (ims@ms) \ 1" 279 | "\ = \types_t=tfs, func_t=ifts@fts, global=igs@gts, table=its@ts, memory=ims@ms, local=[], label=[], return=None\" 280 | "\' = \types_t=[], func_t=[], global=igs, table=[], memory=[], local=[], label=[], return=None\" 281 | using assms 282 | unfolding m_def 283 | apply (simp only: module_typing.simps) 284 | apply blast 285 | done 286 | 287 | have "gather_m_f_types tfs fs = Some fts" 288 | using module_typing_is(1,17) module_func_typing_imp_gather_m_f_types 289 | by fastforce 290 | moreover 291 | have "gather_m_g_types gs = gts" 292 | using module_typing_is(4) 293 | unfolding list_all2_conv_all_nth module_glob_typing.simps 294 | by (metis length_map module_glob.select_convs(1) nth_equalityI nth_map) 295 | moreover 296 | have "module_imports_typer tfs imps = Some impts" 297 | using module_typing_is(8) 298 | by (simp add: list_all2_module_imports_typer module_typing_is(17)) 299 | moreover 300 | have "module_exports_typer \ exps = Some expts" 301 | using module_typing_is(9) 302 | by (simp add: list_all2_module_exports_typer) 303 | moreover 304 | have "list_all (module_func_type_checker \) fs" 305 | "list_all (module_tab_type_checker) ts" 306 | "list_all (module_mem_type_checker) ms" 307 | "list_all (module_glob_type_checker \') gs" 308 | "list_all (module_elem_type_checker \) els" 309 | "list_all (module_data_type_checker \) ds" 310 | "pred_option (module_start_type_checker \) i_opt" 311 | "module_exports_distinct exps" 312 | using module_typing_is(1-7,14) 313 | module_func_typing_equiv_module_func_type_checker 314 | module_glob_typing_equiv_module_glob_type_checker 315 | module_elem_typing_equiv_module_elem_type_checker 316 | module_data_typing_equiv_module_data_type_checker 317 | by (simp_all add: list_all2_conv_all_nth list_all_length) 318 | ultimately 319 | show ?thesis 320 | using module_typing_is 321 | unfolding m_def 322 | by simp 323 | qed 324 | 325 | lemma module_type_checker_imp_module_typing: 326 | assumes "module_type_checker m = Some (impts, expts)" 327 | shows "module_typing m impts expts" 328 | proof - 329 | obtain tfs fs ts ms gs els ds i_opt imps exps where m_def: 330 | "m =\m_types = tfs, 331 | m_funcs = fs, 332 | m_tabs = ts, 333 | m_mems = ms, 334 | m_globs = gs, 335 | m_elem = els, 336 | m_data = ds, 337 | m_start = i_opt, 338 | m_imports = imps, 339 | m_exports = exps\" 340 | using module_type_checker.cases 341 | by blast 342 | obtain fts ifts its ims igs gts \ \' where module_type_checker_is: 343 | "gather_m_f_types tfs fs = Some fts" 344 | "module_imports_typer tfs imps = Some impts" 345 | "ifts = ext_t_funcs impts" 346 | "its = ext_t_tabs impts" 347 | "ims = ext_t_mems impts" 348 | "igs = ext_t_globs impts" 349 | "gts = gather_m_g_types gs" 350 | "\ = \types_t=tfs, func_t=ifts@fts, global=igs@gts, table=its@ts, memory=ims@ms, local=[], label=[], return=None\" 351 | "\' = \types_t=[], func_t=[], global=igs, table=[], memory=[], local=[], label=[], return=None\" 352 | "list_all (module_func_type_checker \) fs" 353 | "list_all (module_tab_type_checker) ts" 354 | "list_all (module_mem_type_checker) ms" 355 | "list_all (module_glob_type_checker \') gs" 356 | "list_all (module_elem_type_checker \) els" 357 | "list_all (module_data_type_checker \) ds" 358 | "pred_option (module_start_type_checker \) i_opt" 359 | "module_exports_distinct exps" 360 | "length (its@ts) \ 1" 361 | "length (ims@ms) \ 1" 362 | "module_exports_typer \ exps = Some expts" 363 | using assms m_def 364 | by (simp add: Let_def split: option.splits if_splits) 365 | have "list_all2 (module_func_typing \) fs fts" 366 | using gather_m_f_types_imp_module_func_typing 367 | module_type_checker_is 368 | by fastforce 369 | moreover 370 | have "list_all (module_tab_typing) ts" 371 | "list_all (module_mem_typing) ms" 372 | "list_all2 (module_glob_typing \') gs gts" 373 | "list_all (module_elem_typing \) els" 374 | "list_all (module_data_typing \) ds" 375 | "pred_option (module_start_typing \) i_opt" 376 | using module_type_checker_is 377 | module_glob_typing_equiv_module_glob_type_checker 378 | module_elem_typing_equiv_module_elem_type_checker 379 | module_data_typing_equiv_module_data_type_checker 380 | by (simp_all add: list_all2_conv_all_nth list_all_length) 381 | moreover 382 | have "list_all2 (\imp. module_import_typing \ (I_desc imp)) imps impts" 383 | using list_all2_module_imports_typer[symmetric] 384 | module_type_checker_is(2,8) 385 | by fastforce 386 | moreover 387 | have "list_all2 (\exp. module_export_typing \ (E_desc exp)) exps expts" 388 | using list_all2_module_exports_typer[symmetric] 389 | module_type_checker_is(20) 390 | by fastforce 391 | ultimately 392 | show ?thesis 393 | using m_def module_type_checker_is 394 | by (fastforce simp add: module_typing.simps) 395 | qed 396 | 397 | theorem module_typing_equiv_module_type_checker: 398 | "module_typing m impts expts = (module_type_checker m = Some (impts, expts))" 399 | using module_typing_imp_module_type_checker 400 | module_type_checker_imp_module_typing 401 | by blast 402 | 403 | end -------------------------------------------------------------------------------- /WebAssembly/Wasm_Native_Word_Entry.thy: -------------------------------------------------------------------------------- 1 | theory Wasm_Native_Word_Entry imports Wasm_Base_Defs "Native_Word.Uint32" "Native_Word.Uint64" begin 2 | 3 | lift_definition i32_impl_abs :: "uint32 \i32" is "(\x. x)" . 4 | lift_definition i64_impl_abs :: "uint64 \i64" is "(\x. x)" . 5 | 6 | lift_definition i32_impl_rep :: "i32 \uint32" is "(\x. x)" . 7 | lift_definition i64_impl_rep :: "i64 \uint64" is "(\x. x)" . 8 | 9 | end -------------------------------------------------------------------------------- /WebAssembly/Wasm_Printing.thy: -------------------------------------------------------------------------------- 1 | theory Wasm_Printing imports OCaml_Printing Wasm_Instantiation_Printing Wasm_Checker_Printing Wasm_Interpreter_Printing Wasm_Type_Printing "HOL-Library.Code_Target_Nat" "Native_Word.Code_Target_Integer_Bit" begin 2 | 3 | lemma[code]: "mem_rep_append (Abs_mem_rep m) n b = Abs_mem_rep (app_rev_tr (rev m) (replicate n b))" 4 | using mem_rep_append.abs_eq 5 | by (simp add: append_app_rev_tr) 6 | 7 | (* avoid name-mangling *) 8 | code_identifier constant Neg \ (OCaml) "WasmRef_Isa.Neg" 9 | 10 | export_code open nat_of_byte byte_of_nat 11 | ocaml_int32_to_isabelle_int32 12 | isabelle_int32_to_ocaml_int32 13 | ocaml_int64_to_isabelle_int64 14 | isabelle_int64_to_ocaml_int64 15 | ocaml_char_to_isabelle_byte 16 | isabelle_byte_to_ocaml_char 17 | m_imports module_type_checker interp_instantiate_init typing run run_invoke 18 | in OCaml module_name WasmRef_Isa file_prefix WasmRef_Isa 19 | 20 | end 21 | -------------------------------------------------------------------------------- /WebAssembly/Wasm_Soundness.thy: -------------------------------------------------------------------------------- 1 | section \Soundness Theorems\ 2 | 3 | theory Wasm_Soundness imports Main Wasm_Properties begin 4 | 5 | theorem preservation: 6 | assumes "\ s;f;es : ts" 7 | "\s;f;es\ \ \s';f';es'\" 8 | shows "(\ s';f';es' : ts) \ store_extension s s'" 9 | proof - 10 | have "store_typing s" "s\None \ f;es : ts" 11 | using assms(1) config_typing.simps 12 | by blast+ 13 | hence "store_typing s'" "s'\None \ f';es' : ts" 14 | "store_extension s s'" 15 | using assms(2) 16 | store_preserved 17 | types_preserved_e 18 | by blast+ 19 | thus ?thesis 20 | using config_typing.intros 21 | by blast 22 | qed 23 | 24 | theorem progress: 25 | assumes "\ s;f;es : ts" 26 | shows "const_list es \ es = [Trap] \ (\a s' f' es'. \s;f;es\ \ \s';f';es'\)" 27 | proof - 28 | have "store_typing s" "s\None \ f;es : ts" 29 | using assms config_typing.simps 30 | by blast+ 31 | thus ?thesis 32 | using progress_e3 33 | by blast 34 | qed 35 | 36 | end -------------------------------------------------------------------------------- /WebAssembly/Wasm_Type_Abs.thy: -------------------------------------------------------------------------------- 1 | section\Numeric WebAssembly Types\ 2 | 3 | theory Wasm_Type_Abs imports 4 | Main 5 | "HOL-Library.Type_Length" 6 | "Word_Lib.Reversed_Bit_Lists" 7 | HOL.Rat 8 | PowerSum 9 | begin 10 | 11 | text\ 12 | This contains word size-agnostic specifications of numeric types and ops as found in the 13 | WebAssembly specification. 14 | \ 15 | 16 | class wasm_base = zero 17 | 18 | subsection\Integer\ 19 | 20 | context len 21 | begin 22 | 23 | definition ibits :: "'a itself \ int \ bool list" where 24 | "ibits N i \ THE l. 25 | length l = LENGTH('a) \ 26 | i = (\n \ {0.. (\ c dvd b) \ b div c = 0 \ ((a::int) + b) div c = (a::int) div c" 29 | using div_plus_div_distrib_dvd_left 30 | by (simp add: div_plus_div_distrib_dvd_left) 31 | 32 | lemma ibits_l: 33 | assumes "0 \ i" "i < 2 ^ LENGTH('a)" 34 | shows "length l = LENGTH('a) 35 | \ i = (\n = 0.. l = bin_to_bl LENGTH('a) i" 37 | proof - 38 | have gen: " 39 | 0 \ i \ i < 2 ^ N \ 40 | length l = N 41 | \ i = (\n = 0.. l = bin_to_bl N i" for N 43 | proof (induction N arbitrary: i l) 44 | case 0 45 | then show ?case by simp 46 | next 47 | case (Suc N) 48 | have IH: "(length (butlast l) = N \ i div 2 = 49 | (\n = 0.. (butlast l = bin_to_bl N (i div 2))" 51 | apply (rule Suc.IH[where l="butlast l" and i="i div 2"]) 52 | using Suc.prems by auto 53 | 54 | have sumdiv: "length (butlast l) = N \ 55 | (\n = 0..n = 0..n. Suc N - n - 1 \ 0) {x \ {0.. {0..n = 0..n = 0.. = (\n = 0.. {0.. butlast l ! n = l ! n" for n 77 | apply (rule nth_butlast) 78 | using \length (butlast l) = N\ atLeastLessThan_iff by blast 79 | thus ?thesis by simp 80 | qed 81 | finally show ?thesis . 82 | qed 83 | 84 | show ?case 85 | unfolding bin_to_bl_def apply (subst bin_to_bl_aux.simps) 86 | apply (subst bin_to_bl_aux_alt) 87 | proof (rule iffI, goal_cases) 88 | case 1 89 | hence "length (butlast l) = N" by simp 90 | moreover have "i div 2 = (\n = 0.. {0.. a \ N \ \ odd (if l ! a then 2 ^ (Suc N - a - 1) else 0)" for a 99 | by simp 100 | hence "{a \ {0.. {N}. odd (if l ! a then 2 ^ (Suc N - a - 1) else 0)}" by auto 102 | thus ?thesis apply (cases "l ! N") apply force by force 103 | qed 104 | hence "(odd (card {a \ {0..n = 0.. = (\n = 0..i div 2 = _\) 130 | apply (subst sum_distrib_right) 131 | apply (subst if_distrib[where f="\x. x * 2"]) 132 | apply (subst power_Suc2[THEN sym]) 133 | apply (subst mult_zero_left) 134 | apply (subst sum.cong[of 135 | "{0..n. if butlast l ! n then 2 ^ Suc (N - n - 1) else 0" 137 | "\n. if l ! n then 2 ^ (Suc N - n - 1) else 0"]) 138 | by (auto simp: Suc_diff_Suc len nth_butlast) 139 | also have "\ = (\n = 0.. = (\n = 0.. i" "i < 2 ^ LENGTH('a)" 154 | shows "ibits N i = bin_to_bl LENGTH('a) i" 155 | unfolding ibits_def sum_distrib_right if_distrib mult_zero_right mult_1_right 156 | apply (rule the_equality) 157 | using ibits_l[OF assms] by auto 158 | 159 | definition ibits_inv :: "'a itself \ bool list \ int" where 160 | "ibits_inv N \ the_inv_into {0 ..< 2^LENGTH('a)} (ibits N)" 161 | 162 | lemma ibits_inv: 163 | assumes "length l = LENGTH('a)" 164 | shows "ibits_inv N l = bl_to_bin l" 165 | proof - 166 | have ge0: "0 \ bl_to_bin l" using bl_to_bin_ge0 . 167 | have lt2p: "bl_to_bin l < 2 ^ LENGTH('a)" 168 | unfolding assms[THEN sym] using bl_to_bin_lt2p . 169 | show ?thesis 170 | unfolding ibits_inv_def 171 | proof (rule the_inv_into_f_eq, goal_cases) 172 | case 1 173 | then show ?case 174 | apply (rule inj_onI) 175 | apply (subst (asm) ibits) 176 | apply auto[2] 177 | apply (subst (asm) ibits) 178 | apply auto[2] 179 | by (metis atLeastLessThan_iff bin_bl_bin take_bit_int_eq_self) 180 | next 181 | case 2 182 | then show ?case 183 | apply (subst ibits) 184 | using ge0 lt2p apply auto[2] 185 | unfolding assms[THEN sym] 186 | by (rule bl_bin_bl) 187 | next 188 | case 3 189 | then show ?case using ge0 lt2p by simp 190 | qed 191 | qed 192 | 193 | 194 | lemma half_power: 195 | "2 ^ LENGTH('a) = 2 * 2 ^ (LENGTH('a) - 1)" 196 | using power_Suc[of 2 "LENGTH('a) - 1"] by simp 197 | 198 | text\Interpret an unsigned number i obtained from a word of size N as signed.\ 199 | definition signed :: "'a itself \ int \ int" where 200 | "signed _ i \ 201 | if 0 \ i \ i < (2^(LENGTH('a)-1)) then i 202 | else if 2^(LENGTH('a)-1) \ i \ i < 2^LENGTH('a) then i - (2^LENGTH('a)) 203 | else 0" 204 | 205 | text\Inverse of signed, refined below.\ 206 | definition signed_inv :: "'a itself \ int \ int" where 207 | "signed_inv N \ the_inv_into {0 ..< 2^LENGTH('a)} (signed N)" 208 | 209 | lemma signed_inj: "inj_on (signed (N::'a itself)) {0 ..< 2^LENGTH('a)}" 210 | proof (rule inj_onI, goal_cases) 211 | case (1 x y) 212 | thus ?case unfolding signed_def 213 | apply (cases "x < (2^(LENGTH('a)-1))") 214 | subgoal 215 | apply (cases "y < (2^(LENGTH('a)-1))") 216 | using atLeastLessThan_iff by simp_all 217 | apply (cases "y < (2^(LENGTH('a)-1))") 218 | using atLeastLessThan_iff by simp_all 219 | qed 220 | 221 | lemma signed_inv_id: 222 | assumes "0 \ y" "y < 2 ^ (LENGTH('a) - 1)" 223 | shows "signed N y = y" 224 | unfolding signed_def half_power using assms by simp 225 | 226 | lemma signed_inv_neg: 227 | assumes "- (2 ^ (LENGTH('a) - 1)) \ y" "y < 0" 228 | shows "signed N (y + (2 ^ LENGTH('a))) = y" 229 | proof - 230 | let ?x = "y + (2 ^ LENGTH('a))" 231 | have "(2^(LENGTH('a)-1)) \ ?x " using assms(1) unfolding half_power by simp 232 | moreover have "2^(LENGTH('a)-1) \ ?x \ ?x < 2^LENGTH('a)" 233 | using assms(2) calculation by force 234 | ultimately show ?thesis unfolding signed_def by simp 235 | qed 236 | 237 | lemma signed_image: "signed N ` {0 ..< 2^LENGTH('a)} = {-(2^(LENGTH('a)-1)) ..< 2^(LENGTH('a)-1)}" 238 | unfolding image_def proof (intro Set.equalityI Set.subsetI, goal_cases) 239 | case (1 y) 240 | then obtain x where x: "x\{0..<2 ^ LENGTH('a)}" "y = signed N x" by blast 241 | hence xb: "0 \ x" "x < 2 ^ LENGTH('a)" by auto 242 | { 243 | assume nx: "\x < 2 ^ (LENGTH('a) - 1)" 244 | hence "2 ^ (LENGTH('a) - 1) \ x \ x < 2 ^ LENGTH('a)" using xb(2) by fastforce 245 | hence signed: "signed N x = x - 2 ^ LENGTH('a)" unfolding signed_def using nx by simp 246 | have "- (2 ^ (LENGTH('a) - 1)) \ signed N x" 247 | proof - 248 | have "0 \ x - 2 * (2 ^ (LENGTH('a) - 1)) + (2 ^ (LENGTH('a) - 1))" 249 | using nx by linarith 250 | hence "0 \ x - 2 ^ LENGTH('a) + (2 ^ (LENGTH('a) - 1))" 251 | unfolding half_power . 252 | hence "- (2 ^ (LENGTH('a) - 1)) \ x - 2 ^ LENGTH('a)" by simp 253 | thus ?thesis by (subst signed) 254 | qed 255 | moreover from nx have "signed N x < 2 ^ (LENGTH('a) - 1)" 256 | using calculation signed xb(2) by force 257 | ultimately have "signed N x \ {- (2 ^ (LENGTH('a) - 1))..<2 ^ (LENGTH('a) - 1)}" by simp 258 | } 259 | then show ?case unfolding x(2) signed_def using x(1) 260 | by (cases "x < 2 ^ (LENGTH('a) - 1)") auto 261 | next 262 | case (2 y) 263 | show ?case 264 | proof (cases "0 \ y") 265 | case True 266 | have "signed N y = y" 267 | apply (rule signed_inv_id[OF True]) 268 | using 2 by auto 269 | moreover have "y < 2 ^ LENGTH('a)" unfolding half_power using "2" by force 270 | ultimately show ?thesis using True by force 271 | next 272 | case False 273 | have eq: "signed N (y + (2 ^ LENGTH('a))) = y" 274 | apply (rule signed_inv_neg) 275 | subgoal using "2" atLeastLessThan_iff by blast 276 | using False by simp 277 | have lt: "y + (2 ^ LENGTH('a)) < 2 ^ LENGTH('a)" unfolding half_power using False by auto 278 | have ge: "0 \ y + 2 ^ LENGTH('a)" unfolding half_power using "2" by auto 279 | show ?thesis 280 | apply (intro CollectI bexI[where x="y + 2 ^ LENGTH('a)"]) 281 | subgoal using eq[THEN sym] . 282 | unfolding atLeastLessThan_iff 283 | using lt ge by blast 284 | qed 285 | qed 286 | 287 | lemma signed_bij: 288 | "bij_betw (signed N) {0 ..< 2^LENGTH('a)} {-(2^(LENGTH('a)-1)) ..< 2^(LENGTH('a)-1)}" 289 | by (rule bij_betw_imageI[OF signed_inj signed_image]) 290 | 291 | lemma signed_inv: 292 | assumes "- (2^(LENGTH('a)-1)) \ i" "i < 2^(LENGTH('a)-1)" 293 | shows "signed_inv N i = (if 0 \ i then i else i + (2^LENGTH('a)))" 294 | proof (cases "0 \ i") 295 | case True 296 | note val = signed_inv_id[OF True assms(2)] 297 | show ?thesis unfolding signed_inv_def the_inv_into_def 298 | proof (rule the_equality, goal_cases) 299 | case 1 300 | then show ?case using val unfolding half_power using assms(2) True by auto 301 | next 302 | case (2 y) 303 | hence other: "signed N y = signed N i" using val by simp 304 | show ?case using inj_onD[OF signed_inj other 2[THEN conjunct1]] 305 | unfolding half_power using True assms(2) by auto 306 | qed 307 | next 308 | case False 309 | hence False: "i < 0" by simp 310 | note val = signed_inv_neg[OF assms(1) False] 311 | show ?thesis unfolding signed_inv_def the_inv_into_def 312 | proof (rule the_equality, goal_cases) 313 | case 1 314 | then show ?case using val unfolding half_power using assms(1) False by auto 315 | next 316 | case (2 y) 317 | hence other: "signed N y = signed N (i + 2 ^ LENGTH('a))" using val by simp 318 | show ?case using inj_onD[OF signed_inj other 2[THEN conjunct1]] 319 | unfolding half_power using False assms(1) by auto 320 | qed 321 | qed 322 | 323 | lemma signed_inv_nneg: 324 | assumes "- (2^(LENGTH('a)-1)) \ i" "i < 2^(LENGTH('a)-1)" 325 | shows "0 \ signed_inv N i" 326 | using signed_inv[OF assms, unfolded half_power] 327 | apply (cases "0 \ i") 328 | apply presburger 329 | using assms(1) by force 330 | 331 | end 332 | 333 | text\Pure syntactic type class for integers\ 334 | class wasm_int_ops = wasm_base + len + 335 | (* unops*) 336 | fixes int_clz :: "'a \ 'a" 337 | fixes int_ctz :: "'a \ 'a" 338 | fixes int_popcnt :: "'a \ 'a" 339 | (* binops *) 340 | fixes int_add :: "'a \ 'a \ 'a" 341 | fixes int_sub :: "'a \ 'a \ 'a" 342 | fixes int_mul :: "'a \ 'a \ 'a" 343 | fixes int_div_u :: "'a \ 'a \ 'a option" 344 | fixes int_div_s :: "'a \ 'a \ 'a option" 345 | fixes int_rem_u :: "'a \ 'a \ 'a option" 346 | fixes int_rem_s :: "'a \ 'a \ 'a option" 347 | fixes int_and :: "'a \ 'a \ 'a" 348 | fixes int_or :: "'a \ 'a \ 'a" 349 | fixes int_xor :: "'a \ 'a \ 'a" 350 | fixes int_shl :: "'a \ 'a \ 'a" 351 | fixes int_shr_u :: "'a \ 'a \ 'a" 352 | fixes int_shr_s :: "'a \ 'a \ 'a" 353 | fixes int_rotl :: "'a \ 'a \ 'a" 354 | fixes int_rotr :: "'a \ 'a \ 'a" 355 | (* testops *) 356 | fixes int_eqz :: "'a \ bool" 357 | (* relops *) 358 | fixes int_eq :: "'a \ 'a \ bool" 359 | fixes int_lt_u :: "'a \ 'a \ bool" 360 | fixes int_lt_s :: "'a \ 'a \ bool" 361 | fixes int_gt_u :: "'a \ 'a \ bool" 362 | fixes int_gt_s :: "'a \ 'a \ bool" 363 | fixes int_le_u :: "'a \ 'a \ bool" 364 | fixes int_le_s :: "'a \ 'a \ bool" 365 | fixes int_ge_u :: "'a \ 'a \ bool" 366 | fixes int_ge_s :: "'a \ 'a \ bool" 367 | (* value conversions *) 368 | fixes int_of_nat :: "nat \ 'a" 369 | fixes nat_of_int :: "'a \ nat" 370 | begin 371 | abbreviation (input) 372 | int_ne where 373 | "int_ne x y \ \ (int_eq x y)" 374 | 375 | text\ 376 | Convert a concrete wasm_int (usually a word) to its "abstract" integer representation, 377 | as used in the Wasm specs, where the whole integer domain is considered. 378 | \ 379 | abbreviation abs_int :: "'a \ int" 380 | where "abs_int a \ int (nat_of_int a)" 381 | 382 | abbreviation rep_int :: "int \ 'a" 383 | where "rep_int a \ int_of_nat (nat a)" 384 | 385 | abbreviation abs_int_bits :: "'a \ bool list" 386 | where "abs_int_bits a \ ibits TYPE('a) (abs_int a)" 387 | 388 | abbreviation rep_int_bits :: "bool list \ 'a" 389 | where "rep_int_bits a \ rep_int (ibits_inv TYPE('a) a)" 390 | 391 | abbreviation abs_int_s :: "'a \ int" 392 | where "abs_int_s a \ signed TYPE('a) (abs_int a)" 393 | 394 | abbreviation rep_int_s :: "int \ 'a" 395 | where "rep_int_s a \ rep_int (signed_inv TYPE('a) a)" 396 | end 397 | 398 | definition trunc :: "rat \ int" where 399 | "trunc q \ 400 | if 0 \ q 401 | then int (THE i::nat. q - 1 < rat_of_nat i \ rat_of_nat i \ q) 402 | else - int (THE i::nat. \q\ - 1 < rat_of_nat i \ rat_of_nat i \ \q\)" 403 | 404 | lemma trunc_exists1: 405 | assumes "0 \ q" 406 | shows "\!i. q - 1 < rat_of_nat i \ rat_of_nat i \ q" 407 | proof - 408 | let ?F = "\z. rat_of_int z \ q \ q < rat_of_int (z + 1)" 409 | let ?T = "\i. q - 1 < rat_of_nat i \ rat_of_nat i \ q" 410 | obtain z where z: "?F z" "\z'. ?F z' \ ?F z" using floor_exists1[of q] .. 411 | hence "q - 1 < rat_of_int z" by linarith 412 | moreover have "rat_of_int z \ q" using z(1) by blast 413 | moreover have "z \ 0" using assms z(1) by linarith 414 | ultimately have "?T (nat z)" "\i'. ?T i' \ i' = (nat z)" using z by auto 415 | thus ?thesis by blast 416 | qed 417 | 418 | lemma trunc: "trunc q = (if 0 \ q then \q\ else -\-q\)" 419 | proof - 420 | { 421 | fix q :: rat assume q: "0 \ q" 422 | have "(THE i::nat. q - 1 < rat_of_nat i \ rat_of_nat i \ q) = nat \q\" 423 | apply (rule the1_equality[OF trunc_exists1[OF q]]) 424 | using q floor_less_cancel by force 425 | } 426 | thus ?thesis unfolding trunc_def by auto 427 | qed 428 | 429 | text\Extension of wasm_int with semantic specifications\ 430 | class wasm_int = wasm_int_ops + 431 | assumes zero: "nat_of_int (0::'a) = 0" 432 | assumes add: "int_add (i\<^sub>1::'a) i\<^sub>2 = 433 | rep_int ((abs_int i\<^sub>1 + abs_int i\<^sub>2) mod (2^LENGTH('a)))" 434 | assumes sub: "int_sub (i\<^sub>1::'a) i\<^sub>2 = 435 | rep_int ((abs_int i\<^sub>1 - abs_int i\<^sub>2 + (2^LENGTH('a))) mod (2^LENGTH('a)))" 436 | assumes mul: "int_mul (i\<^sub>1::'a) i\<^sub>2 = 437 | rep_int ((abs_int i\<^sub>1 * abs_int i\<^sub>2) mod (2^LENGTH('a)))" 438 | assumes div_u_0: "i\<^sub>2 = 0 \ int_div_u (i\<^sub>1::'a) i\<^sub>2 = None" 439 | assumes div_u: "i\<^sub>2 \ 0 \ int_div_u (i\<^sub>1::'a) i\<^sub>2 = 440 | Some (rep_int (trunc (of_int (abs_int i\<^sub>1) / of_int (abs_int i\<^sub>2))))" 441 | assumes div_s_0: "i\<^sub>2 = 0 \ int_div_s (i\<^sub>1::'a) i\<^sub>2 = None" 442 | assumes div_s_nrep: 443 | "i\<^sub>2 \ 0 444 | \ rat_of_int (abs_int_s i\<^sub>1) / of_int (abs_int_s i\<^sub>2) = 2^(LENGTH('a)-1) 445 | \ int_div_s (i\<^sub>1::'a) i\<^sub>2 = None" 446 | assumes div_s: 447 | "i\<^sub>2 \ 0 448 | \ rat_of_int (abs_int_s i\<^sub>1) / of_int (abs_int_s i\<^sub>2) \ 2^(LENGTH('a)-1) 449 | \ int_div_s (i\<^sub>1::'a) i\<^sub>2 = 450 | Some (rep_int_s (trunc (of_int (abs_int_s i\<^sub>1) / of_int (abs_int_s i\<^sub>2))))" 451 | assumes rem_u_0: "i\<^sub>2 = 0 \ int_rem_u (i\<^sub>1::'a) i\<^sub>2 = None" 452 | assumes rem_u: "i\<^sub>2 \ 0 \ int_rem_u (i\<^sub>1::'a) i\<^sub>2 = 453 | Some (rep_int (abs_int i\<^sub>1 - abs_int i\<^sub>2 * trunc (of_int (abs_int i\<^sub>1) / of_int (abs_int i\<^sub>2))))" 454 | assumes rem_s_0: "i\<^sub>2 = 0 \ int_rem_s (i\<^sub>1::'a) i\<^sub>2 = None" 455 | assumes rem_s: "i\<^sub>2 \ 0 \ int_rem_s (i\<^sub>1::'a) i\<^sub>2 = Some (rep_int_s ( 456 | abs_int_s i\<^sub>1 - abs_int_s i\<^sub>2 * trunc (of_int (abs_int_s i\<^sub>1) / of_int (abs_int_s i\<^sub>2))))" 457 | assumes iand: "int_and i\<^sub>1 i\<^sub>2 = rep_int_bits (map2 (\) (abs_int_bits i\<^sub>1) (abs_int_bits i\<^sub>2))" 458 | assumes ior: "int_or i\<^sub>1 i\<^sub>2 = rep_int_bits (map2 (\) (abs_int_bits i\<^sub>1) (abs_int_bits i\<^sub>2))" 459 | assumes ixor: "int_xor i\<^sub>1 i\<^sub>2 = rep_int_bits (map2 (\) (abs_int_bits i\<^sub>1) (abs_int_bits i\<^sub>2))" 460 | assumes shl: 461 | "abs_int_bits i\<^sub>1 = d\<^sub>1 @ d\<^sub>2 462 | \ int k = abs_int i\<^sub>2 mod int (LENGTH('a)) 463 | \ length d\<^sub>1 = k 464 | \ length d\<^sub>2 = (LENGTH('a) - k) 465 | \ int_shl i\<^sub>1 i\<^sub>2 = rep_int_bits (d\<^sub>2 @ replicate k False)" 466 | assumes shr_u: 467 | "abs_int_bits i\<^sub>1 = d\<^sub>1 @ d\<^sub>2 468 | \ int k = abs_int i\<^sub>2 mod int (LENGTH('a)) 469 | \ length d\<^sub>1 = (LENGTH('a) - k) 470 | \ length d\<^sub>2 = k 471 | \ int_shr_u i\<^sub>1 i\<^sub>2 = rep_int_bits (replicate k False @ d\<^sub>1)" 472 | assumes shr_s: 473 | "abs_int_bits i\<^sub>1 = d\<^sub>0 # d\<^sub>1 @ d\<^sub>2 474 | \ int k = abs_int i\<^sub>2 mod int (LENGTH('a)) 475 | \ length d\<^sub>1 = (LENGTH('a) - k - 1) 476 | \ length d\<^sub>2 = k 477 | \ int_shr_s i\<^sub>1 i\<^sub>2 = rep_int_bits (replicate (k + 1) d\<^sub>0 @ d\<^sub>1)" 478 | assumes rotl: 479 | "abs_int_bits i\<^sub>1 = d\<^sub>1 @ d\<^sub>2 480 | \ int k = abs_int i\<^sub>2 mod int (LENGTH('a)) 481 | \ length d\<^sub>1 = k 482 | \ length d\<^sub>2 = (LENGTH('a) - k) 483 | \ int_rotl i\<^sub>1 i\<^sub>2 = rep_int_bits (d\<^sub>2 @ d\<^sub>1)" 484 | assumes rotr: 485 | "abs_int_bits i\<^sub>1 = d\<^sub>1 @ d\<^sub>2 486 | \ int k = abs_int i\<^sub>2 mod int (LENGTH('a)) 487 | \ length d\<^sub>1 = (LENGTH('a) - k) 488 | \ length d\<^sub>2 = k 489 | \ int_rotr i\<^sub>1 i\<^sub>2 = rep_int_bits (d\<^sub>2 @ d\<^sub>1)" 490 | assumes clz_0: "abs_int_bits i\<^sub>1 = replicate k False \ int_clz i\<^sub>1 = int_of_nat k" 491 | assumes clz_1: "abs_int_bits i\<^sub>1 = replicate k False @ True # d \ int_clz i\<^sub>1 = int_of_nat k" 492 | assumes ctz_0: "abs_int_bits i\<^sub>1 = replicate k False \ int_ctz i\<^sub>1 = int_of_nat k" 493 | assumes ctz_1: "abs_int_bits i\<^sub>1 = d @ True # replicate k False \ int_ctz i\<^sub>1 = int_of_nat k" 494 | assumes popcnt: 495 | "abs_int_bits i\<^sub>1 = concat bls @ replicate (LENGTH('a) - length (concat bls)) False 496 | \ length bls = k 497 | \ (\bl. bl \ set bls \ bl = replicate (length bl - 1) False @ [True]) 498 | \ int_popcnt i\<^sub>1 = int_of_nat k" 499 | assumes ieqz: "int_eqz i\<^sub>1 \ abs_int i\<^sub>1 = 0" 500 | assumes ieq: "int_eq i\<^sub>1 i\<^sub>2 \ abs_int i\<^sub>1 = abs_int i\<^sub>2" 501 | assumes ilt_u: "int_lt_u i\<^sub>1 i\<^sub>2 \ abs_int i\<^sub>1 < abs_int i\<^sub>2" 502 | assumes ilt_s: "int_lt_s i\<^sub>1 i\<^sub>2 \ abs_int_s i\<^sub>1 < abs_int_s i\<^sub>2" 503 | assumes igt_u: "int_gt_u i\<^sub>1 i\<^sub>2 \ abs_int i\<^sub>1 > abs_int i\<^sub>2" 504 | assumes igt_s: "int_gt_s i\<^sub>1 i\<^sub>2 \ abs_int_s i\<^sub>1 > abs_int_s i\<^sub>2" 505 | assumes ile_u: "int_le_u i\<^sub>1 i\<^sub>2 \ abs_int i\<^sub>1 \ abs_int i\<^sub>2" 506 | assumes ile_s: "int_le_s i\<^sub>1 i\<^sub>2 \ abs_int_s i\<^sub>1 \ abs_int_s i\<^sub>2" 507 | assumes ige_u: "int_ge_u i\<^sub>1 i\<^sub>2 \ abs_int i\<^sub>1 \ abs_int i\<^sub>2" 508 | assumes ige_s: "int_ge_s i\<^sub>1 i\<^sub>2 \ abs_int_s i\<^sub>1 \ abs_int_s i\<^sub>2" 509 | begin 510 | lemma ine: "int_ne i\<^sub>1 i\<^sub>2 \ abs_int i\<^sub>1 \ abs_int i\<^sub>2" unfolding ieq .. 511 | end 512 | 513 | subsection\Float\ 514 | 515 | class wasm_float = wasm_base + 516 | (* unops *) 517 | fixes float_neg :: "'a \ 'a" 518 | fixes float_abs :: "'a \ 'a" 519 | fixes float_ceil :: "'a \ 'a" 520 | fixes float_floor :: "'a \ 'a" 521 | fixes float_trunc :: "'a \ 'a" 522 | fixes float_nearest :: "'a \ 'a" 523 | fixes float_sqrt :: "'a \ 'a" 524 | (* binops *) 525 | fixes float_add :: "'a \ 'a \ 'a" 526 | fixes float_sub :: "'a \ 'a \ 'a" 527 | fixes float_mul :: "'a \ 'a \ 'a" 528 | fixes float_div :: "'a \ 'a \ 'a" 529 | fixes float_min :: "'a \ 'a \ 'a" 530 | fixes float_max :: "'a \ 'a \ 'a" 531 | fixes float_copysign :: "'a \ 'a \ 'a" 532 | (* relops *) 533 | fixes float_eq :: "'a \ 'a \ bool" 534 | fixes float_lt :: "'a \ 'a \ bool" 535 | fixes float_gt :: "'a \ 'a \ bool" 536 | fixes float_le :: "'a \ 'a \ bool" 537 | fixes float_ge :: "'a \ 'a \ bool" 538 | begin 539 | abbreviation (input) 540 | float_ne where 541 | "float_ne x y \ \ (float_eq x y)" 542 | end 543 | end -------------------------------------------------------------------------------- /WebAssembly/code/.keep: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/WasmCert/WasmCert-Isabelle/a3b0082ed815f0547ccbb973bf77bec5c8204461/WebAssembly/code/.keep -------------------------------------------------------------------------------- /libs/Misc_Generic_Lemmas.thy: -------------------------------------------------------------------------------- 1 | theory Misc_Generic_Lemmas imports Main Word_Lib.Reversed_Bit_Lists begin 2 | 3 | (* These lemmas are fairly generic and could be contributed back to their libs? *) 4 | 5 | lemma map_takefill:"(map f (takefill k n bs)) = (takefill (f k) n (map f bs))" 6 | apply (induction n arbitrary: bs) 7 | apply (simp_all split: list.splits) 8 | done 9 | 10 | lemma length_filter_fold:"length (filter P l) + n = 11 | fold (\n acc. if P n then acc + 1 else acc) l n" 12 | proof (induction l arbitrary: n) 13 | case Nil 14 | thus ?case 15 | by simp 16 | next 17 | case (Cons a l) 18 | thus ?case 19 | apply simp 20 | apply (metis add_Suc_right) 21 | done 22 | qed 23 | 24 | 25 | text \Just an alternative characterization of find, 26 | to increase trust in that it actually finds first occurrence. 27 | \ 28 | 29 | definition "is_first_elem_with_prop P xs x \ 30 | \xs\<^sub>1 xs\<^sub>2. xs = xs\<^sub>1@x#xs\<^sub>2 \ P x \ (\x'\set xs\<^sub>1. \P x')" 31 | 32 | lemma is_first_elem_with_prop_propI: "is_first_elem_with_prop P xs x \ P x" 33 | unfolding is_first_elem_with_prop_def 34 | by auto 35 | 36 | lemma find_finds_first: "List.find P xs = Some x 37 | \ is_first_elem_with_prop P xs x" 38 | unfolding is_first_elem_with_prop_def 39 | apply (rule iffI) 40 | subgoal 41 | apply (clarsimp simp: List.find_Some_iff) 42 | subgoal for i 43 | by (auto 0 3 44 | simp: in_set_conv_nth Cons_nth_drop_Suc 45 | intro: exI[where x="drop (Suc i) xs"] exI[where x="take i xs"]) 46 | done 47 | subgoal 48 | apply (clarsimp simp: List.find_Some_iff) 49 | by (metis add_Suc_right length_Cons length_greater_0_conv less_add_same_cancel1 list.simps(3) nth_append nth_append_length nth_mem) 50 | done 51 | 52 | 53 | 54 | end 55 | -------------------------------------------------------------------------------- /libs/More_More_Word.thy: -------------------------------------------------------------------------------- 1 | theory More_More_Word 2 | imports 3 | Word_Lib.More_Word_Operations 4 | Word_Lib.Rsplit 5 | Word_Lib.Syntax_Bundles 6 | begin 7 | 8 | unbundle bit_projection_infix_syntax 9 | 10 | fun bin_rsplit_rev :: "nat \ nat \ int \ int list" 11 | where "bin_rsplit_rev n m c = 12 | (if m = 0 \ n = 0 then [] 13 | else 14 | let (a, b) = bin_split n c 15 | in b # bin_rsplit_rev n (m - n) a)" 16 | 17 | lemma bin_rsplit_rev_is: 18 | "(rev acc)@(bin_rsplit_rev n m c) = rev (bin_rsplit_aux n m c acc)" 19 | proof (induction n m c arbitrary: acc rule: bin_rsplit_rev.induct) 20 | case (1 n m c) 21 | consider (1) "m = 0 \ n = 0" | (2) "\(m = 0 \ n = 0)" 22 | by blast 23 | thus ?case 24 | proof (cases) 25 | case 1 26 | thus ?thesis 27 | by fastforce 28 | next 29 | case 2 30 | obtain a b where a:"(a,b) = bin_split n c" 31 | by simp 32 | have "rev (b # acc) @ bin_rsplit_rev n (m - n) a = 33 | rev (bin_rsplit_aux n (m - n) a (b # acc))" 34 | using 2 1 a 35 | by blast 36 | thus ?thesis 37 | using 2 a bin_rsplit_aux.elims 38 | by fastforce 39 | qed 40 | qed 41 | 42 | definition word_rsplit_rev :: "'a::len word \ 'b::len word list" 43 | where "word_rsplit_rev w = map word_of_int (bin_rsplit_rev (LENGTH('b)) (LENGTH('a)) (uint w))" 44 | 45 | lemma word_rsplit_rev_is: "word_rsplit_rev = rev \ word_rsplit" 46 | using bin_rsplit_rev_is 47 | unfolding word_rsplit_def bin_rsplit_def word_rsplit_rev_def comp_def 48 | by (metis (no_types, opaque_lifting) append_self_conv2 fst_eqD rev_append rev_map snd_eqD) 49 | 50 | definition word_rcat_rev :: \'a::len word list \ 'b::len word\ 51 | where \word_rcat_rev = word_of_int \ horner_sum uint (2 ^ LENGTH('a))\ 52 | 53 | lemma word_rcat_rev_is: "word_rcat_rev = word_rcat \ rev" 54 | unfolding word_rcat_def word_rcat_rev_def comp_def 55 | by simp 56 | 57 | lemma word_rcat_rsplit_rev: "word_rcat_rev (word_rsplit_rev w) = w" 58 | using word_rcat_rsplit[of w] 59 | by (simp add: word_rcat_rev_is word_rsplit_rev_is) 60 | 61 | lemma word_split_rcat_rev_size [OF refl]: 62 | "word_rcat_rev ws = frcw \ 63 | size frcw = length ws * LENGTH('a) \ word_rsplit_rev frcw = ws" 64 | for ws :: "'a::len word list" 65 | using word_rsplit_rcat_size[of "rev ws"] 66 | unfolding word_rcat_rev_is word_rsplit_rev_is 67 | by fastforce 68 | 69 | definition word_list_sign_extend :: "nat \ ('a::len) word list \ 'a word list" where 70 | "word_list_sign_extend l (ws::'a word list) = 71 | takefill (if msb (last ws) then -1 else 0) l ws" 72 | 73 | lemma word_list_sign_extend_is: 74 | assumes "word_list_sign_extend l ws = ws'" 75 | "i < l" 76 | shows "length ws' = l \ ((i < length ws \ ws!i = ws'!i) \ (i \ length ws \ ws'!i = (if msb (last ws) then -1 else 0)))" 77 | using assms length_takefill[of "(if msb (last ws) then -1 else 0)" l ws] 78 | unfolding word_list_sign_extend_def 79 | apply (simp split: if_splits) 80 | apply (metis le_eq_less_or_eq nat_le_linear nth_takefill) 81 | apply (metis not_le_imp_less nth_takefill) 82 | done 83 | 84 | lemma bit_rcat_rev_iff: 85 | assumes "((word_rcat_rev (ws::'a::len word list))) = (w::'b::len word)" 86 | shows "bit w n = (n < LENGTH('b) \ n div LENGTH('a) < length ws \ ws ! (n div LENGTH('a)) !! (n mod LENGTH('a)))" 87 | proof - 88 | have 1:"LENGTH('a) = size (hd (rev ws))" 89 | by (simp add: word_size) 90 | 91 | have 2:"LENGTH('b) = size ((word_rcat_rev ws)::'b::len word)" 92 | by (simp add: word_size) 93 | 94 | have 3:"((word_rcat_rev ws)::'b::len word) = word_rcat (rev ws)" 95 | by (metis comp_eq_dest_lhs word_rcat_rev_is) 96 | 97 | show ?thesis 98 | using test_bit_rcat[OF 1 3] assms 99 | by (simp add: size_word.rep_eq) 100 | qed 101 | 102 | lemma bit_word_scast_iff': 103 | assumes "(scast (w::'a::len word)) = (w' :: 'b::len word)" 104 | shows \bit w' n \ 105 | n < LENGTH('b) \ ((LENGTH('a) > n \ bit w n) \ LENGTH('a) \ n \ bit w (LENGTH('a) - Suc 0))\ 106 | using assms[symmetric] 107 | apply simp 108 | apply transfer 109 | apply (auto simp add: bit_signed_take_bit_iff le_less min_def) 110 | done 111 | 112 | lemma msb_bl_concat: 113 | shows "hd (concat (map to_bl (rev (ws@[w::'a::len word])))) = msb (last (ws@[w]))" 114 | proof (induction ws) 115 | case Nil 116 | thus ?case 117 | by (simp add: word_msb_alt) 118 | next 119 | case (Cons a ws) 120 | thus ?case 121 | by simp 122 | qed 123 | 124 | lemma hd_to_bl_of_bl: 125 | assumes "length xs > 0" 126 | "length (xs@xs') = LENGTH('a::len)" 127 | "(of_bl (xs @ xs')) = (w::'a word)" 128 | shows "hd (to_bl w) = hd xs" 129 | using assms(1,3) 130 | by simp (metis assms(2) hd_append2 to_bl_use_of_bl word_bl_Rep') 131 | 132 | lemma msb_word_rcat_rev: 133 | assumes "length ws*LENGTH('a::len) = LENGTH('b::len)" 134 | shows "msb ((word_rcat_rev (ws::'a word list))::'b word) = msb (last ws)" 135 | proof - 136 | have 1:"0 < length ws" 137 | using assms 138 | by fastforce 139 | then obtain ws' w' where ws_is:"ws = ws'@[w']" 140 | using rev_exhaust 141 | by auto 142 | have "msb ((of_bl (concat (map to_bl (rev ws))))::'b word) = hd (concat (map to_bl (rev (ws'@[w']))))" 143 | using msb_bl_concat ws_is hd_to_bl_of_bl[of "to_bl w'" "concat (map to_bl (rev ws'))" "_::'b word"] 144 | apply (simp add: word_msb_alt) 145 | apply (metis assms length_append_singleton length_rev mult_Suc size_rcat_lem) 146 | done 147 | thus ?thesis 148 | unfolding word_rcat_rev_is word_rcat_bl 149 | by simp (metis last_snoc word_msb_alt ws_is) 150 | qed 151 | 152 | lemma scast_word_rcat_rev_is_word_rcat_rev_word_list_sign_extend: 153 | assumes "(LENGTH('b::len)) \ (LENGTH('a::len))" 154 | "l*LENGTH('c::len) = LENGTH('b::len)" 155 | "(length (ws::('c word) list))*LENGTH('c) = LENGTH('a)" 156 | shows "(scast::'a word\'b word) (word_rcat_rev ws) = (word_rcat_rev::(('c::len word) list)\'b word) (word_list_sign_extend l ws)" 157 | proof - 158 | { fix n 159 | assume local_assms:"n < LENGTH('b)" 160 | consider 161 | (1) "n < LENGTH('a)" 162 | | (2) "n \ LENGTH('a)" 163 | by linarith 164 | hence "bit ((scast::'a word\'b word) (word_rcat_rev ws)) n = 165 | bit ((word_rcat_rev (word_list_sign_extend l ws))::'b word) n" 166 | proof (cases) 167 | case 1 168 | have a:"n < LENGTH('a) \ n div LENGTH('c) < length ws" 169 | using assms 170 | by (simp add: less_mult_imp_div_less) 171 | thus ?thesis 172 | using bit_word_scast_iff'[of "(word_rcat_rev ws)::'a word" "_::'b word" n] 173 | word_list_sign_extend_is[of l ws _ "(n div LENGTH('c))"] 174 | bit_rcat_rev_iff assms local_assms 1 175 | by (fastforce simp add: bit_rcat_rev_iff less_mult_imp_div_less) 176 | next 177 | case 2 178 | hence a:"n div LENGTH('c) \ length ws" 179 | using assms 180 | by (metis len_gt_0 td_gal) 181 | hence "bit ((scast ((word_rcat_rev ws)::'a word))::'b word) n = msb ((word_rcat_rev ws)::'a word)" 182 | using bit_word_scast_iff'[of "(word_rcat_rev ws)::'a word" "_::'b word" n] 2 local_assms 183 | by (simp add: msb_word_iff_bit) 184 | moreover have "bit ((word_rcat_rev (word_list_sign_extend l ws))::'b word) n = msb ((word_rcat_rev ws)::'a word)" 185 | using word_list_sign_extend_is[of l ws _ "n div LENGTH('c)"] a 2 local_assms 186 | bit_rcat_rev_iff[of "(word_list_sign_extend l ws)" "_::'b word" n] 187 | by (simp add: assms(2,3) less_mult_imp_div_less msb_word_rcat_rev) 188 | ultimately show ?thesis 189 | by blast 190 | qed 191 | } 192 | thus ?thesis 193 | by (simp add: bit_word_eqI) 194 | qed 195 | 196 | lemma ucast_word_rcat_rev_is_word_rcat_rev_takefill: 197 | assumes "(LENGTH('b::len)) \ (LENGTH('a::len))" 198 | "l*LENGTH('c::len) \ LENGTH('b::len)" 199 | "(length (ws::('c word) list))*LENGTH('c) \ LENGTH('a)" 200 | "length ws \ l" 201 | shows "(ucast::'a word\'b word) (word_rcat_rev ws) = (word_rcat_rev::(('c::len word) list)\'b word) (takefill 0 l ws)" 202 | proof - 203 | { fix n 204 | assume local_assms:"n < LENGTH('b)" 205 | consider 206 | (1) "n < (length (ws::('c word) list))*LENGTH('c)" 207 | | (2) "n \ (length (ws::('c word) list))*LENGTH('c)" 208 | by linarith 209 | hence "bit ((ucast::'a word\'b word) (word_rcat_rev ws)) n = 210 | bit ((word_rcat_rev (takefill 0 l ws))::'b word) n" 211 | proof (cases) 212 | case 1 213 | hence a:"n div LENGTH('c) < length ws" 214 | using assms 215 | by (simp add: less_mult_imp_div_less) 216 | thus ?thesis 217 | using bit_word_ucast_iff[of "(word_rcat_rev ws)::'a word"] 218 | bit_rcat_rev_iff assms local_assms 1 219 | length_takefill[of 0 l ws] nth_takefill[of _ l 0 ws] 220 | apply (simp add: bit_rcat_rev_iff less_mult_imp_div_less split: if_splits) 221 | using a by auto 222 | next 223 | case 2 224 | hence a:"n div LENGTH('c) \ length ws" 225 | using assms 226 | by (metis len_gt_0 td_gal) 227 | hence "\bit ((ucast ((word_rcat_rev ws)::'a word))::'b word) n" 228 | using 2 assms(3) 229 | by (simp add: bit_word_ucast_iff bit_rcat_rev_iff) 230 | moreover have "\bit ((word_rcat_rev (takefill 0 l ws))::'b word) n" 231 | using a bit_rcat_rev_iff[of "(takefill 0 l ws)" "_::'b word" n] 232 | length_takefill[of 0 l ws] nth_takefill[of _ l 0 ws] 233 | by simp 234 | ultimately show ?thesis 235 | by blast 236 | qed 237 | } 238 | thus ?thesis 239 | by (simp add: bit_word_eqI) 240 | qed 241 | 242 | lemma word_rcat_rev_is_word_rcat_rev_takefill: 243 | assumes "l*LENGTH('b::len) \ (LENGTH('a::len))" 244 | "length (ws::'b word list) \ l" 245 | shows "((word_rcat_rev::(('b::len word) list)\'a word) ws) = 246 | (word_rcat_rev::(('b::len word) list)\'a word) (takefill 0 l ws)" 247 | using ucast_word_rcat_rev_is_word_rcat_rev_takefill[OF _ assms(1)] ucast_id 248 | by (metis assms(1,2) dual_order.trans le_refl mult.commute mult_le_mono2) 249 | 250 | lemma ucast_word_rcat_rev_is_word_rcat_rev: 251 | assumes "(LENGTH('b::len)) \ (LENGTH('a::len))" 252 | "(length (ws::('c word) list))*LENGTH('c) = LENGTH('a)" 253 | shows "(ucast::('a word \ 'b word)) ((word_rcat_rev::(('c::len word) list)\'a word) ws) = 254 | (word_rcat_rev::(('c::len word) list)\'b word) ws" 255 | using ucast_word_rcat_rev_is_word_rcat_rev_takefill[OF assms(1), of "length ws" ws] assms(2) 256 | by (simp add: assms(1)) 257 | 258 | end 259 | --------------------------------------------------------------------------------